Package::Generator - generate new packages quickly and easily

Package-Generator documentation Contained in the Package-Generator distribution.

Index

Code Index:

NAME

Top

Package::Generator - generate new packages quickly and easily

VERSION

Top

version 0.103

SYNOPSIS

Top

    use Package::Generator;

    my $package = Package::Generator->new_package;
    ...

DESCRIPTION

Top

This module lets you quickly and easily construct new packages. It gives them unused names and sets up their package data, if provided.

INTERFACE

Top

new_package

  my $package = Package::Generator->new_package(\%arg);

This returns the newly generated package. It can be called with no arguments, in which case it just returns the name of a pristene package. The base argument can be provided to generate the package under an existing namespace. A make_unique argument can also be provided; it must be a coderef which will be passed the base package name and returns a unique package name under the base name.

A data argument may be passed as a reference to an array of pairs. These pairs will be used to set up the data in the generated package. For example, the following call will create a package with a $foo set to 1 and a @foo set to the first ten counting numbers.

  my $package = Package::Generator->new_package({
    data => [
      foo => 1,
      foo => [ 1 .. 10 ],
    ]
  });

For convenience, isa and version arguments may be passed to new_package. They will set up @ISA, $VERSION, or &VERSION, as appropriate. If a single scalar value is passed as the isa argument, it will be used as the only value to assign to @ISA. (That is, it will not cause $ISA to be assigned; that wouldn't be very helpful.)

assign_symbols

  Package::Generator->assign_symbols($package, \@key_value_pairs);

This routine is used by new_package to set up the data in a package.

package_exists

  ... if Package::Generator->package_exists($package);

This method returns true if something has already created a symbol table for the named package. This is equivalent to:

  ... if defined *{$package . '::'};

It's just a little less voodoo-y.

AUTHOR

Top

Ricardo SIGNES, <rjbs@cpan.org>

BUGS

Top

Please report any bugs or feature requests to bug-package-generator@rt.cpan.org, or through the web interface at http://rt.cpan.org. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.

COPYRIGHT

Top

Copyright 2006 Ricardo Signes, all rights reserved.

This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

Package-Generator documentation Contained in the Package-Generator distribution. 
package Package::Generator;
use 5.008;
use warnings;
use strict;

use Carp ();
use Scalar::Util ();


our $VERSION = '0.103';


my $i = 0;
my $unique_part = sub { $i++ };
my $make_unique = sub { sprintf "%s::%u", $_[0], $_[1]->() };

sub new_package {
  my ($self, $arg) = @_;
  $arg->{base} ||= 'Package::Generator::__GENERATED__';
  $arg->{unique_part} ||= $unique_part;
  $arg->{make_unique} ||= $make_unique;
  $arg->{max_tries} ||= 1;

  my $package;
  for (my $i = 1; 1; $i++) {
    $package = $arg->{make_unique}->($arg->{base}, $arg->{unique_part});
    last unless $self->package_exists($package); 
    Carp::croak "couldn't generate a pristene package under $arg->{base}"
      if $i >= $arg->{max_tries};
  }

  my @data = $arg->{data} ? @{ $arg->{data} } : ();

  push @data, (
    ($arg->{isa} ? (ISA => (ref $arg->{isa} ? $arg->{isa} : [ $arg->{isa} ]))
                 : ()),
    ($arg->{version} ? (VERSION => $arg->{version}) : ()),
  );

  if (@data) {
    $self->assign_symbols($package, \@data);
  } else {
    # This ensures that even without symbols, the package is created so that it
    # will not be detected as pristene by package_exists.  Without this line of
    # code, non-unique tests will fail. -- rjbs, 2006-04-14
    {
      ## no critic (ProhibitNoStrict)
      no strict qw(refs);
      no warnings qw(void);
      %{$package . '::'};
    }
  }

  return $package;
}


sub assign_symbols {
  my ($self, $package, $key_value_pairs) = @_;
  
  Carp::croak "list of key/value pairs must be even!" if @$key_value_pairs % 2;

  ## no critic (ProhibitNoStrict)
  no strict 'refs';
  while (my ($name, $value) = splice @$key_value_pairs, 0, 2) {
    my $full_name = "$package\:\:$name";
    
    if (!ref($value) or Scalar::Util::blessed($value)) {
      ${$full_name} = $value;
    } else {
      *{$full_name} = $value;
    }
  }
}


sub package_exists {
  my ($self, $package) = @_;

  return defined *{$package . '::'};
}

# My first attempt!  How silly I felt when I threw in some Data::Dumper and saw
# that the above would suffice. -- rjbs, 2006-04-14
#
#  my @parts = split /::/, $package;
#  
#  my $current_pkg = 'main';
#  for (@parts) {
#    my $current_stash = do { no strict 'refs'; \%{$current_pkg . "::"} };
#    return unless exists $current_stash->{$_ . "::"};
#    $current_pkg .= "::$_"
#  }
#  return 1;


1;