Class-AutoGenerate

 view release on metacpan or  search on metacpan

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

  My::AutoGenerator::autogenerated 'Some::Module';
  My::AutoGenerator->autogenerated('Some::Module');

  # Where $autogenerator->isa('Class::AutoGenerate');
  $autogenerator->autogenerated('Some::Module');

Returns true if the package named was autogenerated by a L<Class::AutoGenerate> class loader. Returns C<undef> in any other case.

=cut

sub autogenerated($) {
    my $class = shift;
    if (blessed $class or (not ref $class and $class =~ /^[:\w]+$/)) {
        $class = shift if $class->isa('Class::AutoGenerate');
    }

    return exists $AUTOGENERATED{ $class };
}

=head2 autogenerator_of MODULE

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

  My::AutoGenerator::autogenerator_of 'Some::Module';
  My::AutoGenerator->autogenerator_of('Some::Module');

  # Where $autogenerator->isa('Class::AutoGenerate');
  $autogenerator->autogenerator_of('Some::Module');

Returns the object that was used to autogenerate the module. This is really just a shortcut for looking up the information in C<%INC>, but saves some work of converting Perl module names into package file names and the cryptic use of the C<%INC> vari...

=cut

sub autogenerator_of($) {
    my $class = shift;
    if (blessed $class or (not ref $class and $class =~ /^[:\w]+$/)) {
        $class = shift if $class->isa('Class::AutoGenerate');
    }

    # Convert the module name into a package file, Some::Thing -> Some/Thing.pm
    my $package_file = $class;
    $package_file =~ s{::}{/}g;
    $package_file .= '.pm';

lib/Class/AutoGenerate/Declare.pm  view on Meta::CPAN

=item Array of Matches

Finally, you may also place a series of matches into an array. The given generates block will be used if any of the matches match a given module name.

  requiring [ 'App', 'App::**', qr/^SomeOther::(Thing|Whatsit)$/ ] => ...

=back

=cut

sub _compile_glob_pattern($) {
    my $glob = shift;

    # If it's a regexp, we don't want to compile it as if it's a glob!
    return $glob if ref $glob and ref $glob eq 'Regexp';

    # The following code was adapted from Jifty::Dispatcher of trunk r2520
    
    # Escape and normalize
    $glob = quotemeta($glob);
    $glob =~ s{(?:\\:)(?:\\:)}{::}g;

lib/Class/AutoGenerate/Declare.pm  view on Meta::CPAN

        $glob = "($glob)";
    }

    # Make a regexp
    return qr{^$glob$};
}

# This variable used to communicate when declare { requiring ... }
our $declare_to = undef;

sub _register_rules($$$) {
    my $class   = shift;
    my $pattern = shift;
    my $code    = shift;

    # If an array, push the generates code for each pattern
    if (ref $pattern and reftype $pattern eq 'ARRAY') {
        &_register_rules($class, $_, $code) foreach @$pattern;
    }

    # Otherwise, compile globs and push in the pattern => code rule thingies
    else {
        $pattern = _compile_glob_pattern $pattern;
        push @{ $declare_to || $class->_declarations }, [ $pattern => $code ];
    }
}

sub requiring($$) {
    my $pattern = shift;
    my $code    = shift;

    # Register a new rule (or rules) for the caller
    my $package = caller;
    _register_rules $package, $pattern, $code;
}

=head2 generates { ... }

lib/Class/AutoGenerate/Declare.pm  view on Meta::CPAN

  };

If we included the rule above, intantiated the class loader, and then ran:

  use My::Flipper;

A class would be generated named C<My::Flipper> that uses C<My::Base::Flipper> as its only base class, imports the C<looks_like_number> function from L<Scalar::Util>, defines a scalar package variable C<$scalar> set to 14, an array package variable, ...

=cut

sub generates(&) { shift }

=head2 declare { ... };

A declare block may be used to wrap your class loader code, but is not required. The block will be passed a single argument, C<$self>, which is the initialized class loader object. It is helpful if you need a reference to your C<$self>.

For example,

  package My::Classloader;
  use Class::Autogenerate -base;

lib/Class/AutoGenerate/Declare.pm  view on Meta::CPAN

  # later...
  use My::Classloader;
  BEGIN { My::Classloader->new( base => 'Foo' ) };

You may have multiple C<declare> blocks in your class loader.

It is important to note that the C<declare> block modifies the semantics of how the class loader is built. Normally, the C<requiring> rules are all generated and associated with the class loader package immediately. A C<declare> block causes all rule...

=cut

