view release on metacpan or  search on metacpan

lib/Class/Autouse.pm  view on Meta::CPAN

	goto &{$ORIGINAL_CAN};
}





#####################################################################
# Support Functions

sub _preload {
	_debug(\@_) if DEBUG;

	# Does it look like a package?
	my $class = ref $_[0] || $_[0];
	unless ( $class and $class =~ /^[^\W\d]\w*(?:(?:\'|::)[^\W]\w*)*$/o ) {
		return $LOADED{$class} = 1;
	}

	# Do we try to load the class
	my $load = 0;
	my $file = _class_file($class);
	if ( defined $INC{$file} and $INC{$file} eq 'Class::Autouse' ) {
		# It's an autoused class
		$load = 1;
	} elsif ( ! $SUPERLOAD ) {
		# Superloader isn't on, don't load
		$load = 0;
	} elsif ( _namespace_occupied($class) ) {
		# Superloader is on, but there is something already in the class
		# This can't be the autouse loader, because we would have caught
		# that case already.
		$load = 0;
	} else {
		# The rules of the superloader say we assume loaded unless we can
		# tell otherwise. Thus, we have to have a go at loading.
		$load = 1;
	}

	# If needed, load the class and all its dependencies.
	Class::Autouse->load($class) if $load;

	unless ( $LOADED{$class} ) {
		_try_loaders($class);
		unless ( $LOADED{$class} ) {
			if ( _namespace_occupied($class) ) {
				# The class is not flagged as loaded by autouse, but exists
				# to ensure its ancestry is loaded before calling $orig
				$LOADED{$class} = 1;
				_load_ancestors($class);
			}
		}
	}

	return 1;
}

sub _try_loaders {
	_debug(\@_, 0) if DEBUG;
	my ($class, $function, @optional_args) = @_;
	# The function and args are only present to help callbacks whose main goal is to
	# do "syntactic sugar" instead of really writing a class

	# This allows us to shortcut out of re-checking a class
	$TRIED_CLASS{$class}++;

	if ( _namespace_occupied($class) ) {
		$LOADED{$class} = 1;
		_load_ancestors($class);
		return 1;
	}

	# Try each of the special loaders, if there are any.
	for my $loader ( @LOADERS ) {
		my $ref = ref($loader);
		if ( $ref ) {
			if ( $ref eq "Regexp" ) {
				next unless $class =~ $loader;
				my $file = _class_file($class);
				next unless grep { -e $_ . '/' . $file } @INC;
				local $^W = 0;
				local $@;
				eval "use $class";
				die "Class::Autouse found module $file for class $class matching regex '$loader',"
					. " but it failed to compile with the following error: $@" if $@;
			} elsif ( $ref eq "CODE" ) {
				unless ( $loader->( $class,$function,@optional_args ) ) {
					next;
				}
			} else {
				die "Unexpected loader.  Expected qr//, sub{}, or class name string."
			}
			$LOADED{$class} = 1;
			_load_ancestors($class);
			return 1;
		} else {
			die "Odd loader $loader passed to " . __PACKAGE__;
		}
	}

	return;
}

# This is called after any class is hit by load/preload to ensure that parent classes are also loaded
sub _load_ancestors {
	_debug(\@_, 0) if DEBUG;
	my $class = $_[0];
	my ($this_class,@ancestors) = _super($class);
	for my $ancestor ( @ancestors ) {
		# this is a bit ugly, _preload presumes either isa or can is being called,
		# and does a goto at the end of it, we just want the core logic, not the redirection
		# so we pass undef as the subref parameter
		_preload($ancestor);
	}
	if ( $STATICISA ) {
		# Optional performance optimization.
		# After we have the entire ancestry,
		# set the greatest grandparent's can/isa to the originals.
		# This keeps the versions in this module from being used where they're not needed.
		my $final_parent = $ancestors[-1] || $this_class;
		no strict 'refs';

lib/Class/Autouse.pm  view on Meta::CPAN

        my ($class) = @_;
        if ($class =~ /(^.*)::Wrapper/) {
            my $wrapped_class = $1;
            eval "package $class; use Class::AutoloadCAN;";
            die $@ if $@;
            no strict 'refs';
            *{$class . '::new' } = sub {
                my $class = shift;
                my $proxy = $wrapped_class->new(@_);
                my $self = bless({proxy => $proxy},$class);
                return $self;
            };
            *{$class . '::CAN' } = sub {
                my ($obj,$method) = @_;
                my $delegate = $wrapped_class->can($method);
                return unless $delegate;
                my $delegator = sub {
                    my $self = shift;
                    if (ref($self)) {
                        return $self->{proxy}->$method(@_);
                    }
                    else {
                        return $wrapped_class->$method(@_);
                    }
                };
                return *{ $class . '::' . $method } = $delegator;
            };

            return 1;
        }
        return;
    };

    package Foo;
    sub new { my $class = shift; bless({@_},$class); }
    sub class_method { 123 }
    sub instance_method {
        my ($self,$v) = @_;
        return $v * $self->some_property
    }
    sub some_property { shift->{some_property} }


    package main;
    my $x = Foo::Wrapper->new(
        some_property => 111,
    );
    print $x->some_property,"\n";
    print $x->instance_method(5),"\n";
    print Foo::Wrapper->class_method,"\n";

=head2 sugar

This method is provided to support "syntactic sugar": allowing the developer
to put things into Perl which do not look like regular Perl.  There are
several ways to do this in Perl.  Strategies which require overriding
UNIVERSAL::AUTOLOAD can use this interface instead to share that method
with the superloader, and with class gnerators.

When Perl is unable to find a subroutine/method, and all of the class loaders
are exhausted, callbacks registered via sugar() are called.  The callbacks
recieve the class name, method name, and parameters of the call.

If the callback returns nothing, Class::Autouse will continue to iterate through
other callbacks.  The first callback which returns a true value will
end iteration.  That value is expected to be a CODE reference which will respond
to the AUTOLOAD call.

Note: The sugar callback(s) will only be fired by UNIVERSAL::AUTOLOAD after all
other attempts at loading the class are done, and after attempts to use regular
AUTOLOAD to handle the method call.  It is never fired by isa() or can().  It
will fire repatedly for the same class.  To generate classes, use the
regular CODE ref support in autouse().

=head3 Syntactic Sugar Example

    use Class::Autouse;
    Class::Autouse->sugar(
        sub {
            my $caller = caller(1);
            my ($class,$method,@params) = @_;
            shift @params;
            my @words = ($method,$class,@params);
            my $sentence = join(" ",@words);
            return sub { $sentence };
        }
    );

    $x = trolls have big ugly hairy feet;

    print $x,"\n";
    # trolls have big ugly hairy feet

=head2 mod_perl

The mechanism that C<Class::Autouse> uses is not compatible with L<mod_perl>.
In particular with reloader modules like L<Apache::Reload>. C<Class::Autouse>
detects the presence of mod_perl and acts as normal, but will always load
all classes immediately, equivalent to having developer mode enabled.

This is actually beneficial, as under mod_perl classes should be preloaded
in the parent mod_perl process anyway, to prevent them having to be loaded
by the Apache child classes. It also saves HUGE amounts of memory.

Note that dynamically generated classes and classes loaded via regex CANNOT
be pre-loaded automatically before forking child processes.  They will still
be loaded on demand, often in the child process.  See L<prefork> below.

=head2 prefork

As with mod_perl, C<Class::Autouse> is compatible with the L<prefork> module,
and all modules specifically autoloaded will be loaded before forking correctly,
when requested by L<prefork>.

Since modules generated via callback or regex cannot be loaded automatically
by prefork in a generic way, it's advised to use prefork directly to load/generate
classes when using mod_perl.

=head2 Performance Optimizatons

=over

=item :nostat

Described above, this option is useful when the module in question is on