asa-0.02/0000755000175100017510000000000010430405665012032 5ustar adamadam00000000000000asa-0.02/inc/0000755000175100017510000000000010430405665012603 5ustar adamadam00000000000000asa-0.02/inc/Module/0000755000175100017510000000000010430405665014030 5ustar adamadam00000000000000asa-0.02/inc/Module/Install.pm0000644000175100017510000001660010430405663015775 0ustar adamadam00000000000000#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.004; use strict 'vars'; use vars qw{$VERSION}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '0.62'; } # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE"; Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE } use Cwd (); use File::Find (); use File::Path (); use FindBin; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # delegate back to parent dirs goto &$code unless $cwd eq $pwd; } $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym"; unshift @_, ($self, $1); goto &{$self->can('call')} unless uc($1) eq $1; }; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; unless ( -f $self->{file} ) { require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{"$self->{file}"}; delete $INC{"$self->{path}.pm"}; } sub preload { my ($self) = @_; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { my $admin = $self->{admin}; @exts = $admin->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless exists &{ref($obj).'::'.$method}; next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = delete $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { open PKGFILE, "<$subpath.pm" or die "find_extensions: Can't open $subpath.pm: $!"; my $in_pod = 0; while ( ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } close PKGFILE; } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } 1; asa-0.02/inc/Module/Install/0000755000175100017510000000000010430405665015436 5ustar adamadam00000000000000asa-0.02/inc/Module/Install/Fetch.pm0000644000175100017510000000463010430405663017026 0ustar adamadam00000000000000#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base; use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.62'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; asa-0.02/inc/Module/Install/Makefile.pm0000644000175100017510000001317210430405663017513 0ustar adamadam00000000000000#line 1 package Module::Install::Makefile; use strict 'vars'; use Module::Install::Base; use ExtUtils::MakeMaker (); use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.62'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing, always use defaults if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } sub makemaker_args { my $self = shift; my $args = ($self->{makemaker_args} ||= {}); %$args = ( %$args, @_ ) if @_; $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{name} = defined $args->{$name} ? join( ' ', $args->{name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join(' ', grep length, $clean->{FILES}, @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join(' ', grep length, $realclean->{FILES}, @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name || $self->determine_NAME($args); $args->{VERSION} = $self->version || $self->determine_VERSION($args); $args->{NAME} =~ s/-/::/g; if ( $self->tests ) { $args->{test} = { TESTS => $self->tests }; } if ($] >= 5.005) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = $self->author; } if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) { $args->{NO_META} = 1; } if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } # merge both kinds of requires into prereq_pm my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } map { @$_ } grep $_, ($self->build_requires, $self->requires) ); # merge both kinds of requires into prereq_pm my $subdirs = ($args->{DIR} ||= []); if ($self->bundles) { foreach my $bundle (@{ $self->bundles }) { my ($file, $dir) = @$bundle; push @$subdirs, $dir if -d $dir; delete $prereq->{$file}; } } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args; if ($self->admin->preop) { $args{dist} = $self->admin->preop; } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; my $makefile = do { local $/; }; close MAKEFILE or die $!; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 331 asa-0.02/inc/Module/Install/Base.pm0000644000175100017510000000203510430405663016644 0ustar adamadam00000000000000#line 1 package Module::Install::Base; $VERSION = '0.62'; # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } ### This is the ONLY module that shouldn't have strict on # use strict; #line 41 sub new { my ($class, %args) = @_; foreach my $method ( qw(call load) ) { *{"$class\::$method"} = sub { shift()->_top->$method(@_); } unless defined &{"$class\::$method"}; } bless( \%args, $class ); } #line 61 sub AUTOLOAD { my $self = shift; local $@; my $autoload = eval { $self->_top->autoload } or return; goto &$autoload; } #line 76 sub _top { $_[0]->{_top} } #line 89 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } sub is_admin { $_[0]->admin->VERSION; } sub DESTROY {} package Module::Install::Base::FakeAdmin; my $Fake; sub new { $Fake ||= bless(\@_, $_[0]) } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 138 asa-0.02/inc/Module/Install/Metadata.pm0000644000175100017510000001750410430405663017521 0ustar adamadam00000000000000#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base; use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.62'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } my @scalar_keys = qw{ name module_name abstract author version license distribution_type perl_version tests }; my @tuple_keys = qw{ build_requires requires recommends bundles }; sub Meta { shift } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } foreach my $key (@scalar_keys) { *$key = sub { my $self = shift; return $self->{values}{$key} if defined wantarray and !@_; $self->{values}{$key} = shift; return $self; }; } foreach my $key (@tuple_keys) { *$key = sub { my $self = shift; return $self->{values}{$key} unless @_; my @rv; while (@_) { my $module = shift or last; my $version = shift || 0; if ( $module eq 'perl' ) { $version =~ s{^(\d+)\.(\d+)\.(\d+)} {$1 + $2/1_000 + $3/1_000_000}e; $self->perl_version($version); next; } my $rv = [ $module, $version ]; push @rv, $rv; } push @{ $self->{values}{$key} }, @rv; @rv; }; } sub sign { my $self = shift; return $self->{'values'}{'sign'} if defined wantarray and !@_; $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 ); return $self; } sub dynamic_config { my $self = shift; unless ( @_ ) { warn "You MUST provide an explicit true/false value to dynamic_config, skipping\n"; return $self; } $self->{'values'}{'dynamic_config'} = $_[0] ? 1 : 0; return $self; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die "all_from called with no args without setting name() first"; $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; die "all_from: cannot find $file from $name" unless -e $file; } $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; # The remaining probes read from POD sections; if the file # has an accompanying .pod, use that instead my $pod = $file; if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) { $file = $pod; } $self->author_from($file) unless $self->author; $self->license_from($file) unless $self->license; $self->abstract_from($file) unless $self->abstract; } sub provides { my $self = shift; my $provides = ( $self->{values}{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->{name}, dist_version => $self->{version}, license => $self->{license}, ); $self->provides(%{ $build->find_dist_packages || {} }); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}{no_index}{$type} }, @_ if $type; return $self->{values}{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML', 0 ); require YAML; my $data = YAML::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { my ( $self, $file ) = @_; require ExtUtils::MM_Unix; $self->version( ExtUtils::MM_Unix->parse_version($file) ); } sub abstract_from { my ( $self, $file ) = @_; require ExtUtils::MM_Unix; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } sub _slurp { my ( $self, $file ) = @_; local *FH; open FH, "< $file" or die "Cannot open $file.pod: $!"; do { local $/; }; } sub perl_version_from { my ( $self, $file ) = @_; if ( $self->_slurp($file) =~ m/ ^ use \s* v? ([\d_\.]+) \s* ; /ixms ) { my $v = $1; $v =~ s{_}{}g; $self->perl_version($1); } else { warn "Cannot determine perl version info from $file\n"; return; } } sub author_from { my ( $self, $file ) = @_; my $content = $self->_slurp($file); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; $author =~ s{E}{<}g; $author =~ s{E}{>}g; $self->author($author); } else { warn "Cannot determine author info from $file\n"; } } sub license_from { my ( $self, $file ) = @_; if ( $self->_slurp($file) =~ m/ =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b (.*?) (=head\\d.*|=cut.*|) \z /ixms ) { my $license_text = $1; my @phrases = ( 'under the same (?:terms|license) as perl itself' => 'perl', 'GNU public license' => 'gpl', 'GNU lesser public license' => 'gpl', 'BSD license' => 'bsd', 'Artistic license' => 'artistic', 'GPL' => 'gpl', 'LGPL' => 'lgpl', 'BSD' => 'bsd', 'Artistic' => 'artistic', ); while ( my ( $pattern, $license ) = splice( @phrases, 0, 2 ) ) { $pattern =~ s{\s+}{\\s+}g; if ( $license_text =~ /\b$pattern\b/i ) { $self->license($license); return 1; } } } warn "Cannot determine license info from $file\n"; return 'unknown'; } 1; asa-0.02/inc/Module/Install/Can.pm0000644000175100017510000000337410430405663016502 0ustar adamadam00000000000000#line 1 package Module::Install::Can; use strict; use Module::Install::Base; use Config (); ### This adds a 5.005 Perl version dependency. ### This is a bug and will be fixed. use File::Spec (); use ExtUtils::MakeMaker (); use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.62'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { my $abs = File::Spec->catfile($dir, $_[1]); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 157 asa-0.02/inc/Module/Install/WriteAll.pm0000644000175100017510000000162410430405663017520 0ustar adamadam00000000000000#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base; use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.62'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_ ); $self->sign(1) if $args{sign}; $self->Meta->write if $args{meta}; $self->admin->WriteAll(%args) if $self->is_admin; if ( $0 =~ /Build.PL$/i ) { $self->Build->write; } else { $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{'PL_FILES'} ) { $self->makemaker_args( PL_FILES => {} ); } if ($args{inline}) { $self->Inline->write; } else { $self->Makefile->write; } } } 1; asa-0.02/inc/Module/Install/Win32.pm0000644000175100017510000000341610430405663016700 0ustar adamadam00000000000000#line 1 package Module::Install::Win32; use strict; use Module::Install::Base; use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.62'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); if (!$rv) { die <<'END_MESSAGE'; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } } 1; asa-0.02/Changes0000644000175100017510000000035610430405663013327 0ustar adamadam00000000000000Revision history for Perl extension asa 0.02 Thu 11 May 2006 - Upgrading Module::Install to 0.62 final - Removing auto_install 0.01 Fri 14 Apr 2006 - original version - Only a naive implementation, doesn't handle corner cases yet asa-0.02/t/0000755000175100017510000000000010430405665012275 5ustar adamadam00000000000000asa-0.02/t/02_usage.t0000644000175100017510000000373310430405663014073 0ustar adamadam00000000000000#!/usr/bin/perl -w # Testing the basic usage of asa.pm use strict; use lib (); use File::Spec::Functions ':ALL'; BEGIN { $| = 1; unless ( $ENV{HARNESS_ACTIVE} ) { require FindBin; $FindBin::Bin = $FindBin::Bin; # Avoid a warning chdir catdir( $FindBin::Bin, updir() ); lib->import( catdir('blib', 'arch'), catdir('blib', 'lib' ), catdir('lib'), ); } } use Test::More tests => 18; my $duck = Duck->new; isa_ok( $duck, 'Duck' ); can_ok( $duck, 'quack' ); ok( ! $duck->{human}, 'Duck is not human' ); is( $duck->quack, 'Quack', 'A Duck quacks' ); my $wereduck = WereDuck->new; isa_ok( $wereduck, 'WereDuck' ); isa_ok( $wereduck, 'Lycanthrope' ); isa_ok( $wereduck, 'Duck' ); isa_ok( $wereduck, 'Horror' ); can_ok( $wereduck, 'morph' ); can_ok( $wereduck, 'quack' ); is( $wereduck->{human}, 1, 'A WereDuck is human' ); is( $wereduck->quack, 'Hi! I mean Quack!', 'A wereduck quacks' ); my $broken = BrokenDuck->new; isa_ok( $broken, 'BrokenDuck' ); isa_ok( $broken, 'Lycanthrope' ); isa_ok( $broken, 'Duck' ); can_ok( $broken, 'morph' ); is( $broken->can('quack'), undef, "A BrokenDuck can't quack" ); eval "$broken->quack"; ok( $@, 'A BrokenDuck dies if it tries to quack' ); exit(0); ##################################################################### # Packages used for testing package Duck; use strict; use vars qw{$VERSION}; BEGIN { $VERSION = '0.02'; } sub new { bless {}, $_[0] } sub quack { 'Quack' } 1; ################### package Lycanthrope; use strict; use vars qw{$VERSION}; BEGIN { $VERSION = '0.02'; } sub new { bless { human => 1 }, $_[0] } sub morph { 'HRALGLAHRLAHRAL' }; 1; ################### package WereDuck; use strict; use vars qw{$VERSION}; BEGIN { $VERSION = '0.02'; } use base 'Lycanthrope'; use asa 'Duck', 'Horror'; sub quack { 'Hi! I mean Quack!' } 1; #################### package BrokenDuck; use strict; use vars qw{$VERSION}; BEGIN { $VERSION = '0.02'; } use base 'Lycanthrope'; use asa 'Duck'; 1; asa-0.02/t/99_pod.t0000644000175100017510000000200410430405663013557 0ustar adamadam00000000000000use Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; ##################################################################### # WARNING: INSANE BLACK MAGIC ##################################################################### # Hack Pod::Simple::BlackBox to ignore the Test::Inline "=begin has more than one word errors" my $begin = \&Pod::Simple::BlackBox::_ponder_begin; sub mybegin { my $para = $_[1]; my $content = join ' ', splice @$para, 2; $content =~ s/^\s+//s; $content =~ s/\s+$//s; my @words = split /\s+/, $content; if ( $words[0] =~ /^test(?:ing)?\z/s ) { foreach ( 2 .. $#$para ) { $para->[$_] = ''; } $para->[2] = $words[0]; } # Continue as normal push @$para, @words; return &$begin(@_); } local $^W = 0; *Pod::Simple::BlackBox::_ponder_begin = \&mybegin; ##################################################################### # END BLACK MAGIC ##################################################################### all_pod_files_ok(); asa-0.02/t/01_compile.t0000644000175100017510000000101210430405663014402 0ustar adamadam00000000000000#!/usr/bin/perl -w # Compile testing for asa use strict; use lib (); use File::Spec::Functions ':ALL'; BEGIN { $| = 1; unless ( $ENV{HARNESS_ACTIVE} ) { require FindBin; $FindBin::Bin = $FindBin::Bin; # Avoid a warning chdir catdir( $FindBin::Bin, updir() ); lib->import( catdir('blib', 'arch'), catdir('blib', 'lib' ), catdir('lib'), ); } } use Test::More tests => 2; # Check their perl version ok( $] >= 5.005, "Your perl is new enough" ); # Does the module load require_ok('asa'); exit(0); asa-0.02/MANIFEST0000644000175100017510000000053410430405663013163 0ustar adamadam00000000000000Changes inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/asa.pm LICENSE Makefile.PL MANIFEST This list of files META.yml README t/01_compile.t t/02_usage.t t/99_pod.t asa-0.02/lib/0000755000175100017510000000000010430405665012600 5ustar adamadam00000000000000asa-0.02/lib/asa.pm0000644000175100017510000001247710430405663013713 0ustar adamadam00000000000000package asa; =pod =head1 NAME asa - Lets your class/object say it works like something else =head1 SYNOPSIS ######################################### # Your Code package My::WereDuck; use base 'My::Lycanthrope'; use asa 'Duck'; sub quack { return "Hi! errr... Quack!"; } ################################################ # Their Code sub strangle { my $duck = shift; unless ( $duck->isa('Duck') ) { die "We only strangle ducks"; } print "Farmer Joe wrings the duck's neck\n"; print "Said the duck, '" . $duck->quack . "'\n"; print "We ate well that night.\n"; } =head1 DESCRIPTION Perl 5 doesn't natively support Java-style interfaces, and it doesn't support Perl 6 style roles either. You can get both of these things in half a dozen different ways via various CPAN modules, but they usually require that you buy into "their way" of implementing your code. Other have turned to "duck typing". This is, for the most part, a fairly naive check that says "can you do this method", under the "if it looks like a duck, and quacks like a duck, then it must be a duck". It assumes that if you have a C<-Equack> method, then they will treat you as a duck, because doing things like adding C to your C<@ISA> array means you are also forced to take their implementation. There is, of course, a better way. For better or worse, Perl's C<-Eisa> functionality to determine if something is or is not a particular class/object is defined as a B, not a function, and so that means that as well as adding something to you C<@ISA> array, so that Perl's C method can work with it, you are also allowed to simply overload your own C method and answer directly whether or not you are something. The simplest form of the idiom looks like this. sub isa { return 1 if $_[1] eq 'Duck'; shift->SUPER::isa(@_); } This reads "Check my type as normal, but if anyone wants to know if I'm a duck, then tell them yes". Now, there are a few people that have argued that this is "lying" about your class, but this argument is based on the idea that C<@ISA> is somehow more "real" than using the method directly. It also assumes that what you advertise you implement needs to be in sync with the method resolution for any given function. But in the best and cleanest implementation of code, the API is orthogonal (although most often related) to the implementation. And although C<@ISA> is about implementation B API, overloading C to let you change your API is not at all bad when seen in this light. =head2 What does asa.pm do? Much as L provides convenient syntactic sugar for loading your parent class and setting C<@ISA>, this pragma will provide convenient syntactic sugar for creating your own custom overloaded isa functions. Beyond just the idiom above, it implements various workarounds for some edge cases, so you don't have to, and allows clear seperation of concerns. You should just be able to use it, and if something ever goes wrong, then it's my fault, and I'll fix it. =head2 What doesn't asa.pm do? In Perl, highly robust introspection is B hard. Which is why most modules that provide some level of interface functionality require you to explicitly define them in multiple classes, and start to tread on your toes. This class does B do any strict enforcement of interfaces. 90% of the time, what you want to do, and the methods you need to implement, are going to be pretty obvious, so it's your fault if you don't provide them. But at least this way, you can implement them however you like, and C will just take care of the details of safely telling everyone else you are a duck :) =head2 What if a Duck method clashes with a My::Package method? Unlike Perl 6, which implements a concept called "multi-methods", Perl 5 does not have a native approach to solving the problem of "API collision". Originally from the Java/C++ world, the problem of overcoming language API limitations can be done through the use of one of several "design patterns". For you, the victim of API collision, you might be interested in the "Adapter" pattern. For more information on implementing the Adapter pattern in Perl, see L, which provides a veritable toolkit for creating an implementation of the Adapter pattern which can solve your problem. =cut use 5.005; use strict; use Carp (); use vars qw{$VERSION}; BEGIN { $VERSION = '0.02'; } sub import { my $class = shift; my $have = caller(0); my $code = join '', "package $have;\n", "\n", "sub isa {\n", ( map { "\treturn 1 if \$_[1] eq '$_';\n" } @_ ), "\tshift->SUPER::isa(\@_);\n", "}\n"; eval( $code ); Carp::croak( "Failed to create isa method: $@" ) if $@; return 1; } 1; =head1 SUPPORT Bugs should be always be reported via the CPAN bug tracker at L For other issues, or commercial enhancement or support, contact the author. =head1 AUTHORS Adam Kennedy Ecpan@ali.asE =head1 SEE ALSO L, L =head1 COPYRIGHT Copyright (c) 2006 Adam Kennedy. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut asa-0.02/META.yml0000644000175100017510000000054010430405663013300 0ustar adamadam00000000000000 no_index: directory: - inc - t generated_by: Module::Install version 0.62 distribution_type: module version: 0.02 name: asa author: Adam Kennedy 0; requires 'base' => 0; build_requires 'File::Spec' => '0.80'; build_requires 'Test::More' => '0.47'; WriteAll; asa-0.02/README0000644000175100017510000001220710430405663012712 0ustar adamadam00000000000000NAME asa - Lets your class/object say it works like something else SYNOPSIS ######################################### # Your Code package My::WereDuck; use base 'My::Lycanthrope'; use asa 'Duck'; sub quack { return "Hi! errr... Quack!"; } ################################################ # Their Code sub strangle { my $duck = shift; unless ( $duck->isa('Duck') ) { die "We only strangle ducks"; } print "Farmer Joe wrings the duck's neck\n"; print "Said the duck, '" . $duck->quack . "'\n"; print "We ate well that night.\n"; } DESCRIPTION Perl 5 doesn't natively support Java-style interfaces, and it doesn't support Perl 6 style roles either. You can get both of these things in half a dozen different ways via various CPAN modules, but they usually require that you buy into "their way" of implementing your code. Other have turned to "duck typing". This is, for the most part, a fairly naive check that says "can you do this method", under the "if it looks like a duck, and quacks like a duck, then it must be a duck". It assumes that if you have a "->quack" method, then they will treat you as a duck, because doing things like adding "Duck" to your @ISA array means you are also forced to take their implementation. There is, of course, a better way. For better or worse, Perl's "->isa" functionality to determine if something is or is not a particular class/object is defined as a method, not a function, and so that means that as well as adding something to you @ISA array, so that Perl's "UNIVERSAL::isa" method can work with it, you are also allowed to simply overload your own "isa" method and answer directly whether or not you are something. The simplest form of the idiom looks like this. sub isa { return 1 if $_[1] eq 'Duck'; shift->SUPER::isa(@_); } This reads "Check my type as normal, but if anyone wants to know if I'm a duck, then tell them yes". Now, there are a few people that have argued that this is "lying" about your class, but this argument is based on the idea that @ISA is somehow more "real" than using the method directly. It also assumes that what you advertise you implement needs to be in sync with the method resolution for any given function. But in the best and cleanest implementation of code, the API is orthogonal (although most often related) to the implementation. And although @ISA is about implementation and API, overloading "isa" to let you change your API is not at all bad when seen in this light. What does asa.pm do? Much as base provides convenient syntactic sugar for loading your parent class and setting @ISA, this pragma will provide convenient syntactic sugar for creating your own custom overloaded isa functions. Beyond just the idiom above, it implements various workarounds for some edge cases, so you don't have to, and allows clear seperation of concerns. You should just be able to use it, and if something ever goes wrong, then it's my fault, and I'll fix it. What doesn't asa.pm do? In Perl, highly robust introspection is really hard. Which is why most modules that provide some level of interface functionality require you to explicitly define them in multiple classes, and start to tread on your toes. This class does not do any strict enforcement of interfaces. 90% of the time, what you want to do, and the methods you need to implement, are going to be pretty obvious, so it's your fault if you don't provide them. But at least this way, you can implement them however you like, and "asa" will just take care of the details of safely telling everyone else you are a duck :) What if a Duck method clashes with a My::Package method? Unlike Perl 6, which implements a concept called "multi-methods", Perl 5 does not have a native approach to solving the problem of "API collision". Originally from the Java/C++ world, the problem of overcoming language API limitations can be done through the use of one of several "design patterns". For you, the victim of API collision, you might be interested in the "Adapter" pattern. For more information on implementing the Adapter pattern in Perl, see Class::Adapter, which provides a veritable toolkit for creating an implementation of the Adapter pattern which can solve your problem. SUPPORT Bugs should be always be reported via the CPAN bug tracker at For other issues, or commercial enhancement or support, contact the author. AUTHORS Adam Kennedy COPYRIGHT Copyright (c) 2006 Adam Kennedy. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module.