sub declare(&) {
    my $code    = shift;

    # Wrap that code in a little more code that sets things up
    my $declaration = sub {
        my $self = shift;

        # $declare_to signals to requiring to register rules differently
        local $declare_to   = [];
        $code->($self);
        return @$declare_to;

lib/Class/AutoGenerate/Declare.pm  view on Meta::CPAN

This subroutine is used with L</generates> to mark the generated class as extending the named class or classes. This pushes the named classes into the C<@ISA> array for the class when it is generated.

B<N.B.> You need to ask Perl to include this class on your own. This is not exactly equivalent to <use base qw/$class/> in this regard. If a class might not be included already, you may wish to do something like the following:

  require My::Parent::Class;
  extends 'My::Parent::Class';

=cut

sub extends(@) {
    no strict 'refs';
    push @{ $Class::AutoGenerate::package . '::ISA' }, @_;
}

=head2 uses CLASS, ARGS

This subroutine states that the generated class uses another package. The first argument is the class to use and the remaining arguments are passed to the import method of the used class (the first argument may also be a version number, see L<perlfun...

=cut

sub uses($;@) {
    my $class = shift;
    my $args = join ', ', map { "'".quotemeta($_)."'" } @_;
    $args = " ($args)" if $args;

    eval "package $Class::AutoGenerate::package; use $class$args;";
    die $@ if $@;
}

=head2 requires EXPR

This is similar to L</uses>, but uses L<perlfunc/require> instead of C<use>.

=cut

sub requires($) {
    my $expr  = shift;

    # Make a nice string unless it's barewordable... this might not always do
    # the right thing...
    $expr = '"' . quotemeta($expr) . '"' unless $expr =~ /^[\w:]+$/;

    eval "package $Class::AutoGenerate::package; require $expr;";
    die $@ if $@;
}

=head2 defines NAME => VALUE

This is the general purpose definition declaration. If the given name starts with a dollar sign ($), then a scalar value is created. If the given name starts with an at sign (@), then an array value is added to the class. If the given starts with a p...

The given value must be appropriate for the type of definition being generated.

=cut

sub defines($$) {
    my $name  = shift;
    my $value = shift;

    # It's a scalar
    if ($name =~ s/^\$//) {
        no strict 'refs';
        ${ $Class::AutoGenerate::package . '::' . $name } = $value;
    }

    # It's an array

lib/Class/AutoGenerate/Declare.pm  view on Meta::CPAN

          __PACKAGE__->mk_accessors( qw/ name title description / );

      };
  };

B<Caution:> If user input has any effect on the code generated, you should make certain that all input is carefully validated to prevent code injection.

=cut

sub generate_from($) {
    my $source_code = shift;

    eval "package $Class::AutoGenerate::package; $source_code";
    die $@ if $@;
}

=head2 conclude_with SOURCE

This is a special helper used in place of L</generate_from> for code that could cause a loop during code generation. This can occur because Perl does not realize that the generated module has been loaded until I<after> the L</generates> block has bee...

lib/Class/AutoGenerate/Declare.pm  view on Meta::CPAN

  };

If we had used C<generate_from> rather than C<conclude_with> in the code above, a loop would have been generated upon calling C<require My::Thing::Flup>. This would have resulted in a call to C<require_helpers> in the sample, which would have resulte...

By using C<conclude_with>, the code given is not executed until Perl has already noted that the class is loaded, so the loop stops and this code should execute successfully.

B<Caution:> If user input has any effect on the code generated, you should make certain that all input is carefully validated to prevent code injection.

=cut

sub conclude_with($) {
    my $code = shift;

    push @{ $Class::AutoGenerate::conclude_with }, $code;
}

=head2 source_code SOURCE

This method is purely for use with making your code a little easier to read. It doesn't do anything but return the argument passed to it.

B<Caution:> If user input has any effect on the code generated, you should make certain that all input is carefully validated to prevent code injection.

=cut

sub source_code($) { shift }

=head2 source_file FILENAME

Given a file name, this evalutes the Perl in that file within the context of the package.

  requiring 'Another::Class' => generates {
      generate_from source_file 'code_base.pl';
  };

B<Caution:> If user input has any effect on this file included, you should make certain that all input is carefully validated to prevent code injection.

=cut

sub source_file($) {
    my $filename = shift;

    # Open the file...
    open my $fh, '<', $filename or die "failed to open $filename: $!";

    # Slurp it down...
    local $/;
    return <$fh>;
}

=head2 next_rule

By calling the C<next_rule> statement, you will prevent the current L</generates> statement from finishing. Instead, it will quit and the next L</requirng> rule will be tried.

=cut

sub next_rule() { die "NEXT_RULE\n" }

=head2 last_rule

The C<last_rule> statement causes the class loader to stop completely and return that it found no matching Perl modules.

=cut

sub last_rule() { die "LAST_RULE\n" }

=head1 SEE ALSO

L<UNIVERSAL::require>

=head1 AUTHOR

Andrew Sterling Hanenkamp C<< <hanenkamp@cpan.org> >>

=head1 COPYRIGHT AND LICENSE

t/util.pl  view on Meta::CPAN

sub require_not_ok($;$) {
    my ($class, $message) = @_;
    eval "require $class";
    ok($@, ($message||"not require $class"));
}

1;