???????????????????????????????

???????????????????????????????

???????????????????????????????

>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<

<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>.


﻿???????????????????????????????

???????????????????????????????

???????????????????????????????
﻿???????????????????????????????

???????????????????????????????

???????????????????????????????

>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<

<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>.

>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<


PK       ! �ßA)  )    perl5/ExtUtils/MM_DOS.pmnu ��6�$        package ExtUtils::MM_DOS;

use strict;
use warnings;

our $VERSION = '7.50';
$VERSION =~ tr/_//d;

require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );


=head1 NAME

ExtUtils::MM_DOS - DOS specific subclass of ExtUtils::MM_Unix

=head1 SYNOPSIS

  Don't use this module directly.
  Use ExtUtils::MM and let it choose.

=head1 DESCRIPTION

This is a subclass of L<ExtUtils::MM_Unix> which contains functionality
for DOS.

Unless otherwise stated, it works just like ExtUtils::MM_Unix.

=head2 Overridden methods

=over 4

=item os_flavor

=cut

sub os_flavor {
    return('DOS');
}

=item B<replace_manpage_separator>

Generates Foo__Bar.3 style man page names

=cut

sub replace_manpage_separator {
    my($self, $man) = @_;

    $man =~ s,/+,__,g;
    return $man;
}

=item xs_static_lib_is_xs

=cut

sub xs_static_lib_is_xs {
    return 1;
}

=back

=head1 AUTHOR

Michael G Schwern <schwern@pobox.com> with code from ExtUtils::MM_Unix

=head1 SEE ALSO

L<ExtUtils::MM_Unix>, L<ExtUtils::MakeMaker>

=cut

1;
PK       ! �!�u!  u!    perl5/ExtUtils/Packlist.pmnu ��6�$        package ExtUtils::Packlist;

use 5.00503;
use strict;
use Carp qw();
use Config;
use vars qw($VERSION $Relocations);
$VERSION = '2.06';
$VERSION = eval $VERSION;

# Used for generating filehandle globs.  IO::File might not be available!
my $fhname = "FH1";

=begin _undocumented

=over

=item mkfh()

Make a filehandle. Same kind of idea as Symbol::gensym().

=cut

sub mkfh()
{
no strict;
local $^W;
my $fh = \*{$fhname++};
use strict;
return($fh);
}

=item __find_relocations

Works out what absolute paths in the configuration have been located at run
time relative to $^X, and generates a regexp that matches them

=back

=end _undocumented

=cut

sub __find_relocations
{
    my %paths;
    while (my ($raw_key, $raw_val) = each %Config) {
	my $exp_key = $raw_key . "exp";
	next unless exists $Config{$exp_key};
	next unless $raw_val =~ m!\.\.\./!;
	$paths{$Config{$exp_key}}++;
    }
    # Longest prefixes go first in the alternatives
    my $alternations = join "|", map {quotemeta $_}
    sort {length $b <=> length $a} keys %paths;
    qr/^($alternations)/o;
}

sub new($$)
{
my ($class, $packfile) = @_;
$class = ref($class) || $class;
my %self;
tie(%self, $class, $packfile);
return(bless(\%self, $class));
}

sub TIEHASH
{
my ($class, $packfile) = @_;
my $self = { packfile => $packfile };
bless($self, $class);
$self->read($packfile) if (defined($packfile) && -f $packfile);
return($self);
}

sub STORE
{
$_[0]->{data}->{$_[1]} = $_[2];
}

sub FETCH
{
return($_[0]->{data}->{$_[1]});
}

sub FIRSTKEY
{
my $reset = scalar(keys(%{$_[0]->{data}}));
return(each(%{$_[0]->{data}}));
}

sub NEXTKEY
{
return(each(%{$_[0]->{data}}));
}

sub EXISTS
{
return(exists($_[0]->{data}->{$_[1]}));
}

sub DELETE
{
return(delete($_[0]->{data}->{$_[1]}));
}

sub CLEAR
{
%{$_[0]->{data}} = ();
}

sub DESTROY
{
}

sub read($;$)
{
my ($self, $packfile) = @_;
$self = tied(%$self) || $self;

if (defined($packfile)) { $self->{packfile} = $packfile; }
else { $packfile = $self->{packfile}; }
Carp::croak("No packlist filename specified") if (! defined($packfile));
my $fh = mkfh();
open($fh, "<$packfile") || Carp::croak("Can't open file $packfile: $!");
$self->{data} = {};
my ($line);
while (defined($line = <$fh>))
   {
   chomp $line;
   my ($key, $data) = $line;
   if ($key =~ /^(.*?)( \w+=.*)$/)
      {
      $key = $1;
      $data = { map { split('=', $_) } split(' ', $2)};

      if ($Config{userelocatableinc} && $data->{relocate_as})
      {
	  require File::Spec;
	  require Cwd;
	  my ($vol, $dir) = File::Spec->splitpath($packfile);
	  my $newpath = File::Spec->catpath($vol, $dir, $data->{relocate_as});
	  $key = Cwd::realpath($newpath);
      }
         }
   $key =~ s!/\./!/!g;   # Some .packlists have spurious '/./' bits in the paths
      $self->{data}->{$key} = $data;
      }
close($fh);
}

sub write($;$)
{
my ($self, $packfile) = @_;
$self = tied(%$self) || $self;
if (defined($packfile)) { $self->{packfile} = $packfile; }
else { $packfile = $self->{packfile}; }
Carp::croak("No packlist filename specified") if (! defined($packfile));
my $fh = mkfh();
open($fh, ">$packfile") || Carp::croak("Can't open file $packfile: $!");
foreach my $key (sort(keys(%{$self->{data}})))
   {
       my $data = $self->{data}->{$key};
       if ($Config{userelocatableinc}) {
	   $Relocations ||= __find_relocations();
	   if ($packfile =~ $Relocations) {
	       # We are writing into a subdirectory of a run-time relocated
	       # path. Figure out if the this file is also within a subdir.
	       my $prefix = $1;
	       if (File::Spec->no_upwards(File::Spec->abs2rel($key, $prefix)))
	       {
		   # The relocated path is within the found prefix
		   my $packfile_prefix;
		   (undef, $packfile_prefix)
		       = File::Spec->splitpath($packfile);

		   my $relocate_as
		       = File::Spec->abs2rel($key, $packfile_prefix);

		   if (!ref $data) {
		       $data = {};
		   }
		   $data->{relocate_as} = $relocate_as;
	       }
	   }
       }
   print $fh ("$key");
   if (ref($data))
      {
      foreach my $k (sort(keys(%$data)))
         {
         print $fh (" $k=$data->{$k}");
         }
      }
   print $fh ("\n");
   }
close($fh);
}

sub validate($;$)
{
my ($self, $remove) = @_;
$self = tied(%$self) || $self;
my @missing;
foreach my $key (sort(keys(%{$self->{data}})))
   {
   if (! -e $key)
      {
      push(@missing, $key);
      delete($self->{data}{$key}) if ($remove);
      }
   }
return(@missing);
}

sub packlist_file($)
{
my ($self) = @_;
$self = tied(%$self) || $self;
return($self->{packfile});
}

1;

__END__

=head1 NAME

ExtUtils::Packlist - manage .packlist files

=head1 SYNOPSIS

   use ExtUtils::Packlist;
   my ($pl) = ExtUtils::Packlist->new('.packlist');
   $pl->read('/an/old/.packlist');
   my @missing_files = $pl->validate();
   $pl->write('/a/new/.packlist');

   $pl->{'/some/file/name'}++;
      or
   $pl->{'/some/other/file/name'} = { type => 'file',
                                      from => '/some/file' };

=head1 DESCRIPTION

ExtUtils::Packlist provides a standard way to manage .packlist files.
Functions are provided to read and write .packlist files.  The original
.packlist format is a simple list of absolute pathnames, one per line.  In
addition, this package supports an extended format, where as well as a filename
each line may contain a list of attributes in the form of a space separated
list of key=value pairs.  This is used by the installperl script to
differentiate between files and links, for example.

=head1 USAGE

The hash reference returned by the new() function can be used to examine and
modify the contents of the .packlist.  Items may be added/deleted from the
.packlist by modifying the hash.  If the value associated with a hash key is a
scalar, the entry written to the .packlist by any subsequent write() will be a
simple filename.  If the value is a hash, the entry written will be the
filename followed by the key=value pairs from the hash.  Reading back the
.packlist will recreate the original entries.

=head1 FUNCTIONS

=over 4

=item new()

This takes an optional parameter, the name of a .packlist.  If the file exists,
it will be opened and the contents of the file will be read.  The new() method
returns a reference to a hash.  This hash holds an entry for each line in the
.packlist.  In the case of old-style .packlists, the value associated with each
key is undef.  In the case of new-style .packlists, the value associated with
each key is a hash containing the key=value pairs following the filename in the
.packlist.

=item read()

This takes an optional parameter, the name of the .packlist to be read.  If
no file is specified, the .packlist specified to new() will be read.  If the
.packlist does not exist, Carp::croak will be called.

=item write()

This takes an optional parameter, the name of the .packlist to be written.  If
no file is specified, the .packlist specified to new() will be overwritten.

=item validate()

This checks that every file listed in the .packlist actually exists.  If an
argument which evaluates to true is given, any missing files will be removed
from the internal hash.  The return value is a list of the missing files, which
will be empty if they all exist.

=item packlist_file()

This returns the name of the associated .packlist file

=back

=head1 EXAMPLE

Here's C<modrm>, a little utility to cleanly remove an installed module.

    #!/usr/local/bin/perl -w

    use strict;
    use IO::Dir;
    use ExtUtils::Packlist;
    use ExtUtils::Installed;

    sub emptydir($) {
	my ($dir) = @_;
	my $dh = IO::Dir->new($dir) || return(0);
	my @count = $dh->read();
	$dh->close();
	return(@count == 2 ? 1 : 0);
    }

    # Find all the installed packages
    print("Finding all installed modules...\n");
    my $installed = ExtUtils::Installed->new();

    foreach my $module (grep(!/^Perl$/, $installed->modules())) {
       my $version = $installed->version($module) || "???";
       print("Found module $module Version $version\n");
       print("Do you want to delete $module? [n] ");
       my $r = <STDIN>; chomp($r);
       if ($r && $r =~ /^y/i) {
	  # Remove all the files
	  foreach my $file (sort($installed->files($module))) {
	     print("rm $file\n");
	     unlink($file);
	  }
	  my $pf = $installed->packlist($module)->packlist_file();
	  print("rm $pf\n");
	  unlink($pf);
	  foreach my $dir (sort($installed->directory_tree($module))) {
	     if (emptydir($dir)) {
		print("rmdir $dir\n");
		rmdir($dir);
	     }
	  }
       }
    }

=head1 AUTHOR

Alan Burlison <Alan.Burlison@uk.sun.com>

=cut
PK       ! t2�i�  �    perl5/ExtUtils/MM_VOS.pmnu ��6�$        package ExtUtils::MM_VOS;

use strict;
use warnings;
our $VERSION = '7.50';
$VERSION =~ tr/_//d;

require ExtUtils::MM_Unix;
our @ISA = qw(ExtUtils::MM_Unix);


=head1 NAME

ExtUtils::MM_VOS - VOS specific subclass of ExtUtils::MM_Unix

=head1 SYNOPSIS

  Don't use this module directly.
  Use ExtUtils::MM and let it choose.

=head1 DESCRIPTION

This is a subclass of L<ExtUtils::MM_Unix> which contains functionality for
VOS.

Unless otherwise stated it works just like ExtUtils::MM_Unix.

=head2 Overridden methods

=head3 extra_clean_files

Cleanup VOS core files

=cut

sub extra_clean_files {
    return qw(*.kp);
}


=head1 AUTHOR

Michael G Schwern <schwern@pobox.com> with code from ExtUtils::MM_Unix

=head1 SEE ALSO

L<ExtUtils::MakeMaker>

=cut


1;
PK       ! 	���  �    perl5/ExtUtils/MM_OS2.pmnu ��6�$        package ExtUtils::MM_OS2;

use strict;
use warnings;

use ExtUtils::MakeMaker qw(neatvalue);
use File::Spec;

our $VERSION = '7.50';
$VERSION =~ tr/_//d;

require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
our @ISA = qw(ExtUtils::MM_Any ExtUtils::MM_Unix);

=pod

=head1 NAME

ExtUtils::MM_OS2 - methods to override UN*X behaviour in ExtUtils::MakeMaker

=head1 SYNOPSIS

 use ExtUtils::MM_OS2; # Done internally by ExtUtils::MakeMaker if needed

=head1 DESCRIPTION

See L<ExtUtils::MM_Unix> for a documentation of the methods provided
there. This package overrides the implementation of these methods, not
the semantics.

=head1 METHODS

=over 4

=item init_dist

Define TO_UNIX to convert OS2 linefeeds to Unix style.

=cut

sub init_dist {
    my($self) = @_;

    $self->{TO_UNIX} ||= <<'MAKE_TEXT';
$(NOECHO) $(TEST_F) tmp.zip && $(RM_F) tmp.zip; $(ZIP) -ll -mr tmp.zip $(DISTVNAME) && unzip -o tmp.zip && $(RM_F) tmp.zip
MAKE_TEXT

    $self->SUPER::init_dist;
}

sub dlsyms {
    my($self,%attribs) = @_;
    if ($self->{IMPORTS} && %{$self->{IMPORTS}}) {
	# Make import files (needed for static build)
	-d 'tmp_imp' or mkdir 'tmp_imp', 0777 or die "Can't mkdir tmp_imp";
	open my $imp, '>', 'tmpimp.imp' or die "Can't open tmpimp.imp";
	foreach my $name (sort keys %{$self->{IMPORTS}}) {
	    my $exp = $self->{IMPORTS}->{$name};
	    my ($lib, $id) = ($exp =~ /(.*)\.(.*)/) or die "Malformed IMPORT `$exp'";
	    print $imp "$name $lib $id ?\n";
	}
	close $imp or die "Can't close tmpimp.imp";
	# print "emximp -o tmpimp$Config::Config{lib_ext} tmpimp.imp\n";
	system "emximp -o tmpimp$Config::Config{lib_ext} tmpimp.imp"
	    and die "Cannot make import library: $!, \$?=$?";
	# May be running under miniperl, so have no glob...
	eval { unlink <tmp_imp/*>; 1 } or system "rm tmp_imp/*";
	system "cd tmp_imp; $Config::Config{ar} x ../tmpimp$Config::Config{lib_ext}"
	    and die "Cannot extract import objects: $!, \$?=$?";
    }
    return '' if $self->{SKIPHASH}{'dynamic'};
    $self->xs_dlsyms_iterator(\%attribs);
}

sub xs_dlsyms_ext {
    '.def';
}

sub xs_dlsyms_extra {
    join '', map { qq{, "$_" => "\$($_)"} } qw(VERSION DISTNAME INSTALLDIRS);
}

sub static_lib_pure_cmd {
    my($self) = @_;
    my $old = $self->SUPER::static_lib_pure_cmd;
    return $old unless $self->{IMPORTS} && %{$self->{IMPORTS}};
    $old . <<'EOC';
	$(AR) $(AR_STATIC_ARGS) "$@" tmp_imp/*
	$(RANLIB) "$@"
EOC
}

sub replace_manpage_separator {
    my($self,$man) = @_;
    $man =~ s,/+,.,g;
    $man;
}

sub maybe_command {
    my($self,$file) = @_;
    $file =~ s,[/\\]+,/,g;
    return $file if -x $file && ! -d _;
    return "$file.exe" if -x "$file.exe" && ! -d _;
    return "$file.cmd" if -x "$file.cmd" && ! -d _;
    return;
}

=item init_linker

=cut

sub init_linker {
    my $self = shift;

    $self->{PERL_ARCHIVE} = "\$(PERL_INC)/libperl\$(LIB_EXT)";

    $self->{PERL_ARCHIVEDEP} ||= '';
    $self->{PERL_ARCHIVE_AFTER} = $OS2::is_aout
      ? ''
      : '$(PERL_INC)/libperl_override$(LIB_EXT)';
    $self->{EXPORT_LIST} = '$(BASEEXT).def';
}

=item os_flavor

OS/2 is OS/2

=cut

sub os_flavor {
    return('OS/2');
}

=item xs_static_lib_is_xs

=cut

sub xs_static_lib_is_xs {
    return 1;
}

=back

=cut

1;
PK       ! �8�      perl5/ExtUtils/Command/MM.pmnu ��6�$        package ExtUtils::Command::MM;

require 5.006;

use strict;
use warnings;

require Exporter;
our @ISA = qw(Exporter);

our @EXPORT  = qw(test_harness pod2man perllocal_install uninstall
                  warn_if_old_packlist test_s cp_nonempty);
our $VERSION = '7.50';
$VERSION =~ tr/_//d;

my $Is_VMS = $^O eq 'VMS';

sub mtime {
  no warnings 'redefine';
  local $@;
  *mtime = (eval { require Time::HiRes } && defined &Time::HiRes::stat)
    ? sub { (Time::HiRes::stat($_[0]))[9] }
    : sub { (             stat($_[0]))[9] }
  ;
  goto &mtime;
}

=head1 NAME

ExtUtils::Command::MM - Commands for the MM's to use in Makefiles

=head1 SYNOPSIS

  perl "-MExtUtils::Command::MM" -e "function" "--" arguments...


=head1 DESCRIPTION

B<FOR INTERNAL USE ONLY!>  The interface is not stable.

ExtUtils::Command::MM encapsulates code which would otherwise have to
be done with large "one" liners.

Any $(FOO) used in the examples are make variables, not Perl.

=over 4

=item B<test_harness>

  test_harness($verbose, @test_libs);

Runs the tests on @ARGV via Test::Harness passing through the $verbose
flag.  Any @test_libs will be unshifted onto the test's @INC.

@test_libs are run in alphabetical order.

=cut

sub test_harness {
    require Test::Harness;
    require File::Spec;

    $Test::Harness::verbose = shift;

    # Because Windows doesn't do this for us and listing all the *.t files
    # out on the command line can blow over its exec limit.
    require ExtUtils::Command;
    my @argv = ExtUtils::Command::expand_wildcards(@ARGV);

    local @INC = @INC;
    unshift @INC, map { File::Spec->rel2abs($_) } @_;
    Test::Harness::runtests(sort { lc $a cmp lc $b } @argv);
}


=item B<pod2man>

  pod2man( '--option=value',
           $podfile1 => $manpage1,
           $podfile2 => $manpage2,
           ...
         );

  # or args on @ARGV

pod2man() is a function performing most of the duties of the pod2man
program.  Its arguments are exactly the same as pod2man as of 5.8.0
with the addition of:

    --perm_rw   octal permission to set the resulting manpage to

And the removal of:

    --verbose/-v
    --help/-h

If no arguments are given to pod2man it will read from @ARGV.

If Pod::Man is unavailable, this function will warn and return undef.

=cut

sub pod2man {
    local @ARGV = @_ ? @_ : @ARGV;

    {
        local $@;
        if( !eval { require Pod::Man } ) {
            warn "Pod::Man is not available: $@".
                 "Man pages will not be generated during this install.\n";
            return 0;
        }
    }
    require Getopt::Long;

    # We will cheat and just use Getopt::Long.  We fool it by putting
    # our arguments into @ARGV.  Should be safe.
    my %options = ();
    Getopt::Long::config ('bundling_override');
    Getopt::Long::GetOptions (\%options,
                'section|s=s', 'release|r=s', 'center|c=s',
                'date|d=s', 'fixed=s', 'fixedbold=s', 'fixeditalic=s',
                'fixedbolditalic=s', 'official|o', 'quotes|q=s', 'lax|l',
                'name|n=s', 'perm_rw=i', 'utf8|u'
    );
    delete $options{utf8} unless $Pod::Man::VERSION >= 2.17;

    # If there's no files, don't bother going further.
    return 0 unless @ARGV;

    # Official sets --center, but don't override things explicitly set.
    if ($options{official} && !defined $options{center}) {
        $options{center} = q[Perl Programmer's Reference Guide];
    }

    # This isn't a valid Pod::Man option and is only accepted for backwards
    # compatibility.
    delete $options{lax};
    my $count = scalar @ARGV / 2;
    my $plural = $count == 1 ? 'document' : 'documents';
    print "Manifying $count pod $plural\n";

    do {{  # so 'next' works
        my ($pod, $man) = splice(@ARGV, 0, 2);

        next if ((-e $man) &&
                 (mtime($man) > mtime($pod)) &&
                 (mtime($man) > mtime("Makefile")));

        my $parser = Pod::Man->new(%options);
        $parser->parse_from_file($pod, $man)
          or do { warn("Could not install $man\n");  next };

        if (exists $options{perm_rw}) {
            chmod(oct($options{perm_rw}), $man)
              or do { warn("chmod $options{perm_rw} $man: $!\n"); next };
        }
    }} while @ARGV;

    return 1;
}


=item B<warn_if_old_packlist>

  perl "-MExtUtils::Command::MM" -e warn_if_old_packlist <somefile>

Displays a warning that an old packlist file was found.  Reads the
filename from @ARGV.

=cut

sub warn_if_old_packlist {
    my $packlist = $ARGV[0];

    return unless -f $packlist;
    print <<"PACKLIST_WARNING";
WARNING: I have found an old package in
    $packlist.
Please make sure the two installations are not conflicting
PACKLIST_WARNING

}


=item B<perllocal_install>

    perl "-MExtUtils::Command::MM" -e perllocal_install
        <type> <module name> <key> <value> ...

    # VMS only, key|value pairs come on STDIN
    perl "-MExtUtils::Command::MM" -e perllocal_install
        <type> <module name> < <key>|<value> ...

Prints a fragment of POD suitable for appending to perllocal.pod.
Arguments are read from @ARGV.

'type' is the type of what you're installing.  Usually 'Module'.

'module name' is simply the name of your module.  (Foo::Bar)

Key/value pairs are extra information about the module.  Fields include:

    installed into      which directory your module was out into
    LINKTYPE            dynamic or static linking
    VERSION             module version number
    EXE_FILES           any executables installed in a space separated
                        list

=cut

sub perllocal_install {
    my($type, $name) = splice(@ARGV, 0, 2);

    # VMS feeds args as a piped file on STDIN since it usually can't
    # fit all the args on a single command line.
    my @mod_info = $Is_VMS ? split /\|/, <STDIN>
                           : @ARGV;

    my $pod;
    my $time = gmtime($ENV{SOURCE_DATE_EPOCH} || time);
    $pod = sprintf <<'POD', scalar($time), $type, $name, $name;
 =head2 %s: C<%s> L<%s|%s>

 =over 4

POD

    do {
        my($key, $val) = splice(@mod_info, 0, 2);

        $pod .= <<POD
 =item *

 C<$key: $val>

POD

    } while(@mod_info);

    $pod .= "=back\n\n";
    $pod =~ s/^ //mg;
    print $pod;

    return 1;
}

=item B<uninstall>

    perl "-MExtUtils::Command::MM" -e uninstall <packlist>

A wrapper around ExtUtils::Install::uninstall().  Warns that
uninstallation is deprecated and doesn't actually perform the
uninstallation.

=cut

sub uninstall {
    my($packlist) = shift @ARGV;

    require ExtUtils::Install;

    print <<'WARNING';

Uninstall is unsafe and deprecated, the uninstallation was not performed.
We will show what would have been done.

WARNING

    ExtUtils::Install::uninstall($packlist, 1, 1);

    print <<'WARNING';

Uninstall is unsafe and deprecated, the uninstallation was not performed.
Please check the list above carefully, there may be errors.
Remove the appropriate files manually.
Sorry for the inconvenience.

WARNING

}

=item B<test_s>

   perl "-MExtUtils::Command::MM" -e test_s <file>

Tests if a file exists and is not empty (size > 0).
I<Exits> with 0 if it does, 1 if it does not.

=cut

sub test_s {
  exit(-s $ARGV[0] ? 0 : 1);
}

=item B<cp_nonempty>

  perl "-MExtUtils::Command::MM" -e cp_nonempty <srcfile> <dstfile> <perm>

Tests if the source file exists and is not empty (size > 0). If it is not empty
it copies it to the given destination with the given permissions.

=back

=cut

sub cp_nonempty {
  my @args = @ARGV;
  return 0 unless -s $args[0];
  require ExtUtils::Command;
  {
    local @ARGV = @args[0,1];
    ExtUtils::Command::cp(@ARGV);
  }
  {
    local @ARGV = @args[2,1];
    ExtUtils::Command::chmod(@ARGV);
  }
}


1;
PK       ! 6�FN�C �C   perl5/ExtUtils/MM_Any.pmnu ��6�$        package ExtUtils::MM_Any;

use strict;
use warnings;
our $VERSION = '7.50';
$VERSION =~ tr/_//d;

use Carp;
use File::Spec;
use File::Basename;
BEGIN { our @ISA = qw(File::Spec); }

# We need $Verbose
use ExtUtils::MakeMaker qw($Verbose neatvalue _sprintf562);

use ExtUtils::MakeMaker::Config;


# So we don't have to keep calling the methods over and over again,
# we have these globals to cache the values.  Faster and shrtr.
my $Curdir  = __PACKAGE__->curdir;
#my $Updir   = __PACKAGE__->updir;

my $METASPEC_URL = 'https://metacpan.org/pod/CPAN::Meta::Spec';
my $METASPEC_V = 2;

=head1 NAME

ExtUtils::MM_Any - Platform-agnostic MM methods

=head1 SYNOPSIS

  FOR INTERNAL USE ONLY!

  package ExtUtils::MM_SomeOS;

  # Temporarily, you have to subclass both.  Put MM_Any first.
  require ExtUtils::MM_Any;
  require ExtUtils::MM_Unix;
  @ISA = qw(ExtUtils::MM_Any ExtUtils::Unix);

=head1 DESCRIPTION

B<FOR INTERNAL USE ONLY!>

ExtUtils::MM_Any is a superclass for the ExtUtils::MM_* set of
modules.  It contains methods which are either inherently
cross-platform or are written in a cross-platform manner.

Subclass off of ExtUtils::MM_Any I<and> L<ExtUtils::MM_Unix>.  This is a
temporary solution.

B<THIS MAY BE TEMPORARY!>


=head1 METHODS

Any methods marked I<Abstract> must be implemented by subclasses.


=head2 Cross-platform helper methods

These are methods which help writing cross-platform code.


=head3 os_flavor  I<Abstract>

    my @os_flavor = $mm->os_flavor;

@os_flavor is the style of operating system this is, usually
corresponding to the MM_*.pm file we're using.

The first element of @os_flavor is the major family (ie. Unix,
Windows, VMS, OS/2, etc...) and the rest are sub families.

Some examples:

    Cygwin98       ('Unix',  'Cygwin', 'Cygwin9x')
    Windows        ('Win32')
    Win98          ('Win32', 'Win9x')
    Linux          ('Unix',  'Linux')
    MacOS X        ('Unix',  'Darwin', 'MacOS', 'MacOS X')
    OS/2           ('OS/2')

This is used to write code for styles of operating system.
See os_flavor_is() for use.


=head3 os_flavor_is

    my $is_this_flavor = $mm->os_flavor_is($this_flavor);
    my $is_this_flavor = $mm->os_flavor_is(@one_of_these_flavors);

Checks to see if the current operating system is one of the given flavors.

This is useful for code like:

    if( $mm->os_flavor_is('Unix') ) {
        $out = `foo 2>&1`;
    }
    else {
        $out = `foo`;
    }

=cut

sub os_flavor_is {
    my $self = shift;
    my %flavors = map { ($_ => 1) } $self->os_flavor;
    return (grep { $flavors{$_} } @_) ? 1 : 0;
}


=head3 can_load_xs

    my $can_load_xs = $self->can_load_xs;

Returns true if we have the ability to load XS.

This is important because miniperl, used to build XS modules in the
core, can not load XS.

=cut

sub can_load_xs {
    return defined &DynaLoader::boot_DynaLoader ? 1 : 0;
}


=head3 can_run

  use ExtUtils::MM;
  my $runnable = MM->can_run($Config{make});

If called in a scalar context it will return the full path to the binary
you asked for if it was found, or C<undef> if it was not.

If called in a list context, it will return a list of the full paths to instances
of the binary where found in C<PATH>, or an empty list if it was not found.

Copied from L<IPC::Cmd|IPC::Cmd/"$path = can_run( PROGRAM );">, but modified into
a method (and removed C<$INSTANCES> capability).

=cut

sub can_run {
    my ($self, $command) = @_;

    # a lot of VMS executables have a symbol defined
    # check those first
    if ( $^O eq 'VMS' ) {
        require VMS::DCLsym;
        my $syms = VMS::DCLsym->new;
        return $command if scalar $syms->getsym( uc $command );
    }

    my @possibles;

    if( File::Spec->file_name_is_absolute($command) ) {
        return $self->maybe_command($command);

    } else {
        for my $dir (
            File::Spec->path,
            File::Spec->curdir
        ) {
            next if ! $dir || ! -d $dir;
            my $abs = File::Spec->catfile($self->os_flavor_is('Win32') ? Win32::GetShortPathName( $dir ) : $dir, $command);
            push @possibles, $abs if $abs = $self->maybe_command($abs);
        }
    }
    return @possibles if wantarray;
    return shift @possibles;
}


=head3 can_redirect_error

  $useredirect = MM->can_redirect_error;

True if on an OS where qx operator (or backticks) can redirect C<STDERR>
onto C<STDOUT>.

=cut

sub can_redirect_error {
  my $self = shift;
  $self->os_flavor_is('Unix')
      or ($self->os_flavor_is('Win32') and !$self->os_flavor_is('Win9x'))
      or $self->os_flavor_is('OS/2')
}


=head3 is_make_type

    my $is_dmake = $self->is_make_type('dmake');

Returns true if C<< $self->make >> is the given type; possibilities are:

  gmake    GNU make
  dmake
  nmake
  bsdmake  BSD pmake-derived

=cut

my %maketype2true;
# undocumented - so t/cd.t can still do its thing
sub _clear_maketype_cache { %maketype2true = () }

sub is_make_type {
    my($self, $type) = @_;
    return $maketype2true{$type} if defined $maketype2true{$type};
    (undef, undef, my $make_basename) = $self->splitpath($self->make);
    return $maketype2true{$type} = 1
        if $make_basename =~ /\b$type\b/i; # executable's filename
    return $maketype2true{$type} = 0
        if $make_basename =~ /\b[gdn]make\b/i; # Never fall through for dmake/nmake/gmake
    # now have to run with "-v" and guess
    my $redirect = $self->can_redirect_error ? '2>&1' : '';
    my $make = $self->make || $self->{MAKE};
    my $minus_v = `"$make" -v $redirect`;
    return $maketype2true{$type} = 1
        if $type eq 'gmake' and $minus_v =~ /GNU make/i;
    return $maketype2true{$type} = 1
        if $type eq 'bsdmake'
      and $minus_v =~ /^usage: make \[-BeikNnqrstWwX\]/im;
    $maketype2true{$type} = 0; # it wasn't whatever you asked
}


=head3 can_dep_space

    my $can_dep_space = $self->can_dep_space;

Returns true if C<make> can handle (probably by quoting)
dependencies that contain a space. Currently known true for GNU make,
false for BSD pmake derivative.

=cut

my $cached_dep_space;
sub can_dep_space {
    my $self = shift;
    return $cached_dep_space if defined $cached_dep_space;
    return $cached_dep_space = 1 if $self->is_make_type('gmake');
    return $cached_dep_space = 0 if $self->is_make_type('dmake'); # only on W32
    return $cached_dep_space = 0 if $self->is_make_type('bsdmake');
    return $cached_dep_space = 0; # assume no
}


=head3 quote_dep

  $text = $mm->quote_dep($text);

Method that protects Makefile single-value constants (mainly filenames),
so that make will still treat them as single values even if they
inconveniently have spaces in. If the make program being used cannot
achieve such protection and the given text would need it, throws an
exception.

=cut

sub quote_dep {
    my ($self, $arg) = @_;
    die <<EOF if $arg =~ / / and not $self->can_dep_space;
Tried to use make dependency with space for make that can't:
  '$arg'
EOF
    $arg =~ s/( )/\\$1/g; # how GNU make does it
    return $arg;
}


=head3 split_command

    my @cmds = $MM->split_command($cmd, @args);

Most OS have a maximum command length they can execute at once.  Large
modules can easily generate commands well past that limit.  Its
necessary to split long commands up into a series of shorter commands.

C<split_command> will return a series of @cmds each processing part of
the args.  Collectively they will process all the arguments.  Each
individual line in @cmds will not be longer than the
$self->max_exec_len being careful to take into account macro expansion.

$cmd should include any switches and repeated initial arguments.

If no @args are given, no @cmds will be returned.

Pairs of arguments will always be preserved in a single command, this
is a heuristic for things like pm_to_blib and pod2man which work on
pairs of arguments.  This makes things like this safe:

    $self->split_command($cmd, %pod2man);


=cut

sub split_command {
    my($self, $cmd, @args) = @_;

    my @cmds = ();
    return(@cmds) unless @args;

    # If the command was given as a here-doc, there's probably a trailing
    # newline.
    chomp $cmd;

    # set aside 30% for macro expansion.
    my $len_left = int($self->max_exec_len * 0.70);
    $len_left -= length $self->_expand_macros($cmd);

    do {
        my $arg_str = '';
        my @next_args;
        while( @next_args = splice(@args, 0, 2) ) {
            # Two at a time to preserve pairs.
            my $next_arg_str = "\t  ". join ' ', @next_args, "\n";

            if( !length $arg_str ) {
                $arg_str .= $next_arg_str
            }
            elsif( length($arg_str) + length($next_arg_str) > $len_left ) {
                unshift @args, @next_args;
                last;
            }
            else {
                $arg_str .= $next_arg_str;
            }
        }
        chop $arg_str;

        push @cmds, $self->escape_newlines("$cmd \n$arg_str");
    } while @args;

    return @cmds;
}


sub _expand_macros {
    my($self, $cmd) = @_;

    $cmd =~ s{\$\((\w+)\)}{
        defined $self->{$1} ? $self->{$1} : "\$($1)"
    }e;
    return $cmd;
}


=head3 make_type

Returns a suitable string describing the type of makefile being written.

=cut

# override if this isn't suitable!
sub make_type { return 'Unix-style'; }


=head3 stashmeta

    my @recipelines = $MM->stashmeta($text, $file);

Generates a set of C<@recipelines> which will result in the literal
C<$text> ending up in literal C<$file> when the recipe is executed. Call
it once, with all the text you want in C<$file>. Make macros will not
be expanded, so the locations will be fixed at configure-time, not
at build-time.

=cut

sub stashmeta {
    my($self, $text, $file) = @_;
    $self->echo($text, $file, { allow_variables => 0, append => 0 });
}


=head3 echo

    my @commands = $MM->echo($text);
    my @commands = $MM->echo($text, $file);
    my @commands = $MM->echo($text, $file, \%opts);

Generates a set of @commands which print the $text to a $file.

If $file is not given, output goes to STDOUT.

If $opts{append} is true the $file will be appended to rather than
overwritten.  Default is to overwrite.

If $opts{allow_variables} is true, make variables of the form
C<$(...)> will not be escaped.  Other C<$> will.  Default is to escape
all C<$>.

Example of use:

    my $make = join '', map "\t$_\n", $MM->echo($text, $file);

=cut

sub echo {
    my($self, $text, $file, $opts) = @_;

    # Compatibility with old options
    if( !ref $opts ) {
        my $append = $opts;
        $opts = { append => $append || 0 };
    }
    $opts->{allow_variables} = 0 unless defined $opts->{allow_variables};

    my $ql_opts = { allow_variables => $opts->{allow_variables} };
    my @cmds = map { '$(NOECHO) $(ECHO) '.$self->quote_literal($_, $ql_opts) }
               split /\n/, $text;
    if( $file ) {
        my $redirect = $opts->{append} ? '>>' : '>';
        $cmds[0] .= " $redirect $file";
        $_ .= " >> $file" foreach @cmds[1..$#cmds];
    }

    return @cmds;
}


=head3 wraplist

  my $args = $mm->wraplist(@list);

Takes an array of items and turns them into a well-formatted list of
arguments.  In most cases this is simply something like:

    FOO \
    BAR \
    BAZ

=cut

sub wraplist {
    my $self = shift;
    return join " \\\n\t", @_;
}


=head3 maketext_filter

    my $filter_make_text = $mm->maketext_filter($make_text);

The text of the Makefile is run through this method before writing to
disk.  It allows systems a chance to make portability fixes to the
Makefile.

By default it does nothing.

This method is protected and not intended to be called outside of
MakeMaker.

=cut

sub maketext_filter { return $_[1] }


=head3 cd  I<Abstract>

  my $subdir_cmd = $MM->cd($subdir, @cmds);

This will generate a make fragment which runs the @cmds in the given
$dir.  The rough equivalent to this, except cross platform.

  cd $subdir && $cmd

Currently $dir can only go down one level.  "foo" is fine.  "foo/bar" is
not.  "../foo" is right out.

The resulting $subdir_cmd has no leading tab nor trailing newline.  This
makes it easier to embed in a make string.  For example.

      my $make = sprintf <<'CODE', $subdir_cmd;
  foo :
      $(ECHO) what
      %s
      $(ECHO) mouche
  CODE


=head3 oneliner  I<Abstract>

  my $oneliner = $MM->oneliner($perl_code);
  my $oneliner = $MM->oneliner($perl_code, \@switches);

This will generate a perl one-liner safe for the particular platform
you're on based on the given $perl_code and @switches (a -e is
assumed) suitable for using in a make target.  It will use the proper
shell quoting and escapes.

$(PERLRUN) will be used as perl.

Any newlines in $perl_code will be escaped.  Leading and trailing
newlines will be stripped.  Makes this idiom much easier:

    my $code = $MM->oneliner(<<'CODE', [...switches...]);
some code here
another line here
CODE

Usage might be something like:

    # an echo emulation
    $oneliner = $MM->oneliner('print "Foo\n"');
    $make = '$oneliner > somefile';

Dollar signs in the $perl_code will be protected from make using the
C<quote_literal> method, unless they are recognised as being a make
variable, C<$(varname)>, in which case they will be left for make
to expand. Remember to quote make macros else it might be used as a
bareword. For example:

    # Assign the value of the $(VERSION_FROM) make macro to $vf.
    $oneliner = $MM->oneliner('$vf = "$(VERSION_FROM)"');

Its currently very simple and may be expanded sometime in the figure
to include more flexible code and switches.


=head3 quote_literal  I<Abstract>

    my $safe_text = $MM->quote_literal($text);
    my $safe_text = $MM->quote_literal($text, \%options);

This will quote $text so it is interpreted literally in the shell.

For example, on Unix this would escape any single-quotes in $text and
put single-quotes around the whole thing.

If $options{allow_variables} is true it will leave C<'$(FOO)'> make
variables untouched.  If false they will be escaped like any other
C<$>.  Defaults to true.

=head3 escape_dollarsigns

    my $escaped_text = $MM->escape_dollarsigns($text);

Escapes stray C<$> so they are not interpreted as make variables.

It lets by C<$(...)>.

=cut

sub escape_dollarsigns {
    my($self, $text) = @_;

    # Escape dollar signs which are not starting a variable
    $text =~ s{\$ (?!\() }{\$\$}gx;

    return $text;
}


=head3 escape_all_dollarsigns

    my $escaped_text = $MM->escape_all_dollarsigns($text);

Escapes all C<$> so they are not interpreted as make variables.

=cut

sub escape_all_dollarsigns {
    my($self, $text) = @_;

    # Escape dollar signs
    $text =~ s{\$}{\$\$}gx;

    return $text;
}


=head3 escape_newlines  I<Abstract>

    my $escaped_text = $MM->escape_newlines($text);

Shell escapes newlines in $text.


=head3 max_exec_len  I<Abstract>

    my $max_exec_len = $MM->max_exec_len;

Calculates the maximum command size the OS can exec.  Effectively,
this is the max size of a shell command line.

=for _private
$self->{_MAX_EXEC_LEN} is set by this method, but only for testing purposes.


=head3 make

    my $make = $MM->make;

Returns the make variant we're generating the Makefile for.  This attempts
to do some normalization on the information from %Config or the user.

=cut

sub make {
    my $self = shift;

    my $make = lc $self->{MAKE};

    # Truncate anything like foomake6 to just foomake.
    $make =~ s/^(\w+make).*/$1/;

    # Turn gnumake into gmake.
    $make =~ s/^gnu/g/;

    return $make;
}


=head2 Targets

These are methods which produce make targets.


=head3 all_target

Generate the default target 'all'.

=cut

sub all_target {
    my $self = shift;

    return <<'MAKE_EXT';
all :: pure_all
	$(NOECHO) $(NOOP)
MAKE_EXT

}


=head3 blibdirs_target

    my $make_frag = $mm->blibdirs_target;

Creates the blibdirs target which creates all the directories we use
in blib/.

The blibdirs.ts target is deprecated.  Depend on blibdirs instead.


=cut

sub _xs_list_basenames {
    my ($self) = @_;
    map { (my $b = $_) =~ s/\.xs$//; $b } sort keys %{ $self->{XS} };
}

sub blibdirs_target {
    my $self = shift;

    my @dirs = map { uc "\$(INST_$_)" } qw(libdir archlib
                                           autodir archautodir
                                           bin script
                                           man1dir man3dir
                                          );
    if ($self->{XSMULTI}) {
        for my $ext ($self->_xs_list_basenames) {
            my ($v, $d, $f) = File::Spec->splitpath($ext);
            my @d = File::Spec->splitdir($d);
            shift @d if $d[0] eq 'lib';
            push @dirs, $self->catdir('$(INST_ARCHLIB)', 'auto', @d, $f);
	}
    }

    my @exists = map { $_.'$(DFSEP).exists' } @dirs;

    my $make = sprintf <<'MAKE', join(' ', @exists);
blibdirs : %s
	$(NOECHO) $(NOOP)

# Backwards compat with 6.18 through 6.25
blibdirs.ts : blibdirs
	$(NOECHO) $(NOOP)

MAKE

    $make .= $self->dir_target(@dirs);

    return $make;
}


=head3 clean (o)

Defines the clean target.

=cut

sub clean {
# --- Cleanup and Distribution Sections ---

    my($self, %attribs) = @_;
    my @m;
    push(@m, '
# Delete temporary files but do not touch installed files. We don\'t delete
# the Makefile here so a later make realclean still has a makefile to use.

clean :: clean_subdirs
');

    my @files = sort values %{$self->{XS}}; # .c files from *.xs files
    push @files, map {
	my $file = $_;
	map { $file.$_ } $self->{OBJ_EXT}, qw(.def _def.old .bs .bso .exp .base);
    } $self->_xs_list_basenames;
    my @dirs  = qw(blib);

    # Normally these are all under blib but they might have been
    # redefined.
    # XXX normally this would be a good idea, but the Perl core sets
    # INST_LIB = ../../lib rather than actually installing the files.
    # So a "make clean" in an ext/ directory would blow away lib.
    # Until the core is adjusted let's leave this out.
#     push @dirs, qw($(INST_ARCHLIB) $(INST_LIB)
#                    $(INST_BIN) $(INST_SCRIPT)
#                    $(INST_MAN1DIR) $(INST_MAN3DIR)
#                    $(INST_LIBDIR) $(INST_ARCHLIBDIR) $(INST_AUTODIR)
#                    $(INST_STATIC) $(INST_DYNAMIC)
#                 );


    if( $attribs{FILES} ) {
        # Use @dirs because we don't know what's in here.
        push @dirs, ref $attribs{FILES}                ?
                        @{$attribs{FILES}}             :
                        split /\s+/, $attribs{FILES}   ;
    }

    push(@files, qw[$(MAKE_APERL_FILE)
                    MYMETA.json MYMETA.yml perlmain.c tmon.out mon.out so_locations
                    blibdirs.ts pm_to_blib pm_to_blib.ts
                    *$(OBJ_EXT) *$(LIB_EXT) perl.exe perl perl$(EXE_EXT)
                    $(BOOTSTRAP) $(BASEEXT).bso
                    $(BASEEXT).def lib$(BASEEXT).def
                    $(BASEEXT).exp $(BASEEXT).x
                   ]);

    push(@files, $self->catfile('$(INST_ARCHAUTODIR)','extralibs.all'));
    push(@files, $self->catfile('$(INST_ARCHAUTODIR)','extralibs.ld'));

    # core files
    if ($^O eq 'vos') {
        push(@files, qw[perl*.kp]);
    }
    else {
        push(@files, qw[core core.*perl.*.? *perl.core]);
    }

    push(@files, map { "core." . "[0-9]"x$_ } (1..5));

    # OS specific things to clean up.  Use @dirs since we don't know
    # what might be in here.
    push @dirs, $self->extra_clean_files;

    # Occasionally files are repeated several times from different sources
    { my(%f) = map { ($_ => 1) } @files; @files = sort keys %f; }
    { my(%d) = map { ($_ => 1) } @dirs;  @dirs  = sort keys %d; }

    push @m, map "\t$_\n", $self->split_command('- $(RM_F)',  @files);
    push @m, map "\t$_\n", $self->split_command('- $(RM_RF)', @dirs);

    # Leave Makefile.old around for realclean
    push @m, <<'MAKE';
	  $(NOECHO) $(RM_F) $(MAKEFILE_OLD)
	- $(MV) $(FIRST_MAKEFILE) $(MAKEFILE_OLD) $(DEV_NULL)
MAKE

    push(@m, "\t$attribs{POSTOP}\n")   if $attribs{POSTOP};

    join("", @m);
}


=head3 clean_subdirs_target

  my $make_frag = $MM->clean_subdirs_target;

Returns the clean_subdirs target.  This is used by the clean target to
call clean on any subdirectories which contain Makefiles.

=cut

sub clean_subdirs_target {
    my($self) = shift;

    # No subdirectories, no cleaning.
    return <<'NOOP_FRAG' unless @{$self->{DIR}};
clean_subdirs :
	$(NOECHO) $(NOOP)
NOOP_FRAG


    my $clean = "clean_subdirs :\n";

    for my $dir (@{$self->{DIR}}) {
        my $subclean = $self->oneliner(sprintf <<'CODE', $dir);
exit 0 unless chdir '%s';  system '$(MAKE) clean' if -f '$(FIRST_MAKEFILE)';
CODE

        $clean .= "\t$subclean\n";
    }

    return $clean;
}


=head3 dir_target

    my $make_frag = $mm->dir_target(@directories);

Generates targets to create the specified directories and set its
permission to PERM_DIR.

Because depending on a directory to just ensure it exists doesn't work
too well (the modified time changes too often) dir_target() creates a
.exists file in the created directory.  It is this you should depend on.
For portability purposes you should use the $(DIRFILESEP) macro rather
than a '/' to separate the directory from the file.

    yourdirectory$(DIRFILESEP).exists

=cut

sub dir_target {
    my($self, @dirs) = @_;

    my $make = '';
    foreach my $dir (@dirs) {
        $make .= sprintf <<'MAKE', ($dir) x 4;
%s$(DFSEP).exists :: Makefile.PL
	$(NOECHO) $(MKPATH) %s
	$(NOECHO) $(CHMOD) $(PERM_DIR) %s
	$(NOECHO) $(TOUCH) %s$(DFSEP).exists

MAKE

    }

    return $make;
}


=head3 distdir

Defines the scratch directory target that will hold the distribution
before tar-ing (or shar-ing).

=cut

# For backwards compatibility.
*dist_dir = *distdir;

sub distdir {
    my($self) = shift;

    my $meta_target = $self->{NO_META} ? '' : 'distmeta';
    my $sign_target = !$self->{SIGN}   ? '' : 'distsignature';

    return sprintf <<'MAKE_FRAG', $meta_target, $sign_target;
create_distdir :
	$(RM_RF) $(DISTVNAME)
	$(PERLRUN) "-MExtUtils::Manifest=manicopy,maniread" \
		-e "manicopy(maniread(),'$(DISTVNAME)', '$(DIST_CP)');"

distdir : create_distdir %s %s
	$(NOECHO) $(NOOP)

MAKE_FRAG

}


=head3 dist_test

Defines a target that produces the distribution in the
scratch directory, and runs 'perl Makefile.PL; make ;make test' in that
subdirectory.

=cut

sub dist_test {
    my($self) = shift;

    my $mpl_args = join " ", map qq["$_"], @ARGV;

    my $test = $self->cd('$(DISTVNAME)',
                         '$(ABSPERLRUN) Makefile.PL '.$mpl_args,
                         '$(MAKE) $(PASTHRU)',
                         '$(MAKE) test $(PASTHRU)'
                        );

    return sprintf <<'MAKE_FRAG', $test;
disttest : distdir
	%s

MAKE_FRAG


}


=head3 xs_dlsyms_arg

Returns command-line arg(s) to linker for file listing dlsyms to export.
Defaults to returning empty string, can be overridden by e.g. AIX.

=cut

sub xs_dlsyms_arg {
    return '';
}

=head3 xs_dlsyms_ext

Returns file-extension for C<xs_make_dlsyms> method's output file,
including any "." character.

=cut

sub xs_dlsyms_ext {
    die "Pure virtual method";
}

=head3 xs_dlsyms_extra

Returns any extra text to be prepended to the C<$extra> argument of
C<xs_make_dlsyms>.

=cut

sub xs_dlsyms_extra {
    '';
}

=head3 xs_dlsyms_iterator

Iterates over necessary shared objects, calling C<xs_make_dlsyms> method
for each with appropriate arguments.

=cut

sub xs_dlsyms_iterator {
    my ($self, $attribs) = @_;
    if ($self->{XSMULTI}) {
        my @m;
        for my $ext ($self->_xs_list_basenames) {
            my @parts = File::Spec->splitdir($ext);
            shift @parts if $parts[0] eq 'lib';
            my $name = join '::', @parts;
            push @m, $self->xs_make_dlsyms(
                $attribs,
                $ext . $self->xs_dlsyms_ext,
                "$ext.xs",
                $name,
                $parts[-1],
                {}, [], {}, [],
                $self->xs_dlsyms_extra . q!, 'FILE' => ! . neatvalue($ext),
            );
        }
        return join "\n", @m;
    } else {
        return $self->xs_make_dlsyms(
            $attribs,
            $self->{BASEEXT} . $self->xs_dlsyms_ext,
            'Makefile.PL',
            $self->{NAME},
            $self->{DLBASE},
            $attribs->{DL_FUNCS} || $self->{DL_FUNCS} || {},
            $attribs->{FUNCLIST} || $self->{FUNCLIST} || [],
            $attribs->{IMPORTS} || $self->{IMPORTS} || {},
            $attribs->{DL_VARS} || $self->{DL_VARS} || [],
            $self->xs_dlsyms_extra,
        );
    }
}

=head3 xs_make_dlsyms

    $self->xs_make_dlsyms(
        \%attribs, # hashref from %attribs in caller
        "$self->{BASEEXT}.def", # output file for Makefile target
        'Makefile.PL', # dependency
        $self->{NAME}, # shared object's "name"
        $self->{DLBASE}, # last ::-separated part of name
        $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {}, # various params
        $attribs{FUNCLIST} || $self->{FUNCLIST} || [],
        $attribs{IMPORTS} || $self->{IMPORTS} || {},
        $attribs{DL_VARS} || $self->{DL_VARS} || [],
        # optional extra param that will be added as param to Mksymlists
    );

Utility method that returns Makefile snippet to call C<Mksymlists>.

=cut

sub xs_make_dlsyms {
    my ($self, $attribs, $target, $dep, $name, $dlbase, $funcs, $funclist, $imports, $vars, $extra) = @_;
    my @m = (
     "\n$target: $dep\n",
     q!	$(PERLRUN) -MExtUtils::Mksymlists \\
     -e "Mksymlists('NAME'=>\"!, $name,
     q!\", 'DLBASE' => '!,$dlbase,
     # The above two lines quoted differently to work around
     # a bug in the 4DOS/4NT command line interpreter.  The visible
     # result of the bug was files named q('extension_name',) *with the
     # single quotes and the comma* in the extension build directories.
     q!', 'DL_FUNCS' => !,neatvalue($funcs),
     q!, 'FUNCLIST' => !,neatvalue($funclist),
     q!, 'IMPORTS' => !,neatvalue($imports),
     q!, 'DL_VARS' => !, neatvalue($vars)
    );
    push @m, $extra if defined $extra;
    push @m, qq!);"\n!;
    join '', @m;
}

=head3 dynamic (o)

Defines the dynamic target.

=cut

sub dynamic {
# --- Dynamic Loading Sections ---

    my($self) = shift;
    '
dynamic :: $(FIRST_MAKEFILE) config $(INST_BOOT) $(INST_DYNAMIC)
	$(NOECHO) $(NOOP)
';
}


=head3 makemakerdflt_target

  my $make_frag = $mm->makemakerdflt_target

Returns a make fragment with the makemakerdeflt_target specified.
This target is the first target in the Makefile, is the default target
and simply points off to 'all' just in case any make variant gets
confused or something gets snuck in before the real 'all' target.

=cut

sub makemakerdflt_target {
    return <<'MAKE_FRAG';
makemakerdflt : all
	$(NOECHO) $(NOOP)
MAKE_FRAG

}


=head3 manifypods_target

  my $manifypods_target = $self->manifypods_target;

Generates the manifypods target.  This target generates man pages from
all POD files in MAN1PODS and MAN3PODS.

=cut

sub manifypods_target {
    my($self) = shift;

    my $man1pods      = '';
    my $man3pods      = '';
    my $dependencies  = '';

    # populate manXpods & dependencies:
    foreach my $name (sort keys %{$self->{MAN1PODS}}, sort keys %{$self->{MAN3PODS}}) {
        $dependencies .= " \\\n\t$name";
    }

    my $manify = <<END;
manifypods : pure_all config $dependencies
END

    my @man_cmds;
    foreach my $num (qw(1 3)) {
        my $pods = $self->{"MAN${num}PODS"};
        my $p2m = sprintf <<'CMD', "\$(MAN${num}SECTION)", "$]" > 5.008 ? " -u" : "";
	$(NOECHO) $(POD2MAN) --section=%s --perm_rw=$(PERM_RW)%s
CMD
        push @man_cmds, $self->split_command($p2m, map {($_,$pods->{$_})} sort keys %$pods);
    }

    $manify .= "\t\$(NOECHO) \$(NOOP)\n" unless @man_cmds;
    $manify .= join '', map { "$_\n" } @man_cmds;

    return $manify;
}

{
    my $has_cpan_meta;
    sub _has_cpan_meta {
        return $has_cpan_meta if defined $has_cpan_meta;
        return $has_cpan_meta = !!eval {
            require CPAN::Meta;
            CPAN::Meta->VERSION(2.112150);
            1;
        };
    }
}

=head3 metafile_target

    my $target = $mm->metafile_target;

Generate the metafile target.

Writes the file META.yml (YAML encoded meta-data) and META.json
(JSON encoded meta-data) about the module in the distdir.
The format follows Module::Build's as closely as possible.

=cut

sub metafile_target {
    my $self = shift;
    return <<'MAKE_FRAG' if $self->{NO_META} or ! _has_cpan_meta();
metafile :
	$(NOECHO) $(NOOP)
MAKE_FRAG

    my $metadata   = $self->metafile_data(
        $self->{META_ADD}   || {},
        $self->{META_MERGE} || {},
    );

    my $meta = $self->_fix_metadata_before_conversion( $metadata );

    my @write_metayml = $self->stashmeta(
      $meta->as_string({version => "1.4"}), 'META_new.yml'
    );
    my @write_metajson = $self->stashmeta(
      $meta->as_string({version => "2.0"}), 'META_new.json'
    );

    my $metayml = join("\n\t", @write_metayml);
    my $metajson = join("\n\t", @write_metajson);
    return sprintf <<'MAKE_FRAG', $metayml, $metajson;
metafile : create_distdir
	$(NOECHO) $(ECHO) Generating META.yml
	%s
	-$(NOECHO) $(MV) META_new.yml $(DISTVNAME)/META.yml
	$(NOECHO) $(ECHO) Generating META.json
	%s
	-$(NOECHO) $(MV) META_new.json $(DISTVNAME)/META.json
MAKE_FRAG

}

=begin private

=head3 _fix_metadata_before_conversion

    $mm->_fix_metadata_before_conversion( \%metadata );

Fixes errors in the metadata before it's handed off to L<CPAN::Meta> for
conversion. This hopefully results in something that can be used further
on, no guarantee is made though.

=end private

=cut

sub _fix_metadata_before_conversion {
    my ( $self, $metadata ) = @_;

    # we should never be called unless this already passed but
    # prefer to be defensive in case somebody else calls this

    return unless _has_cpan_meta;

    my $bad_version = $metadata->{version} &&
                      !CPAN::Meta::Validator->new->version( 'version', $metadata->{version} );
    # just delete all invalid versions
    if( $bad_version ) {
        warn "Can't parse version '$metadata->{version}'\n";
        $metadata->{version} = '';
    }

    my $validator2 = CPAN::Meta::Validator->new( $metadata );
    my @errors;
    push @errors, $validator2->errors if !$validator2->is_valid;
    my $validator14 = CPAN::Meta::Validator->new(
        {
            %$metadata,
            'meta-spec' => { version => 1.4 },
        }
    );
    push @errors, $validator14->errors if !$validator14->is_valid;
    # fix non-camelcase custom resource keys (only other trick we know)
    for my $error ( @errors ) {
        my ( $key ) = ( $error =~ /Custom resource '(.*)' must be in CamelCase./ );
        next if !$key;

        # first try to remove all non-alphabetic chars
        ( my $new_key = $key ) =~ s/[^_a-zA-Z]//g;

        # if that doesn't work, uppercase first one
        $new_key = ucfirst $new_key if !$validator14->custom_1( $new_key );

        # copy to new key if that worked
        $metadata->{resources}{$new_key} = $metadata->{resources}{$key}
          if $validator14->custom_1( $new_key );

        # and delete old one in any case
        delete $metadata->{resources}{$key};
    }

    # paper over validation issues, but still complain, necessary because
    # there's no guarantee that the above will fix ALL errors
    my $meta = eval { CPAN::Meta->create( $metadata, { lazy_validation => 1 } ) };
    warn $@ if $@ and
               $@ !~ /encountered CODE.*, but JSON can only represent references to arrays or hashes/;

    # use the original metadata straight if the conversion failed
    # or if it can't be stringified.
    if( !$meta                                                  ||
        !eval { $meta->as_string( { version => $METASPEC_V } ) }      ||
        !eval { $meta->as_string }
    ) {
        $meta = bless $metadata, 'CPAN::Meta';
    }

    my $now_license = $meta->as_struct({ version => 2 })->{license};
    if ($self->{LICENSE} and $self->{LICENSE} ne 'unknown' and
        @{$now_license} == 1 and $now_license->[0] eq 'unknown'
    ) {
        warn "Invalid LICENSE value '$self->{LICENSE}' ignored\n";
    }

    $meta;
}


=begin private

=head3 _sort_pairs

    my @pairs = _sort_pairs($sort_sub, \%hash);

Sorts the pairs of a hash based on keys ordered according
to C<$sort_sub>.

=end private

=cut

sub _sort_pairs {
    my $sort  = shift;
    my $pairs = shift;
    return map  { $_ => $pairs->{$_} }
           sort $sort
           keys %$pairs;
}


# Taken from Module::Build::Base
sub _hash_merge {
    my ($self, $h, $k, $v) = @_;
    if (ref $h->{$k} eq 'ARRAY') {
        push @{$h->{$k}}, ref $v ? @$v : $v;
    } elsif (ref $h->{$k} eq 'HASH') {
        $self->_hash_merge($h->{$k}, $_, $v->{$_}) foreach keys %$v;
    } else {
        $h->{$k} = $v;
    }
}


=head3 metafile_data

    my $metadata_hashref = $mm->metafile_data(\%meta_add, \%meta_merge);

Returns the data which MakeMaker turns into the META.yml file 
and the META.json file. It is always in version 2.0 of the format.

Values of %meta_add will overwrite any existing metadata in those
keys.  %meta_merge will be merged with them.

=cut

sub metafile_data {
    my $self = shift;
    my($meta_add, $meta_merge) = @_;

    $meta_add ||= {};
    $meta_merge ||= {};

    my $version = _normalize_version($self->{VERSION});
    my $release_status = ($version =~ /_/) ? 'unstable' : 'stable';
    my %meta = (
        # required
        abstract     => $self->{ABSTRACT} || 'unknown',
        author       => defined($self->{AUTHOR}) ? $self->{AUTHOR} : ['unknown'],
        dynamic_config => 1,
        generated_by => "ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION",
        license      => [ $self->{LICENSE} || 'unknown' ],
        'meta-spec'  => {
            url         => $METASPEC_URL,
            version     => $METASPEC_V,
        },
        name         => $self->{DISTNAME},
        release_status => $release_status,
        version      => $version,

        # optional
        no_index     => { directory => [qw(t inc)] },
    );
    $self->_add_requirements_to_meta(\%meta);

    if (!eval { require JSON::PP; require CPAN::Meta::Converter; CPAN::Meta::Converter->VERSION(2.141170) }) {
      return \%meta;
    }

    # needs to be based on the original version
    my $v1_add = _metaspec_version($meta_add) !~ /^2/;

    my ($add_v, $merge_v) = map _metaspec_version($_), $meta_add, $meta_merge;
    for my $frag ($meta_add, $meta_merge) {
        my $def_v = $frag == $meta_add ? $merge_v : $add_v;
        $frag = CPAN::Meta::Converter->new($frag, default_version => $def_v)->upgrade_fragment;
    }

    # if we upgraded a 1.x _ADD fragment, we gave it a prereqs key that
    # will override all prereqs, which is more than the user asked for;
    # instead, we'll go inside the prereqs and override all those
    while( my($key, $val) = each %$meta_add ) {
        if ($v1_add and $key eq 'prereqs') {
            $meta{$key}{$_} = $val->{$_} for keys %$val;
        } elsif ($key ne 'meta-spec') {
            $meta{$key} = $val;
        }
    }

    while( my($key, $val) = each %$meta_merge ) {
        next if $key eq 'meta-spec';
        $self->_hash_merge(\%meta, $key, $val);
    }

    return \%meta;
}


=begin private

=cut

sub _add_requirements_to_meta {
    my ( $self, $meta ) = @_;
    # Check the original args so we can tell between the user setting it
    # to an empty hash and it just being initialized.
    $meta->{prereqs}{configure}{requires} = $self->{ARGS}{CONFIGURE_REQUIRES}
        ? $self->{CONFIGURE_REQUIRES}
        : { 'ExtUtils::MakeMaker' => 0, };
    $meta->{prereqs}{build}{requires} = $self->{ARGS}{BUILD_REQUIRES}
        ? $self->{BUILD_REQUIRES}
        : { 'ExtUtils::MakeMaker' => 0, };
    $meta->{prereqs}{test}{requires} = $self->{TEST_REQUIRES}
        if $self->{ARGS}{TEST_REQUIRES};
    $meta->{prereqs}{runtime}{requires} = $self->{PREREQ_PM}
        if $self->{ARGS}{PREREQ_PM};
    $meta->{prereqs}{runtime}{requires}{perl} = _normalize_version($self->{MIN_PERL_VERSION})
        if $self->{MIN_PERL_VERSION};
}

# spec version of given fragment - if not given, assume 1.4
sub _metaspec_version {
  my ( $meta ) = @_;
  return $meta->{'meta-spec'}->{version}
    if defined $meta->{'meta-spec'}
       and defined $meta->{'meta-spec'}->{version};
  return '1.4';
}

sub _add_requirements_to_meta_v1_4 {
    my ( $self, $meta ) = @_;
    # Check the original args so we can tell between the user setting it
    # to an empty hash and it just being initialized.
    if( $self->{ARGS}{CONFIGURE_REQUIRES} ) {
        $meta->{configure_requires} = $self->{CONFIGURE_REQUIRES};
    } else {
        $meta->{configure_requires} = {
            'ExtUtils::MakeMaker'       => 0,
        };
    }
    if( $self->{ARGS}{BUILD_REQUIRES} ) {
        $meta->{build_requires} = $self->{BUILD_REQUIRES};
    } else {
        $meta->{build_requires} = {
            'ExtUtils::MakeMaker'       => 0,
        };
    }
    if( $self->{ARGS}{TEST_REQUIRES} ) {
        $meta->{build_requires} = {
          %{ $meta->{build_requires} },
          %{ $self->{TEST_REQUIRES} },
        };
    }
    $meta->{requires} = $self->{PREREQ_PM}
        if defined $self->{PREREQ_PM};
    $meta->{requires}{perl} = _normalize_version($self->{MIN_PERL_VERSION})
        if $self->{MIN_PERL_VERSION};
}

# Adapted from Module::Build::Base
sub _normalize_version {
  my ($version) = @_;
  $version = 0 unless defined $version;

  if ( ref $version eq 'version' ) { # version objects
    $version = $version->stringify;
  }
  elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots
    # normalize string tuples without "v": "1.2.3" -> "v1.2.3"
    $version = "v$version";
  }
  else {
    # leave alone
  }
  return $version;
}

=head3 _dump_hash

    $yaml = _dump_hash(\%options, %hash);

Implements a fake YAML dumper for a hash given
as a list of pairs. No quoting/escaping is done. Keys
are supposed to be strings. Values are undef, strings,
hash refs or array refs of strings.

Supported options are:

    delta => STR - indentation delta
    use_header => BOOL - whether to include a YAML header
    indent => STR - a string of spaces
          default: ''

    max_key_length => INT - maximum key length used to align
        keys and values of the same hash
        default: 20
    key_sort => CODE - a sort sub
            It may be undef, which means no sorting by keys
        default: sub { lc $a cmp lc $b }

    customs => HASH - special options for certain keys
           (whose values are hashes themselves)
        may contain: max_key_length, key_sort, customs

=end private

=cut

sub _dump_hash {
    croak "first argument should be a hash ref" unless ref $_[0] eq 'HASH';
    my $options = shift;
    my %hash = @_;

    # Use a list to preserve order.
    my @pairs;

    my $k_sort
        = exists $options->{key_sort} ? $options->{key_sort}
                                      : sub { lc $a cmp lc $b };
    if ($k_sort) {
        croak "'key_sort' should be a coderef" unless ref $k_sort eq 'CODE';
        @pairs = _sort_pairs($k_sort, \%hash);
    } else { # list of pairs, no sorting
        @pairs = @_;
    }

    my $yaml     = $options->{use_header} ? "--- #YAML:1.0\n" : '';
    my $indent   = $options->{indent} || '';
    my $k_length = min(
        ($options->{max_key_length} || 20),
        max(map { length($_) + 1 } grep { !ref $hash{$_} } keys %hash)
    );
    my $customs  = $options->{customs} || {};

    # printf format for key
    my $k_format = "%-${k_length}s";

    while( @pairs ) {
        my($key, $val) = splice @pairs, 0, 2;
        $val = '~' unless defined $val;
        if(ref $val eq 'HASH') {
            if ( keys %$val ) {
                my %k_options = ( # options for recursive call
                    delta => $options->{delta},
                    use_header => 0,
                    indent => $indent . $options->{delta},
                );
                if (exists $customs->{$key}) {
                    my %k_custom = %{$customs->{$key}};
                    foreach my $k (qw(key_sort max_key_length customs)) {
                        $k_options{$k} = $k_custom{$k} if exists $k_custom{$k};
                    }
                }
                $yaml .= $indent . "$key:\n"
                  . _dump_hash(\%k_options, %$val);
            }
            else {
                $yaml .= $indent . "$key:  {}\n";
            }
        }
        elsif (ref $val eq 'ARRAY') {
            if( @$val ) {
                $yaml .= $indent . "$key:\n";

                for (@$val) {
                    croak "only nested arrays of non-refs are supported" if ref $_;
                    $yaml .= $indent . $options->{delta} . "- $_\n";
                }
            }
            else {
                $yaml .= $indent . "$key:  []\n";
            }
        }
        elsif( ref $val and !blessed($val) ) {
            croak "only nested hashes, arrays and objects are supported";
        }
        else {  # if it's an object, just stringify it
            $yaml .= $indent . sprintf "$k_format  %s\n", "$key:", $val;
        }
    };

    return $yaml;

}

sub blessed {
    return eval { $_[0]->isa("UNIVERSAL"); };
}

sub max {
    return (sort { $b <=> $a } @_)[0];
}

sub min {
    return (sort { $a <=> $b } @_)[0];
}

=head3 metafile_file

    my $meta_yml = $mm->metafile_file(@metadata_pairs);

Turns the @metadata_pairs into YAML.

This method does not implement a complete YAML dumper, being limited
to dump a hash with values which are strings, undef's or nested hashes
and arrays of strings. No quoting/escaping is done.

=cut

sub metafile_file {
    my $self = shift;

    my %dump_options = (
        use_header => 1,
        delta      => ' ' x 4,
        key_sort   => undef,
    );
    return _dump_hash(\%dump_options, @_);

}


=head3 distmeta_target

    my $make_frag = $mm->distmeta_target;

Generates the distmeta target to add META.yml and META.json to the MANIFEST
in the distdir.

=cut

sub distmeta_target {
    my $self = shift;

    my @add_meta = (
      $self->oneliner(<<'CODE', ['-MExtUtils::Manifest=maniadd']),
exit unless -e q{META.yml};
eval { maniadd({q{META.yml} => q{Module YAML meta-data (added by MakeMaker)}}) }
    or die "Could not add META.yml to MANIFEST: ${'@'}"
CODE
      $self->oneliner(<<'CODE', ['-MExtUtils::Manifest=maniadd'])
exit unless -f q{META.json};
eval { maniadd({q{META.json} => q{Module JSON meta-data (added by MakeMaker)}}) }
    or die "Could not add META.json to MANIFEST: ${'@'}"
CODE
    );

    my @add_meta_to_distdir = map { $self->cd('$(DISTVNAME)', $_) } @add_meta;

    return sprintf <<'MAKE', @add_meta_to_distdir;
distmeta : create_distdir metafile
	$(NOECHO) %s
	$(NOECHO) %s

MAKE

}


=head3 mymeta

    my $mymeta = $mm->mymeta;

Generate MYMETA information as a hash either from an existing CPAN Meta file
(META.json or META.yml) or from internal data.

=cut

sub mymeta {
    my $self = shift;
    my $file = shift || ''; # for testing

    my $mymeta = $self->_mymeta_from_meta($file);
    my $v2 = 1;

    unless ( $mymeta ) {
        $mymeta = $self->metafile_data(
            $self->{META_ADD}   || {},
            $self->{META_MERGE} || {},
        );
        $v2 = 0;
    }

    # Overwrite the non-configure dependency hashes
    $self->_add_requirements_to_meta($mymeta);

    $mymeta->{dynamic_config} = 0;

    return $mymeta;
}


sub _mymeta_from_meta {
    my $self = shift;
    my $metafile = shift || ''; # for testing

    return unless _has_cpan_meta();

    my $meta;
    for my $file ( $metafile, "META.json", "META.yml" ) {
      next unless -e $file;
      eval {
          $meta = CPAN::Meta->load_file($file)->as_struct( { version => 2 } );
      };
      last if $meta;
    }
    return unless $meta;

    # META.yml before 6.25_01 cannot be trusted.  META.yml lived in the source directory.
    # There was a good chance the author accidentally uploaded a stale META.yml if they
    # rolled their own tarball rather than using "make dist".
    if ($meta->{generated_by} &&
        $meta->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
        my $eummv = do { no warnings; $1+0; };
        if ($eummv < 6.2501) {
            return;
        }
    }

    return $meta;
}

=head3 write_mymeta

    $self->write_mymeta( $mymeta );

Write MYMETA information to MYMETA.json and MYMETA.yml.

=cut

sub write_mymeta {
    my $self = shift;
    my $mymeta = shift;

    return unless _has_cpan_meta();

    my $meta_obj = $self->_fix_metadata_before_conversion( $mymeta );

    $meta_obj->save( 'MYMETA.json', { version => "2.0" } );
    $meta_obj->save( 'MYMETA.yml', { version => "1.4" } );
    return 1;
}

=head3 realclean (o)

Defines the realclean target.

=cut

sub realclean {
    my($self, %attribs) = @_;

    my @dirs  = qw($(DISTVNAME));
    my @files = qw($(FIRST_MAKEFILE) $(MAKEFILE_OLD));

    # Special exception for the perl core where INST_* is not in blib.
    # This cleans up the files built from the ext/ directory (all XS).
    if( $self->{PERL_CORE} ) {
        push @dirs, qw($(INST_AUTODIR) $(INST_ARCHAUTODIR));
        push @files, values %{$self->{PM}};
    }

    if( $self->has_link_code ){
        push @files, qw($(OBJECT));
    }

    if( $attribs{FILES} ) {
        if( ref $attribs{FILES} ) {
            push @dirs, @{ $attribs{FILES} };
        }
        else {
            push @dirs, split /\s+/, $attribs{FILES};
        }
    }

    # Occasionally files are repeated several times from different sources
    { my(%f) = map { ($_ => 1) } @files;  @files = sort keys %f; }
    { my(%d) = map { ($_ => 1) } @dirs;   @dirs  = sort keys %d; }

    my $rm_cmd  = join "\n\t", map { "$_" }
                    $self->split_command('- $(RM_F)',  @files);
    my $rmf_cmd = join "\n\t", map { "$_" }
                    $self->split_command('- $(RM_RF)', @dirs);

    my $m = sprintf <<'MAKE', $rm_cmd, $rmf_cmd;
# Delete temporary files (via clean) and also delete dist files
realclean purge :: realclean_subdirs
	%s
	%s
MAKE

    $m .= "\t$attribs{POSTOP}\n" if $attribs{POSTOP};

    return $m;
}


=head3 realclean_subdirs_target

  my $make_frag = $MM->realclean_subdirs_target;

Returns the realclean_subdirs target.  This is used by the realclean
target to call realclean on any subdirectories which contain Makefiles.

=cut

sub realclean_subdirs_target {
    my $self = shift;
    my @m = <<'EOF';
# so clean is forced to complete before realclean_subdirs runs
realclean_subdirs : clean
EOF
    return join '', @m, "\t\$(NOECHO) \$(NOOP)\n" unless @{$self->{DIR}};
    foreach my $dir (@{$self->{DIR}}) {
        foreach my $makefile ('$(MAKEFILE_OLD)', '$(FIRST_MAKEFILE)' ) {
            my $subrclean .= $self->oneliner(_sprintf562 <<'CODE', $dir, $makefile);
chdir '%1$s';  system '$(MAKE) $(USEMAKEFILE) %2$s realclean' if -f '%2$s';
CODE
            push @m, "\t- $subrclean\n";
        }
    }
    return join '', @m;
}


=head3 signature_target

    my $target = $mm->signature_target;

Generate the signature target.

Writes the file SIGNATURE with "cpansign -s".

=cut

sub signature_target {
    my $self = shift;

    return <<'MAKE_FRAG';
signature :
	cpansign -s
MAKE_FRAG

}


=head3 distsignature_target

    my $make_frag = $mm->distsignature_target;

Generates the distsignature target to add SIGNATURE to the MANIFEST in the
distdir.

=cut

sub distsignature_target {
    my $self = shift;

    my $add_sign = $self->oneliner(<<'CODE', ['-MExtUtils::Manifest=maniadd']);
eval { maniadd({q{SIGNATURE} => q{Public-key signature (added by MakeMaker)}}) }
    or die "Could not add SIGNATURE to MANIFEST: ${'@'}"
CODE

    my $sign_dist        = $self->cd('$(DISTVNAME)' => 'cpansign -s');

    # cpansign -s complains if SIGNATURE is in the MANIFEST yet does not
    # exist
    my $touch_sig        = $self->cd('$(DISTVNAME)' => '$(TOUCH) SIGNATURE');
    my $add_sign_to_dist = $self->cd('$(DISTVNAME)' => $add_sign );

    return sprintf <<'MAKE', $add_sign_to_dist, $touch_sig, $sign_dist
distsignature : distmeta
	$(NOECHO) %s
	$(NOECHO) %s
	%s

MAKE

}


=head3 special_targets

  my $make_frag = $mm->special_targets

Returns a make fragment containing any targets which have special
meaning to make.  For example, .SUFFIXES and .PHONY.

=cut

sub special_targets {
    my $make_frag = <<'MAKE_FRAG';
.SUFFIXES : .xs .c .C .cpp .i .s .cxx .cc $(OBJ_EXT)

.PHONY: all config static dynamic test linkext manifest blibdirs clean realclean disttest distdir pure_all subdirs clean_subdirs makemakerdflt manifypods realclean_subdirs subdirs_dynamic subdirs_pure_nolink subdirs_static subdirs-test_dynamic subdirs-test_static test_dynamic test_static

MAKE_FRAG

    $make_frag .= <<'MAKE_FRAG' if $ENV{CLEARCASE_ROOT};
.NO_CONFIG_REC: Makefile

MAKE_FRAG

    return $make_frag;
}


=head2 Init methods

Methods which help initialize the MakeMaker object and macros.


=head3 init_ABSTRACT

    $mm->init_ABSTRACT

=cut

sub init_ABSTRACT {
    my $self = shift;

    if( $self->{ABSTRACT_FROM} and $self->{ABSTRACT} ) {
        warn "Both ABSTRACT_FROM and ABSTRACT are set.  ".
             "Ignoring ABSTRACT_FROM.\n";
        return;
    }

    if ($self->{ABSTRACT_FROM}){
        $self->{ABSTRACT} = $self->parse_abstract($self->{ABSTRACT_FROM}) or
            carp "WARNING: Setting ABSTRACT via file ".
                 "'$self->{ABSTRACT_FROM}' failed\n";
    }

    if ($self->{ABSTRACT} && $self->{ABSTRACT} =~ m![[:cntrl:]]+!) {
            warn "WARNING: ABSTRACT contains control character(s),".
                 " they will be removed\n";
            $self->{ABSTRACT} =~ s![[:cntrl:]]+!!g;
            return;
    }
}

=head3 init_INST

    $mm->init_INST;

Called by init_main.  Sets up all INST_* variables except those related
to XS code.  Those are handled in init_xs.

=cut

sub init_INST {
    my($self) = shift;

    $self->{INST_ARCHLIB} ||= $self->catdir($Curdir,"blib","arch");
    $self->{INST_BIN}     ||= $self->catdir($Curdir,'blib','bin');

    # INST_LIB typically pre-set if building an extension after
    # perl has been built and installed. Setting INST_LIB allows
    # you to build directly into, say $Config{privlibexp}.
    unless ($self->{INST_LIB}){
        if ($self->{PERL_CORE}) {
            $self->{INST_LIB} = $self->{INST_ARCHLIB} = $self->{PERL_LIB};
        } else {
            $self->{INST_LIB} = $self->catdir($Curdir,"blib","lib");
        }
    }

    my @parentdir = split(/::/, $self->{PARENT_NAME});
    $self->{INST_LIBDIR}      = $self->catdir('$(INST_LIB)',     @parentdir);
    $self->{INST_ARCHLIBDIR}  = $self->catdir('$(INST_ARCHLIB)', @parentdir);
    $self->{INST_AUTODIR}     = $self->catdir('$(INST_LIB)', 'auto',
                                              '$(FULLEXT)');
    $self->{INST_ARCHAUTODIR} = $self->catdir('$(INST_ARCHLIB)', 'auto',
                                              '$(FULLEXT)');

    $self->{INST_SCRIPT}  ||= $self->catdir($Curdir,'blib','script');

    $self->{INST_MAN1DIR} ||= $self->catdir($Curdir,'blib','man1');
    $self->{INST_MAN3DIR} ||= $self->catdir($Curdir,'blib','man3');

    return 1;
}


=head3 init_INSTALL

    $mm->init_INSTALL;

Called by init_main.  Sets up all INSTALL_* variables (except
INSTALLDIRS) and *PREFIX.

=cut

sub init_INSTALL {
    my($self) = shift;

    if( $self->{ARGS}{INSTALL_BASE} and $self->{ARGS}{PREFIX} ) {
        die "Only one of PREFIX or INSTALL_BASE can be given.  Not both.\n";
    }

    if( $self->{ARGS}{INSTALL_BASE} ) {
        $self->init_INSTALL_from_INSTALL_BASE;
    }
    else {
        $self->init_INSTALL_from_PREFIX;
    }
}


=head3 init_INSTALL_from_PREFIX

  $mm->init_INSTALL_from_PREFIX;

=cut

sub init_INSTALL_from_PREFIX {
    my $self = shift;

    $self->init_lib2arch;

    # There are often no Config.pm defaults for these new man variables so
    # we fall back to the old behavior which is to use installman*dir
    foreach my $num (1, 3) {
        my $k = 'installsiteman'.$num.'dir';

        $self->{uc $k} ||= uc "\$(installman${num}dir)"
          unless $Config{$k};
    }

    foreach my $num (1, 3) {
        my $k = 'installvendorman'.$num.'dir';

        unless( $Config{$k} ) {
            $self->{uc $k}  ||= $Config{usevendorprefix}
                              ? uc "\$(installman${num}dir)"
                              : '';
        }
    }

    $self->{INSTALLSITEBIN} ||= '$(INSTALLBIN)'
      unless $Config{installsitebin};
    $self->{INSTALLSITESCRIPT} ||= '$(INSTALLSCRIPT)'
      unless $Config{installsitescript};

    unless( $Config{installvendorbin} ) {
        $self->{INSTALLVENDORBIN} ||= $Config{usevendorprefix}
                                    ? $Config{installbin}
                                    : '';
    }
    unless( $Config{installvendorscript} ) {
        $self->{INSTALLVENDORSCRIPT} ||= $Config{usevendorprefix}
                                       ? $Config{installscript}
                                       : '';
    }


    my $iprefix = $Config{installprefixexp} || $Config{installprefix} ||
                  $Config{prefixexp}        || $Config{prefix} || '';
    my $vprefix = $Config{usevendorprefix}  ? $Config{vendorprefixexp} : '';
    my $sprefix = $Config{siteprefixexp}    || '';

    # 5.005_03 doesn't have a siteprefix.
    $sprefix = $iprefix unless $sprefix;


    $self->{PREFIX}       ||= '';

    if( $self->{PREFIX} ) {
        @{$self}{qw(PERLPREFIX SITEPREFIX VENDORPREFIX)} =
          ('$(PREFIX)') x 3;
    }
    else {
        $self->{PERLPREFIX}   ||= $iprefix;
        $self->{SITEPREFIX}   ||= $sprefix;
        $self->{VENDORPREFIX} ||= $vprefix;

        # Lots of MM extension authors like to use $(PREFIX) so we
        # put something sensible in there no matter what.
        $self->{PREFIX} = '$('.uc $self->{INSTALLDIRS}.'PREFIX)';
    }

    my $arch    = $Config{archname};
    my $version = $Config{version};

    # default style
    my $libstyle = $Config{installstyle} || 'lib/perl5';
    my $manstyle = '';

    if( $self->{LIBSTYLE} ) {
        $libstyle = $self->{LIBSTYLE};
        $manstyle = $self->{LIBSTYLE} eq 'lib/perl5' ? 'lib/perl5' : '';
    }

    # Some systems, like VOS, set installman*dir to '' if they can't
    # read man pages.
    for my $num (1, 3) {
        $self->{'INSTALLMAN'.$num.'DIR'} ||= 'none'
          unless $Config{'installman'.$num.'dir'};
    }

    my %bin_layouts =
    (
        bin         => { s => $iprefix,
                         t => 'perl',
                         d => 'bin' },
        vendorbin   => { s => $vprefix,
                         t => 'vendor',
                         d => 'bin' },
        sitebin     => { s => $sprefix,
                         t => 'site',
                         d => 'bin' },
        script      => { s => $iprefix,
                         t => 'perl',
                         d => 'bin' },
        vendorscript=> { s => $vprefix,
                         t => 'vendor',
                         d => 'bin' },
        sitescript  => { s => $sprefix,
                         t => 'site',
                         d => 'bin' },
    );

    my %man_layouts =
    (
        man1dir         => { s => $iprefix,
                             t => 'perl',
                             d => 'man/man1',
                             style => $manstyle, },
        siteman1dir     => { s => $sprefix,
                             t => 'site',
                             d => 'man/man1',
                             style => $manstyle, },
        vendorman1dir   => { s => $vprefix,
                             t => 'vendor',
                             d => 'man/man1',
                             style => $manstyle, },

        man3dir         => { s => $iprefix,
                             t => 'perl',
                             d => 'man/man3',
                             style => $manstyle, },
        siteman3dir     => { s => $sprefix,
                             t => 'site',
                             d => 'man/man3',
                             style => $manstyle, },
        vendorman3dir   => { s => $vprefix,
                             t => 'vendor',
                             d => 'man/man3',
                             style => $manstyle, },
    );

    my %lib_layouts =
    (
        privlib     => { s => $iprefix,
                         t => 'perl',
                         d => '',
                         style => $libstyle, },
        vendorlib   => { s => $vprefix,
                         t => 'vendor',
                         d => '',
                         style => $libstyle, },
        sitelib     => { s => $sprefix,
                         t => 'site',
                         d => 'site_perl',
                         style => $libstyle, },

        archlib     => { s => $iprefix,
                         t => 'perl',
                         d => "$version/$arch",
                         style => $libstyle },
        vendorarch  => { s => $vprefix,
                         t => 'vendor',
                         d => "$version/$arch",
                         style => $libstyle },
        sitearch    => { s => $sprefix,
                         t => 'site',
                         d => "site_perl/$version/$arch",
                         style => $libstyle },
    );


    # Special case for LIB.
    if( $self->{LIB} ) {
        foreach my $var (keys %lib_layouts) {
            my $Installvar = uc "install$var";

            if( $var =~ /arch/ ) {
                $self->{$Installvar} ||=
                  $self->catdir($self->{LIB}, $Config{archname});
            }
            else {
                $self->{$Installvar} ||= $self->{LIB};
            }
        }
    }

    my %type2prefix = ( perl    => 'PERLPREFIX',
                        site    => 'SITEPREFIX',
                        vendor  => 'VENDORPREFIX'
                      );

    my %layouts = (%bin_layouts, %man_layouts, %lib_layouts);
    while( my($var, $layout) = each(%layouts) ) {
        my($s, $t, $d, $style) = @{$layout}{qw(s t d style)};
        my $r = '$('.$type2prefix{$t}.')';

        warn "Prefixing $var\n" if $Verbose >= 2;

        my $installvar = "install$var";
        my $Installvar = uc $installvar;
        next if $self->{$Installvar};

        $d = "$style/$d" if $style;
        $self->prefixify($installvar, $s, $r, $d);

        warn "  $Installvar == $self->{$Installvar}\n"
          if $Verbose >= 2;
    }

    # Generate these if they weren't figured out.
    $self->{VENDORARCHEXP} ||= $self->{INSTALLVENDORARCH};
    $self->{VENDORLIBEXP}  ||= $self->{INSTALLVENDORLIB};

    return 1;
}


=head3 init_from_INSTALL_BASE

    $mm->init_from_INSTALL_BASE

=cut

my %map = (
           lib      => [qw(lib perl5)],
           arch     => [('lib', 'perl5', $Config{archname})],
           bin      => [qw(bin)],
           man1dir  => [qw(man man1)],
           man3dir  => [qw(man man3)]
          );
$map{script} = $map{bin};

sub init_INSTALL_from_INSTALL_BASE {
    my $self = shift;

    @{$self}{qw(PREFIX VENDORPREFIX SITEPREFIX PERLPREFIX)} =
                                                         '$(INSTALL_BASE)';

    my %install;
    foreach my $thing (keys %map) {
        foreach my $dir (('', 'SITE', 'VENDOR')) {
            my $uc_thing = uc $thing;
            my $key = "INSTALL".$dir.$uc_thing;

            $install{$key} ||=
                ($thing =~ /^man.dir$/ and not $Config{lc $key})
                ? 'none'
                : $self->catdir('$(INSTALL_BASE)', @{$map{$thing}});
        }
    }

    # Adjust for variable quirks.
    $install{INSTALLARCHLIB} ||= delete $install{INSTALLARCH};
    $install{INSTALLPRIVLIB} ||= delete $install{INSTALLLIB};

    foreach my $key (keys %install) {
        $self->{$key} ||= $install{$key};
    }

    return 1;
}


=head3 init_VERSION  I<Abstract>

    $mm->init_VERSION

Initialize macros representing versions of MakeMaker and other tools

MAKEMAKER: path to the MakeMaker module.

MM_VERSION: ExtUtils::MakeMaker Version

MM_REVISION: ExtUtils::MakeMaker version control revision (for backwards
             compat)

VERSION: version of your module

VERSION_MACRO: which macro represents the version (usually 'VERSION')

VERSION_SYM: like version but safe for use as an RCS revision number

DEFINE_VERSION: -D line to set the module version when compiling

XS_VERSION: version in your .xs file.  Defaults to $(VERSION)

XS_VERSION_MACRO: which macro represents the XS version.

XS_DEFINE_VERSION: -D line to set the xs version when compiling.

Called by init_main.

=cut

sub init_VERSION {
    my($self) = shift;

    $self->{MAKEMAKER}  = $ExtUtils::MakeMaker::Filename;
    $self->{MM_VERSION} = $ExtUtils::MakeMaker::VERSION;
    $self->{MM_REVISION}= $ExtUtils::MakeMaker::Revision;
    $self->{VERSION_FROM} ||= '';

    if ($self->{VERSION_FROM}){
        $self->{VERSION} = $self->parse_version($self->{VERSION_FROM});
        if( $self->{VERSION} eq 'undef' ) {
            carp("WARNING: Setting VERSION via file ".
                 "'$self->{VERSION_FROM}' failed\n");
        }
    }

    if (defined $self->{VERSION}) {
        if ( $self->{VERSION} !~ /^\s*v?[\d_\.]+\s*$/ ) {
          require version;
          my $normal = eval { version->new( $self->{VERSION} ) };
          $self->{VERSION} = $normal if defined $normal;
        }
        $self->{VERSION} =~ s/^\s+//;
        $self->{VERSION} =~ s/\s+$//;
    }
    else {
        $self->{VERSION} = '';
    }


    $self->{VERSION_MACRO}  = 'VERSION';
    ($self->{VERSION_SYM} = $self->{VERSION}) =~ s/\W/_/g;
    $self->{DEFINE_VERSION} = '-D$(VERSION_MACRO)=\"$(VERSION)\"';


    # Graham Barr and Paul Marquess had some ideas how to ensure
    # version compatibility between the *.pm file and the
    # corresponding *.xs file. The bottom line was, that we need an
    # XS_VERSION macro that defaults to VERSION:
    $self->{XS_VERSION} ||= $self->{VERSION};

    $self->{XS_VERSION_MACRO}  = 'XS_VERSION';
    $self->{XS_DEFINE_VERSION} = '-D$(XS_VERSION_MACRO)=\"$(XS_VERSION)\"';

}


=head3 init_tools

    $MM->init_tools();

Initializes the simple macro definitions used by tools_other() and
places them in the $MM object.  These use conservative cross platform
versions and should be overridden with platform specific versions for
performance.

Defines at least these macros.

  Macro             Description

  NOOP              Do nothing
  NOECHO            Tell make not to display the command itself

  SHELL             Program used to run shell commands

  ECHO              Print text adding a newline on the end
  RM_F              Remove a file
  RM_RF             Remove a directory
  TOUCH             Update a file's timestamp
  TEST_F            Test for a file's existence
  TEST_S            Test the size of a file
  CP                Copy a file
  CP_NONEMPTY       Copy a file if it is not empty
  MV                Move a file
  CHMOD             Change permissions on a file
  FALSE             Exit with non-zero
  TRUE              Exit with zero

  UMASK_NULL        Nullify umask
  DEV_NULL          Suppress all command output

=cut

sub init_tools {
    my $self = shift;

    $self->{ECHO}     ||= $self->oneliner('binmode STDOUT, qq{:raw}; print qq{@ARGV}', ['-l']);
    $self->{ECHO_N}   ||= $self->oneliner('print qq{@ARGV}');

    $self->{TOUCH}    ||= $self->oneliner('touch', ["-MExtUtils::Command"]);
    $self->{CHMOD}    ||= $self->oneliner('chmod', ["-MExtUtils::Command"]);
    $self->{RM_F}     ||= $self->oneliner('rm_f',  ["-MExtUtils::Command"]);
    $self->{RM_RF}    ||= $self->oneliner('rm_rf', ["-MExtUtils::Command"]);
    $self->{TEST_F}   ||= $self->oneliner('test_f', ["-MExtUtils::Command"]);
    $self->{TEST_S}   ||= $self->oneliner('test_s', ["-MExtUtils::Command::MM"]);
    $self->{CP_NONEMPTY} ||= $self->oneliner('cp_nonempty', ["-MExtUtils::Command::MM"]);
    $self->{FALSE}    ||= $self->oneliner('exit 1');
    $self->{TRUE}     ||= $self->oneliner('exit 0');

    $self->{MKPATH}   ||= $self->oneliner('mkpath', ["-MExtUtils::Command"]);

    $self->{CP}       ||= $self->oneliner('cp', ["-MExtUtils::Command"]);
    $self->{MV}       ||= $self->oneliner('mv', ["-MExtUtils::Command"]);

    $self->{MOD_INSTALL} ||=
      $self->oneliner(<<'CODE', ['-MExtUtils::Install']);
install([ from_to => {@ARGV}, verbose => '$(VERBINST)', uninstall_shadows => '$(UNINST)', dir_mode => '$(PERM_DIR)' ]);
CODE
    $self->{DOC_INSTALL} ||= $self->oneliner('perllocal_install', ["-MExtUtils::Command::MM"]);
    $self->{UNINSTALL}   ||= $self->oneliner('uninstall', ["-MExtUtils::Command::MM"]);
    $self->{WARN_IF_OLD_PACKLIST} ||=
      $self->oneliner('warn_if_old_packlist', ["-MExtUtils::Command::MM"]);
    $self->{FIXIN}       ||= $self->oneliner('MY->fixin(shift)', ["-MExtUtils::MY"]);
    $self->{EQUALIZE_TIMESTAMP} ||= $self->oneliner('eqtime', ["-MExtUtils::Command"]);

    $self->{UNINST}     ||= 0;
    $self->{VERBINST}   ||= 0;

    $self->{SHELL}              ||= $Config{sh};

    # UMASK_NULL is not used by MakeMaker but some CPAN modules
    # make use of it.
    $self->{UMASK_NULL}         ||= "umask 0";

    # Not the greatest default, but its something.
    $self->{DEV_NULL}           ||= "> /dev/null 2>&1";

    $self->{NOOP}               ||= '$(TRUE)';
    $self->{NOECHO}             = '@' unless defined $self->{NOECHO};

    $self->{FIRST_MAKEFILE}     ||= $self->{MAKEFILE} || 'Makefile';
    $self->{MAKEFILE}           ||= $self->{FIRST_MAKEFILE};
    $self->{MAKEFILE_OLD}       ||= $self->{MAKEFILE}.'.old';
    $self->{MAKE_APERL_FILE}    ||= $self->{MAKEFILE}.'.aperl';

    # Not everybody uses -f to indicate "use this Makefile instead"
    $self->{USEMAKEFILE}        ||= '-f';

    # Some makes require a wrapper around macros passed in on the command
    # line.
    $self->{MACROSTART}         ||= '';
    $self->{MACROEND}           ||= '';

    return;
}


=head3 init_others

    $MM->init_others();

Initializes the macro definitions having to do with compiling and
linking used by tools_other() and places them in the $MM object.

If there is no description, its the same as the parameter to
WriteMakefile() documented in L<ExtUtils::MakeMaker>.

=cut

sub init_others {
    my $self = shift;

    $self->{LD_RUN_PATH} = "";

    $self->{LIBS} = $self->_fix_libs($self->{LIBS});

    # Compute EXTRALIBS, BSLOADLIBS and LDLOADLIBS from $self->{LIBS}
    foreach my $libs ( @{$self->{LIBS}} ){
        $libs =~ s/^\s*(.*\S)\s*$/$1/; # remove leading and trailing whitespace
        my(@libs) = $self->extliblist($libs);
        if ($libs[0] or $libs[1] or $libs[2]){
            # LD_RUN_PATH now computed by ExtUtils::Liblist
            ($self->{EXTRALIBS},  $self->{BSLOADLIBS},
             $self->{LDLOADLIBS}, $self->{LD_RUN_PATH}) = @libs;
            last;
        }
    }

    if ( $self->{OBJECT} ) {
        $self->{OBJECT} = join(" ", @{$self->{OBJECT}}) if ref $self->{OBJECT};
        $self->{OBJECT} =~ s!\.o(bj)?\b!\$(OBJ_EXT)!g;
    } elsif ( ($self->{MAGICXS} || $self->{XSMULTI}) && @{$self->{O_FILES}||[]} ) {
        $self->{OBJECT} = join(" ", @{$self->{O_FILES}});
        $self->{OBJECT} =~ s!\.o(bj)?\b!\$(OBJ_EXT)!g;
    } else {
        # init_dirscan should have found out, if we have C files
        $self->{OBJECT} = "";
        $self->{OBJECT} = '$(BASEEXT)$(OBJ_EXT)' if @{$self->{C}||[]};
    }
    $self->{OBJECT} =~ s/\n+/ \\\n\t/g;

    $self->{BOOTDEP}  = (-f "$self->{BASEEXT}_BS") ? "$self->{BASEEXT}_BS" : "";
    $self->{PERLMAINCC} ||= '$(CC)';
    $self->{LDFROM} = '$(OBJECT)' unless $self->{LDFROM};

    # Sanity check: don't define LINKTYPE = dynamic if we're skipping
    # the 'dynamic' section of MM.  We don't have this problem with
    # 'static', since we either must use it (%Config says we can't
    # use dynamic loading) or the caller asked for it explicitly.
    if (!$self->{LINKTYPE}) {
       $self->{LINKTYPE} = $self->{SKIPHASH}{'dynamic'}
                        ? 'static'
                        : ($Config{usedl} ? 'dynamic' : 'static');
    }

    return;
}


# Lets look at $self->{LIBS} carefully: It may be an anon array, a string or
# undefined. In any case we turn it into an anon array
sub _fix_libs {
    my($self, $libs) = @_;

    return !defined $libs       ? ['']          :
           !ref $libs           ? [$libs]       :
           !defined $libs->[0]  ? ['']          :
                                  $libs         ;
}


=head3 tools_other

    my $make_frag = $MM->tools_other;

Returns a make fragment containing definitions for the macros init_others()
initializes.

=cut

sub tools_other {
    my($self) = shift;
    my @m;

    # We set PM_FILTER as late as possible so it can see all the earlier
    # on macro-order sensitive makes such as nmake.
    for my $tool (qw{ SHELL CHMOD CP MV NOOP NOECHO RM_F RM_RF TEST_F TOUCH
                      UMASK_NULL DEV_NULL MKPATH EQUALIZE_TIMESTAMP
                      FALSE TRUE
                      ECHO ECHO_N
                      UNINST VERBINST
                      MOD_INSTALL DOC_INSTALL UNINSTALL
                      WARN_IF_OLD_PACKLIST
                      MACROSTART MACROEND
                      USEMAKEFILE
                      PM_FILTER
                      FIXIN
                      CP_NONEMPTY
                    } )
    {
        next unless defined $self->{$tool};
        push @m, "$tool = $self->{$tool}\n";
    }

    return join "", @m;
}


=head3 init_DIRFILESEP  I<Abstract>

  $MM->init_DIRFILESEP;
  my $dirfilesep = $MM->{DIRFILESEP};

Initializes the DIRFILESEP macro which is the separator between the
directory and filename in a filepath.  ie. / on Unix, \ on Win32 and
nothing on VMS.

For example:

    # instead of $(INST_ARCHAUTODIR)/extralibs.ld
    $(INST_ARCHAUTODIR)$(DIRFILESEP)extralibs.ld

Something of a hack but it prevents a lot of code duplication between
MM_* variants.

Do not use this as a separator between directories.  Some operating
systems use different separators between subdirectories as between
directories and filenames (for example:  VOLUME:[dir1.dir2]file on VMS).

=head3 init_linker  I<Abstract>

    $mm->init_linker;

Initialize macros which have to do with linking.

PERL_ARCHIVE: path to libperl.a equivalent to be linked to dynamic
extensions.

PERL_ARCHIVE_AFTER: path to a library which should be put on the
linker command line I<after> the external libraries to be linked to
dynamic extensions.  This may be needed if the linker is one-pass, and
Perl includes some overrides for C RTL functions, such as malloc().

EXPORT_LIST: name of a file that is passed to linker to define symbols
to be exported.

Some OSes do not need these in which case leave it blank.


=head3 init_platform

    $mm->init_platform

Initialize any macros which are for platform specific use only.

A typical one is the version number of your OS specific module.
(ie. MM_Unix_VERSION or MM_VMS_VERSION).

=cut

sub init_platform {
    return '';
}


=head3 init_MAKE

    $mm->init_MAKE

Initialize MAKE from either a MAKE environment variable or $Config{make}.

=cut

sub init_MAKE {
    my $self = shift;

    $self->{MAKE} ||= $ENV{MAKE} || $Config{make};
}


=head2 Tools

A grab bag of methods to generate specific macros and commands.


=head3 manifypods

Defines targets and routines to translate the pods into manpages and
put them into the INST_* directories.

=cut

sub manifypods {
    my $self          = shift;

    my $POD2MAN_macro = $self->POD2MAN_macro();
    my $manifypods_target = $self->manifypods_target();

    return <<END_OF_TARGET;

$POD2MAN_macro

$manifypods_target

END_OF_TARGET

}


=head3 POD2MAN_macro

  my $pod2man_macro = $self->POD2MAN_macro

Returns a definition for the POD2MAN macro.  This is a program
which emulates the pod2man utility.  You can add more switches to the
command by simply appending them on the macro.

Typical usage:

    $(POD2MAN) --section=3 --perm_rw=$(PERM_RW) podfile1 man_page1 ...

=cut

sub POD2MAN_macro {
    my $self = shift;

# Need the trailing '--' so perl stops gobbling arguments and - happens
# to be an alternative end of line separator on VMS so we quote it
    return <<'END_OF_DEF';
POD2MAN_EXE = $(PERLRUN) "-MExtUtils::Command::MM" -e pod2man "--"
POD2MAN = $(POD2MAN_EXE)
END_OF_DEF
}


=head3 test_via_harness

  my $command = $mm->test_via_harness($perl, $tests);

Returns a $command line which runs the given set of $tests with
Test::Harness and the given $perl.

Used on the t/*.t files.

=cut

sub test_via_harness {
    my($self, $perl, $tests) = @_;

    return qq{\t$perl "-MExtUtils::Command::MM" "-MTest::Harness" }.
           qq{"-e" "undef *Test::Harness::Switches; test_harness(\$(TEST_VERBOSE), '\$(INST_LIB)', '\$(INST_ARCHLIB)')" $tests\n};
}

=head3 test_via_script

  my $command = $mm->test_via_script($perl, $script);

Returns a $command line which just runs a single test without
Test::Harness.  No checks are done on the results, they're just
printed.

Used for test.pl, since they don't always follow Test::Harness
formatting.

=cut

sub test_via_script {
    my($self, $perl, $script) = @_;
    return qq{\t$perl "-I\$(INST_LIB)" "-I\$(INST_ARCHLIB)" $script\n};
}


=head3 tool_autosplit

Defines a simple perl call that runs autosplit. May be deprecated by
pm_to_blib soon.

=cut

sub tool_autosplit {
    my($self, %attribs) = @_;

    my $maxlen = $attribs{MAXLEN} ? '$$AutoSplit::Maxlen=$attribs{MAXLEN};'
                                  : '';

    my $asplit = $self->oneliner(sprintf <<'PERL_CODE', $maxlen);
use AutoSplit; %s autosplit($$ARGV[0], $$ARGV[1], 0, 1, 1)
PERL_CODE

    return sprintf <<'MAKE_FRAG', $asplit;
# Usage: $(AUTOSPLITFILE) FileToSplit AutoDirToSplitInto
AUTOSPLITFILE = %s

MAKE_FRAG

}


=head3 arch_check

    my $arch_ok = $mm->arch_check(
        $INC{"Config.pm"},
        File::Spec->catfile($Config{archlibexp}, "Config.pm")
    );

A sanity check that what Perl thinks the architecture is and what
Config thinks the architecture is are the same.  If they're not it
will return false and show a diagnostic message.

When building Perl it will always return true, as nothing is installed
yet.

The interface is a bit odd because this is the result of a
quick refactoring.  Don't rely on it.

=cut

sub arch_check {
    my $self = shift;
    my($pconfig, $cconfig) = @_;

    return 1 if $self->{PERL_SRC};

    my($pvol, $pthinks) = $self->splitpath($pconfig);
    my($cvol, $cthinks) = $self->splitpath($cconfig);

    $pthinks = $self->canonpath($pthinks);
    $cthinks = $self->canonpath($cthinks);

    my $ret = 1;
    if ($pthinks ne $cthinks) {
        print "Have $pthinks\n";
        print "Want $cthinks\n";

        $ret = 0;

        my $arch = (grep length, $self->splitdir($pthinks))[-1];

        print <<END unless $self->{UNINSTALLED_PERL};
Your perl and your Config.pm seem to have different ideas about the
architecture they are running on.
Perl thinks: [$arch]
Config says: [$Config{archname}]
This may or may not cause problems. Please check your installation of perl
if you have problems building this extension.
END
    }

    return $ret;
}


=head2 File::Spec wrappers

ExtUtils::MM_Any is a subclass of L<File::Spec>.  The methods noted here
override File::Spec.


=head3 catfile

File::Spec <= 0.83 has a bug where the file part of catfile is not
canonicalized.  This override fixes that bug.

=cut

sub catfile {
    my $self = shift;
    return $self->canonpath($self->SUPER::catfile(@_));
}


=head2 Misc

Methods I can't really figure out where they should go yet.


=head3 find_tests

  my $test = $mm->find_tests;

Returns a string suitable for feeding to the shell to return all
tests in t/*.t.

=cut

sub find_tests {
    my($self) = shift;
    return -d 't' ? 't/*.t' : '';
}

=head3 find_tests_recursive

  my $tests = $mm->find_tests_recursive;

Returns a string suitable for feeding to the shell to return all
tests in t/ but recursively. Equivalent to

  my $tests = $mm->find_tests_recursive_in('t');

=cut

sub find_tests_recursive {
    my $self = shift;
    return $self->find_tests_recursive_in('t');
}

=head3 find_tests_recursive_in

  my $tests = $mm->find_tests_recursive_in($dir);

Returns a string suitable for feeding to the shell to return all
tests in $dir recursively.

=cut

sub find_tests_recursive_in {
    my($self, $dir) = @_;
    return '' unless -d $dir;

    require File::Find;

    my $base_depth = grep { $_ ne '' } File::Spec->splitdir( (File::Spec->splitpath($dir))[1] );
    my %depths;

    my $wanted = sub {
        return unless m!\.t$!;
        my ($volume,$directories,$file) =
            File::Spec->splitpath( $File::Find::name  );
        my $depth = grep { $_ ne '' } File::Spec->splitdir( $directories );
        $depth -= $base_depth;
        $depths{ $depth } = 1;
    };

    File::Find::find( $wanted, $dir );

    return join ' ',
        map { $dir . '/*' x $_ . '.t' }
        sort { $a <=> $b }
        keys %depths;
}

=head3 extra_clean_files

    my @files_to_clean = $MM->extra_clean_files;

Returns a list of OS specific files to be removed in the clean target in
addition to the usual set.

=cut

# An empty method here tickled a perl 5.8.1 bug and would return its object.
sub extra_clean_files {
    return;
}


=head3 installvars

    my @installvars = $mm->installvars;

A list of all the INSTALL* variables without the INSTALL prefix.  Useful
for iteration or building related variable sets.

=cut

sub installvars {
    return qw(PRIVLIB SITELIB  VENDORLIB
              ARCHLIB SITEARCH VENDORARCH
              BIN     SITEBIN  VENDORBIN
              SCRIPT  SITESCRIPT  VENDORSCRIPT
              MAN1DIR SITEMAN1DIR VENDORMAN1DIR
              MAN3DIR SITEMAN3DIR VENDORMAN3DIR
             );
}


=head3 libscan

  my $wanted = $self->libscan($path);

Takes a path to a file or dir and returns an empty string if we don't
want to include this file in the library.  Otherwise it returns the
the $path unchanged.

Mainly used to exclude version control administrative directories
and base-level F<README.pod> from installation.

=cut

sub libscan {
    my($self,$path) = @_;

    if ($path =~ m<^README\.pod$>i) {
        warn "WARNING: Older versions of ExtUtils::MakeMaker may errantly install $path as part of this distribution. It is recommended to avoid using this path in CPAN modules.\n";
        return '';
    }

    my($dirs,$file) = ($self->splitpath($path))[1,2];
    return '' if grep /^(?:RCS|CVS|SCCS|\.svn|_darcs)$/,
                     $self->splitdir($dirs), $file;

    return $path;
}


=head3 platform_constants

    my $make_frag = $mm->platform_constants

Returns a make fragment defining all the macros initialized in
init_platform() rather than put them in constants().

=cut

sub platform_constants {
    return '';
}

=head3 post_constants (o)

Returns an empty string per default. Dedicated to overrides from
within Makefile.PL after all constants have been defined.

=cut

sub post_constants {
    "";
}

=head3 post_initialize (o)

Returns an empty string per default. Used in Makefile.PLs to add some
chunk of text to the Makefile after the object is initialized.

=cut

sub post_initialize {
    "";
}

=head3 postamble (o)

Returns an empty string. Can be used in Makefile.PLs to write some
text to the Makefile at the end.

=cut

sub postamble {
    "";
}

=begin private

=head3 _PREREQ_PRINT

    $self->_PREREQ_PRINT;

Implements PREREQ_PRINT.

Refactored out of MakeMaker->new().

=end private

=cut

sub _PREREQ_PRINT {
    my $self = shift;

    require Data::Dumper;
    my @what = ('PREREQ_PM');
    push @what, 'MIN_PERL_VERSION' if $self->{MIN_PERL_VERSION};
    push @what, 'BUILD_REQUIRES'   if $self->{BUILD_REQUIRES};
    print Data::Dumper->Dump([@{$self}{@what}], \@what);
    exit 0;
}


=begin private

=head3 _PRINT_PREREQ

  $mm->_PRINT_PREREQ;

Implements PRINT_PREREQ, a slightly different version of PREREQ_PRINT
added by Redhat to, I think, support generating RPMs from Perl modules.

Should not include BUILD_REQUIRES as RPMs do not include them.

Refactored out of MakeMaker->new().

=end private

=cut

sub _PRINT_PREREQ {
    my $self = shift;

    my $prereqs= $self->{PREREQ_PM};
    my @prereq = map { [$_, $prereqs->{$_}] } keys %$prereqs;

    if ( $self->{MIN_PERL_VERSION} ) {
        push @prereq, ['perl' => $self->{MIN_PERL_VERSION}];
    }

    print join(" ", map { "perl($_->[0])>=$_->[1] " }
                 sort { $a->[0] cmp $b->[0] } @prereq), "\n";
    exit 0;
}


=begin private

=head3 _perl_header_files

  my $perl_header_files= $self->_perl_header_files;

returns a sorted list of header files as found in PERL_SRC or $archlibexp/CORE.

Used by perldepend() in MM_Unix and MM_VMS via _perl_header_files_fragment()

=end private

=cut

sub _perl_header_files {
    my $self = shift;

    my $header_dir = $self->{PERL_SRC} || $ENV{PERL_SRC} || $self->catdir($Config{archlibexp}, 'CORE');
    opendir my $dh, $header_dir
        or die "Failed to opendir '$header_dir' to find header files: $!";

    # we need to use a temporary here as the sort in scalar context would have undefined results.
    my @perl_headers= sort grep { /\.h\z/ } readdir($dh);

    closedir $dh;

    return @perl_headers;
}

=begin private

=head3 _perl_header_files_fragment ($o, $separator)

  my $perl_header_files_fragment= $self->_perl_header_files_fragment("/");

return a Makefile fragment which holds the list of perl header files which
XS code depends on $(PERL_INC), and sets up the dependency for the $(OBJECT) file.

The $separator argument defaults to "". MM_VMS will set it to "" and MM_UNIX to "/"
in perldepend(). This reason child subclasses need to control this is that in
VMS the $(PERL_INC) directory will already have delimiters in it, but in
UNIX $(PERL_INC) will need a slash between it an the filename. Hypothetically
win32 could use "\\" (but it doesn't need to).

=end private

=cut

sub _perl_header_files_fragment {
    my ($self, $separator)= @_;
    $separator ||= "";
    return join("\\\n",
                "PERL_HDRS = ",
                map {
                    sprintf( "        \$(PERL_INCDEP)%s%s            ", $separator, $_ )
                } $self->_perl_header_files()
           ) . "\n\n"
           . "\$(OBJECT) : \$(PERL_HDRS)\n";
}


=head1 AUTHOR

Michael G Schwern <schwern@pobox.com> and the denizens of
makemaker@perl.org with code from ExtUtils::MM_Unix and
ExtUtils::MM_Win32.


=cut

1;
PK       ! �'�  �    perl5/ExtUtils/testlib.pmnu ��6�$        package ExtUtils::testlib;

use strict;
use warnings;

our $VERSION = '7.50';
$VERSION =~ tr/_//d;

use Cwd;
use File::Spec;

# So the tests can chdir around and not break @INC.
# We use getcwd() because otherwise rel2abs will blow up under taint
# mode pre-5.8.  We detaint is so @INC won't be tainted.  This is
# no worse, and probably better, than just shoving an untainted,
# relative "blib/lib" onto @INC.
my $cwd;
BEGIN {
    ($cwd) = getcwd() =~ /(.*)/;
}
use lib map { File::Spec->rel2abs($_, $cwd) } qw(blib/arch blib/lib);
1;
__END__

=head1 NAME

ExtUtils::testlib - add blib/* directories to @INC

=head1 SYNOPSIS

  use ExtUtils::testlib;

=head1 DESCRIPTION

After an extension has been built and before it is installed it may be
desirable to test it bypassing C<make test>. By adding

    use ExtUtils::testlib;

to a test program the intermediate directories used by C<make> are
added to @INC.

PK       ! �Yq��  �    perl5/ExtUtils/MM_UWIN.pmnu ��6�$        package ExtUtils::MM_UWIN;

use strict;
use warnings;
our $VERSION = '7.50';
$VERSION =~ tr/_//d;

require ExtUtils::MM_Unix;
our @ISA = qw(ExtUtils::MM_Unix);


=head1 NAME

ExtUtils::MM_UWIN - U/WIN specific subclass of ExtUtils::MM_Unix

=head1 SYNOPSIS

  Don't use this module directly.
  Use ExtUtils::MM and let it choose.

=head1 DESCRIPTION

This is a subclass of L<ExtUtils::MM_Unix> which contains functionality for
the AT&T U/WIN UNIX on Windows environment.

Unless otherwise stated it works just like ExtUtils::MM_Unix.

=head2 Overridden methods

=over 4

=item os_flavor

In addition to being Unix, we're U/WIN.

=cut

sub os_flavor {
    return('Unix', 'U/WIN');
}


=item B<replace_manpage_separator>

=cut

sub replace_manpage_separator {
    my($self, $man) = @_;

    $man =~ s,/+,.,g;
    return $man;
}

=back

=head1 AUTHOR

Michael G Schwern <schwern@pobox.com> with code from ExtUtils::MM_Unix

=head1 SEE ALSO

L<ExtUtils::MM_Win32>, L<ExtUtils::MakeMaker>

=cut

1;
PK       ! X���  �    perl5/ExtUtils/Mkbootstrap.pmnu ��6�$        package ExtUtils::Mkbootstrap;

use strict;
use warnings;

our $VERSION = '7.50';
$VERSION =~ tr/_//d;

require Exporter;
our @ISA = ('Exporter');
our @EXPORT = ('&Mkbootstrap');

use Config;

our $Verbose = 0;


sub Mkbootstrap {
    my($baseext, @bsloadlibs)=@_;
    @bsloadlibs = grep($_, @bsloadlibs); # strip empty libs

    print "	bsloadlibs=@bsloadlibs\n" if $Verbose;

    # We need DynaLoader here because we and/or the *_BS file may
    # call dl_findfile(). We don't say `use' here because when
    # first building perl extensions the DynaLoader will not have
    # been built when MakeMaker gets first used.
    require DynaLoader;

    rename "$baseext.bs", "$baseext.bso"
      if -s "$baseext.bs";

    if (-f "${baseext}_BS"){
	$_ = "${baseext}_BS";
	package DynaLoader; # execute code as if in DynaLoader
	no strict 'vars';
	local($osname, $dlsrc) = (); # avoid warnings
	($osname, $dlsrc) = @Config::Config{qw(osname dlsrc)};
	$bscode = "";
	unshift @INC, ".";
	require $_;
	shift @INC;
    }

    if ($Config{'dlsrc'} =~ /^dl_dld/){
	package DynaLoader;
	no strict 'vars';
	push(@dl_resolve_using, dl_findfile('-lc'));
    }

    my(@all) = (@bsloadlibs, @DynaLoader::dl_resolve_using);
    my($method) = '';
    if (@all || (defined $DynaLoader::bscode && length $DynaLoader::bscode)){
	open my $bs, ">", "$baseext.bs"
		or die "Unable to open $baseext.bs: $!";
	print "Writing $baseext.bs\n";
	print "	containing: @all" if $Verbose;
	print $bs "# $baseext DynaLoader bootstrap file for $^O architecture.\n";
	print $bs "# Do not edit this file, changes will be lost.\n";
	print $bs "# This file was automatically generated by the\n";
	print $bs "# Mkbootstrap routine in ExtUtils::Mkbootstrap (v$VERSION).\n";
	if (@all) {
	    print $bs "\@DynaLoader::dl_resolve_using = ";
	    # If @all contains names in the form -lxxx or -Lxxx then it's asking for
	    # runtime library location so we automatically add a call to dl_findfile()
	    if (" @all" =~ m/ -[lLR]/){
		print $bs "  dl_findfile(qw(\n  @all\n  ));\n";
	    } else {
		print $bs "  qw(@all);\n";
	    }
	}
	# write extra code if *_BS says so
	print $bs $DynaLoader::bscode if $DynaLoader::bscode;
	print $bs "\n1;\n";
	close $bs;
    }
}

1;

__END__

=head1 NAME

ExtUtils::Mkbootstrap - make a bootstrap file for use by DynaLoader

=head1 SYNOPSIS

  Mkbootstrap

=head1 DESCRIPTION

Mkbootstrap typically gets called from an extension Makefile.

There is no C<*.bs> file supplied with the extension. Instead, there may
be a C<*_BS> file which has code for the special cases, like posix for
berkeley db on the NeXT.

This file will get parsed, and produce a maybe empty
C<@DynaLoader::dl_resolve_using> array for the current architecture.
That will be extended by $BSLOADLIBS, which was computed by
ExtUtils::Liblist::ext(). If this array still is empty, we do nothing,
else we write a .bs file with an C<@DynaLoader::dl_resolve_using>
array.

The C<*_BS> file can put some code into the generated C<*.bs> file by
placing it in C<$bscode>. This is a handy 'escape' mechanism that may
prove useful in complex situations.

If @DynaLoader::dl_resolve_using contains C<-L*> or C<-l*> entries then
Mkbootstrap will automatically add a dl_findfile() call to the
generated C<*.bs> file.

=cut
PK       ! �"�  �    perl5/ExtUtils/MM_AIX.pmnu ��6�$        package ExtUtils::MM_AIX;

use strict;
use warnings;
our $VERSION = '7.50';
$VERSION =~ tr/_//d;

use ExtUtils::MakeMaker::Config;
require ExtUtils::MM_Unix;
our @ISA = qw(ExtUtils::MM_Unix);

=head1 NAME

ExtUtils::MM_AIX - AIX specific subclass of ExtUtils::MM_Unix

=head1 SYNOPSIS

  Don't use this module directly.
  Use ExtUtils::MM and let it choose.

=head1 DESCRIPTION

This is a subclass of L<ExtUtils::MM_Unix> which contains functionality for
AIX.

Unless otherwise stated it works just like ExtUtils::MM_Unix.

=head2 Overridden methods

=head3 dlsyms

Define DL_FUNCS and DL_VARS and write the *.exp files.

=cut

sub dlsyms {
    my($self,%attribs) = @_;
    return '' unless $self->needs_linking;
    join "\n", $self->xs_dlsyms_iterator(\%attribs);
}

=head3 xs_dlsyms_ext

On AIX, is C<.exp>.

=cut

sub xs_dlsyms_ext {
    '.exp';
}

sub xs_dlsyms_arg {
    my($self, $file) = @_;
    my $arg = qq{-bE:${file}};
    $arg = '-Wl,'.$arg if $Config{lddlflags} =~ /-Wl,-bE:/;
    return $arg;
}

sub init_others {
    my $self = shift;
    $self->SUPER::init_others;
    # perl "hints" add -bE:$(BASEEXT).exp to LDDLFLAGS. strip that out
    # so right value can be added by xs_make_dynamic_lib to work for XSMULTI
    $self->{LDDLFLAGS} ||= $Config{lddlflags};
    $self->{LDDLFLAGS} =~ s#(\s*)\S*\Q$(BASEEXT)\E\S*(\s*)#$1$2#;
    return;
}

=head1 AUTHOR

Michael G Schwern <schwern@pobox.com> with code from ExtUtils::MM_Unix

=head1 SEE ALSO

L<ExtUtils::MakeMaker>

=cut


1;
PK       ! o���8  8    perl5/ExtUtils/Installed.pmnu ��6�$        package ExtUtils::Installed;

use 5.00503;
use strict;
#use warnings; # XXX requires 5.6
use Carp qw();
use ExtUtils::Packlist;
use ExtUtils::MakeMaker;
use Config;
use File::Find;
use File::Basename;
use File::Spec;

my $Is_VMS = $^O eq 'VMS';
my $DOSISH = ($^O =~ /^(MSWin\d\d|os2|dos|mint)$/);

require VMS::Filespec if $Is_VMS;

use vars qw($VERSION);
$VERSION = '2.06';
$VERSION = eval $VERSION;

sub _is_prefix {
    my ($self, $path, $prefix) = @_;
    return unless defined $prefix && defined $path;

    if( $Is_VMS ) {
        $prefix = VMS::Filespec::unixify($prefix);
        $path   = VMS::Filespec::unixify($path);
    }

    # Unix path normalization.
    $prefix = File::Spec->canonpath($prefix);

    return 1 if substr($path, 0, length($prefix)) eq $prefix;

    if ($DOSISH) {
        $path =~ s|\\|/|g;
        $prefix =~ s|\\|/|g;
        return 1 if $path =~ m{^\Q$prefix\E}i;
    }
    return(0);
}

sub _is_doc {
    my ($self, $path) = @_;

    my $man1dir = $self->{':private:'}{Config}{man1direxp};
    my $man3dir = $self->{':private:'}{Config}{man3direxp};
    return(($man1dir && $self->_is_prefix($path, $man1dir))
           ||
           ($man3dir && $self->_is_prefix($path, $man3dir))
           ? 1 : 0)
}

sub _is_type {
    my ($self, $path, $type) = @_;
    return 1 if $type eq "all";

    return($self->_is_doc($path)) if $type eq "doc";
    my $conf= $self->{':private:'}{Config};
    if ($type eq "prog") {
        return($self->_is_prefix($path, $conf->{prefix} || $conf->{prefixexp})
               && !($self->_is_doc($path)) ? 1 : 0);
    }
    return(0);
}

sub _is_under {
    my ($self, $path, @under) = @_;
    $under[0] = "" if (! @under);
    foreach my $dir (@under) {
        return(1) if ($self->_is_prefix($path, $dir));
    }

    return(0);
}

sub _fix_dirs {
    my ($self, @dirs)= @_;
    # File::Find does not know how to deal with VMS filepaths.
    if( $Is_VMS ) {
        $_ = VMS::Filespec::unixify($_)
            for @dirs;
    }

    if ($DOSISH) {
        s|\\|/|g for @dirs;
    }
    return wantarray ? @dirs : $dirs[0];
}

sub _make_entry {
    my ($self, $module, $packlist_file, $modfile)= @_;

    my $data= {
        module => $module,
        packlist => scalar(ExtUtils::Packlist->new($packlist_file)),
        packlist_file => $packlist_file,
    };

    if (!$modfile) {
        $data->{version} = $self->{':private:'}{Config}{version};
    } else {
        $data->{modfile} = $modfile;
        # Find the top-level module file in @INC
        $data->{version} = '';
        foreach my $dir (@{$self->{':private:'}{INC}}) {
            my $p = File::Spec->catfile($dir, $modfile);
            if (-r $p) {
                $module = _module_name($p, $module) if $Is_VMS;

                $data->{version} = MM->parse_version($p);
                $data->{version_from} = $p;
                $data->{packlist_valid} = exists $data->{packlist}{$p};
                last;
            }
        }
    }
    $self->{$module}= $data;
}

our $INSTALLED;
sub new {
    my ($class) = shift(@_);
    $class = ref($class) || $class;

    my %args = @_;

    return $INSTALLED if $INSTALLED and ($args{default_get} || $args{default});

    my $self = bless {}, $class;

    $INSTALLED= $self if $args{default_set} || $args{default};


    if ($args{config_override}) {
        eval {
            $self->{':private:'}{Config} = { %{$args{config_override}} };
        } or Carp::croak(
            "The 'config_override' parameter must be a hash reference."
        );
    }
    else {
        $self->{':private:'}{Config} = \%Config;
    }

    for my $tuple ([inc_override => INC => [ @INC ] ],
                   [ extra_libs => EXTRA => [] ])
    {
        my ($arg,$key,$val)=@$tuple;
        if ( $args{$arg} ) {
            eval {
                $self->{':private:'}{$key} = [ @{$args{$arg}} ];
            } or Carp::croak(
                "The '$arg' parameter must be an array reference."
            );
        }
        elsif ($val) {
            $self->{':private:'}{$key} = $val;
        }
    }
    {
        my %dupe;
        @{$self->{':private:'}{LIBDIRS}} =
            grep { $_ ne '.' || ! $args{skip_cwd} }
            grep { -e $_ && !$dupe{$_}++ }
            @{$self->{':private:'}{EXTRA}}, @{$self->{':private:'}{INC}};
    }

    my @dirs= $self->_fix_dirs(@{$self->{':private:'}{LIBDIRS}});

    # Read the core packlist
    my $archlib = $self->_fix_dirs($self->{':private:'}{Config}{archlibexp});
    $self->_make_entry("Perl",File::Spec->catfile($archlib, '.packlist'));

    my $root;
    # Read the module packlists
    my $sub = sub {
        # Only process module .packlists
        return if $_ ne ".packlist" || $File::Find::dir eq $archlib;

        # Hack of the leading bits of the paths & convert to a module name
        my $module = $File::Find::name;
        my $found = $module =~ s!^.*?/auto/(.*)/.packlist!$1!s
            or do {
            # warn "Woah! \$_=$_\n\$module=$module\n\$File::Find::dir=$File::Find::dir\n",
            #    join ("\n",@dirs);
            return;
        };

        my $modfile = "$module.pm";
        $module =~ s!/!::!g;

        return if $self->{$module}; #shadowing?
        $self->_make_entry($module,$File::Find::name,$modfile);
    };
    while (@dirs) {
        $root= shift @dirs;
        next if !-d $root;
        find($sub,$root);
    }

    return $self;
}

# VMS's non-case preserving file-system means the package name can't
# be reconstructed from the filename.
sub _module_name {
    my($file, $orig_module) = @_;

    my $module = '';
    if (open PACKFH, $file) {
        while (<PACKFH>) {
            if (/package\s+(\S+)\s*;/) {
                my $pack = $1;
                # Make a sanity check, that lower case $module
                # is identical to lowercase $pack before
                # accepting it
                if (lc($pack) eq lc($orig_module)) {
                    $module = $pack;
                    last;
                }
            }
        }
        close PACKFH;
    }

    print STDERR "Couldn't figure out the package name for $file\n"
      unless $module;

    return $module;
}

sub modules {
    my ($self) = @_;
    $self= $self->new(default=>1) if !ref $self;

    # Bug/feature of sort in scalar context requires this.
    return wantarray
        ? sort grep { not /^:private:$/ } keys %$self
        : grep { not /^:private:$/ } keys %$self;
}

sub files {
    my ($self, $module, $type, @under) = @_;
    $self= $self->new(default=>1) if !ref $self;

    # Validate arguments
    Carp::croak("$module is not installed") if (! exists($self->{$module}));
    $type = "all" if (! defined($type));
    Carp::croak('type must be "all", "prog" or "doc"')
        if ($type ne "all" && $type ne "prog" && $type ne "doc");

    my (@files);
    foreach my $file (keys(%{$self->{$module}{packlist}})) {
        push(@files, $file)
          if ($self->_is_type($file, $type) &&
              $self->_is_under($file, @under));
    }
    return(@files);
}

sub directories {
    my ($self, $module, $type, @under) = @_;
    $self= $self->new(default=>1) if !ref $self;
    my (%dirs);
    foreach my $file ($self->files($module, $type, @under)) {
        $dirs{dirname($file)}++;
    }
    return sort keys %dirs;
}

sub directory_tree {
    my ($self, $module, $type, @under) = @_;
    $self= $self->new(default=>1) if !ref $self;
    my (%dirs);
    foreach my $dir ($self->directories($module, $type, @under)) {
        $dirs{$dir}++;
        my ($last) = ("");
        while ($last ne $dir) {
            $last = $dir;
            $dir = dirname($dir);
            last if !$self->_is_under($dir, @under);
            $dirs{$dir}++;
        }
    }
    return(sort(keys(%dirs)));
}

sub validate {
    my ($self, $module, $remove) = @_;
    $self= $self->new(default=>1) if !ref $self;
    Carp::croak("$module is not installed") if (! exists($self->{$module}));
    return($self->{$module}{packlist}->validate($remove));
}

sub packlist {
    my ($self, $module) = @_;
    $self= $self->new(default=>1) if !ref $self;
    Carp::croak("$module is not installed") if (! exists($self->{$module}));
    return($self->{$module}{packlist});
}

sub version {
    my ($self, $module) = @_;
    $self= $self->new(default=>1) if !ref $self;
    Carp::croak("$module is not installed") if (! exists($self->{$module}));
    return($self->{$module}{version});
}

sub debug_dump {
    my ($self, $module) = @_;
    $self= $self->new(default=>1) if !ref $self;
    local $self->{":private:"}{Config};
    require Data::Dumper;
    print Data::Dumper->new([$self])->Sortkeys(1)->Indent(1)->Dump();
}


1;

__END__

=head1 NAME

ExtUtils::Installed - Inventory management of installed modules

=head1 SYNOPSIS

   use ExtUtils::Installed;
   my ($inst) = ExtUtils::Installed->new( skip_cwd => 1 );
   my (@modules) = $inst->modules();
   my (@missing) = $inst->validate("DBI");
   my $all_files = $inst->files("DBI");
   my $files_below_usr_local = $inst->files("DBI", "all", "/usr/local");
   my $all_dirs = $inst->directories("DBI");
   my $dirs_below_usr_local = $inst->directory_tree("DBI", "prog");
   my $packlist = $inst->packlist("DBI");

=head1 DESCRIPTION

ExtUtils::Installed  provides a standard way to find out what core and module
files have been installed.  It uses the information stored in .packlist files
created during installation to provide this information.  In addition it
provides facilities to classify the installed files and to extract directory
information from the .packlist files.

=head1 USAGE

The new() function searches for all the installed .packlists on the system, and
stores their contents. The .packlists can be queried with the functions
described below. Where it searches by default is determined by the settings found
in C<%Config::Config>, and what the value is of the PERL5LIB environment variable.

=head1 METHODS

Unless specified otherwise all method can be called as class methods, or as object
methods. If called as class methods then the "default" object will be used, and if
necessary created using the current processes %Config and @INC.  See the
'default' option to new() for details.


=over 4

=item new()

This takes optional named parameters. Without parameters, this
searches for all the installed .packlists on the system using
information from C<%Config::Config> and the default module search
paths C<@INC>. The packlists are read using the
L<ExtUtils::Packlist> module.

If the named parameter C<skip_cwd> is true, the current directory C<.> will
be stripped from C<@INC> before searching for .packlists.  This keeps
ExtUtils::Installed from finding modules installed in other perls that
happen to be located below the current directory.

If the named parameter C<config_override> is specified,
it should be a reference to a hash which contains all information
usually found in C<%Config::Config>. For example, you can obtain
the configuration information for a separate perl installation and
pass that in.

    my $yoda_cfg  = get_fake_config('yoda');
    my $yoda_inst =
               ExtUtils::Installed->new(config_override=>$yoda_cfg);

Similarly, the parameter C<inc_override> may be a reference to an
array which is used in place of the default module search paths
from C<@INC>.

    use Config;
    my @dirs = split(/\Q$Config{path_sep}\E/, $ENV{PERL5LIB});
    my $p5libs = ExtUtils::Installed->new(inc_override=>\@dirs);

B<Note>: You probably do not want to use these options alone, almost always
you will want to set both together.

The parameter C<extra_libs> can be used to specify B<additional> paths to
search for installed modules. For instance

    my $installed =
             ExtUtils::Installed->new(extra_libs=>["/my/lib/path"]);

This should only be necessary if F</my/lib/path> is not in PERL5LIB.

Finally there is the 'default', and the related 'default_get' and 'default_set'
options. These options control the "default" object which is provided by the
class interface to the methods. Setting C<default_get> to true tells the constructor
to return the default object if it is defined. Setting C<default_set> to true tells
the constructor to make the default object the constructed object. Setting the
C<default> option is like setting both to true. This is used primarily internally
and probably isn't interesting to any real user.

=item modules()

This returns a list of the names of all the installed modules.  The perl 'core'
is given the special name 'Perl'.

=item files()

This takes one mandatory parameter, the name of a module.  It returns a list of
all the filenames from the package.  To obtain a list of core perl files, use
the module name 'Perl'.  Additional parameters are allowed.  The first is one
of the strings "prog", "doc" or "all", to select either just program files,
just manual files or all files.  The remaining parameters are a list of
directories. The filenames returned will be restricted to those under the
specified directories.

=item directories()

This takes one mandatory parameter, the name of a module.  It returns a list of
all the directories from the package.  Additional parameters are allowed.  The
first is one of the strings "prog", "doc" or "all", to select either just
program directories, just manual directories or all directories.  The remaining
parameters are a list of directories. The directories returned will be
restricted to those under the specified directories.  This method returns only
the leaf directories that contain files from the specified module.

=item directory_tree()

This is identical in operation to directories(), except that it includes all the
intermediate directories back up to the specified directories.

=item validate()

This takes one mandatory parameter, the name of a module.  It checks that all
the files listed in the modules .packlist actually exist, and returns a list of
any missing files.  If an optional second argument which evaluates to true is
given any missing files will be removed from the .packlist

=item packlist()

This returns the ExtUtils::Packlist object for the specified module.

=item version()

This returns the version number for the specified module.

=back

=head1 EXAMPLE

See the example in L<ExtUtils::Packlist>.

=head1 AUTHOR

Alan Burlison <Alan.Burlison@uk.sun.com>

=cut
PK       ! ��_� _�   perl5/ExtUtils/MakeMaker.pmnu ��6�$        # $Id$
package ExtUtils::MakeMaker;

use strict;
use warnings;

BEGIN {require 5.006;}

require Exporter;
use ExtUtils::MakeMaker::Config;
use ExtUtils::MakeMaker::version; # ensure we always have our fake version.pm
use Carp;
use File::Path;
my $CAN_DECODE = eval { require ExtUtils::MakeMaker::Locale; }; # 2 birds, 1 stone
eval { ExtUtils::MakeMaker::Locale::reinit('UTF-8') }
  if $CAN_DECODE and Encode::find_encoding('locale')->name eq 'ascii';

our $Verbose = 0;       # exported
our @Parent;            # needs to be localized
our @Get_from_Config;   # referenced by MM_Unix
our @MM_Sections;
our @Overridable;
my @Prepend_parent;
my %Recognized_Att_Keys;
our %macro_fsentity; # whether a macro is a filesystem name
our %macro_dep; # whether a macro is a dependency

our $VERSION = '7.50';
$VERSION =~ tr/_//d;

# Emulate something resembling CVS $Revision$
(our $Revision = $VERSION) =~ s{_}{};
$Revision = int $Revision * 10000;

our $Filename = __FILE__;   # referenced outside MakeMaker

our @ISA = qw(Exporter);
our @EXPORT    = qw(&WriteMakefile $Verbose &prompt &os_unsupported);
our @EXPORT_OK = qw($VERSION &neatvalue &mkbootstrap &mksymlists
                    &WriteEmptyMakefile &open_for_writing &write_file_via_tmp
                    &_sprintf562);

# These will go away once the last of the Win32 & VMS specific code is
# purged.
my $Is_VMS     = $^O eq 'VMS';
my $Is_Win32   = $^O eq 'MSWin32';
our $UNDER_CORE = $ENV{PERL_CORE}; # needs to be our

full_setup();

require ExtUtils::MM;  # Things like CPAN assume loading ExtUtils::MakeMaker
                       # will give them MM.

require ExtUtils::MY;  # XXX pre-5.8 versions of ExtUtils::Embed expect
                       # loading ExtUtils::MakeMaker will give them MY.
                       # This will go when Embed is its own CPAN module.


# 5.6.2 can't do sprintf "%1$s" - this can only do %s
sub _sprintf562 {
    my ($format, @args) = @_;
    for (my $i = 1; $i <= @args; $i++) {
        $format =~ s#%$i\$s#$args[$i-1]#g;
    }
    $format;
}

sub WriteMakefile {
    croak "WriteMakefile: Need even number of args" if @_ % 2;

    require ExtUtils::MY;
    my %att = @_;

    _convert_compat_attrs(\%att);

    _verify_att(\%att);

    my $mm = MM->new(\%att);
    $mm->flush;

    return $mm;
}


# Basic signatures of the attributes WriteMakefile takes.  Each is the
# reference type.  Empty value indicate it takes a non-reference
# scalar.
my %Att_Sigs;
my %Special_Sigs = (
 AUTHOR             => 'ARRAY',
 C                  => 'ARRAY',
 CONFIG             => 'ARRAY',
 CONFIGURE          => 'CODE',
 DIR                => 'ARRAY',
 DL_FUNCS           => 'HASH',
 DL_VARS            => 'ARRAY',
 EXCLUDE_EXT        => 'ARRAY',
 EXE_FILES          => 'ARRAY',
 FUNCLIST           => 'ARRAY',
 H                  => 'ARRAY',
 IMPORTS            => 'HASH',
 INCLUDE_EXT        => 'ARRAY',
 LIBS               => ['ARRAY',''],
 MAN1PODS           => 'HASH',
 MAN3PODS           => 'HASH',
 META_ADD           => 'HASH',
 META_MERGE         => 'HASH',
 OBJECT             => ['ARRAY', ''],
 PL_FILES           => 'HASH',
 PM                 => 'HASH',
 PMLIBDIRS          => 'ARRAY',
 PMLIBPARENTDIRS    => 'ARRAY',
 PREREQ_PM          => 'HASH',
 BUILD_REQUIRES     => 'HASH',
 CONFIGURE_REQUIRES => 'HASH',
 TEST_REQUIRES      => 'HASH',
 SKIP               => 'ARRAY',
 TYPEMAPS           => 'ARRAY',
 XS                 => 'HASH',
 XSBUILD            => 'HASH',
 VERSION            => ['version',''],
 _KEEP_AFTER_FLUSH  => '',

 clean      => 'HASH',
 depend     => 'HASH',
 dist       => 'HASH',
 dynamic_lib=> 'HASH',
 linkext    => 'HASH',
 macro      => 'HASH',
 postamble  => 'HASH',
 realclean  => 'HASH',
 test       => 'HASH',
 tool_autosplit => 'HASH',
);

@Att_Sigs{keys %Recognized_Att_Keys} = ('') x keys %Recognized_Att_Keys;
@Att_Sigs{keys %Special_Sigs} = values %Special_Sigs;

sub _convert_compat_attrs { #result of running several times should be same
    my($att) = @_;
    if (exists $att->{AUTHOR}) {
        if ($att->{AUTHOR}) {
            if (!ref($att->{AUTHOR})) {
                my $t = $att->{AUTHOR};
                $att->{AUTHOR} = [$t];
            }
        } else {
                $att->{AUTHOR} = [];
        }
    }
}

sub _verify_att {
    my($att) = @_;

    foreach my $key (sort keys %$att) {
        my $val = $att->{$key};
        my $sig = $Att_Sigs{$key};
        unless( defined $sig ) {
            warn "WARNING: $key is not a known parameter.\n";
            next;
        }

        my @sigs   = ref $sig ? @$sig : $sig;
        my $given  = ref $val;
        unless( grep { _is_of_type($val, $_) } @sigs ) {
            my $takes = join " or ", map { _format_att($_) } @sigs;

            my $has = _format_att($given);
            warn "WARNING: $key takes a $takes not a $has.\n".
                 "         Please inform the author.\n";
        }
    }
}


# Check if a given thing is a reference or instance of $type
sub _is_of_type {
    my($thing, $type) = @_;

    return 1 if ref $thing eq $type;

    local $SIG{__DIE__};
    return 1 if eval{ $thing->isa($type) };

    return 0;
}


sub _format_att {
    my $given = shift;

    return $given eq ''        ? "string/number"
         : uc $given eq $given ? "$given reference"
         :                       "$given object"
         ;
}


sub prompt ($;$) {  ## no critic
    my($mess, $def) = @_;
    confess("prompt function called without an argument")
        unless defined $mess;

    my $isa_tty = -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)) ;

    my $dispdef = defined $def ? "[$def] " : " ";
    $def = defined $def ? $def : "";

    local $|=1;
    local $\;
    print "$mess $dispdef";

    my $ans;
    if ($ENV{PERL_MM_USE_DEFAULT} || (!$isa_tty && eof STDIN)) {
        print "$def\n";
    }
    else {
        $ans = <STDIN>;
        if( defined $ans ) {
            $ans =~ s{\015?\012$}{};
        }
        else { # user hit ctrl-D
            print "\n";
        }
    }

    return (!defined $ans || $ans eq '') ? $def : $ans;
}

sub os_unsupported {
    die "OS unsupported\n";
}

sub eval_in_subdirs {
    my($self) = @_;
    use Cwd qw(cwd abs_path);
    my $pwd = cwd() || die "Can't figure out your cwd!";

    local @INC = map eval {abs_path($_) if -e} || $_, @INC;
    push @INC, '.';     # '.' has to always be at the end of @INC

    foreach my $dir (@{$self->{DIR}}){
        my($abs) = $self->catdir($pwd,$dir);
        eval { $self->eval_in_x($abs); };
        last if $@;
    }
    chdir $pwd;
    die $@ if $@;
}

sub eval_in_x {
    my($self,$dir) = @_;
    chdir $dir or carp("Couldn't change to directory $dir: $!");

    {
        package main;
        do './Makefile.PL';
    };
    if ($@) {
#         if ($@ =~ /prerequisites/) {
#             die "MakeMaker WARNING: $@";
#         } else {
#             warn "WARNING from evaluation of $dir/Makefile.PL: $@";
#         }
        die "ERROR from evaluation of $dir/Makefile.PL: $@";
    }
}


# package name for the classes into which the first object will be blessed
my $PACKNAME = 'PACK000';

sub full_setup {
    $Verbose ||= 0;

    my @dep_macros = qw/
    PERL_INCDEP        PERL_ARCHLIBDEP     PERL_ARCHIVEDEP
    /;

    my @fs_macros = qw/
    FULLPERL XSUBPPDIR

    INST_ARCHLIB INST_SCRIPT INST_BIN INST_LIB INST_MAN1DIR INST_MAN3DIR
    INSTALLDIRS
    DESTDIR PREFIX INSTALL_BASE
    PERLPREFIX      SITEPREFIX      VENDORPREFIX
    INSTALLPRIVLIB  INSTALLSITELIB  INSTALLVENDORLIB
    INSTALLARCHLIB  INSTALLSITEARCH INSTALLVENDORARCH
    INSTALLBIN      INSTALLSITEBIN  INSTALLVENDORBIN
    INSTALLMAN1DIR          INSTALLMAN3DIR
    INSTALLSITEMAN1DIR      INSTALLSITEMAN3DIR
    INSTALLVENDORMAN1DIR    INSTALLVENDORMAN3DIR
    INSTALLSCRIPT   INSTALLSITESCRIPT  INSTALLVENDORSCRIPT
    PERL_LIB        PERL_ARCHLIB
    SITELIBEXP      SITEARCHEXP

    MAKE LIBPERL_A LIB PERL_SRC PERL_INC
    PPM_INSTALL_EXEC PPM_UNINSTALL_EXEC
    PPM_INSTALL_SCRIPT PPM_UNINSTALL_SCRIPT
    /;

    my @attrib_help = qw/

    AUTHOR ABSTRACT ABSTRACT_FROM BINARY_LOCATION
    C CAPI CCFLAGS CONFIG CONFIGURE DEFINE DIR DISTNAME DISTVNAME
    DL_FUNCS DL_VARS
    EXCLUDE_EXT EXE_FILES FIRST_MAKEFILE
    FULLPERLRUN FULLPERLRUNINST
    FUNCLIST H IMPORTS

    INC INCLUDE_EXT LDFROM LIBS LICENSE
    LINKTYPE MAKEAPERL MAKEFILE MAKEFILE_OLD MAN1PODS MAN3PODS MAP_TARGET
    META_ADD META_MERGE MIN_PERL_VERSION BUILD_REQUIRES CONFIGURE_REQUIRES
    MYEXTLIB NAME NEEDS_LINKING NOECHO NO_META NO_MYMETA NO_PACKLIST NO_PERLLOCAL
    NORECURS NO_VC OBJECT OPTIMIZE PERL_MALLOC_OK PERL PERLMAINCC PERLRUN
    PERLRUNINST PERL_CORE
    PERM_DIR PERM_RW PERM_RWX MAGICXS
    PL_FILES PM PM_FILTER PMLIBDIRS PMLIBPARENTDIRS POLLUTE
    PREREQ_FATAL PREREQ_PM PREREQ_PRINT PRINT_PREREQ PUREPERL_ONLY
    SIGN SKIP TEST_REQUIRES TYPEMAPS UNINST VERSION VERSION_FROM XS
    XSBUILD XSMULTI XSOPT XSPROTOARG XS_VERSION
    clean depend dist dynamic_lib linkext macro realclean tool_autosplit

    MAN1EXT MAN3EXT

    MACPERL_SRC MACPERL_LIB MACLIBS_68K MACLIBS_PPC MACLIBS_SC MACLIBS_MRC
    MACLIBS_ALL_68K MACLIBS_ALL_PPC MACLIBS_SHARED
        /;
    push @attrib_help, @fs_macros;
    @macro_fsentity{@fs_macros, @dep_macros} = (1) x (@fs_macros+@dep_macros);
    @macro_dep{@dep_macros} = (1) x @dep_macros;

    # IMPORTS is used under OS/2 and Win32

    # @Overridable is close to @MM_Sections but not identical.  The
    # order is important. Many subroutines declare macros. These
    # depend on each other. Let's try to collect the macros up front,
    # then pasthru, then the rules.

    # MM_Sections are the sections we have to call explicitly
    # in Overridable we have subroutines that are used indirectly


    @MM_Sections =
        qw(

 post_initialize const_config constants platform_constants
 tool_autosplit tool_xsubpp tools_other

 makemakerdflt

 dist macro depend cflags const_loadlibs const_cccmd
 post_constants

 pasthru

 special_targets
 c_o xs_c xs_o
 top_targets blibdirs linkext dlsyms dynamic_bs dynamic
 dynamic_lib static static_lib manifypods processPL
 installbin subdirs
 clean_subdirs clean realclean_subdirs realclean
 metafile signature
 dist_basics dist_core distdir dist_test dist_ci distmeta distsignature
 install force perldepend makefile staticmake test ppd

          ); # loses section ordering

    @Overridable = @MM_Sections;
    push @Overridable, qw[

 libscan makeaperl needs_linking
 subdir_x test_via_harness test_via_script

 init_VERSION init_dist init_INST init_INSTALL init_DEST init_dirscan
 init_PM init_MANPODS init_xs init_PERL init_DIRFILESEP init_linker
                         ];

    push @MM_Sections, qw[

 pm_to_blib selfdocument

                         ];

    # Postamble needs to be the last that was always the case
    push @MM_Sections, "postamble";
    push @Overridable, "postamble";

    # All sections are valid keys.
    @Recognized_Att_Keys{@MM_Sections} = (1) x @MM_Sections;

    # we will use all these variables in the Makefile
    @Get_from_Config =
        qw(
           ar cc cccdlflags ccdlflags dlext dlsrc exe_ext full_ar ld
           lddlflags ldflags libc lib_ext obj_ext osname osvers ranlib
           sitelibexp sitearchexp so
          );

    # 5.5.3 doesn't have any concept of vendor libs
    push @Get_from_Config, qw( vendorarchexp vendorlibexp ) if "$]" >= 5.006;

    foreach my $item (@attrib_help){
        $Recognized_Att_Keys{$item} = 1;
    }
    foreach my $item (@Get_from_Config) {
        $Recognized_Att_Keys{uc $item} = $Config{$item};
        print "Attribute '\U$item\E' => '$Config{$item}'\n"
            if ($Verbose >= 2);
    }

    #
    # When we eval a Makefile.PL in a subdirectory, that one will ask
    # us (the parent) for the values and will prepend "..", so that
    # all files to be installed end up below OUR ./blib
    #
    @Prepend_parent = qw(
           INST_BIN INST_LIB INST_ARCHLIB INST_SCRIPT
           MAP_TARGET INST_MAN1DIR INST_MAN3DIR PERL_SRC
           PERL FULLPERL
    );
}

sub _has_cpan_meta_requirements {
    return eval {
      require CPAN::Meta::Requirements;
      CPAN::Meta::Requirements->VERSION(2.130);
      require B; # CMR requires this, for core we have to too.
    };
}

sub new {
    my($class,$self) = @_;
    my($key);

    _convert_compat_attrs($self) if defined $self && $self;

    # Store the original args passed to WriteMakefile()
    foreach my $k (keys %$self) {
        $self->{ARGS}{$k} = $self->{$k};
    }

    $self = {} unless defined $self;

    # Temporarily bless it into MM so it can be used as an
    # object.  It will be blessed into a temp package later.
    bless $self, "MM";

    # Cleanup all the module requirement bits
    my %key2cmr;
    for my $key (qw(PREREQ_PM BUILD_REQUIRES CONFIGURE_REQUIRES TEST_REQUIRES)) {
        $self->{$key}      ||= {};
        if (_has_cpan_meta_requirements) {
            my $cmr = CPAN::Meta::Requirements->from_string_hash(
                $self->{$key},
                {
                  bad_version_hook => sub {
                    #no warnings 'numeric'; # module doesn't use warnings
                    my $fallback;
                    if ( $_[0] =~ m!^[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?$! ) {
                      $fallback = sprintf "%f", $_[0];
                    } else {
                      ($fallback) = $_[0] ? ($_[0] =~ /^([0-9.]+)/) : 0;
                      $fallback += 0;
                      carp "Unparsable version '$_[0]' for prerequisite $_[1] treated as $fallback";
                    }
                    version->new($fallback);
                  },
                },
            );
            $self->{$key} = $cmr->as_string_hash;
            $key2cmr{$key} = $cmr;
        } else {
            for my $module (sort keys %{ $self->{$key} }) {
                my $version = $self->{$key}->{$module};
                my $fallback = 0;
                if (!defined($version) or !length($version)) {
                    carp "Undefined requirement for $module treated as '0' (CPAN::Meta::Requirements not available)";
                }
                elsif ($version =~ /^\d+(?:\.\d+(?:_\d+)*)?$/) {
                    next;
                }
                else {
                    if ( $version =~ m!^[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?$! ) {
                      $fallback = sprintf "%f", $version;
                    } else {
                      ($fallback) = $version ? ($version =~ /^([0-9.]+)/) : 0;
                      $fallback += 0;
                      carp "Unparsable version '$version' for prerequisite $module treated as $fallback (CPAN::Meta::Requirements not available)";
                    }
                }
                $self->{$key}->{$module} = $fallback;
            }
        }
    }

    if ("@ARGV" =~ /\bPREREQ_PRINT\b/) {
        $self->_PREREQ_PRINT;
    }

    # PRINT_PREREQ is RedHatism.
    if ("@ARGV" =~ /\bPRINT_PREREQ\b/) {
        $self->_PRINT_PREREQ;
   }

    print "MakeMaker (v$VERSION)\n" if $Verbose;
    if (-f "MANIFEST" && ! -f "Makefile" && ! $UNDER_CORE){
        check_manifest();
    }

    check_hints($self);

    if ( $self->{MIN_PERL_VERSION}) {
        my $perl_version = $self->{MIN_PERL_VERSION};
        if (ref $perl_version) {
            # assume a version object
        }
        else {
            $perl_version = eval {
                local $SIG{__WARN__} = sub {
                    # simulate "use warnings FATAL => 'all'" for vintage perls
                    die @_;
                };
                version->new( $perl_version )->numify;
            };
            $perl_version =~ tr/_//d
                if defined $perl_version;
        }

        if (!defined $perl_version) {
            # should this be a warning?
            die sprintf <<'END', $self->{MIN_PERL_VERSION};
MakeMaker FATAL: MIN_PERL_VERSION (%s) is not in a recognized format.
Recommended is a quoted numerical value like '5.005' or '5.008001'.
END
        }
        elsif ($perl_version > "$]") {
            my $message = sprintf <<'END', $perl_version, $];
Perl version %s or higher required. We run %s.
END
            if ($self->{PREREQ_FATAL}) {
                die "MakeMaker FATAL: $message";
            }
            else {
                warn "Warning: $message";
            }
        }

        $self->{MIN_PERL_VERSION} = $perl_version;
    }

    my %configure_att;         # record &{$self->{CONFIGURE}} attributes
    my(%initial_att) = %$self; # record initial attributes

    my(%unsatisfied) = ();
    my %prereq2version;
    my $cmr;
    if (_has_cpan_meta_requirements) {
        $cmr = CPAN::Meta::Requirements->new;
        for my $key (qw(PREREQ_PM BUILD_REQUIRES CONFIGURE_REQUIRES TEST_REQUIRES)) {
            $cmr->add_requirements($key2cmr{$key}) if $key2cmr{$key};
        }
        foreach my $prereq ($cmr->required_modules) {
            $prereq2version{$prereq} = $cmr->requirements_for_module($prereq);
        }
    } else {
        for my $key (qw(PREREQ_PM BUILD_REQUIRES CONFIGURE_REQUIRES TEST_REQUIRES)) {
            next unless my $module2version = $self->{$key};
            $prereq2version{$_} = $module2version->{$_} for keys %$module2version;
        }
    }
    foreach my $prereq (sort keys %prereq2version) {
        my $required_version = $prereq2version{$prereq};

        my $pr_version = 0;
        my $installed_file;

        if ( $prereq eq 'perl' ) {
          if ( defined $required_version && $required_version =~ /^v?[\d_\.]+$/
               || $required_version !~ /^v?[\d_\.]+$/ ) {
            require version;
            my $normal = eval { version->new( $required_version ) };
            $required_version = $normal if defined $normal;
          }
          $installed_file = $prereq;
          $pr_version = $];
        }
        else {
          $installed_file = MM->_installed_file_for_module($prereq);
          $pr_version = MM->parse_version($installed_file) if $installed_file;
          $pr_version = 0 if $pr_version eq 'undef';
          if ( !eval { version->new( $pr_version ); 1 } ) {
            #no warnings 'numeric'; # module doesn't use warnings
            my $fallback;
            if ( $pr_version =~ m!^[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?$! ) {
              $fallback = sprintf '%f', $pr_version;
            } else {
              ($fallback) = $pr_version ? ($pr_version =~ /^([0-9.]+)/) : 0;
              $fallback += 0;
              carp "Unparsable version '$pr_version' for installed prerequisite $prereq treated as $fallback";
            }
            $pr_version = $fallback;
          }
        }

        # convert X.Y_Z alpha version #s to X.YZ for easier comparisons
        $pr_version =~ s/(\d+)\.(\d+)_(\d+)/$1.$2$3/;

        if (!$installed_file) {
            warn sprintf "Warning: prerequisite %s %s not found.\n",
              $prereq, $required_version
                   unless $self->{PREREQ_FATAL}
                       or $UNDER_CORE;

            $unsatisfied{$prereq} = 'not installed';
        }
        elsif (
            $cmr
                ? !$cmr->accepts_module($prereq, $pr_version)
                : $required_version > $pr_version
        ) {
            warn sprintf "Warning: prerequisite %s %s not found. We have %s.\n",
              $prereq, $required_version, ($pr_version || 'unknown version')
                  unless $self->{PREREQ_FATAL}
                       or $UNDER_CORE;

            $unsatisfied{$prereq} = $required_version || 'unknown version' ;
        }
    }

    if (%unsatisfied && $self->{PREREQ_FATAL}){
        my $failedprereqs = join "\n", map {"    $_ $unsatisfied{$_}"}
                            sort { $a cmp $b } keys %unsatisfied;
        die <<"END";
MakeMaker FATAL: prerequisites not found.
$failedprereqs

Please install these modules first and rerun 'perl Makefile.PL'.
END
    }

    if (defined $self->{CONFIGURE}) {
        if (ref $self->{CONFIGURE} eq 'CODE') {
            %configure_att = %{&{$self->{CONFIGURE}}};
            _convert_compat_attrs(\%configure_att);
            $self = { %$self, %configure_att };
        } else {
            croak "Attribute 'CONFIGURE' to WriteMakefile() not a code reference\n";
        }
    }

    my $newclass = ++$PACKNAME;
    local @Parent = @Parent;    # Protect against non-local exits
    {
        print "Blessing Object into class [$newclass]\n" if $Verbose>=2;
        mv_all_methods("MY",$newclass);
        bless $self, $newclass;
        push @Parent, $self;
        require ExtUtils::MY;

        no strict 'refs';   ## no critic;
        @{"$newclass\:\:ISA"} = 'MM';
    }

    if (defined $Parent[-2]){
        $self->{PARENT} = $Parent[-2];
        for my $key (@Prepend_parent) {
            next unless defined $self->{PARENT}{$key};

            # Don't stomp on WriteMakefile() args.
            next if defined $self->{ARGS}{$key} and
                    $self->{ARGS}{$key} eq $self->{$key};

            $self->{$key} = $self->{PARENT}{$key};

            if ($Is_VMS && $key =~ /PERL$/) {
                # PERL or FULLPERL will be a command verb or even a
                # command with an argument instead of a full file
                # specification under VMS.  So, don't turn the command
                # into a filespec, but do add a level to the path of
                # the argument if not already absolute.
                my @cmd = split /\s+/, $self->{$key};
                $cmd[1] = $self->catfile('[-]',$cmd[1])
                  unless (@cmd < 2) || $self->file_name_is_absolute($cmd[1]);
                $self->{$key} = join(' ', @cmd);
            } else {
                my $value = $self->{$key};
                # not going to test in FS so only stripping start
                $value =~ s/"// if $key =~ /PERL$/ and $self->is_make_type('dmake');
                $value =~ s/^"// if $key =~ /PERL$/;
                $value = $self->catdir("..", $value)
                  unless $self->file_name_is_absolute($value);
                $value = qq{"$value} if $key =~ /PERL$/;
                $self->{$key} = $value;
            }
        }
        if ($self->{PARENT}) {
            $self->{PARENT}->{CHILDREN}->{$newclass} = $self;
            foreach my $opt (qw(POLLUTE PERL_CORE LINKTYPE AR FULL_AR CC CCFLAGS
                                OPTIMIZE LD LDDLFLAGS LDFLAGS PERL_ARCHLIB DESTDIR)) {
                if (exists $self->{PARENT}->{$opt}
                    and not exists $self->{$opt})
                    {
                        # inherit, but only if already unspecified
                        $self->{$opt} = $self->{PARENT}->{$opt};
                    }
            }
        }
        my @fm = grep /^FIRST_MAKEFILE=/, @ARGV;
        parse_args($self,@fm) if @fm;
    }
    else {
        parse_args($self, _shellwords($ENV{PERL_MM_OPT} || ''),@ARGV);
    }

    # RT#91540 PREREQ_FATAL not recognized on command line
    if (%unsatisfied && $self->{PREREQ_FATAL}){
        my $failedprereqs = join "\n", map {"    $_ $unsatisfied{$_}"}
                            sort { $a cmp $b } keys %unsatisfied;
        die <<"END";
MakeMaker FATAL: prerequisites not found.
$failedprereqs

Please install these modules first and rerun 'perl Makefile.PL'.
END
    }

    $self->{NAME} ||= $self->guess_name;

    warn "Warning: NAME must be a package name\n"
      unless $self->{NAME} =~ m!^[A-Z_a-z][0-9A-Z_a-z]*(?:::[0-9A-Z_a-z]+)*$!;

    ($self->{NAME_SYM} = $self->{NAME}) =~ s/\W+/_/g;

    $self->init_MAKE;
    $self->init_main;
    $self->init_VERSION;
    $self->init_dist;
    $self->init_INST;
    $self->init_INSTALL;
    $self->init_DEST;
    $self->init_dirscan;
    $self->init_PM;
    $self->init_MANPODS;
    $self->init_xs;
    $self->init_PERL;
    $self->init_DIRFILESEP;
    $self->init_linker;
    $self->init_ABSTRACT;

    $self->arch_check(
        $INC{'Config.pm'},
        $self->catfile($Config{'archlibexp'}, "Config.pm")
    );

    $self->init_tools();
    $self->init_others();
    $self->init_platform();
    $self->init_PERM();
    my @args = @ARGV;
    @args = map { Encode::decode(locale => $_) } @args if $CAN_DECODE;
    my($argv) = neatvalue(\@args);
    $argv =~ s/^\[/(/;
    $argv =~ s/\]$/)/;

    push @{$self->{RESULT}}, <<END;
# This Makefile is for the $self->{NAME} extension to perl.
#
# It was generated automatically by MakeMaker version
# $VERSION (Revision: $Revision) from the contents of
# Makefile.PL. Don't edit this file, edit Makefile.PL instead.
#
#       ANY CHANGES MADE HERE WILL BE LOST!
#
#   MakeMaker ARGV: $argv
#
END

    push @{$self->{RESULT}}, $self->_MakeMaker_Parameters_section(\%initial_att);

    if (defined $self->{CONFIGURE}) {
       push @{$self->{RESULT}}, <<END;

#   MakeMaker 'CONFIGURE' Parameters:
END
        if (scalar(keys %configure_att) > 0) {
            foreach my $key (sort keys %configure_att){
               next if $key eq 'ARGS';
               my($v) = neatvalue($configure_att{$key});
               $v =~ s/(CODE|HASH|ARRAY|SCALAR)\([\dxa-f]+\)/$1\(...\)/;
               $v =~ tr/\n/ /s;
               push @{$self->{RESULT}}, "#     $key => $v";
            }
        }
        else
        {
           push @{$self->{RESULT}}, "# no values returned";
        }
        undef %configure_att;  # free memory
    }

    # turn the SKIP array into a SKIPHASH hash
    for my $skip (@{$self->{SKIP} || []}) {
        $self->{SKIPHASH}{$skip} = 1;
    }
    delete $self->{SKIP}; # free memory

    if ($self->{PARENT}) {
        for (qw/install dist dist_basics dist_core distdir dist_test dist_ci/) {
            $self->{SKIPHASH}{$_} = 1;
        }
    }

    # We run all the subdirectories now. They don't have much to query
    # from the parent, but the parent has to query them: if they need linking!
    unless ($self->{NORECURS}) {
        $self->eval_in_subdirs if @{$self->{DIR}};
    }

    foreach my $section ( @MM_Sections ){
        # Support for new foo_target() methods.
        my $method = $section;
        $method .= '_target' unless $self->can($method);

        print "Processing Makefile '$section' section\n" if ($Verbose >= 2);
        my($skipit) = $self->skipcheck($section);
        if ($skipit){
            push @{$self->{RESULT}}, "\n# --- MakeMaker $section section $skipit.";
        } else {
            my(%a) = %{$self->{$section} || {}};
            push @{$self->{RESULT}}, "\n# --- MakeMaker $section section:";
            push @{$self->{RESULT}}, "# " . join ", ", %a if $Verbose && %a;
            push @{$self->{RESULT}}, $self->maketext_filter(
                $self->$method( %a )
            );
        }
    }

    push @{$self->{RESULT}}, "\n# End.";

    $self;
}

sub WriteEmptyMakefile {
    croak "WriteEmptyMakefile: Need an even number of args" if @_ % 2;

    my %att = @_;
    $att{DIR} = [] unless $att{DIR}; # don't recurse by default
    my $self = MM->new(\%att);

    my $new = $self->{MAKEFILE};
    my $old = $self->{MAKEFILE_OLD};
    if (-f $old) {
        _unlink($old) or warn "unlink $old: $!";
    }
    if ( -f $new ) {
        _rename($new, $old) or warn "rename $new => $old: $!"
    }
    open my $mfh, '>', $new or die "open $new for write: $!";
    print $mfh <<'EOP';
all :

manifypods :

subdirs :

dynamic :

static :

clean :

install :

makemakerdflt :

test :

test_dynamic :

test_static :

EOP
    close $mfh or die "close $new for write: $!";
}


=begin private

=head3 _installed_file_for_module

  my $file = MM->_installed_file_for_module($module);

Return the first installed .pm $file associated with the $module.  The
one which will show up when you C<use $module>.

$module is something like "strict" or "Test::More".

=end private

=cut

sub _installed_file_for_module {
    my $class  = shift;
    my $prereq = shift;

    my $file = "$prereq.pm";
    $file =~ s{::}{/}g;

    my $path;
    for my $dir (@INC) {
        my $tmp = File::Spec->catfile($dir, $file);
        if ( -r $tmp ) {
            $path = $tmp;
            last;
        }
    }

    return $path;
}


# Extracted from MakeMaker->new so we can test it
sub _MakeMaker_Parameters_section {
    my $self = shift;
    my $att  = shift;

    my @result = <<'END';
#   MakeMaker Parameters:
END

    foreach my $key (sort keys %$att){
        next if $key eq 'ARGS';
        my $v;
        if ($key eq 'PREREQ_PM') {
            # CPAN.pm takes prereqs from this field in 'Makefile'
            # and does not know about BUILD_REQUIRES
            $v = neatvalue({
                %{ $att->{PREREQ_PM} || {} },
                %{ $att->{BUILD_REQUIRES} || {} },
                %{ $att->{TEST_REQUIRES} || {} },
            });
        } else {
            $v = neatvalue($att->{$key});
        }

        $v =~ s/(CODE|HASH|ARRAY|SCALAR)\([\dxa-f]+\)/$1\(...\)/;
        $v =~ tr/\n/ /s;
        push @result, "#     $key => $v";
    }

    return @result;
}

# _shellwords and _parseline borrowed from Text::ParseWords
sub _shellwords {
    my (@lines) = @_;
    my @allwords;

    foreach my $line (@lines) {
      $line =~ s/^\s+//;
      my @words = _parse_line('\s+', 0, $line);
      pop @words if (@words and !defined $words[-1]);
      return() unless (@words || !length($line));
      push(@allwords, @words);
    }
    return(@allwords);
}

sub _parse_line {
    my($delimiter, $keep, $line) = @_;
    my($word, @pieces);

    no warnings 'uninitialized';  # we will be testing undef strings

    while (length($line)) {
        # This pattern is optimised to be stack conservative on older perls.
        # Do not refactor without being careful and testing it on very long strings.
        # See Perl bug #42980 for an example of a stack busting input.
        $line =~ s/^
                    (?:
                        # double quoted string
                        (")                             # $quote
                        ((?>[^\\"]*(?:\\.[^\\"]*)*))"   # $quoted
        | # --OR--
                        # singe quoted string
                        (')                             # $quote
                        ((?>[^\\']*(?:\\.[^\\']*)*))'   # $quoted
                    |   # --OR--
                        # unquoted string
            (                               # $unquoted
                            (?:\\.|[^\\"'])*?
                        )
                        # followed by
            (                               # $delim
                            \Z(?!\n)                    # EOL
                        |   # --OR--
                            (?-x:$delimiter)            # delimiter
                        |   # --OR--
                            (?!^)(?=["'])               # a quote
                        )
        )//xs or return;    # extended layout
        my ($quote, $quoted, $unquoted, $delim) = (($1 ? ($1,$2) : ($3,$4)), $5, $6);


  return() unless( defined($quote) || length($unquoted) || length($delim));

        if ($keep) {
      $quoted = "$quote$quoted$quote";
  }
        else {
      $unquoted =~ s/\\(.)/$1/sg;
      if (defined $quote) {
    $quoted =~ s/\\(.)/$1/sg if ($quote eq '"');
    #$quoted =~ s/\\([\\'])/$1/g if ( $PERL_SINGLE_QUOTE && $quote eq "'");
            }
  }
        $word .= substr($line, 0, 0); # leave results tainted
        $word .= defined $quote ? $quoted : $unquoted;

        if (length($delim)) {
            push(@pieces, $word);
            push(@pieces, $delim) if ($keep eq 'delimiters');
            undef $word;
        }
        if (!length($line)) {
            push(@pieces, $word);
  }
    }
    return(@pieces);
}

sub check_manifest {
    print "Checking if your kit is complete...\n";
    require ExtUtils::Manifest;
    # avoid warning
    $ExtUtils::Manifest::Quiet = $ExtUtils::Manifest::Quiet = 1;
    my(@missed) = ExtUtils::Manifest::manicheck();
    if (@missed) {
        print "Warning: the following files are missing in your kit:\n";
        print "\t", join "\n\t", @missed;
        print "\n";
        print "Please inform the author.\n";
    } else {
        print "Looks good\n";
    }
}

sub parse_args{
    my($self, @args) = @_;
    @args = map { Encode::decode(locale => $_) } @args if $CAN_DECODE;
    foreach (@args) {
        unless (m/(.*?)=(.*)/) {
            ++$Verbose if m/^verb/;
            next;
        }
        my($name, $value) = ($1, $2);
        if ($value =~ m/^~(\w+)?/) { # tilde with optional username
            $value =~ s [^~(\w*)]
                [$1 ?
                 ((getpwnam($1))[7] || "~$1") :
                 (getpwuid($>))[7]
                 ]ex;
        }

        # Remember the original args passed it.  It will be useful later.
        $self->{ARGS}{uc $name} = $self->{uc $name} = $value;
    }

    # catch old-style 'potential_libs' and inform user how to 'upgrade'
    if (defined $self->{potential_libs}){
        my($msg)="'potential_libs' => '$self->{potential_libs}' should be";
        if ($self->{potential_libs}){
            print "$msg changed to:\n\t'LIBS' => ['$self->{potential_libs}']\n";
        } else {
            print "$msg deleted.\n";
        }
        $self->{LIBS} = [$self->{potential_libs}];
        delete $self->{potential_libs};
    }
    # catch old-style 'ARMAYBE' and inform user how to 'upgrade'
    if (defined $self->{ARMAYBE}){
        my($armaybe) = $self->{ARMAYBE};
        print "ARMAYBE => '$armaybe' should be changed to:\n",
                        "\t'dynamic_lib' => {ARMAYBE => '$armaybe'}\n";
        my(%dl) = %{$self->{dynamic_lib} || {}};
        $self->{dynamic_lib} = { %dl, ARMAYBE => $armaybe};
        delete $self->{ARMAYBE};
    }
    if (defined $self->{LDTARGET}){
        print "LDTARGET should be changed to LDFROM\n";
        $self->{LDFROM} = $self->{LDTARGET};
        delete $self->{LDTARGET};
    }
    # Turn a DIR argument on the command line into an array
    if (defined $self->{DIR} && ref \$self->{DIR} eq 'SCALAR') {
        # So they can choose from the command line, which extensions they want
        # the grep enables them to have some colons too much in case they
        # have to build a list with the shell
        $self->{DIR} = [grep $_, split ":", $self->{DIR}];
    }
    # Turn a INCLUDE_EXT argument on the command line into an array
    if (defined $self->{INCLUDE_EXT} && ref \$self->{INCLUDE_EXT} eq 'SCALAR') {
        $self->{INCLUDE_EXT} = [grep $_, split '\s+', $self->{INCLUDE_EXT}];
    }
    # Turn a EXCLUDE_EXT argument on the command line into an array
    if (defined $self->{EXCLUDE_EXT} && ref \$self->{EXCLUDE_EXT} eq 'SCALAR') {
        $self->{EXCLUDE_EXT} = [grep $_, split '\s+', $self->{EXCLUDE_EXT}];
    }

    foreach my $mmkey (sort keys %$self){
        next if $mmkey eq 'ARGS';
        print "  $mmkey => ", neatvalue($self->{$mmkey}), "\n" if $Verbose;
        print "'$mmkey' is not a known MakeMaker parameter name.\n"
            unless exists $Recognized_Att_Keys{$mmkey};
    }
    $| = 1 if $Verbose;
}

sub check_hints {
    my($self) = @_;
    # We allow extension-specific hints files.

    require File::Spec;
    my $curdir = File::Spec->curdir;

    my $hint_dir = File::Spec->catdir($curdir, "hints");
    return unless -d $hint_dir;

    # First we look for the best hintsfile we have
    my($hint)="${^O}_$Config{osvers}";
    $hint =~ s/\./_/g;
    $hint =~ s/_$//;
    return unless $hint;

    # Also try without trailing minor version numbers.
    while (1) {
        last if -f File::Spec->catfile($hint_dir, "$hint.pl");  # found
    } continue {
        last unless $hint =~ s/_[^_]*$//; # nothing to cut off
    }
    my $hint_file = File::Spec->catfile($hint_dir, "$hint.pl");

    return unless -f $hint_file;    # really there

    _run_hintfile($self, $hint_file);
}

sub _run_hintfile {
    my ($self, $hint_file) = @_;

    local($@, $!);
    print "Processing hints file $hint_file\n" if $Verbose;

    if(open(my $fh, '<', $hint_file)) {
        my $hints_content = do { local $/; <$fh> };
        no strict;
        eval $hints_content;
        warn "Failed to run hint file $hint_file: $@" if $@;
    }
    else {
        warn "Could not open $hint_file for read: $!";
    }
}

sub mv_all_methods {
    my($from,$to) = @_;
    local $SIG{__WARN__} = sub {
        # can't use 'no warnings redefined', 5.6 only
        warn @_ unless $_[0] =~ /^Subroutine .* redefined/
    };
    foreach my $method (@Overridable) {
        next unless defined &{"${from}::$method"};
        no strict 'refs';   ## no critic
        *{"${to}::$method"} = \&{"${from}::$method"};

        # If we delete a method, then it will be undefined and cannot
        # be called.  But as long as we have Makefile.PLs that rely on
        # %MY:: being intact, we have to fill the hole with an
        # inheriting method:

        {
            package MY;
            my $super = "SUPER::".$method;
            *{$method} = sub {
                shift->$super(@_);
            };
        }
    }
}

sub skipcheck {
    my($self) = shift;
    my($section) = @_;
    return 'skipped' if $section eq 'metafile' && $UNDER_CORE;
    if ($section eq 'dynamic') {
        print "Warning (non-fatal): Target 'dynamic' depends on targets ",
        "in skipped section 'dynamic_bs'\n"
            if $self->{SKIPHASH}{dynamic_bs} && $Verbose;
        print "Warning (non-fatal): Target 'dynamic' depends on targets ",
        "in skipped section 'dynamic_lib'\n"
            if $self->{SKIPHASH}{dynamic_lib} && $Verbose;
    }
    if ($section eq 'dynamic_lib') {
        print "Warning (non-fatal): Target '\$(INST_DYNAMIC)' depends on ",
        "targets in skipped section 'dynamic_bs'\n"
            if $self->{SKIPHASH}{dynamic_bs} && $Verbose;
    }
    if ($section eq 'static') {
        print "Warning (non-fatal): Target 'static' depends on targets ",
        "in skipped section 'static_lib'\n"
            if $self->{SKIPHASH}{static_lib} && $Verbose;
    }
    return 'skipped' if $self->{SKIPHASH}{$section};
    return '';
}

# returns filehandle, dies on fail. :raw so no :crlf
sub open_for_writing {
    my ($file) = @_;
    open my $fh ,">", $file or die "Unable to open $file: $!";
    my @layers = ':raw';
    push @layers, join ' ', ':encoding(locale)' if $CAN_DECODE;
    binmode $fh, join ' ', @layers;
    $fh;
}

sub flush {
    my $self = shift;

    my $finalname = $self->{MAKEFILE};
    printf "Generating a %s %s\n", $self->make_type, $finalname if $Verbose || !$self->{PARENT};
    print "Writing $finalname for $self->{NAME}\n" if $Verbose || !$self->{PARENT};

    unlink($finalname, "MakeMaker.tmp", $Is_VMS ? 'Descrip.MMS' : ());

    write_file_via_tmp($finalname, $self->{RESULT});

    # Write MYMETA.yml to communicate metadata up to the CPAN clients
    print "Writing MYMETA.yml and MYMETA.json\n"
      if !$self->{NO_MYMETA} and $self->write_mymeta( $self->mymeta );

    # save memory
    if ($self->{PARENT} && !$self->{_KEEP_AFTER_FLUSH}) {
        my %keep = map { ($_ => 1) } qw(NEEDS_LINKING HAS_LINK_CODE);
        delete $self->{$_} for grep !$keep{$_}, keys %$self;
    }

    system("$Config::Config{eunicefix} $finalname")
      if $Config::Config{eunicefix} ne ":";

    return;
}

sub write_file_via_tmp {
    my ($finalname, $contents) = @_;
    my $fh = open_for_writing("MakeMaker.tmp");
    die "write_file_via_tmp: 2nd arg must be ref" unless ref $contents;
    for my $chunk (@$contents) {
        my $to_write = $chunk;
        utf8::encode $to_write if !$CAN_DECODE && "$]" > 5.008;
        print $fh "$to_write\n" or die "Can't write to MakeMaker.tmp: $!";
    }
    close $fh or die "Can't write to MakeMaker.tmp: $!";
    _rename("MakeMaker.tmp", $finalname) or
      warn "rename MakeMaker.tmp => $finalname: $!";
    chmod 0644, $finalname if !$Is_VMS;
    return;
}

# This is a rename for OS's where the target must be unlinked first.
sub _rename {
    my($src, $dest) = @_;
    _unlink($dest);
    return rename $src, $dest;
}

# This is an unlink for OS's where the target must be writable first.
sub _unlink {
    my @files = @_;
    chmod 0666, @files;
    return unlink @files;
}


# The following mkbootstrap() is only for installations that are calling
# the pre-4.1 mkbootstrap() from their old Makefiles. This MakeMaker
# writes Makefiles, that use ExtUtils::Mkbootstrap directly.
sub mkbootstrap {
    die <<END;
!!! Your Makefile has been built such a long time ago, !!!
!!! that is unlikely to work with current MakeMaker.   !!!
!!! Please rebuild your Makefile                       !!!
END
}

# Ditto for mksymlists() as of MakeMaker 5.17
sub mksymlists {
    die <<END;
!!! Your Makefile has been built such a long time ago, !!!
!!! that is unlikely to work with current MakeMaker.   !!!
!!! Please rebuild your Makefile                       !!!
END
}

sub neatvalue {
    my($v) = @_;
    return "undef" unless defined $v;
    my($t) = ref $v;
    return "q[$v]" unless $t;
    if ($t eq 'ARRAY') {
        my(@m, @neat);
        push @m, "[";
        foreach my $elem (@$v) {
            push @neat, "q[$elem]";
        }
        push @m, join ", ", @neat;
        push @m, "]";
        return join "", @m;
    }
    return $v unless $t eq 'HASH';
    my(@m, $key, $val);
    for my $key (sort keys %$v) {
        last unless defined $key; # cautious programming in case (undef,undef) is true
        push @m,"$key=>".neatvalue($v->{$key});
    }
    return "{ ".join(', ',@m)." }";
}

sub _find_magic_vstring {
    my $value = shift;
    return $value if $UNDER_CORE;
    my $tvalue = '';
    require B;
    my $sv = B::svref_2object(\$value);
    my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef;
    while ( $magic ) {
        if ( $magic->TYPE eq 'V' ) {
            $tvalue = $magic->PTR;
            $tvalue =~ s/^v?(.+)$/v$1/;
            last;
        }
        else {
            $magic = $magic->MOREMAGIC;
        }
    }
    return $tvalue;
}

sub selfdocument {
    my($self) = @_;
    my(@m);
    if ($Verbose){
        push @m, "\n# Full list of MakeMaker attribute values:";
        foreach my $key (sort keys %$self){
            next if $key eq 'RESULT' || $key =~ /^[A-Z][a-z]/;
            my($v) = neatvalue($self->{$key});
            $v =~ s/(CODE|HASH|ARRAY|SCALAR)\([\dxa-f]+\)/$1\(...\)/;
            $v =~ tr/\n/ /s;
            push @m, "# $key => $v";
        }
    }
    # added here as selfdocument is not overridable
    push @m, <<'EOF';

# here so even if top_targets is overridden, these will still be defined
# gmake will silently still work if any are .PHONY-ed but nmake won't
EOF
    push @m, join "\n", map "$_ ::\n\t\$(NOECHO) \$(NOOP)\n",
        # config is so manifypods won't puke if no subdirs
        grep !$self->{SKIPHASH}{$_},
        qw(static dynamic config);
    join "\n", @m;
}

1;

__END__

=head1 NAME

ExtUtils::MakeMaker - Create a module Makefile

=head1 SYNOPSIS

  use ExtUtils::MakeMaker;

  WriteMakefile(
      NAME              => "Foo::Bar",
      VERSION_FROM      => "lib/Foo/Bar.pm",
  );

=head1 DESCRIPTION

This utility is designed to write a Makefile for an extension module
from a Makefile.PL. It is based on the Makefile.SH model provided by
Andy Dougherty and the perl5-porters.

It splits the task of generating the Makefile into several subroutines
that can be individually overridden.  Each subroutine returns the text
it wishes to have written to the Makefile.

As there are various Make programs with incompatible syntax, which
use operating system shells, again with incompatible syntax, it is
important for users of this module to know which flavour of Make
a Makefile has been written for so they'll use the correct one and
won't have to face the possibly bewildering errors resulting from
using the wrong one.

On POSIX systems, that program will likely be GNU Make; on Microsoft
Windows, it will be either Microsoft NMake, DMake or GNU Make.
See the section on the L</"MAKE"> parameter for details.

ExtUtils::MakeMaker (EUMM) is object oriented. Each directory below the current
directory that contains a Makefile.PL is treated as a separate
object. This makes it possible to write an unlimited number of
Makefiles with a single invocation of WriteMakefile().

All inputs to WriteMakefile are Unicode characters, not just octets. EUMM
seeks to handle all of these correctly. It is currently still not possible
to portably use Unicode characters in module names, because this requires
Perl to handle Unicode filenames, which is not yet the case on Windows.

See L<ExtUtils::MakeMaker::FAQ> for details of the design and usage.

=head2 How To Write A Makefile.PL

See L<ExtUtils::MakeMaker::Tutorial>.

The long answer is the rest of the manpage :-)

=head2 Default Makefile Behaviour

The generated Makefile enables the user of the extension to invoke

  perl Makefile.PL # optionally "perl Makefile.PL verbose"
  make
  make test        # optionally set TEST_VERBOSE=1
  make install     # See below

The Makefile to be produced may be altered by adding arguments of the
form C<KEY=VALUE>. E.g.

  perl Makefile.PL INSTALL_BASE=~

Other interesting targets in the generated Makefile are

  make config     # to check if the Makefile is up-to-date
  make clean      # delete local temp files (Makefile gets renamed)
  make realclean  # delete derived files (including ./blib)
  make ci         # check in all the files in the MANIFEST file
  make dist       # see below the Distribution Support section

=head2 make test

MakeMaker checks for the existence of a file named F<test.pl> in the
current directory, and if it exists it executes the script with the
proper set of perl C<-I> options.

MakeMaker also checks for any files matching glob("t/*.t"). It will
execute all matching files in alphabetical order via the
L<Test::Harness> module with the C<-I> switches set correctly.

You can also organize your tests within subdirectories in the F<t/> directory.
To do so, use the F<test> directive in your I<Makefile.PL>. For example, if you
had tests in:

    t/foo
    t/foo/bar

You could tell make to run tests in both of those directories with the
following directives:

    test => {TESTS => 't/*/*.t t/*/*/*.t'}
    test => {TESTS => 't/foo/*.t t/foo/bar/*.t'}

The first will run all test files in all first-level subdirectories and all
subdirectories they contain. The second will run tests in only the F<t/foo>
and F<t/foo/bar>.

If you'd like to see the raw output of your tests, set the
C<TEST_VERBOSE> variable to true.

  make test TEST_VERBOSE=1

If you want to run particular test files, set the C<TEST_FILES> variable.
It is possible to use globbing with this mechanism.

  make test TEST_FILES='t/foobar.t t/dagobah*.t'

Windows users who are using C<nmake> should note that due to a bug in C<nmake>,
when specifying C<TEST_FILES> you must use back-slashes instead of forward-slashes.

  nmake test TEST_FILES='t\foobar.t t\dagobah*.t'

=head2 make testdb

A useful variation of the above is the target C<testdb>. It runs the
test under the Perl debugger (see L<perldebug>). If the file
F<test.pl> exists in the current directory, it is used for the test.

If you want to debug some other testfile, set the C<TEST_FILE> variable
thusly:

  make testdb TEST_FILE=t/mytest.t

By default the debugger is called using C<-d> option to perl. If you
want to specify some other option, set the C<TESTDB_SW> variable:

  make testdb TESTDB_SW=-Dx

=head2 make install

make alone puts all relevant files into directories that are named by
the macros INST_LIB, INST_ARCHLIB, INST_SCRIPT, INST_MAN1DIR and
INST_MAN3DIR.  All these default to something below ./blib if you are
I<not> building below the perl source directory. If you I<are>
building below the perl source, INST_LIB and INST_ARCHLIB default to
../../lib, and INST_SCRIPT is not defined.

The I<install> target of the generated Makefile copies the files found
below each of the INST_* directories to their INSTALL*
counterparts. Which counterparts are chosen depends on the setting of
INSTALLDIRS according to the following table:

                                 INSTALLDIRS set to
                           perl        site          vendor

                 PERLPREFIX      SITEPREFIX          VENDORPREFIX
  INST_ARCHLIB   INSTALLARCHLIB  INSTALLSITEARCH     INSTALLVENDORARCH
  INST_LIB       INSTALLPRIVLIB  INSTALLSITELIB      INSTALLVENDORLIB
  INST_BIN       INSTALLBIN      INSTALLSITEBIN      INSTALLVENDORBIN
  INST_SCRIPT    INSTALLSCRIPT   INSTALLSITESCRIPT   INSTALLVENDORSCRIPT
  INST_MAN1DIR   INSTALLMAN1DIR  INSTALLSITEMAN1DIR  INSTALLVENDORMAN1DIR
  INST_MAN3DIR   INSTALLMAN3DIR  INSTALLSITEMAN3DIR  INSTALLVENDORMAN3DIR

The INSTALL... macros in turn default to their %Config
($Config{installprivlib}, $Config{installarchlib}, etc.) counterparts.

You can check the values of these variables on your system with

    perl '-V:install.*'

And to check the sequence in which the library directories are
searched by perl, run

    perl -le 'print join $/, @INC'

Sometimes older versions of the module you're installing live in other
directories in @INC.  Because Perl loads the first version of a module it
finds, not the newest, you might accidentally get one of these older
versions even after installing a brand new version.  To delete I<all other
versions of the module you're installing> (not simply older ones) set the
C<UNINST> variable.

    make install UNINST=1


=head2 INSTALL_BASE

INSTALL_BASE can be passed into Makefile.PL to change where your
module will be installed.  INSTALL_BASE is more like what everyone
else calls "prefix" than PREFIX is.

To have everything installed in your home directory, do the following.

    # Unix users, INSTALL_BASE=~ works fine
    perl Makefile.PL INSTALL_BASE=/path/to/your/home/dir

Like PREFIX, it sets several INSTALL* attributes at once.  Unlike
PREFIX it is easy to predict where the module will end up.  The
installation pattern looks like this:

    INSTALLARCHLIB     INSTALL_BASE/lib/perl5/$Config{archname}
    INSTALLPRIVLIB     INSTALL_BASE/lib/perl5
    INSTALLBIN         INSTALL_BASE/bin
    INSTALLSCRIPT      INSTALL_BASE/bin
    INSTALLMAN1DIR     INSTALL_BASE/man/man1
    INSTALLMAN3DIR     INSTALL_BASE/man/man3

INSTALL_BASE in MakeMaker and C<--install_base> in Module::Build (as
of 0.28) install to the same location.  If you want MakeMaker and
Module::Build to install to the same location simply set INSTALL_BASE
and C<--install_base> to the same location.

INSTALL_BASE was added in 6.31.


=head2 PREFIX and LIB attribute

PREFIX and LIB can be used to set several INSTALL* attributes in one
go.  Here's an example for installing into your home directory.

    # Unix users, PREFIX=~ works fine
    perl Makefile.PL PREFIX=/path/to/your/home/dir

This will install all files in the module under your home directory,
with man pages and libraries going into an appropriate place (usually
~/man and ~/lib).  How the exact location is determined is complicated
and depends on how your Perl was configured.  INSTALL_BASE works more
like what other build systems call "prefix" than PREFIX and we
recommend you use that instead.

Another way to specify many INSTALL directories with a single
parameter is LIB.

    perl Makefile.PL LIB=~/lib

This will install the module's architecture-independent files into
~/lib, the architecture-dependent files into ~/lib/$archname.

Note, that in both cases the tilde expansion is done by MakeMaker, not
by perl by default, nor by make.

Conflicts between parameters LIB, PREFIX and the various INSTALL*
arguments are resolved so that:

=over 4

=item *

setting LIB overrides any setting of INSTALLPRIVLIB, INSTALLARCHLIB,
INSTALLSITELIB, INSTALLSITEARCH (and they are not affected by PREFIX);

=item *

without LIB, setting PREFIX replaces the initial C<$Config{prefix}>
part of those INSTALL* arguments, even if the latter are explicitly
set (but are set to still start with C<$Config{prefix}>).

=back

If the user has superuser privileges, and is not working on AFS or
relatives, then the defaults for INSTALLPRIVLIB, INSTALLARCHLIB,
INSTALLSCRIPT, etc. will be appropriate, and this incantation will be
the best:

    perl Makefile.PL;
    make;
    make test
    make install

make install by default writes some documentation of what has been
done into the file C<$(INSTALLARCHLIB)/perllocal.pod>. This feature
can be bypassed by calling make pure_install.

=head2 AFS users

will have to specify the installation directories as these most
probably have changed since perl itself has been installed. They will
have to do this by calling

    perl Makefile.PL INSTALLSITELIB=/afs/here/today \
        INSTALLSCRIPT=/afs/there/now INSTALLMAN3DIR=/afs/for/manpages
    make

Be careful to repeat this procedure every time you recompile an
extension, unless you are sure the AFS installation directories are
still valid.

=head2 Static Linking of a new Perl Binary

An extension that is built with the above steps is ready to use on
systems supporting dynamic loading. On systems that do not support
dynamic loading, any newly created extension has to be linked together
with the available resources. MakeMaker supports the linking process
by creating appropriate targets in the Makefile whenever an extension
is built. You can invoke the corresponding section of the makefile with

    make perl

That produces a new perl binary in the current directory with all
extensions linked in that can be found in INST_ARCHLIB, SITELIBEXP,
and PERL_ARCHLIB. To do that, MakeMaker writes a new Makefile, on
UNIX, this is called F<Makefile.aperl> (may be system dependent). If you
want to force the creation of a new perl, it is recommended that you
delete this F<Makefile.aperl>, so the directories are searched through
for linkable libraries again.

The binary can be installed into the directory where perl normally
resides on your machine with

    make inst_perl

To produce a perl binary with a different name than C<perl>, either say

    perl Makefile.PL MAP_TARGET=myperl
    make myperl
    make inst_perl

or say

    perl Makefile.PL
    make myperl MAP_TARGET=myperl
    make inst_perl MAP_TARGET=myperl

In any case you will be prompted with the correct invocation of the
C<inst_perl> target that installs the new binary into INSTALLBIN.

make inst_perl by default writes some documentation of what has been
done into the file C<$(INSTALLARCHLIB)/perllocal.pod>. This
can be bypassed by calling make pure_inst_perl.

Warning: the inst_perl: target will most probably overwrite your
existing perl binary. Use with care!

Sometimes you might want to build a statically linked perl although
your system supports dynamic loading. In this case you may explicitly
set the linktype with the invocation of the Makefile.PL or make:

    perl Makefile.PL LINKTYPE=static    # recommended

or

    make LINKTYPE=static                # works on most systems

=head2 Determination of Perl Library and Installation Locations

MakeMaker needs to know, or to guess, where certain things are
located.  Especially INST_LIB and INST_ARCHLIB (where to put the files
during the make(1) run), PERL_LIB and PERL_ARCHLIB (where to read
existing modules from), and PERL_INC (header files and C<libperl*.*>).

Extensions may be built either using the contents of the perl source
directory tree or from the installed perl library. The recommended way
is to build extensions after you have run 'make install' on perl
itself. You can do that in any directory on your hard disk that is not
below the perl source tree. The support for extensions below the ext
directory of the perl distribution is only good for the standard
extensions that come with perl.

If an extension is being built below the C<ext/> directory of the perl
source then MakeMaker will set PERL_SRC automatically (e.g.,
C<../..>).  If PERL_SRC is defined and the extension is recognized as
a standard extension, then other variables default to the following:

  PERL_INC     = PERL_SRC
  PERL_LIB     = PERL_SRC/lib
  PERL_ARCHLIB = PERL_SRC/lib
  INST_LIB     = PERL_LIB
  INST_ARCHLIB = PERL_ARCHLIB

If an extension is being built away from the perl source then MakeMaker
will leave PERL_SRC undefined and default to using the installed copy
of the perl library. The other variables default to the following:

  PERL_INC     = $archlibexp/CORE
  PERL_LIB     = $privlibexp
  PERL_ARCHLIB = $archlibexp
  INST_LIB     = ./blib/lib
  INST_ARCHLIB = ./blib/arch

If perl has not yet been installed then PERL_SRC can be defined on the
command line as shown in the previous section.


=head2 Which architecture dependent directory?

If you don't want to keep the defaults for the INSTALL* macros,
MakeMaker helps you to minimize the typing needed: the usual
relationship between INSTALLPRIVLIB and INSTALLARCHLIB is determined
by Configure at perl compilation time. MakeMaker supports the user who
sets INSTALLPRIVLIB. If INSTALLPRIVLIB is set, but INSTALLARCHLIB not,
then MakeMaker defaults the latter to be the same subdirectory of
INSTALLPRIVLIB as Configure decided for the counterparts in %Config,
otherwise it defaults to INSTALLPRIVLIB. The same relationship holds
for INSTALLSITELIB and INSTALLSITEARCH.

MakeMaker gives you much more freedom than needed to configure
internal variables and get different results. It is worth mentioning
that make(1) also lets you configure most of the variables that are
used in the Makefile. But in the majority of situations this will not
be necessary, and should only be done if the author of a package
recommends it (or you know what you're doing).

=head2 Using Attributes and Parameters

The following attributes may be specified as arguments to WriteMakefile()
or as NAME=VALUE pairs on the command line. Attributes that became
available with later versions of MakeMaker are indicated.

In order to maintain portability of attributes with older versions of
MakeMaker you may want to use L<App::EUMM::Upgrade> with your C<Makefile.PL>.

=over 2

=item ABSTRACT

One line description of the module. Will be included in PPD file.

=item ABSTRACT_FROM

Name of the file that contains the package description. MakeMaker looks
for a line in the POD matching /^($package\s-\s)(.*)/. This is typically
the first line in the "=head1 NAME" section. $2 becomes the abstract.

=item AUTHOR

Array of strings containing name (and email address) of package author(s).
Is used in CPAN Meta files (META.yml or META.json) and PPD
(Perl Package Description) files for PPM (Perl Package Manager).

=item BINARY_LOCATION

Used when creating PPD files for binary packages.  It can be set to a
full or relative path or URL to the binary archive for a particular
architecture.  For example:

        perl Makefile.PL BINARY_LOCATION=x86/Agent.tar.gz

builds a PPD package that references a binary of the C<Agent> package,
located in the C<x86> directory relative to the PPD itself.

=item BUILD_REQUIRES

Available in version 6.55_03 and above.

A hash of modules that are needed to build your module but not run it.

This will go into the C<build_requires> field of your F<META.yml> and the C<build> of the C<prereqs> field of your F<META.json>.

Defaults to C<<< { "ExtUtils::MakeMaker" => 0 } >>> if this attribute is not specified.

The format is the same as PREREQ_PM.

=item C

Ref to array of *.c file names. Initialised from a directory scan
and the values portion of the XS attribute hash. This is not
currently used by MakeMaker but may be handy in Makefile.PLs.

=item CCFLAGS

String that will be included in the compiler call command line between
the arguments INC and OPTIMIZE.

=item CONFIG

Arrayref. E.g. [qw(archname manext)] defines ARCHNAME & MANEXT from
config.sh. MakeMaker will add to CONFIG the following values anyway:
ar
cc
cccdlflags
ccdlflags
dlext
dlsrc
ld
lddlflags
ldflags
libc
lib_ext
obj_ext
ranlib
sitelibexp
sitearchexp
so

=item CONFIGURE

CODE reference. The subroutine should return a hash reference. The
hash may contain further attributes, e.g. {LIBS =E<gt> ...}, that have to
be determined by some evaluation method.

=item CONFIGURE_REQUIRES

Available in version 6.52 and above.

A hash of modules that are required to run Makefile.PL itself, but not
to run your distribution.

This will go into the C<configure_requires> field of your F<META.yml> and the C<configure> of the C<prereqs> field of your F<META.json>.

Defaults to C<<< { "ExtUtils::MakeMaker" => 0 } >>> if this attribute is not specified.

The format is the same as PREREQ_PM.

=item DEFINE

Something like C<"-DHAVE_UNISTD_H">

=item DESTDIR

This is the root directory into which the code will be installed.  It
I<prepends itself to the normal prefix>.  For example, if your code
would normally go into F</usr/local/lib/perl> you could set DESTDIR=~/tmp/
and installation would go into F<~/tmp/usr/local/lib/perl>.

This is primarily of use for people who repackage Perl modules.

NOTE: Due to the nature of make, it is important that you put the trailing
slash on your DESTDIR.  F<~/tmp/> not F<~/tmp>.

=item DIR

Ref to array of subdirectories containing Makefile.PLs e.g. ['sdbm']
in ext/SDBM_File

=item DISTNAME

A safe filename for the package.

Defaults to NAME below but with :: replaced with -.

For example, Foo::Bar becomes Foo-Bar.

=item DISTVNAME

Your name for distributing the package with the version number
included.  This is used by 'make dist' to name the resulting archive
file.

Defaults to DISTNAME-VERSION.

For example, version 1.04 of Foo::Bar becomes Foo-Bar-1.04.

On some OS's where . has special meaning VERSION_SYM may be used in
place of VERSION.

=item DLEXT

Specifies the extension of the module's loadable object. For example:

  DLEXT => 'unusual_ext', # Default value is $Config{so}

NOTE: When using this option to alter the extension of a module's
loadable object, it is also necessary that the module's pm file
specifies the same change:

  local $DynaLoader::dl_dlext = 'unusual_ext';

=item DL_FUNCS

Hashref of symbol names for routines to be made available as universal
symbols.  Each key/value pair consists of the package name and an
array of routine names in that package.  Used only under AIX, OS/2,
VMS and Win32 at present.  The routine names supplied will be expanded
in the same way as XSUB names are expanded by the XS() macro.
Defaults to

  {"$(NAME)" => ["boot_$(NAME)" ] }

e.g.

  {"RPC" => [qw( boot_rpcb rpcb_gettime getnetconfigent )],
   "NetconfigPtr" => [ 'DESTROY'] }

Please see the L<ExtUtils::Mksymlists> documentation for more information
about the DL_FUNCS, DL_VARS and FUNCLIST attributes.

=item DL_VARS

Array of symbol names for variables to be made available as universal symbols.
Used only under AIX, OS/2, VMS and Win32 at present.  Defaults to [].
(e.g. [ qw(Foo_version Foo_numstreams Foo_tree ) ])

=item EXCLUDE_EXT

Array of extension names to exclude when doing a static build.  This
is ignored if INCLUDE_EXT is present.  Consult INCLUDE_EXT for more
details.  (e.g.  [ qw( Socket POSIX ) ] )

This attribute may be most useful when specified as a string on the
command line:  perl Makefile.PL EXCLUDE_EXT='Socket Safe'

=item EXE_FILES

Ref to array of executable files. The files will be copied to the
INST_SCRIPT directory. Make realclean will delete them from there
again.

If your executables start with something like #!perl or
#!/usr/bin/perl MakeMaker will change this to the path of the perl
'Makefile.PL' was invoked with so the programs will be sure to run
properly even if perl is not in /usr/bin/perl.

=item FIRST_MAKEFILE

The name of the Makefile to be produced.  This is used for the second
Makefile that will be produced for the MAP_TARGET.

Defaults to 'Makefile' or 'Descrip.MMS' on VMS.

(Note: we couldn't use MAKEFILE because dmake uses this for something
else).

=item FULLPERL

Perl binary able to run this extension, load XS modules, etc...

=item FULLPERLRUN

Like PERLRUN, except it uses FULLPERL.

=item FULLPERLRUNINST

Like PERLRUNINST, except it uses FULLPERL.

=item FUNCLIST

This provides an alternate means to specify function names to be
exported from the extension.  Its value is a reference to an
array of function names to be exported by the extension.  These
names are passed through unaltered to the linker options file.

=item H

Ref to array of *.h file names. Similar to C.

=item IMPORTS

This attribute is used to specify names to be imported into the
extension. Takes a hash ref.

It is only used on OS/2 and Win32.

=item INC

Include file dirs eg: C<"-I/usr/5include -I/path/to/inc">

=item INCLUDE_EXT

Array of extension names to be included when doing a static build.
MakeMaker will normally build with all of the installed extensions when
doing a static build, and that is usually the desired behavior.  If
INCLUDE_EXT is present then MakeMaker will build only with those extensions
which are explicitly mentioned. (e.g.  [ qw( Socket POSIX ) ])

It is not necessary to mention DynaLoader or the current extension when
filling in INCLUDE_EXT.  If the INCLUDE_EXT is mentioned but is empty then
only DynaLoader and the current extension will be included in the build.

This attribute may be most useful when specified as a string on the
command line:  perl Makefile.PL INCLUDE_EXT='POSIX Socket Devel::Peek'

=item INSTALLARCHLIB

Used by 'make install', which copies files from INST_ARCHLIB to this
directory if INSTALLDIRS is set to perl.

=item INSTALLBIN

Directory to install binary files (e.g. tkperl) into if
INSTALLDIRS=perl.

=item INSTALLDIRS

Determines which of the sets of installation directories to choose:
perl, site or vendor.  Defaults to site.

=item INSTALLMAN1DIR

=item INSTALLMAN3DIR

These directories get the man pages at 'make install' time if
INSTALLDIRS=perl.  Defaults to $Config{installman*dir}.

If set to 'none', no man pages will be installed.

=item INSTALLPRIVLIB

Used by 'make install', which copies files from INST_LIB to this
directory if INSTALLDIRS is set to perl.

Defaults to $Config{installprivlib}.

=item INSTALLSCRIPT

Available in version 6.30_02 and above.

Used by 'make install' which copies files from INST_SCRIPT to this
directory if INSTALLDIRS=perl.

=item INSTALLSITEARCH

Used by 'make install', which copies files from INST_ARCHLIB to this
directory if INSTALLDIRS is set to site (default).

=item INSTALLSITEBIN

Used by 'make install', which copies files from INST_BIN to this
directory if INSTALLDIRS is set to site (default).

=item INSTALLSITELIB

Used by 'make install', which copies files from INST_LIB to this
directory if INSTALLDIRS is set to site (default).

=item INSTALLSITEMAN1DIR

=item INSTALLSITEMAN3DIR

These directories get the man pages at 'make install' time if
INSTALLDIRS=site (default).  Defaults to
$(SITEPREFIX)/man/man$(MAN*EXT).

If set to 'none', no man pages will be installed.

=item INSTALLSITESCRIPT

Used by 'make install' which copies files from INST_SCRIPT to this
directory if INSTALLDIRS is set to site (default).

=item INSTALLVENDORARCH

Used by 'make install', which copies files from INST_ARCHLIB to this
directory if INSTALLDIRS is set to vendor. Note that if you do not set
this, the value of INSTALLVENDORLIB will be used, which is probably not
what you want.

=item INSTALLVENDORBIN

Used by 'make install', which copies files from INST_BIN to this
directory if INSTALLDIRS is set to vendor.

=item INSTALLVENDORLIB

Used by 'make install', which copies files from INST_LIB to this
directory if INSTALLDIRS is set to vendor.

=item INSTALLVENDORMAN1DIR

=item INSTALLVENDORMAN3DIR

These directories get the man pages at 'make install' time if
INSTALLDIRS=vendor.  Defaults to $(VENDORPREFIX)/man/man$(MAN*EXT).

If set to 'none', no man pages will be installed.

=item INSTALLVENDORSCRIPT

Available in version 6.30_02 and above.

Used by 'make install' which copies files from INST_SCRIPT to this
directory if INSTALLDIRS is set to vendor.

=item INST_ARCHLIB

Same as INST_LIB for architecture dependent files.

=item INST_BIN

Directory to put real binary files during 'make'. These will be copied
to INSTALLBIN during 'make install'

=item INST_LIB

Directory where we put library files of this extension while building
it.

=item INST_MAN1DIR

Directory to hold the man pages at 'make' time

=item INST_MAN3DIR

Directory to hold the man pages at 'make' time

=item INST_SCRIPT

Directory where executable files should be installed during
'make'. Defaults to "./blib/script", just to have a dummy location during
testing. make install will copy the files in INST_SCRIPT to
INSTALLSCRIPT.

=item LD

Program to be used to link libraries for dynamic loading.

Defaults to $Config{ld}.

=item LDDLFLAGS

Any special flags that might need to be passed to ld to create a
shared library suitable for dynamic loading.  It is up to the makefile
to use it.  (See L<Config/lddlflags>)

Defaults to $Config{lddlflags}.

=item LDFROM

Defaults to "$(OBJECT)" and is used in the ld command to specify
what files to link/load from (also see dynamic_lib below for how to
specify ld flags)

=item LIB

LIB should only be set at C<perl Makefile.PL> time but is allowed as a
MakeMaker argument. It has the effect of setting both INSTALLPRIVLIB
and INSTALLSITELIB to that value regardless any explicit setting of
those arguments (or of PREFIX).  INSTALLARCHLIB and INSTALLSITEARCH
are set to the corresponding architecture subdirectory.

=item LIBPERL_A

The filename of the perllibrary that will be used together with this
extension. Defaults to libperl.a.

=item LIBS

An anonymous array of alternative library
specifications to be searched for (in order) until
at least one library is found. E.g.

  'LIBS' => ["-lgdbm", "-ldbm -lfoo", "-L/path -ldbm.nfs"]

Mind, that any element of the array
contains a complete set of arguments for the ld
command. So do not specify

  'LIBS' => ["-ltcl", "-ltk", "-lX11"]

See ODBM_File/Makefile.PL for an example, where an array is needed. If
you specify a scalar as in

  'LIBS' => "-ltcl -ltk -lX11"

MakeMaker will turn it into an array with one element.

=item LICENSE

Available in version 6.31 and above.

The licensing terms of your distribution.  Generally it's "perl_5" for the
same license as Perl itself.

See L<CPAN::Meta::Spec> for the list of options.

Defaults to "unknown".

=item LINKTYPE

'static' or 'dynamic' (default unless usedl=undef in
config.sh). Should only be used to force static linking (also see
linkext below).

=item MAGICXS

Available in version 6.8305 and above.

When this is set to C<1>, C<OBJECT> will be automagically derived from
C<O_FILES>.

=item MAKE

Available in version 6.30_01 and above.

Variant of make you intend to run the generated Makefile with.  This
parameter lets Makefile.PL know what make quirks to account for when
generating the Makefile.

MakeMaker also honors the MAKE environment variable.  This parameter
takes precedence.

Currently the only significant values are 'dmake' and 'nmake' for Windows
users, instructing MakeMaker to generate a Makefile in the flavour of
DMake ("Dennis Vadura's Make") or Microsoft NMake respectively.

Defaults to $Config{make}, which may go looking for a Make program
in your environment.

How are you supposed to know what flavour of Make a Makefile has
been generated for if you didn't specify a value explicitly? Search
the generated Makefile for the definition of the MAKE variable,
which is used to recursively invoke the Make utility. That will tell
you what Make you're supposed to invoke the Makefile with.

=item MAKEAPERL

Boolean which tells MakeMaker that it should include the rules to
make a perl. This is handled automatically as a switch by
MakeMaker. The user normally does not need it.

=item MAKEFILE_OLD

When 'make clean' or similar is run, the $(FIRST_MAKEFILE) will be
backed up at this location.

Defaults to $(FIRST_MAKEFILE).old or $(FIRST_MAKEFILE)_old on VMS.

=item MAN1PODS

Hashref of pod-containing files. MakeMaker will default this to all
EXE_FILES files that include POD directives. The files listed
here will be converted to man pages and installed as was requested
at Configure time.

This hash should map POD files (or scripts containing POD) to the
man file names under the C<blib/man1/> directory, as in the following
example:

  MAN1PODS            => {
    'doc/command.pod'    => 'blib/man1/command.1',
    'scripts/script.pl'  => 'blib/man1/script.1',
  }

=item MAN3PODS

Hashref that assigns to *.pm and *.pod files the files into which the
manpages are to be written. MakeMaker parses all *.pod and *.pm files
for POD directives. Files that contain POD will be the default keys of
the MAN3PODS hashref. These will then be converted to man pages during
C<make> and will be installed during C<make install>.

Example similar to MAN1PODS.

=item MAP_TARGET

If it is intended that a new perl binary be produced, this variable
may hold a name for that binary. Defaults to perl

=item META_ADD

=item META_MERGE

Available in version 6.46 and above.

A hashref of items to add to the CPAN Meta file (F<META.yml> or
F<META.json>).

They differ in how they behave if they have the same key as the
default metadata.  META_ADD will override the default value with its
own.  META_MERGE will merge its value with the default.

Unless you want to override the defaults, prefer META_MERGE so as to
get the advantage of any future defaults.

Where prereqs are concerned, if META_MERGE is used, prerequisites are merged
with their counterpart C<WriteMakefile()> argument
(PREREQ_PM is merged into {prereqs}{runtime}{requires},
BUILD_REQUIRES into C<{prereqs}{build}{requires}>,
CONFIGURE_REQUIRES into C<{prereqs}{configure}{requires}>,
and TEST_REQUIRES into C<{prereqs}{test}{requires})>.
When prereqs are specified with META_ADD, the only prerequisites added to the
file come from the metadata, not C<WriteMakefile()> arguments.

Note that these configuration options are only used for generating F<META.yml>
and F<META.json> -- they are NOT used for F<MYMETA.yml> and F<MYMETA.json>.
Therefore data in these fields should NOT be used for dynamic (user-side)
configuration.

By default CPAN Meta specification C<1.4> is used. In order to use
CPAN Meta specification C<2.0>, indicate with C<meta-spec> the version
you want to use.

  META_MERGE        => {

    "meta-spec" => { version => 2 },

    resources => {

      repository => {
          type => 'git',
          url => 'git://github.com/Perl-Toolchain-Gang/ExtUtils-MakeMaker.git',
          web => 'https://github.com/Perl-Toolchain-Gang/ExtUtils-MakeMaker',
      },

    },

  },

=item MIN_PERL_VERSION

Available in version 6.48 and above.

The minimum required version of Perl for this distribution.

Either the 5.006001 or the 5.6.1 format is acceptable.

=item MYEXTLIB

If the extension links to a library that it builds, set this to the
name of the library (see SDBM_File)

=item NAME

The package representing the distribution. For example, C<Test::More>
or C<ExtUtils::MakeMaker>. It will be used to derive information about
the distribution such as the L</DISTNAME>, installation locations
within the Perl library and where XS files will be looked for by
default (see L</XS>).

C<NAME> I<must> be a valid Perl package name and it I<must> have an
associated C<.pm> file. For example, C<Foo::Bar> is a valid C<NAME>
and there must exist F<Foo/Bar.pm>.  Any XS code should be in
F<Bar.xs> unless stated otherwise.

Your distribution B<must> have a C<NAME>.

=item NEEDS_LINKING

MakeMaker will figure out if an extension contains linkable code
anywhere down the directory tree, and will set this variable
accordingly, but you can speed it up a very little bit if you define
this boolean variable yourself.

=item NOECHO

Command so make does not print the literal commands it's running.

By setting it to an empty string you can generate a Makefile that
prints all commands. Mainly used in debugging MakeMaker itself.

Defaults to C<@>.

=item NORECURS

Boolean.  Attribute to inhibit descending into subdirectories.

=item NO_META

When true, suppresses the generation and addition to the MANIFEST of
the META.yml and META.json module meta-data files during 'make distdir'.

Defaults to false.

=item NO_MYMETA

Available in version 6.57_02 and above.

When true, suppresses the generation of MYMETA.yml and MYMETA.json module
meta-data files during 'perl Makefile.PL'.

Defaults to false.

=item NO_PACKLIST

Available in version 6.7501 and above.

When true, suppresses the writing of C<packlist> files for installs.

Defaults to false.

=item NO_PERLLOCAL

Available in version 6.7501 and above.

When true, suppresses the appending of installations to C<perllocal>.

Defaults to false.

=item NO_VC

In general, any generated Makefile checks for the current version of
MakeMaker and the version the Makefile was built under. If NO_VC is
set, the version check is neglected. Do not write this into your
Makefile.PL, use it interactively instead.

=item OBJECT

List of object files, defaults to '$(BASEEXT)$(OBJ_EXT)', but can be a long
string or an array containing all object files, e.g. "tkpBind.o
tkpButton.o tkpCanvas.o" or ["tkpBind.o", "tkpButton.o", "tkpCanvas.o"]

(Where BASEEXT is the last component of NAME, and OBJ_EXT is $Config{obj_ext}.)

=item OPTIMIZE

Defaults to C<-O>. Set it to C<-g> to turn debugging on. The flag is
passed to subdirectory makes.

=item PERL

Perl binary for tasks that can be done by miniperl. If it contains
spaces or other shell metacharacters, it needs to be quoted in a way
that protects them, since this value is intended to be inserted in a
shell command line in the Makefile. E.g.:

  # Perl executable lives in "C:/Program Files/Perl/bin"
  # Normally you don't need to set this yourself!
  $ perl Makefile.PL PERL='"C:/Program Files/Perl/bin/perl.exe" -w'

=item PERL_CORE

Set only when MakeMaker is building the extensions of the Perl core
distribution.

=item PERLMAINCC

The call to the program that is able to compile perlmain.c. Defaults
to $(CC).

=item PERL_ARCHLIB

Same as for PERL_LIB, but for architecture dependent files.

Used only when MakeMaker is building the extensions of the Perl core
distribution (because normally $(PERL_ARCHLIB) is automatically in @INC,
and adding it would get in the way of PERL5LIB).

=item PERL_LIB

Directory containing the Perl library to use.

Used only when MakeMaker is building the extensions of the Perl core
distribution (because normally $(PERL_LIB) is automatically in @INC,
and adding it would get in the way of PERL5LIB).

=item PERL_MALLOC_OK

defaults to 0.  Should be set to TRUE if the extension can work with
the memory allocation routines substituted by the Perl malloc() subsystem.
This should be applicable to most extensions with exceptions of those

=over 4

=item *

with bugs in memory allocations which are caught by Perl's malloc();

=item *

which interact with the memory allocator in other ways than via
malloc(), realloc(), free(), calloc(), sbrk() and brk();

=item *

which rely on special alignment which is not provided by Perl's malloc().

=back

B<NOTE.>  Neglecting to set this flag in I<any one> of the loaded extension
nullifies many advantages of Perl's malloc(), such as better usage of
system resources, error detection, memory usage reporting, catchable failure
of memory allocations, etc.

=item PERLPREFIX

Directory under which core modules are to be installed.

Defaults to $Config{installprefixexp}, falling back to
$Config{installprefix}, $Config{prefixexp} or $Config{prefix} should
$Config{installprefixexp} not exist.

Overridden by PREFIX.

=item PERLRUN

Use this instead of $(PERL) when you wish to run perl.  It will set up
extra necessary flags for you.

=item PERLRUNINST

Use this instead of $(PERL) when you wish to run perl to work with
modules.  It will add things like -I$(INST_ARCH) and other necessary
flags so perl can see the modules you're about to install.

=item PERL_SRC

Directory containing the Perl source code (use of this should be
avoided, it may be undefined)

=item PERM_DIR

Available in version 6.51_01 and above.

Desired permission for directories. Defaults to C<755>.

=item PERM_RW

Desired permission for read/writable files. Defaults to C<644>.

=item PERM_RWX

Desired permission for executable files. Defaults to C<755>.

=item PL_FILES

MakeMaker can run programs to generate files for you at build time.
By default any file named *.PL (except Makefile.PL and Build.PL) in
the top level directory will be assumed to be a Perl program and run
passing its own basename in as an argument.  This basename is actually a build
target, and there is an intention, but not a requirement, that the *.PL file
make the file passed to to as an argument. For example...

    perl foo.PL foo

This behavior can be overridden by supplying your own set of files to
search.  PL_FILES accepts a hash ref, the key being the file to run
and the value is passed in as the first argument when the PL file is run.

    PL_FILES => {'bin/foobar.PL' => 'bin/foobar'}

    PL_FILES => {'foo.PL' => 'foo.c'}

Would run bin/foobar.PL like this:

    perl bin/foobar.PL bin/foobar

If multiple files from one program are desired an array ref can be used.

    PL_FILES => {'bin/foobar.PL' => [qw(bin/foobar1 bin/foobar2)]}

In this case the program will be run multiple times using each target file.

    perl bin/foobar.PL bin/foobar1
    perl bin/foobar.PL bin/foobar2

If an output file depends on extra input files beside the script itself,
a hash ref can be used in version 7.36 and above:

    PL_FILES => { 'foo.PL' => {
        'foo.out' => 'foo.in',
        'bar.out' => [qw(bar1.in bar2.in)],
    }

In this case the extra input files will be passed to the program after
the target file:

   perl foo.PL foo.out foo.in
   perl foo.PL bar.out bar1.in bar2.in

PL files are normally run B<after> pm_to_blib and include INST_LIB and
INST_ARCH in their C<@INC>, so the just built modules can be
accessed... unless the PL file is making a module (or anything else in
PM) in which case it is run B<before> pm_to_blib and does not include
INST_LIB and INST_ARCH in its C<@INC>.  This apparently odd behavior
is there for backwards compatibility (and it's somewhat DWIM).  The argument
passed to the .PL is set up as a target to build in the Makefile.  In other
sections such as C<postamble> you can specify a dependency on the
filename/argument that the .PL is supposed (or will have, now that that is
is a dependency) to generate.  Note the file to be generated will still be
generated and the .PL will still run even without an explicit dependency created
by you, since the C<all> target still depends on running all eligible to run.PL
files.

=item PM

Hashref of .pm files and *.pl files to be installed.  e.g.

  {'name_of_file.pm' => '$(INST_LIB)/install_as.pm'}

By default this will include *.pm and *.pl and the files found in
the PMLIBDIRS directories.  Defining PM in the
Makefile.PL will override PMLIBDIRS.

=item PMLIBDIRS

Ref to array of subdirectories containing library files.  Defaults to
[ 'lib', $(BASEEXT) ]. The directories will be scanned and I<any> files
they contain will be installed in the corresponding location in the
library.  A libscan() method can be used to alter the behaviour.
Defining PM in the Makefile.PL will override PMLIBDIRS.

(Where BASEEXT is the last component of NAME.)

=item PM_FILTER

A filter program, in the traditional Unix sense (input from stdin, output
to stdout) that is passed on each .pm file during the build (in the
pm_to_blib() phase).  It is empty by default, meaning no filtering is done.
You could use:

  PM_FILTER => 'perl -ne "print unless /^\\#/"',

to remove all the leading comments on the fly during the build.  In order
to be as portable as possible, please consider using a Perl one-liner
rather than Unix (or other) utilities, as above.  The # is escaped for
the Makefile, since what is going to be generated will then be:

  PM_FILTER = perl -ne "print unless /^\#/"

Without the \ before the #, we'd have the start of a Makefile comment,
and the macro would be incorrectly defined.

You will almost certainly be better off using the C<PL_FILES> system,
instead. See above, or the L<ExtUtils::MakeMaker::FAQ> entry.

=item POLLUTE

Release 5.005 grandfathered old global symbol names by providing preprocessor
macros for extension source compatibility.  As of release 5.6, these
preprocessor definitions are not available by default.  The POLLUTE flag
specifies that the old names should still be defined:

  perl Makefile.PL POLLUTE=1

Please inform the module author if this is necessary to successfully install
a module under 5.6 or later.

=item PPM_INSTALL_EXEC

Name of the executable used to run C<PPM_INSTALL_SCRIPT> below. (e.g. perl)

=item PPM_INSTALL_SCRIPT

Name of the script that gets executed by the Perl Package Manager after
the installation of a package.

=item PPM_UNINSTALL_EXEC

Available in version 6.8502 and above.

Name of the executable used to run C<PPM_UNINSTALL_SCRIPT> below. (e.g. perl)

=item PPM_UNINSTALL_SCRIPT

Available in version 6.8502 and above.

Name of the script that gets executed by the Perl Package Manager before
the removal of a package.

=item PREFIX

This overrides all the default install locations.  Man pages,
libraries, scripts, etc...  MakeMaker will try to make an educated
guess about where to place things under the new PREFIX based on your
Config defaults.  Failing that, it will fall back to a structure
which should be sensible for your platform.

If you specify LIB or any INSTALL* variables they will not be affected
by the PREFIX.

=item PREREQ_FATAL

Bool. If this parameter is true, failing to have the required modules
(or the right versions thereof) will be fatal. C<perl Makefile.PL>
will C<die> instead of simply informing the user of the missing dependencies.

It is I<extremely> rare to have to use C<PREREQ_FATAL>. Its use by module
authors is I<strongly discouraged> and should never be used lightly.

For dependencies that are required in order to run C<Makefile.PL>,
see C<CONFIGURE_REQUIRES>.

Module installation tools have ways of resolving unmet dependencies but
to do that they need a F<Makefile>.  Using C<PREREQ_FATAL> breaks this.
That's bad.

Assuming you have good test coverage, your tests should fail with
missing dependencies informing the user more strongly that something
is wrong.  You can write a F<t/00compile.t> test which will simply
check that your code compiles and stop "make test" prematurely if it
doesn't.  See L<Test::More/BAIL_OUT> for more details.


=item PREREQ_PM

A hash of modules that are needed to run your module.  The keys are
the module names ie. Test::More, and the minimum version is the
value. If the required version number is 0 any version will do.
The versions given may be a Perl v-string (see L<version>) or a range
(see L<CPAN::Meta::Requirements>).

This will go into the C<requires> field of your F<META.yml> and the
C<runtime> of the C<prereqs> field of your F<META.json>.

    PREREQ_PM => {
        # Require Test::More at least 0.47
        "Test::More" => "0.47",

        # Require any version of Acme::Buffy
        "Acme::Buffy" => 0,
    }

=item PREREQ_PRINT

Bool.  If this parameter is true, the prerequisites will be printed to
stdout and MakeMaker will exit.  The output format is an evalable hash
ref.

  $PREREQ_PM = {
                 'A::B' => Vers1,
                 'C::D' => Vers2,
                 ...
               };

If a distribution defines a minimal required perl version, this is
added to the output as an additional line of the form:

  $MIN_PERL_VERSION = '5.008001';

If BUILD_REQUIRES is not empty, it will be dumped as $BUILD_REQUIRES hashref.

=item PRINT_PREREQ

RedHatism for C<PREREQ_PRINT>.  The output format is different, though:

    perl(A::B)>=Vers1 perl(C::D)>=Vers2 ...

A minimal required perl version, if present, will look like this:

    perl(perl)>=5.008001

=item SITEPREFIX

Like PERLPREFIX, but only for the site install locations.

Defaults to $Config{siteprefixexp}.  Perls prior to 5.6.0 didn't have
an explicit siteprefix in the Config.  In those cases
$Config{installprefix} will be used.

Overridable by PREFIX

=item SIGN

Available in version 6.18 and above.

When true, perform the generation and addition to the MANIFEST of the
SIGNATURE file in the distdir during 'make distdir', via 'cpansign
-s'.

Note that you need to install the Module::Signature module to
perform this operation.

Defaults to false.

=item SKIP

Arrayref. E.g. [qw(name1 name2)] skip (do not write) sections of the
Makefile. Caution! Do not use the SKIP attribute for the negligible
speedup. It may seriously damage the resulting Makefile. Only use it
if you really need it.

=item TEST_REQUIRES

Available in version 6.64 and above.

A hash of modules that are needed to test your module but not run or
build it.

This will go into the C<build_requires> field of your F<META.yml> and the C<test> of the C<prereqs> field of your F<META.json>.

The format is the same as PREREQ_PM.

=item TYPEMAPS

Ref to array of typemap file names.  Use this when the typemaps are
in some directory other than the current directory or when they are
not named B<typemap>.  The last typemap in the list takes
precedence.  A typemap in the current directory has highest
precedence, even if it isn't listed in TYPEMAPS.  The default system
typemap has lowest precedence.

=item VENDORPREFIX

Like PERLPREFIX, but only for the vendor install locations.

Defaults to $Config{vendorprefixexp}.

Overridable by PREFIX

=item VERBINST

If true, make install will be verbose

=item VERSION

Your version number for distributing the package.  This defaults to
0.1.

=item VERSION_FROM

Instead of specifying the VERSION in the Makefile.PL you can let
MakeMaker parse a file to determine the version number. The parsing
routine requires that the file named by VERSION_FROM contains one
single line to compute the version number. The first line in the file
that contains something like a $VERSION assignment or C<package Name
VERSION> will be used. The following lines will be parsed o.k.:

    # Good
    package Foo::Bar 1.23;                      # 1.23
    $VERSION   = '1.00';                        # 1.00
    *VERSION   = \'1.01';                       # 1.01
    ($VERSION) = q$Revision$ =~ /(\d+)/g;       # The digits in $Revision$
    $FOO::VERSION = '1.10';                     # 1.10
    *FOO::VERSION = \'1.11';                    # 1.11

but these will fail:

    # Bad
    my $VERSION         = '1.01';
    local $VERSION      = '1.02';
    local $FOO::VERSION = '1.30';

(Putting C<my> or C<local> on the preceding line will work o.k.)

"Version strings" are incompatible and should not be used.

    # Bad
    $VERSION = 1.2.3;
    $VERSION = v1.2.3;

L<version> objects are fine.  As of MakeMaker 6.35 version.pm will be
automatically loaded, but you must declare the dependency on version.pm.
For compatibility with older MakeMaker you should load on the same line
as $VERSION is declared.

    # All on one line
    use version; our $VERSION = qv(1.2.3);

The file named in VERSION_FROM is not added as a dependency to
Makefile. This is not really correct, but it would be a major pain
during development to have to rewrite the Makefile for any smallish
change in that file. If you want to make sure that the Makefile
contains the correct VERSION macro after any change of the file, you
would have to do something like

    depend => { Makefile => '$(VERSION_FROM)' }

See attribute C<depend> below.

=item VERSION_SYM

A sanitized VERSION with . replaced by _.  For places where . has
special meaning (some filesystems, RCS labels, etc...)

=item XS

Hashref of .xs files. MakeMaker will default this.  e.g.

  {'name_of_file.xs' => 'name_of_file.c'}

The .c files will automatically be included in the list of files
deleted by a make clean.

=item XSBUILD

Available in version 7.12 and above.

Hashref with options controlling the operation of C<XSMULTI>:

  {
    xs => {
        all => {
            # options applying to all .xs files for this distribution
        },
        'lib/Class/Name/File' => { # specifically for this file
            DEFINE => '-Dfunktastic', # defines for only this file
            INC => "-I$funkyliblocation", # include flags for only this file
            # OBJECT => 'lib/Class/Name/File$(OBJ_EXT)', # default
            LDFROM => "lib/Class/Name/File\$(OBJ_EXT) $otherfile\$(OBJ_EXT)", # what's linked
        },
    },
  }

Note C<xs> is the file-extension. More possibilities may arise in the
future. Note that object names are specified without their XS extension.

C<LDFROM> defaults to the same as C<OBJECT>. C<OBJECT> defaults to,
for C<XSMULTI>, just the XS filename with the extension replaced with
the compiler-specific object-file extension.

The distinction between C<OBJECT> and C<LDFROM>: C<OBJECT> is the make
target, so make will try to build it. However, C<LDFROM> is what will
actually be linked together to make the shared object or static library
(SO/SL), so if you override it, make sure it includes what you want to
make the final SO/SL, almost certainly including the XS basename with
C<$(OBJ_EXT)> appended.

=item XSMULTI

Available in version 7.12 and above.

When this is set to C<1>, multiple XS files may be placed under F<lib/>
next to their corresponding C<*.pm> files (this is essential for compiling
with the correct C<VERSION> values). This feature should be considered
experimental, and details of it may change.

This feature was inspired by, and small portions of code copied from,
L<ExtUtils::MakeMaker::BigHelper>. Hopefully this feature will render
that module mainly obsolete.

=item XSOPT

String of options to pass to xsubpp.  This might include C<-C++> or
C<-extern>.  Do not include typemaps here; the TYPEMAP parameter exists for
that purpose.

=item XSPROTOARG

May be set to C<-prototypes>, C<-noprototypes> or the empty string.  The
empty string is equivalent to the xsubpp default, or C<-noprototypes>.
See the xsubpp documentation for details.  MakeMaker
defaults to the empty string.

=item XS_VERSION

Your version number for the .xs file of this package.  This defaults
to the value of the VERSION attribute.

=back

=head2 Additional lowercase attributes

can be used to pass parameters to the methods which implement that
part of the Makefile.  Parameters are specified as a hash ref but are
passed to the method as a hash.

=over 2

=item clean

  {FILES => "*.xyz foo"}

=item depend

  {ANY_TARGET => ANY_DEPENDENCY, ...}

(ANY_TARGET must not be given a double-colon rule by MakeMaker.)

=item dist

  {TARFLAGS => 'cvfF', COMPRESS => 'gzip', SUFFIX => '.gz',
  SHAR => 'shar -m', DIST_CP => 'ln', ZIP => '/bin/zip',
  ZIPFLAGS => '-rl', DIST_DEFAULT => 'private tardist' }

If you specify COMPRESS, then SUFFIX should also be altered, as it is
needed to tell make the target file of the compression. Setting
DIST_CP to ln can be useful, if you need to preserve the timestamps on
your files. DIST_CP can take the values 'cp', which copies the file,
'ln', which links the file, and 'best' which copies symbolic links and
links the rest. Default is 'best'.

=item dynamic_lib

  {ARMAYBE => 'ar', OTHERLDFLAGS => '...', INST_DYNAMIC_DEP => '...'}

=item linkext

  {LINKTYPE => 'static', 'dynamic' or ''}

NB: Extensions that have nothing but *.pm files had to say

  {LINKTYPE => ''}

with Pre-5.0 MakeMakers. Since version 5.00 of MakeMaker such a line
can be deleted safely. MakeMaker recognizes when there's nothing to
be linked.

=item macro

  {ANY_MACRO => ANY_VALUE, ...}

=item postamble

Anything put here will be passed to
L<MY::postamble()|ExtUtils::MM_Any/postamble (o)> if you have one.

=item realclean

  {FILES => '$(INST_ARCHAUTODIR)/*.xyz'}

=item test

Specify the targets for testing.

  {TESTS => 't/*.t'}

C<RECURSIVE_TEST_FILES> can be used to include all directories
recursively under C<t> that contain C<.t> files. It will be ignored if
you provide your own C<TESTS> attribute, defaults to false.

  {RECURSIVE_TEST_FILES=>1}

This is supported since 6.76

=item tool_autosplit

  {MAXLEN => 8}

=back

=head2 Overriding MakeMaker Methods

If you cannot achieve the desired Makefile behaviour by specifying
attributes you may define private subroutines in the Makefile.PL.
Each subroutine returns the text it wishes to have written to
the Makefile. To override a section of the Makefile you can
either say:

        sub MY::c_o { "new literal text" }

or you can edit the default by saying something like:

        package MY; # so that "SUPER" works right
        sub c_o {
            my $inherited = shift->SUPER::c_o(@_);
            $inherited =~ s/old text/new text/;
            $inherited;
        }

If you are running experiments with embedding perl as a library into
other applications, you might find MakeMaker is not sufficient. You'd
better have a look at L<ExtUtils::Embed> which is a collection of utilities
for embedding.

If you still need a different solution, try to develop another
subroutine that fits your needs and submit the diffs to
C<makemaker@perl.org>

For a complete description of all MakeMaker methods see
L<ExtUtils::MM_Unix>.

Here is a simple example of how to add a new target to the generated
Makefile:

    sub MY::postamble {
        return <<'MAKE_FRAG';
    $(MYEXTLIB): sdbm/Makefile
            cd sdbm && $(MAKE) all

    MAKE_FRAG
    }

=head2 The End Of Cargo Cult Programming

WriteMakefile() now does some basic sanity checks on its parameters to
protect against typos and malformatted values.  This means some things
which happened to work in the past will now throw warnings and
possibly produce internal errors.

Some of the most common mistakes:

=over 2

=item C<< MAN3PODS => ' ' >>

This is commonly used to suppress the creation of man pages.  MAN3PODS
takes a hash ref not a string, but the above worked by accident in old
versions of MakeMaker.

The correct code is C<< MAN3PODS => { } >>.

=back


=head2 Hintsfile support

MakeMaker.pm uses the architecture-specific information from
Config.pm. In addition it evaluates architecture specific hints files
in a C<hints/> directory. The hints files are expected to be named
like their counterparts in C<PERL_SRC/hints>, but with an C<.pl> file
name extension (eg. C<next_3_2.pl>). They are simply C<eval>ed by
MakeMaker within the WriteMakefile() subroutine, and can be used to
execute commands as well as to include special variables. The rules
which hintsfile is chosen are the same as in Configure.

The hintsfile is eval()ed immediately after the arguments given to
WriteMakefile are stuffed into a hash reference $self but before this
reference becomes blessed. So if you want to do the equivalent to
override or create an attribute you would say something like

    $self->{LIBS} = ['-ldbm -lucb -lc'];

=head2 Distribution Support

For authors of extensions MakeMaker provides several Makefile
targets. Most of the support comes from the L<ExtUtils::Manifest> module,
where additional documentation can be found.

=over 4

=item    make distcheck

reports which files are below the build directory but not in the
MANIFEST file and vice versa. (See L<ExtUtils::Manifest/fullcheck> for
details)

=item    make skipcheck

reports which files are skipped due to the entries in the
C<MANIFEST.SKIP> file (See L<ExtUtils::Manifest/skipcheck> for
details)

=item    make distclean

does a realclean first and then the distcheck. Note that this is not
needed to build a new distribution as long as you are sure that the
MANIFEST file is ok.

=item    make veryclean

does a realclean first and then removes backup files such as C<*~>,
C<*.bak>, C<*.old> and C<*.orig>

=item    make manifest

rewrites the MANIFEST file, adding all remaining files found (See
L<ExtUtils::Manifest/mkmanifest> for details)

=item    make distdir

Copies all the files that are in the MANIFEST file to a newly created
directory with the name C<$(DISTNAME)-$(VERSION)>. If that directory
exists, it will be removed first.

Additionally, it will create META.yml and META.json module meta-data file
in the distdir and add this to the distdir's MANIFEST.  You can shut this
behavior off with the NO_META flag.

=item   make disttest

Makes a distdir first, and runs a C<perl Makefile.PL>, a make, and
a make test in that directory.

=item    make tardist

First does a distdir. Then a command $(PREOP) which defaults to a null
command, followed by $(TO_UNIX), which defaults to a null command under
UNIX, and will convert files in distribution directory to UNIX format
otherwise. Next it runs C<tar> on that directory into a tarfile and
deletes the directory. Finishes with a command $(POSTOP) which
defaults to a null command.

=item    make dist

Defaults to $(DIST_DEFAULT) which in turn defaults to tardist.

=item    make uutardist

Runs a tardist first and uuencodes the tarfile.

=item    make shdist

First does a distdir. Then a command $(PREOP) which defaults to a null
command. Next it runs C<shar> on that directory into a sharfile and
deletes the intermediate directory again. Finishes with a command
$(POSTOP) which defaults to a null command.  Note: For shdist to work
properly a C<shar> program that can handle directories is mandatory.

=item    make zipdist

First does a distdir. Then a command $(PREOP) which defaults to a null
command. Runs C<$(ZIP) $(ZIPFLAGS)> on that directory into a
zipfile. Then deletes that directory. Finishes with a command
$(POSTOP) which defaults to a null command.

=item    make ci

Does a $(CI) and a $(RCS_LABEL) on all files in the MANIFEST file.

=back

Customization of the dist targets can be done by specifying a hash
reference to the dist attribute of the WriteMakefile call. The
following parameters are recognized:

    CI           ('ci -u')
    COMPRESS     ('gzip --best')
    POSTOP       ('@ :')
    PREOP        ('@ :')
    TO_UNIX      (depends on the system)
    RCS_LABEL    ('rcs -q -Nv$(VERSION_SYM):')
    SHAR         ('shar')
    SUFFIX       ('.gz')
    TAR          ('tar')
    TARFLAGS     ('cvf')
    ZIP          ('zip')
    ZIPFLAGS     ('-r')

An example:

    WriteMakefile(
        ...other options...
        dist => {
            COMPRESS => "bzip2",
            SUFFIX   => ".bz2"
        }
    );


=head2 Module Meta-Data (META and MYMETA)

Long plaguing users of MakeMaker based modules has been the problem of
getting basic information about the module out of the sources
I<without> running the F<Makefile.PL> and doing a bunch of messy
heuristics on the resulting F<Makefile>.  Over the years, it has become
standard to keep this information in one or more CPAN Meta files
distributed with each distribution.

The original format of CPAN Meta files was L<YAML> and the corresponding
file was called F<META.yml>.  In 2010, version 2 of the L<CPAN::Meta::Spec>
was released, which mandates JSON format for the metadata in order to
overcome certain compatibility issues between YAML serializers and to
avoid breaking older clients unable to handle a new version of the spec.
The L<CPAN::Meta> library is now standard for accessing old and new-style
Meta files.

If L<CPAN::Meta> is installed, MakeMaker will automatically generate
F<META.json> and F<META.yml> files for you and add them to your F<MANIFEST> as
part of the 'distdir' target (and thus the 'dist' target).  This is intended to
seamlessly and rapidly populate CPAN with module meta-data.  If you wish to
shut this feature off, set the C<NO_META> C<WriteMakefile()> flag to true.

At the 2008 QA Hackathon in Oslo, Perl module toolchain maintainers agreed
to use the CPAN Meta format to communicate post-configuration requirements
between toolchain components.  These files, F<MYMETA.json> and F<MYMETA.yml>,
are generated when F<Makefile.PL> generates a F<Makefile> (if L<CPAN::Meta>
is installed).  Clients like L<CPAN> or L<CPANPLUS> will read these
files to see what prerequisites must be fulfilled before building or testing
the distribution.  If you wish to shut this feature off, set the C<NO_MYMETA>
C<WriteMakeFile()> flag to true.

=head2 Disabling an extension

If some events detected in F<Makefile.PL> imply that there is no way
to create the Module, but this is a normal state of things, then you
can create a F<Makefile> which does nothing, but succeeds on all the
"usual" build targets.  To do so, use

    use ExtUtils::MakeMaker qw(WriteEmptyMakefile);
    WriteEmptyMakefile();

instead of WriteMakefile().

This may be useful if other modules expect this module to be I<built>
OK, as opposed to I<work> OK (say, this system-dependent module builds
in a subdirectory of some other distribution, or is listed as a
dependency in a CPAN::Bundle, but the functionality is supported by
different means on the current architecture).

=head2 Other Handy Functions

=over 4

=item prompt

    my $value = prompt($message);
    my $value = prompt($message, $default);

The C<prompt()> function provides an easy way to request user input
used to write a makefile.  It displays the $message as a prompt for
input.  If a $default is provided it will be used as a default.  The
function returns the $value selected by the user.

If C<prompt()> detects that it is not running interactively and there
is nothing on STDIN or if the PERL_MM_USE_DEFAULT environment variable
is set to true, the $default will be used without prompting.  This
prevents automated processes from blocking on user input.

If no $default is provided an empty string will be used instead.

=item os_unsupported

  os_unsupported();
  os_unsupported if $^O eq 'MSWin32';

The C<os_unsupported()> function provides a way to correctly exit your
C<Makefile.PL> before calling C<WriteMakefile>. It is essentially a
C<die> with the message "OS unsupported".

This is supported since 7.26

=back

=head2 Supported versions of Perl

Please note that while this module works on Perl 5.6, it is no longer
being routinely tested on 5.6 - the earliest Perl version being routinely
tested, and expressly supported, is 5.8.1. However, patches to repair
any breakage on 5.6 are still being accepted.

=head1 ENVIRONMENT

=over 4

=item PERL_MM_OPT

Command line options used by C<MakeMaker-E<gt>new()>, and thus by
C<WriteMakefile()>.  The string is split as the shell would, and the result
is processed before any actual command line arguments are processed.

  PERL_MM_OPT='CCFLAGS="-Wl,-rpath -Wl,/foo/bar/lib" LIBS="-lwibble -lwobble"'

=item PERL_MM_USE_DEFAULT

If set to a true value then MakeMaker's prompt function will
always return the default without waiting for user input.

=item PERL_CORE

Same as the PERL_CORE parameter.  The parameter overrides this.

=back

=head1 SEE ALSO

L<Module::Build> is a pure-Perl alternative to MakeMaker which does
not rely on make or any other external utility.  It may be easier to
extend to suit your needs.

L<Module::Build::Tiny> is a minimal pure-Perl alternative to MakeMaker
that follows the Build.PL protocol of Module::Build but without its
complexity and cruft, implementing only the installation of the module
and leaving authoring to L<mbtiny> or other authoring tools.

L<Module::Install> is a (now discouraged) wrapper around MakeMaker which
adds features not normally available.

L<ExtUtils::ModuleMaker> and L<Module::Starter> are both modules to
help you setup your distribution.

L<CPAN::Meta> and L<CPAN::Meta::Spec> explain CPAN Meta files in detail.

L<File::ShareDir::Install> makes it easy to install static, sometimes
also referred to as 'shared' files. L<File::ShareDir> helps accessing
the shared files after installation. L<Test::File::ShareDir> helps when
writing tests to use the shared files both before and after installation.

L<Dist::Zilla> is an authoring tool which allows great customization and
extensibility of the author experience, relying on the existing install
tools like ExtUtils::MakeMaker only for installation.

L<Dist::Milla> is a Dist::Zilla bundle that greatly simplifies common
usage.

L<Minilla> is a minimal authoring tool that does the same things as
Dist::Milla without the overhead of Dist::Zilla.

=head1 AUTHORS

Andy Dougherty C<doughera@lafayette.edu>, Andreas KE<ouml>nig
C<andreas.koenig@mind.de>, Tim Bunce C<timb@cpan.org>.  VMS
support by Charles Bailey C<bailey@newman.upenn.edu>.  OS/2 support
by Ilya Zakharevich C<ilya@math.ohio-state.edu>.

Currently maintained by Michael G Schwern C<schwern@pobox.com>

Send patches and ideas to C<makemaker@perl.org>.

Send bug reports via http://rt.cpan.org/.  Please send your
generated Makefile along with your report.

For more up-to-date information, see L<https://metacpan.org/release/ExtUtils-MakeMaker>.

Repository available at L<https://github.com/Perl-Toolchain-Gang/ExtUtils-MakeMaker>.

=head1 LICENSE

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

See L<http://www.perl.com/perl/misc/Artistic.html>


=cut
PK       ! ��݅  �    perl5/ExtUtils/MM_MacOS.pmnu ��6�$        package ExtUtils::MM_MacOS;

use strict;
use warnings;

our $VERSION = '7.50';
$VERSION =~ tr/_//d;

sub new {
    die 'MacOS Classic (MacPerl) is no longer supported by MakeMaker';
}

=head1 NAME

ExtUtils::MM_MacOS - once produced Makefiles for MacOS Classic

=head1 SYNOPSIS

  # MM_MacOS no longer contains any code.  This is just a stub.

=head1 DESCRIPTION

Once upon a time, MakeMaker could produce an approximation of a correct
Makefile on MacOS Classic (MacPerl).  Due to a lack of maintainers, this
fell out of sync with the rest of MakeMaker and hadn't worked in years.
Since there's little chance of it being repaired, MacOS Classic is fading
away, and the code was icky to begin with, the code has been deleted to
make maintenance easier.

Anyone interested in resurrecting this file should pull the old version
from the MakeMaker CVS repository and contact makemaker@perl.org.

=cut

1;
PK       ! х׃  �    perl5/ExtUtils/Command.pmnu ��6�$        package ExtUtils::Command;

use 5.00503;
use strict;
use warnings;
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
@ISA       = qw(Exporter);
@EXPORT    = qw(cp rm_f rm_rf mv cat eqtime mkpath touch test_f test_d chmod
                dos2unix);
$VERSION = '7.50';
$VERSION =~ tr/_//d;

my $Is_VMS   = $^O eq 'VMS';
my $Is_VMS_mode = $Is_VMS;
my $Is_VMS_noefs = $Is_VMS;
my $Is_Win32 = $^O eq 'MSWin32';

if( $Is_VMS ) {
    my $vms_unix_rpt;
    my $vms_efs;
    my $vms_case;

    if (eval { local $SIG{__DIE__};
               local @INC = @INC;
               pop @INC if $INC[-1] eq '.';
               require VMS::Feature; }) {
        $vms_unix_rpt = VMS::Feature::current("filename_unix_report");
        $vms_efs = VMS::Feature::current("efs_charset");
        $vms_case = VMS::Feature::current("efs_case_preserve");
    } else {
        my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
        my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || '';
        my $efs_case = $ENV{'DECC$EFS_CASE_PRESERVE'} || '';
        $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i;
        $vms_efs = $efs_charset =~ /^[ET1]/i;
        $vms_case = $efs_case =~ /^[ET1]/i;
    }
    $Is_VMS_mode = 0 if $vms_unix_rpt;
    $Is_VMS_noefs = 0 if ($vms_efs);
}


=head1 NAME

ExtUtils::Command - utilities to replace common UNIX commands in Makefiles etc.

=head1 SYNOPSIS

  perl -MExtUtils::Command -e cat files... > destination
  perl -MExtUtils::Command -e mv source... destination
  perl -MExtUtils::Command -e cp source... destination
  perl -MExtUtils::Command -e touch files...
  perl -MExtUtils::Command -e rm_f files...
  perl -MExtUtils::Command -e rm_rf directories...
  perl -MExtUtils::Command -e mkpath directories...
  perl -MExtUtils::Command -e eqtime source destination
  perl -MExtUtils::Command -e test_f file
  perl -MExtUtils::Command -e test_d directory
  perl -MExtUtils::Command -e chmod mode files...
  ...

=head1 DESCRIPTION

The module is used to replace common UNIX commands.  In all cases the
functions work from @ARGV rather than taking arguments.  This makes
them easier to deal with in Makefiles.  Call them like this:

  perl -MExtUtils::Command -e some_command some files to work on

and I<NOT> like this:

  perl -MExtUtils::Command -e 'some_command qw(some files to work on)'

For that use L<Shell::Command>.

Filenames with * and ? will be glob expanded.


=head2 FUNCTIONS

=over 4

=cut

# VMS uses % instead of ? to mean "one character"
my $wild_regex = $Is_VMS ? '*%' : '*?';
sub expand_wildcards
{
 @ARGV = map(/[$wild_regex]/o ? glob($_) : $_,@ARGV);
}


=item cat

    cat file ...

Concatenates all files mentioned on command line to STDOUT.

=cut

sub cat ()
{
 expand_wildcards();
 print while (<>);
}

=item eqtime

    eqtime source destination

Sets modified time of destination to that of source.

=cut

sub eqtime
{
 my ($src,$dst) = @ARGV;
 local @ARGV = ($dst);  touch();  # in case $dst doesn't exist
 utime((stat($src))[8,9],$dst);
}

=item rm_rf

    rm_rf files or directories ...

Removes files and directories - recursively (even if readonly)

=cut

sub rm_rf
{
 expand_wildcards();
 require File::Path;
 File::Path::rmtree([grep -e $_,@ARGV],0,0);
}

=item rm_f

    rm_f file ...

Removes files (even if readonly)

=cut

sub rm_f {
    expand_wildcards();

    foreach my $file (@ARGV) {
        next unless -f $file;

        next if _unlink($file);

        chmod(0777, $file);

        next if _unlink($file);

        require Carp;
        Carp::carp("Cannot delete $file: $!");
    }
}

sub _unlink {
    my $files_unlinked = 0;
    foreach my $file (@_) {
        my $delete_count = 0;
        $delete_count++ while unlink $file;
        $files_unlinked++ if $delete_count;
    }
    return $files_unlinked;
}


=item touch

    touch file ...

Makes files exist, with current timestamp

=cut

sub touch {
    my $t    = time;
    expand_wildcards();
    foreach my $file (@ARGV) {
        open(FILE,">>$file") || die "Cannot write $file:$!";
        close(FILE);
        utime($t,$t,$file);
    }
}

=item mv

    mv source_file destination_file
    mv source_file source_file destination_dir

Moves source to destination.  Multiple sources are allowed if
destination is an existing directory.

Returns true if all moves succeeded, false otherwise.

=cut

sub mv {
    expand_wildcards();
    my @src = @ARGV;
    my $dst = pop @src;

    if (@src > 1 && ! -d $dst) {
        require Carp;
        Carp::croak("Too many arguments");
    }

    require File::Copy;
    my $nok = 0;
    foreach my $src (@src) {
        $nok ||= !File::Copy::move($src,$dst);
    }
    return !$nok;
}

=item cp

    cp source_file destination_file
    cp source_file source_file destination_dir

Copies sources to the destination.  Multiple sources are allowed if
destination is an existing directory.

Returns true if all copies succeeded, false otherwise.

=cut

sub cp {
    expand_wildcards();
    my @src = @ARGV;
    my $dst = pop @src;

    if (@src > 1 && ! -d $dst) {
        require Carp;
        Carp::croak("Too many arguments");
    }

    require File::Copy;
    my $nok = 0;
    foreach my $src (@src) {
        $nok ||= !File::Copy::copy($src,$dst);

        # Win32 does not update the mod time of a copied file, just the
        # created time which make does not look at.
        utime(time, time, $dst) if $Is_Win32;
    }
    return $nok;
}

=item chmod

    chmod mode files ...

Sets UNIX like permissions 'mode' on all the files.  e.g. 0666

=cut

sub chmod {
    local @ARGV = @ARGV;
    my $mode = shift(@ARGV);
    expand_wildcards();

    if( $Is_VMS_mode && $Is_VMS_noefs) {
        require File::Spec;
        foreach my $idx (0..$#ARGV) {
            my $path = $ARGV[$idx];
            next unless -d $path;

            # chmod 0777, [.foo.bar] doesn't work on VMS, you have to do
            # chmod 0777, [.foo]bar.dir
            my @dirs = File::Spec->splitdir( $path );
            $dirs[-1] .= '.dir';
            $path = File::Spec->catfile(@dirs);

            $ARGV[$idx] = $path;
        }
    }

    chmod(oct $mode,@ARGV) || die "Cannot chmod ".join(' ',$mode,@ARGV).":$!";
}

=item mkpath

    mkpath directory ...

Creates directories, including any parent directories.

=cut

sub mkpath
{
 expand_wildcards();
 require File::Path;
 File::Path::mkpath([@ARGV],0,0777);
}

=item test_f

    test_f file

Tests if a file exists.  I<Exits> with 0 if it does, 1 if it does not (ie.
shell's idea of true and false).

=cut

sub test_f
{
 exit(-f $ARGV[0] ? 0 : 1);
}

=item test_d

    test_d directory

Tests if a directory exists.  I<Exits> with 0 if it does, 1 if it does
not (ie. shell's idea of true and false).

=cut

sub test_d
{
 exit(-d $ARGV[0] ? 0 : 1);
}

=item dos2unix

    dos2unix files or dirs ...

Converts DOS and OS/2 linefeeds to Unix style recursively.

=cut

sub dos2unix {
    require File::Find;
    File::Find::find(sub {
        return if -d;
        return unless -w _;
        return unless -r _;
        return if -B _;

        local $\;

	my $orig = $_;
	my $temp = '.dos2unix_tmp';
	open ORIG, $_ or do { warn "dos2unix can't open $_: $!"; return };
	open TEMP, ">$temp" or
	    do { warn "dos2unix can't create .dos2unix_tmp: $!"; return };
        binmode ORIG; binmode TEMP;
        while (my $line = <ORIG>) {
            $line =~ s/\015\012/\012/g;
            print TEMP $line;
        }
	close ORIG;
	close TEMP;
	rename $temp, $orig;

    }, @ARGV);
}

=back

=head1 SEE ALSO

Shell::Command which is these same functions but take arguments normally.


=head1 AUTHOR

Nick Ing-Simmons C<ni-s@cpan.org>

Maintained by Michael G Schwern C<schwern@pobox.com> within the
ExtUtils-MakeMaker package and, as a separate CPAN package, by
Randy Kobes C<r.kobes@uwinnipeg.ca>.

=cut

PK       ! ���^L  L  $  perl5/ExtUtils/Typemaps/OutputMap.pmnu ��6�$        package ExtUtils::Typemaps::OutputMap;
use 5.006001;
use strict;
use warnings;
our $VERSION = '3.35';

=head1 NAME

ExtUtils::Typemaps::OutputMap - Entry in the OUTPUT section of a typemap

=head1 SYNOPSIS

  use ExtUtils::Typemaps;
  ...
  my $output = $typemap->get_output_map('T_NV');
  my $code = $output->code();
  $output->code("...");

=head1 DESCRIPTION

Refer to L<ExtUtils::Typemaps> for details.

=head1 METHODS

=cut

=head2 new

Requires C<xstype> and C<code> parameters.

=cut

sub new {
  my $prot = shift;
  my $class = ref($prot)||$prot;
  my %args = @_;

  if (!ref($prot)) {
    if (not defined $args{xstype} or not defined $args{code}) {
      die("Need xstype and code parameters");
    }
  }

  my $self = bless(
    (ref($prot) ? {%$prot} : {})
    => $class
  );

  $self->{xstype} = $args{xstype} if defined $args{xstype};
  $self->{code} = $args{code} if defined $args{code};
  $self->{code} =~ s/^(?=\S)/\t/mg;

  return $self;
}

=head2 code

Returns or sets the OUTPUT mapping code for this entry.

=cut

sub code {
  $_[0]->{code} = $_[1] if @_ > 1;
  return $_[0]->{code};
}

=head2 xstype

Returns the name of the XS type of the OUTPUT map.

=cut

sub xstype {
  return $_[0]->{xstype};
}

=head2 cleaned_code

Returns a cleaned-up copy of the code to which certain transformations
have been applied to make it more ANSI compliant.

=cut

sub cleaned_code {
  my $self = shift;
  my $code = $self->code;

  # Move C pre-processor instructions to column 1 to be strictly ANSI
  # conformant. Some pre-processors are fussy about this.
  $code =~ s/^\s+#/#/mg;
  $code =~ s/\s*\z/\n/;

  return $code;
}

=head2 targetable

This is an obscure but effective optimization that used to
live in C<ExtUtils::ParseXS> directly. Not implementing it
should never result in incorrect use of typemaps, just less
efficient code.

In a nutshell, this will check whether the output code
involves calling C<sv_setiv>, C<sv_setuv>, C<sv_setnv>, C<sv_setpv> or
C<sv_setpvn> to set the special C<$arg> placeholder to a new value
B<AT THE END OF THE OUTPUT CODE>. If that is the case, the code is
eligible for using the C<TARG>-related macros to optimize this.
Thus the name of the method: C<targetable>.

If this optimization is applicable, C<ExtUtils::ParseXS> will
emit a C<dXSTARG;> definition at the start of the generated XSUB code,
and type (see below) dependent code to set C<TARG> and push it on
the stack at the end of the generated XSUB code.

If the optimization can not be applied, this returns undef.
If it can be applied, this method returns a hash reference containing
the following information:

  type:      Any of the characters i, u, n, p
  with_size: Bool indicating whether this is the sv_setpvn variant
  what:      The code that actually evaluates to the output scalar
  what_size: If "with_size", this has the string length (as code,
             not constant, including leading comma)

=cut

sub targetable {
  my $self = shift;
  return $self->{targetable} if exists $self->{targetable};

  our $bal; # ()-balanced
  $bal = qr[
    (?:
      (?>[^()]+)
      |
      \( (??{ $bal }) \)
    )*
  ]x;
  my $bal_no_comma = qr[
    (?:
      (?>[^(),]+)
      |
      \( (??{ $bal }) \)
    )+
  ]x;

  # matches variations on (SV*)
  my $sv_cast = qr[
    (?:
      \( \s* SV \s* \* \s* \) \s*
    )?
  ]x;

  my $size = qr[ # Third arg (to setpvn)
    , \s* (??{ $bal })
  ]xo;

  my $code = $self->code;

  # We can still bootstrap compile 're', because in code re.pm is
  # available to miniperl, and does not attempt to load the XS code.
  use re 'eval';

  my ($type, $with_size, $arg, $sarg) =
    ($code =~
      m[^
        \s+
        sv_set([iunp])v(n)?    # Type, is_setpvn
        \s*
        \( \s*
          $sv_cast \$arg \s* , \s*
          ( $bal_no_comma )    # Set from
          ( $size )?           # Possible sizeof set-from
        \s* \) \s* ; \s* $
      ]xo
  );

  my $rv = undef;
  if ($type) {
    $rv = {
      type      => $type,
      with_size => $with_size,
      what      => $arg,
      what_size => $sarg,
    };
  }
  $self->{targetable} = $rv;
  return $rv;
}

=head1 SEE ALSO

L<ExtUtils::Typemaps>

=head1 AUTHOR

Steffen Mueller C<<smueller@cpan.org>>

=head1 COPYRIGHT & LICENSE

Copyright 2009, 2010, 2011, 2012 Steffen Mueller

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

=cut

1;

PK       ! �����  �  #  perl5/ExtUtils/Typemaps/InputMap.pmnu ��6�$        package ExtUtils::Typemaps::InputMap;
use 5.006001;
use strict;
use warnings;
our $VERSION = '3.35';

=head1 NAME

ExtUtils::Typemaps::InputMap - Entry in the INPUT section of a typemap

=head1 SYNOPSIS

  use ExtUtils::Typemaps;
  ...
  my $input = $typemap->get_input_map('T_NV');
  my $code = $input->code();
  $input->code("...");

=head1 DESCRIPTION

Refer to L<ExtUtils::Typemaps> for details.

=head1 METHODS

=cut

=head2 new

Requires C<xstype> and C<code> parameters.

=cut

sub new {
  my $prot = shift;
  my $class = ref($prot)||$prot;
  my %args = @_;

  if (!ref($prot)) {
    if (not defined $args{xstype} or not defined $args{code}) {
      die("Need xstype and code parameters");
    }
  }

  my $self = bless(
    (ref($prot) ? {%$prot} : {})
    => $class
  );

  $self->{xstype} = $args{xstype} if defined $args{xstype};
  $self->{code} = $args{code} if defined $args{code};
  $self->{code} =~ s/^(?=\S)/\t/mg;

  return $self;
}

=head2 code

Returns or sets the INPUT mapping code for this entry.

=cut

sub code {
  $_[0]->{code} = $_[1] if @_ > 1;
  return $_[0]->{code};
}

=head2 xstype

Returns the name of the XS type of the INPUT map.

=cut

sub xstype {
  return $_[0]->{xstype};
}

=head2 cleaned_code

Returns a cleaned-up copy of the code to which certain transformations
have been applied to make it more ANSI compliant.

=cut

sub cleaned_code {
  my $self = shift;
  my $code = $self->code;

  $code =~ s/(?:;+\s*|;*\s+)\z//s;

  # Move C pre-processor instructions to column 1 to be strictly ANSI
  # conformant. Some pre-processors are fussy about this.
  $code =~ s/^\s+#/#/mg;
  $code =~ s/\s*\z/\n/;

  return $code;
}

=head1 SEE ALSO

L<ExtUtils::Typemaps>

=head1 AUTHOR

Steffen Mueller C<<smueller@cpan.org>>

=head1 COPYRIGHT & LICENSE

Copyright 2009, 2010, 2011, 2012 Steffen Mueller

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

=cut

1;

PK       ! H��X%  %    perl5/ExtUtils/Typemaps/Type.pmnu ��6�$        package ExtUtils::Typemaps::Type;
use 5.006001;
use strict;
use warnings;
require ExtUtils::Typemaps;

our $VERSION = '3.35';

=head1 NAME

ExtUtils::Typemaps::Type - Entry in the TYPEMAP section of a typemap

=head1 SYNOPSIS

  use ExtUtils::Typemaps;
  ...
  my $type = $typemap->get_type_map('char*');
  my $input = $typemap->get_input_map($type->xstype);

=head1 DESCRIPTION

Refer to L<ExtUtils::Typemaps> for details.
Object associates C<ctype> with C<xstype>, which is the index
into the in- and output mapping tables.

=head1 METHODS

=cut

=head2 new

Requires C<xstype> and C<ctype> parameters.

Optionally takes C<prototype> parameter.

=cut

sub new {
  my $prot = shift;
  my $class = ref($prot)||$prot;
  my %args = @_;

  if (!ref($prot)) {
    if (not defined $args{xstype} or not defined $args{ctype}) {
      die("Need xstype and ctype parameters");
    }
  }

  my $self = bless(
    (ref($prot) ? {%$prot} : {proto => ''})
    => $class
  );

  $self->{xstype} = $args{xstype} if defined $args{xstype};
  $self->{ctype} = $args{ctype} if defined $args{ctype};
  $self->{tidy_ctype} = ExtUtils::Typemaps::tidy_type($self->{ctype});
  $self->{proto} = $args{'prototype'} if defined $args{'prototype'};

  return $self;
}

=head2 proto

Returns or sets the prototype.

=cut

sub proto {
  $_[0]->{proto} = $_[1] if @_ > 1;
  return $_[0]->{proto};
}

=head2 xstype

Returns the name of the XS type that this C type is associated to.

=cut

sub xstype {
  return $_[0]->{xstype};
}

=head2 ctype

Returns the name of the C type as it was set on construction.

=cut

sub ctype {
  return defined($_[0]->{ctype}) ? $_[0]->{ctype} : $_[0]->{tidy_ctype};
}

=head2 tidy_ctype

Returns the canonicalized name of the C type.

=cut

sub tidy_ctype {
  return $_[0]->{tidy_ctype};
}

=head1 SEE ALSO

L<ExtUtils::Typemaps>

=head1 AUTHOR

Steffen Mueller C<<smueller@cpan.org>>

=head1 COPYRIGHT & LICENSE

Copyright 2009, 2010, 2011, 2012 Steffen Mueller

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

=cut

1;

PK       ! ��B%  %    perl5/ExtUtils/Typemaps/Cmd.pmnu ��6�$        package ExtUtils::Typemaps::Cmd;
use 5.006001;
use strict;
use warnings;
our $VERSION = '3.35';

use ExtUtils::Typemaps;

require Exporter;

our @ISA = qw(Exporter);
our @EXPORT = qw(embeddable_typemap);
our %EXPORT_TAGS = (all => \@EXPORT);

sub embeddable_typemap {
  my @tms = @_;

  # Get typemap objects
  my @tm_objs = map [$_, _intuit_typemap_source($_)], @tms;

  # merge or short-circuit
  my $final_tm;
  if (@tm_objs == 1) {
    # just one, merge would be pointless
    $final_tm = shift(@tm_objs)->[1];
  }
  else {
    # multiple, need merge
    $final_tm = ExtUtils::Typemaps->new;
    foreach my $other_tm (@tm_objs) {
      my ($tm_ident, $tm_obj) = @$other_tm;
      eval {
        $final_tm->merge(typemap => $tm_obj);
        1
      } or do {
        my $err = $@ || 'Zombie error';
        die "Failed to merge typ";
      }
    }
  }

  # stringify for embedding
  return $final_tm->as_embedded_typemap();
}

sub _load_module {
  my $name = shift;
  return eval "require $name; 1";
}

SCOPE: {
  my %sources = (
    module => sub {
      my $ident = shift;
      my $tm;
      if (/::/) { # looks like FQ module name, try that first
        foreach my $module ($ident, "ExtUtils::Typemaps::$ident") {
          if (_load_module($module)) {
            eval { $tm = $module->new }
              and return $tm;
          }
        }
      }
      else {
        foreach my $module ("ExtUtils::Typemaps::$ident", "$ident") {
          if (_load_module($module)) {
            eval { $tm = $module->new }
              and return $tm;
          }
        }
      }
      return();
    },
    file => sub {
      my $ident = shift;
      return unless -e $ident and -r _;
      return ExtUtils::Typemaps->new(file => $ident);
    },
  );
  # Try to find typemap either from module or file
  sub _intuit_typemap_source {
    my $identifier = shift;

    my @locate_attempts;
    if ($identifier =~ /::/ || $identifier !~ /[^\w_]/) {
      @locate_attempts = qw(module file);
    }
    else {
      @locate_attempts = qw(file module);
    }

    foreach my $source (@locate_attempts) {
      my $tm = $sources{$source}->($identifier);
      return $tm if defined $tm;
    }

    die "Unable to find typemap for '$identifier': "
        . "Tried to load both as file or module and failed.\n";
  }
} # end SCOPE

=head1 NAME

ExtUtils::Typemaps::Cmd - Quick commands for handling typemaps

=head1 SYNOPSIS

From XS:

  INCLUDE_COMMAND: $^X -MExtUtils::Typemaps::Cmd \
                   -e "print embeddable_typemap(q{Excommunicated})"

Loads C<ExtUtils::Typemaps::Excommunicated>, instantiates an object,
and dumps it as an embeddable typemap for use directly in your XS file.

=head1 DESCRIPTION

This is a helper module for L<ExtUtils::Typemaps> for quick
one-liners, specifically for inclusion of shared typemaps
that live on CPAN into an XS file (see SYNOPSIS).

For this reason, the following functions are exported by default:

=head1 EXPORTED FUNCTIONS

=head2 embeddable_typemap

Given a list of identifiers, C<embeddable_typemap>
tries to load typemaps from a file of the given name(s),
or from a module that is an C<ExtUtils::Typemaps> subclass.

Returns a string representation of the merged typemaps that can
be included verbatim into XS. Example:

  print embeddable_typemap(
    "Excommunicated", "ExtUtils::Typemaps::Basic", "./typemap"
  );

This will try to load a module C<ExtUtils::Typemaps::Excommunicated>
and use it as an C<ExtUtils::Typemaps> subclass. If that fails, it'll
try loading C<Excommunicated> as a module, if that fails, it'll try to
read a file called F<Excommunicated>. It'll work similarly for the
second argument, but the third will be loaded as a file first.

After loading all typemap files or modules, it will merge them in the
specified order and dump the result as an embeddable typemap.

=head1 SEE ALSO

L<ExtUtils::Typemaps>

L<perlxs>

=head1 AUTHOR

Steffen Mueller C<<smueller@cpan.org>>

=head1 COPYRIGHT & LICENSE

Copyright 2012 Steffen Mueller

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

=cut

1;

PK       ! ��Ht�
 �
   perl5/ExtUtils/MM_VMS.pmnu ��6�$        package ExtUtils::MM_VMS;

use strict;
use warnings;

use ExtUtils::MakeMaker::Config;
require Exporter;

BEGIN {
    # so we can compile the thing on non-VMS platforms.
    if( $^O eq 'VMS' ) {
        require VMS::Filespec;
        VMS::Filespec->import;
    }
}

use File::Basename;

our $VERSION = '7.50';
$VERSION =~ tr/_//d;

require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );

use ExtUtils::MakeMaker qw($Verbose neatvalue _sprintf562);
our $Revision = $ExtUtils::MakeMaker::Revision;


=head1 NAME

ExtUtils::MM_VMS - methods to override UN*X behaviour in ExtUtils::MakeMaker

=head1 SYNOPSIS

  Do not use this directly.
  Instead, use ExtUtils::MM and it will figure out which MM_*
  class to use for you.

=head1 DESCRIPTION

See L<ExtUtils::MM_Unix> for a documentation of the methods provided
there. This package overrides the implementation of these methods, not
the semantics.

=head2 Methods always loaded

=over 4

=item wraplist

Converts a list into a string wrapped at approximately 80 columns.

=cut

sub wraplist {
    my($self) = shift;
    my($line,$hlen) = ('',0);

    foreach my $word (@_) {
      # Perl bug -- seems to occasionally insert extra elements when
      # traversing array (scalar(@array) doesn't show them, but
      # foreach(@array) does) (5.00307)
      next unless $word =~ /\w/;
      $line .= ' ' if length($line);
      if ($hlen > 80) { $line .= "\\\n\t"; $hlen = 0; }
      $line .= $word;
      $hlen += length($word) + 2;
    }
    $line;
}


# This isn't really an override.  It's just here because ExtUtils::MM_VMS
# appears in @MM::ISA before ExtUtils::Liblist::Kid, so if there isn't an ext()
# in MM_VMS, then AUTOLOAD is called, and bad things happen.  So, we just
# mimic inheritance here and hand off to ExtUtils::Liblist::Kid.
# XXX This hackery will die soon. --Schwern
sub ext {
    require ExtUtils::Liblist::Kid;
    goto &ExtUtils::Liblist::Kid::ext;
}

=back

=head2 Methods

Those methods which override default MM_Unix methods are marked
"(override)", while methods unique to MM_VMS are marked "(specific)".
For overridden methods, documentation is limited to an explanation
of why this method overrides the MM_Unix method; see the L<ExtUtils::MM_Unix>
documentation for more details.

=over 4

=item guess_name (override)

Try to determine name of extension being built.  We begin with the name
of the current directory.  Since VMS filenames are case-insensitive,
however, we look for a F<.pm> file whose name matches that of the current
directory (presumably the 'main' F<.pm> file for this extension), and try
to find a C<package> statement from which to obtain the Mixed::Case
package name.

=cut

sub guess_name {
    my($self) = @_;
    my($defname,$defpm,@pm,%xs);
    local *PM;

    $defname = basename(fileify($ENV{'DEFAULT'}));
    $defname =~ s![\d\-_]*\.dir.*$!!;  # Clip off .dir;1 suffix, and package version
    $defpm = $defname;
    # Fallback in case for some reason a user has copied the files for an
    # extension into a working directory whose name doesn't reflect the
    # extension's name.  We'll use the name of a unique .pm file, or the
    # first .pm file with a matching .xs file.
    if (not -e "${defpm}.pm") {
      @pm = glob('*.pm');
      s/.pm$// for @pm;
      if (@pm == 1) { ($defpm = $pm[0]) =~ s/.pm$//; }
      elsif (@pm) {
        %xs = map { s/.xs$//; ($_,1) } glob('*.xs');  ## no critic
        if (keys %xs) {
            foreach my $pm (@pm) {
                $defpm = $pm, last if exists $xs{$pm};
            }
        }
      }
    }
    if (open(my $pm, '<', "${defpm}.pm")){
        while (<$pm>) {
            if (/^\s*package\s+([^;]+)/i) {
                $defname = $1;
                last;
            }
        }
        print "Warning (non-fatal): Couldn't find package name in ${defpm}.pm;\n\t",
                     "defaulting package name to $defname\n"
            if eof($pm);
        close $pm;
    }
    else {
        print "Warning (non-fatal): Couldn't find ${defpm}.pm;\n\t",
                     "defaulting package name to $defname\n";
    }
    $defname =~ s#[\d.\-_]+$##;
    $defname;
}

=item find_perl (override)

Use VMS file specification syntax and CLI commands to find and
invoke Perl images.

=cut

sub find_perl {
    my($self, $ver, $names, $dirs, $trace) = @_;
    my($vmsfile,@sdirs,@snames,@cand);
    my($rslt);
    my($inabs) = 0;
    local *TCF;

    if( $self->{PERL_CORE} ) {
        # Check in relative directories first, so we pick up the current
        # version of Perl if we're running MakeMaker as part of the main build.
        @sdirs = sort { my($absa) = $self->file_name_is_absolute($a);
                        my($absb) = $self->file_name_is_absolute($b);
                        if ($absa && $absb) { return $a cmp $b }
                        else { return $absa ? 1 : ($absb ? -1 : ($a cmp $b)); }
                      } @$dirs;
        # Check miniperl before perl, and check names likely to contain
        # version numbers before "generic" names, so we pick up an
        # executable that's less likely to be from an old installation.
        @snames = sort { my($ba) = $a =~ m!([^:>\]/]+)$!;  # basename
                         my($bb) = $b =~ m!([^:>\]/]+)$!;
                         my($ahasdir) = (length($a) - length($ba) > 0);
                         my($bhasdir) = (length($b) - length($bb) > 0);
                         if    ($ahasdir and not $bhasdir) { return 1; }
                         elsif ($bhasdir and not $ahasdir) { return -1; }
                         else { $bb =~ /\d/ <=> $ba =~ /\d/
                                  or substr($ba,0,1) cmp substr($bb,0,1)
                                  or length($bb) <=> length($ba) } } @$names;
    }
    else {
        @sdirs  = @$dirs;
        @snames = @$names;
    }

    # Image names containing Perl version use '_' instead of '.' under VMS
    s/\.(\d+)$/_$1/ for @snames;
    if ($trace >= 2){
        print "Looking for perl $ver by these names:\n";
        print "\t@snames,\n";
        print "in these dirs:\n";
        print "\t@sdirs\n";
    }
    foreach my $dir (@sdirs){
        next unless defined $dir; # $self->{PERL_SRC} may be undefined
        $inabs++ if $self->file_name_is_absolute($dir);
        if ($inabs == 1) {
            # We've covered relative dirs; everything else is an absolute
            # dir (probably an installed location).  First, we'll try
            # potential command names, to see whether we can avoid a long
            # MCR expression.
            foreach my $name (@snames) {
                push(@cand,$name) if $name =~ /^[\w\-\$]+$/;
            }
            $inabs++; # Should happen above in next $dir, but just in case...
        }
        foreach my $name (@snames){
            push @cand, ($name !~ m![/:>\]]!) ? $self->catfile($dir,$name)
                                              : $self->fixpath($name,0);
        }
    }
    foreach my $name (@cand) {
        print "Checking $name\n" if $trace >= 2;
        # If it looks like a potential command, try it without the MCR
        if ($name =~ /^[\w\-\$]+$/) {
            open(my $tcf, ">", "temp_mmvms.com")
                or die('unable to open temp file');
            print $tcf "\$ set message/nofacil/nosever/noident/notext\n";
            print $tcf "\$ $name -e \"require $ver; print \"\"VER_OK\\n\"\"\"\n";
            close $tcf;
            $rslt = `\@temp_mmvms.com` ;
            unlink('temp_mmvms.com');
            if ($rslt =~ /VER_OK/) {
                print "Using PERL=$name\n" if $trace;
                return $name;
            }
        }
        next unless $vmsfile = $self->maybe_command($name);
        $vmsfile =~ s/;[\d\-]*$//;  # Clip off version number; we can use a newer version as well
        print "Executing $vmsfile\n" if ($trace >= 2);
        open(my $tcf, '>', "temp_mmvms.com")
                or die('unable to open temp file');
        print $tcf "\$ set message/nofacil/nosever/noident/notext\n";
        print $tcf "\$ mcr $vmsfile -e \"require $ver; print \"\"VER_OK\\n\"\"\" \n";
        close $tcf;
        $rslt = `\@temp_mmvms.com`;
        unlink('temp_mmvms.com');
        if ($rslt =~ /VER_OK/) {
            print "Using PERL=MCR $vmsfile\n" if $trace;
            return "MCR $vmsfile";
        }
    }
    print "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n";
    0; # false and not empty
}

=item _fixin_replace_shebang (override)

Helper routine for L<< MM->fixin()|ExtUtils::MM_Unix/fixin >>, overridden
because there's no such thing as an
actual shebang line that will be interpreted by the shell, so we just prepend
$Config{startperl} and preserve the shebang line argument for any switches it
may contain.

=cut

sub _fixin_replace_shebang {
    my ( $self, $file, $line ) = @_;

    my ( undef, $arg ) = split ' ', $line, 2;

    return $Config{startperl} . "\n" . $Config{sharpbang} . "perl $arg\n";
}

=item maybe_command (override)

Follows VMS naming conventions for executable files.
If the name passed in doesn't exactly match an executable file,
appends F<.Exe> (or equivalent) to check for executable image, and F<.Com>
to check for DCL procedure.  If this fails, checks directories in DCL$PATH
and finally F<Sys$System:> for an executable file having the name specified,
with or without the F<.Exe>-equivalent suffix.

=cut

sub maybe_command {
    my($self,$file) = @_;
    return $file if -x $file && ! -d _;
    my(@dirs) = ('');
    my(@exts) = ('',$Config{'exe_ext'},'.exe','.com');

    if ($file !~ m![/:>\]]!) {
        for (my $i = 0; defined $ENV{"DCL\$PATH;$i"}; $i++) {
            my $dir = $ENV{"DCL\$PATH;$i"};
            $dir .= ':' unless $dir =~ m%[\]:]$%;
            push(@dirs,$dir);
        }
        push(@dirs,'Sys$System:');
        foreach my $dir (@dirs) {
            my $sysfile = "$dir$file";
            foreach my $ext (@exts) {
                return $file if -x "$sysfile$ext" && ! -d _;
            }
        }
    }
    return 0;
}


=item pasthru (override)

The list of macro definitions to be passed through must be specified using
the /MACRO qualifier and must not add another /DEFINE qualifier.  We prepend
our own comma here to the contents of $(PASTHRU_DEFINE) because it is often
empty and a comma always present in CCFLAGS would generate a missing
qualifier value error.

=cut

sub pasthru {
    my($self) = shift;
    my $pasthru = $self->SUPER::pasthru;
    $pasthru =~ s|(PASTHRU\s*=\s*)|$1/MACRO=(|;
    $pasthru =~ s|\n\z|)\n|m;
    $pasthru =~ s|/defi?n?e?=\(?([^\),]+)\)?|,$1|ig;

    return $pasthru;
}


=item pm_to_blib (override)

VMS wants a dot in every file so we can't have one called 'pm_to_blib',
it becomes 'pm_to_blib.' and MMS/K isn't smart enough to know that when
you have a target called 'pm_to_blib' it should look for 'pm_to_blib.'.

So in VMS its pm_to_blib.ts.

=cut

sub pm_to_blib {
    my $self = shift;

    my $make = $self->SUPER::pm_to_blib;

    $make =~ s{^pm_to_blib :}{pm_to_blib.ts :}m;
    $make =~ s{\$\(TOUCH\) pm_to_blib}{\$(TOUCH) pm_to_blib.ts};

    $make = <<'MAKE' . $make;
# Dummy target to match Unix target name; we use pm_to_blib.ts as
# timestamp file to avoid repeated invocations under VMS
pm_to_blib : pm_to_blib.ts
	$(NOECHO) $(NOOP)

MAKE

    return $make;
}


=item perl_script (override)

If name passed in doesn't specify a readable file, appends F<.com> or
F<.pl> and tries again, since it's customary to have file types on all files
under VMS.

=cut

sub perl_script {
    my($self,$file) = @_;
    return $file if -r $file && ! -d _;
    return "$file.com" if -r "$file.com";
    return "$file.pl" if -r "$file.pl";
    return '';
}


=item replace_manpage_separator

Use as separator a character which is legal in a VMS-syntax file name.

=cut

sub replace_manpage_separator {
    my($self,$man) = @_;
    $man = unixify($man);
    $man =~ s#/+#__#g;
    $man;
}

=item init_DEST

(override) Because of the difficulty concatenating VMS filepaths we
must pre-expand the DEST* variables.

=cut

sub init_DEST {
    my $self = shift;

    $self->SUPER::init_DEST;

    # Expand DEST variables.
    foreach my $var ($self->installvars) {
        my $destvar = 'DESTINSTALL'.$var;
        $self->{$destvar} = $self->eliminate_macros($self->{$destvar});
    }
}


=item init_DIRFILESEP

No separator between a directory path and a filename on VMS.

=cut

sub init_DIRFILESEP {
    my($self) = shift;

    $self->{DIRFILESEP} = '';
    return 1;
}


=item init_main (override)


=cut

sub init_main {
    my($self) = shift;

    $self->SUPER::init_main;

    $self->{DEFINE} ||= '';
    if ($self->{DEFINE} ne '') {
        my(@terms) = split(/\s+/,$self->{DEFINE});
        my(@defs,@udefs);
        foreach my $def (@terms) {
            next unless $def;
            my $targ = \@defs;
            if ($def =~ s/^-([DU])//) {    # If it was a Unix-style definition
                $targ = \@udefs if $1 eq 'U';
                $def =~ s/='(.*)'$/=$1/;  # then remove shell-protection ''
                $def =~ s/^'(.*)'$/$1/;   # from entire term or argument
            }
            if ($def =~ /=/) {
                $def =~ s/"/""/g;  # Protect existing " from DCL
                $def = qq["$def"]; # and quote to prevent parsing of =
            }
            push @$targ, $def;
        }

        $self->{DEFINE} = '';
        if (@defs)  {
            $self->{DEFINE}  = '/Define=(' . join(',',@defs)  . ')';
        }
        if (@udefs) {
            $self->{DEFINE} .= '/Undef=('  . join(',',@udefs) . ')';
        }
    }
}

=item init_tools (override)

Provide VMS-specific forms of various utility commands.

Sets DEV_NULL to nothing because I don't know how to do it on VMS.

Changes EQUALIZE_TIMESTAMP to set revision date of target file to
one second later than source file, since MMK interprets precisely
equal revision dates for a source and target file as a sign that the
target needs to be updated.

=cut

sub init_tools {
    my($self) = @_;

    $self->{NOOP}               = 'Continue';
    $self->{NOECHO}             ||= '@ ';

    $self->{MAKEFILE}           ||= $self->{FIRST_MAKEFILE} || 'Descrip.MMS';
    $self->{FIRST_MAKEFILE}     ||= $self->{MAKEFILE};
    $self->{MAKE_APERL_FILE}    ||= 'Makeaperl.MMS';
    $self->{MAKEFILE_OLD}       ||= $self->eliminate_macros('$(FIRST_MAKEFILE)_old');
#
#   If an extension is not specified, then MMS/MMK assumes an
#   an extension of .MMS.  If there really is no extension,
#   then a trailing "." needs to be appended to specify a
#   a null extension.
#
    $self->{MAKEFILE} .= '.' unless $self->{MAKEFILE} =~ m/\./;
    $self->{FIRST_MAKEFILE} .= '.' unless $self->{FIRST_MAKEFILE} =~ m/\./;
    $self->{MAKE_APERL_FILE} .= '.' unless $self->{MAKE_APERL_FILE} =~ m/\./;
    $self->{MAKEFILE_OLD} .= '.' unless $self->{MAKEFILE_OLD} =~ m/\./;

    $self->{MACROSTART}         ||= '/Macro=(';
    $self->{MACROEND}           ||= ')';
    $self->{USEMAKEFILE}        ||= '/Descrip=';

    $self->{EQUALIZE_TIMESTAMP} ||= '$(ABSPERLRUN) -we "open F,qq{>>$ARGV[1]};close F;utime(0,(stat($ARGV[0]))[9]+1,$ARGV[1])"';

    $self->{MOD_INSTALL} ||=
      $self->oneliner(<<'CODE', ['-MExtUtils::Install']);
install([ from_to => {split('\|', <STDIN>)}, verbose => '$(VERBINST)', uninstall_shadows => '$(UNINST)', dir_mode => '$(PERM_DIR)' ]);
CODE

    $self->{UMASK_NULL} = '! ';

    $self->SUPER::init_tools;

    # Use the default shell
    $self->{SHELL}    ||= 'Posix';

    # Redirection on VMS goes before the command, not after as on Unix.
    # $(DEV_NULL) is used once and its not worth going nuts over making
    # it work.  However, Unix's DEV_NULL is quite wrong for VMS.
    $self->{DEV_NULL}   = '';

    return;
}

=item init_platform (override)

Add PERL_VMS, MM_VMS_REVISION and MM_VMS_VERSION.

MM_VMS_REVISION is for backwards compatibility before MM_VMS had a
$VERSION.

=cut

sub init_platform {
    my($self) = shift;

    $self->{MM_VMS_REVISION} = $Revision;
    $self->{MM_VMS_VERSION}  = $VERSION;
    $self->{PERL_VMS} = $self->catdir($self->{PERL_SRC}, 'VMS')
      if $self->{PERL_SRC};
}


=item platform_constants

=cut

sub platform_constants {
    my($self) = shift;
    my $make_frag = '';

    foreach my $macro (qw(PERL_VMS MM_VMS_REVISION MM_VMS_VERSION))
    {
        next unless defined $self->{$macro};
        $make_frag .= "$macro = $self->{$macro}\n";
    }

    return $make_frag;
}


=item init_VERSION (override)

Override the *DEFINE_VERSION macros with VMS semantics.  Translate the
MAKEMAKER filepath to VMS style.

=cut

sub init_VERSION {
    my $self = shift;

    $self->SUPER::init_VERSION;

    $self->{DEFINE_VERSION}    = '"$(VERSION_MACRO)=""$(VERSION)"""';
    $self->{XS_DEFINE_VERSION} = '"$(XS_VERSION_MACRO)=""$(XS_VERSION)"""';
    $self->{MAKEMAKER} = vmsify($INC{'ExtUtils/MakeMaker.pm'});
}


=item constants (override)

Fixes up numerous file and directory macros to insure VMS syntax
regardless of input syntax.  Also makes lists of files
comma-separated.

=cut

sub constants {
    my($self) = @_;

    # Be kind about case for pollution
    for (@ARGV) { $_ = uc($_) if /POLLUTE/i; }

    # Cleanup paths for directories in MMS macros.
    foreach my $macro ( qw [
            INST_BIN INST_SCRIPT INST_LIB INST_ARCHLIB
            PERL_LIB PERL_ARCHLIB PERL_ARCHLIBDEP
            PERL_INC PERL_SRC ],
                        (map { 'INSTALL'.$_ } $self->installvars),
                        (map { 'DESTINSTALL'.$_ } $self->installvars)
                      )
    {
        next unless defined $self->{$macro};
        next if $macro =~ /MAN/ && $self->{$macro} eq 'none';
        $self->{$macro} = $self->fixpath($self->{$macro},1);
    }

    # Cleanup paths for files in MMS macros.
    foreach my $macro ( qw[LIBPERL_A FIRST_MAKEFILE MAKEFILE_OLD
                           MAKE_APERL_FILE MYEXTLIB] )
    {
        next unless defined $self->{$macro};
        $self->{$macro} = $self->fixpath($self->{$macro},0);
    }

    # Fixup files for MMS macros
    # XXX is this list complete?
    for my $macro (qw/
                   FULLEXT VERSION_FROM
	      /	) {
        next unless defined $self->{$macro};
        $self->{$macro} = $self->fixpath($self->{$macro},0);
    }


    for my $macro (qw/
                   OBJECT LDFROM
	      /	) {
        next unless defined $self->{$macro};

        # Must expand macros before splitting on unescaped whitespace.
        $self->{$macro} = $self->eliminate_macros($self->{$macro});
        if ($self->{$macro} =~ /(?<!\^)\s/) {
            $self->{$macro} =~ s/(\\)?\n+\s+/ /g;
            $self->{$macro} = $self->wraplist(
                map $self->fixpath($_,0), split /,?(?<!\^)\s+/, $self->{$macro}
            );
        }
        else {
            $self->{$macro} = $self->fixpath($self->{$macro},0);
        }
    }

    for my $macro (qw/ XS MAN1PODS MAN3PODS PM /) {
        # Where is the space coming from? --jhi
        next unless $self ne " " && defined $self->{$macro};
        my %tmp = ();
        for my $key (keys %{$self->{$macro}}) {
            $tmp{$self->fixpath($key,0)} =
                                     $self->fixpath($self->{$macro}{$key},0);
        }
        $self->{$macro} = \%tmp;
    }

    for my $macro (qw/ C O_FILES H /) {
        next unless defined $self->{$macro};
        my @tmp = ();
        for my $val (@{$self->{$macro}}) {
            push(@tmp,$self->fixpath($val,0));
        }
        $self->{$macro} = \@tmp;
    }

    # mms/k does not define a $(MAKE) macro.
    $self->{MAKE} = '$(MMS)$(MMSQUALIFIERS)';

    return $self->SUPER::constants;
}


=item special_targets

Clear the default .SUFFIXES and put in our own list.

=cut

sub special_targets {
    my $self = shift;

    my $make_frag .= <<'MAKE_FRAG';
.SUFFIXES :
.SUFFIXES : $(OBJ_EXT) .c .cpp .cxx .xs

MAKE_FRAG

    return $make_frag;
}

=item cflags (override)

Bypass shell script and produce qualifiers for CC directly (but warn
user if a shell script for this extension exists).  Fold multiple
/Defines into one, since some C compilers pay attention to only one
instance of this qualifier on the command line.

=cut

sub cflags {
    my($self,$libperl) = @_;
    my($quals) = $self->{CCFLAGS} || $Config{'ccflags'};
    my($definestr,$undefstr,$flagoptstr) = ('','','');
    my($incstr) = '/Include=($(PERL_INC)';
    my($name,$sys,@m);

    ( $name = $self->{NAME} . "_cflags" ) =~ s/:/_/g ;
    print "Unix shell script ".$Config{"$self->{'BASEEXT'}_cflags"}.
         " required to modify CC command for $self->{'BASEEXT'}\n"
    if ($Config{$name});

    if ($quals =~ / -[DIUOg]/) {
	while ($quals =~ / -([Og])(\d*)\b/) {
	    my($type,$lvl) = ($1,$2);
	    $quals =~ s/ -$type$lvl\b\s*//;
	    if ($type eq 'g') { $flagoptstr = '/NoOptimize'; }
	    else { $flagoptstr = '/Optimize' . (defined($lvl) ? "=$lvl" : ''); }
	}
	while ($quals =~ / -([DIU])(\S+)/) {
	    my($type,$def) = ($1,$2);
	    $quals =~ s/ -$type$def\s*//;
	    $def =~ s/"/""/g;
	    if    ($type eq 'D') { $definestr .= qq["$def",]; }
	    elsif ($type eq 'I') { $incstr .= ',' . $self->fixpath($def,1); }
	    else                 { $undefstr  .= qq["$def",]; }
	}
    }
    if (length $quals and $quals !~ m!/!) {
	warn "MM_VMS: Ignoring unrecognized CCFLAGS elements \"$quals\"\n";
	$quals = '';
    }
    $definestr .= q["PERL_POLLUTE",] if $self->{POLLUTE};
    if (length $definestr) { chop($definestr); $quals .= "/Define=($definestr)"; }
    if (length $undefstr)  { chop($undefstr);  $quals .= "/Undef=($undefstr)";   }
    # Deal with $self->{DEFINE} here since some C compilers pay attention
    # to only one /Define clause on command line, so we have to
    # conflate the ones from $Config{'ccflags'} and $self->{DEFINE}
    # ($self->{DEFINE} has already been VMSified in constants() above)
    if ($self->{DEFINE}) { $quals .= $self->{DEFINE}; }
    for my $type (qw(Def Undef)) {
	my(@terms);
	while ($quals =~ m:/${type}i?n?e?=([^/]+):ig) {
		my $term = $1;
		$term =~ s:^\((.+)\)$:$1:;
		push @terms, $term;
	}
	if ($type eq 'Def') {
	    push @terms, qw[ $(DEFINE_VERSION) $(XS_DEFINE_VERSION) ];
	}
	if (@terms) {
	    $quals =~ s:/${type}i?n?e?=[^/]+::ig;
            # PASTHRU_DEFINE will have its own comma
	    $quals .= "/${type}ine=(" . join(',',@terms) . ($type eq 'Def' ? '$(PASTHRU_DEFINE)' : '') . ')';
	}
    }

    $libperl or $libperl = $self->{LIBPERL_A} || "libperl.olb";

    # Likewise with $self->{INC} and /Include
    if ($self->{'INC'}) {
	my(@includes) = split(/\s+/,$self->{INC});
	foreach (@includes) {
	    s/^-I//;
	    $incstr .= ','.$self->fixpath($_,1);
	}
    }
    $quals .= "$incstr)";
#    $quals =~ s/,,/,/g; $quals =~ s/\(,/(/g;
    $self->{CCFLAGS} = $quals;

    $self->{PERLTYPE} ||= '';

    $self->{OPTIMIZE} ||= $flagoptstr || $Config{'optimize'};
    if ($self->{OPTIMIZE} !~ m!/!) {
	if    ($self->{OPTIMIZE} =~ m!-g!) { $self->{OPTIMIZE} = '/Debug/NoOptimize' }
	elsif ($self->{OPTIMIZE} =~ /-O(\d*)/) {
	    $self->{OPTIMIZE} = '/Optimize' . (defined($1) ? "=$1" : '');
	}
	else {
	    warn "MM_VMS: Can't parse OPTIMIZE \"$self->{OPTIMIZE}\"; using default\n" if length $self->{OPTIMIZE};
	    $self->{OPTIMIZE} = '/Optimize';
	}
    }

    return $self->{CFLAGS} = qq{
CCFLAGS = $self->{CCFLAGS}
OPTIMIZE = $self->{OPTIMIZE}
PERLTYPE = $self->{PERLTYPE}
};
}

=item const_cccmd (override)

Adds directives to point C preprocessor to the right place when
handling #include E<lt>sys/foo.hE<gt> directives.  Also constructs CC
command line a bit differently than MM_Unix method.

=cut

sub const_cccmd {
    my($self,$libperl) = @_;
    my(@m);

    return $self->{CONST_CCCMD} if $self->{CONST_CCCMD};
    return '' unless $self->needs_linking();
    if ($Config{'vms_cc_type'} eq 'gcc') {
        push @m,'
.FIRST
	',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" Then Define/NoLog SYS GNU_CC_Include:[VMS]';
    }
    elsif ($Config{'vms_cc_type'} eq 'vaxc') {
        push @m,'
.FIRST
	',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("VAXC$Include").eqs."" Then Define/NoLog SYS Sys$Library
	',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("VAXC$Include").nes."" Then Define/NoLog SYS VAXC$Include';
    }
    else {
        push @m,'
.FIRST
	',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("DECC$System_Include").eqs."" Then Define/NoLog SYS ',
		($Config{'archname'} eq 'VMS_AXP' ? 'Sys$Library' : 'DECC$Library_Include'),'
	',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("DECC$System_Include").nes."" Then Define/NoLog SYS DECC$System_Include';
    }

    push(@m, "\n\nCCCMD = $Config{'cc'} \$(CCFLAGS)\$(OPTIMIZE)\n");

    $self->{CONST_CCCMD} = join('',@m);
}


=item tools_other (override)

Throw in some dubious extra macros for Makefile args.

Also keep around the old $(SAY) macro in case somebody's using it.

=cut

sub tools_other {
    my($self) = @_;

    # XXX Are these necessary?  Does anyone override them?  They're longer
    # than just typing the literal string.
    my $extra_tools = <<'EXTRA_TOOLS';

# Just in case anyone is using the old macro.
USEMACROS = $(MACROSTART)
SAY = $(ECHO)

EXTRA_TOOLS

    return $self->SUPER::tools_other . $extra_tools;
}

=item init_dist (override)

VMSish defaults for some values.

  macro         description                     default

  ZIPFLAGS      flags to pass to ZIP            -Vu

  COMPRESS      compression command to          gzip
                use for tarfiles
  SUFFIX        suffix to put on                -gz
                compressed files

  SHAR          shar command to use             vms_share

  DIST_DEFAULT  default target to use to        tardist
                create a distribution

  DISTVNAME     Use VERSION_SYM instead of      $(DISTNAME)-$(VERSION_SYM)
                VERSION for the name

=cut

sub init_dist {
    my($self) = @_;
    $self->{ZIPFLAGS}     ||= '-Vu';
    $self->{COMPRESS}     ||= 'gzip';
    $self->{SUFFIX}       ||= '-gz';
    $self->{SHAR}         ||= 'vms_share';
    $self->{DIST_DEFAULT} ||= 'zipdist';

    $self->SUPER::init_dist;

    $self->{DISTVNAME} = "$self->{DISTNAME}-$self->{VERSION_SYM}"
      unless $self->{ARGS}{DISTVNAME};

    return;
}

=item c_o (override)

Use VMS syntax on command line.  In particular, $(DEFINE) and
$(PERL_INC) have been pulled into $(CCCMD).  Also use MM[SK] macros.

=cut

sub c_o {
    my($self) = @_;
    return '' unless $self->needs_linking();
    '
.c$(OBJ_EXT) :
	$(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT)

.cpp$(OBJ_EXT) :
	$(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).cpp /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT)

.cxx$(OBJ_EXT) :
	$(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).cxx /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT)

';
}

=item xs_c (override)

Use MM[SK] macros.

=cut

sub xs_c {
    my($self) = @_;
    return '' unless $self->needs_linking();
    '
.xs.c :
	$(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET_NAME).xsc
	$(MV) $(MMS$TARGET_NAME).xsc $(MMS$TARGET_NAME).c
';
}

=item xs_o (override)

Use MM[SK] macros, and VMS command line for C compiler.

=cut

sub xs_o {
    my ($self) = @_;
    return '' unless $self->needs_linking();
    my $frag = '
.xs$(OBJ_EXT) :
	$(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET_NAME).xsc
	$(MV) $(MMS$TARGET_NAME).xsc $(MMS$TARGET_NAME).c
	$(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT)
';
    if ($self->{XSMULTI}) {
	for my $ext ($self->_xs_list_basenames) {
	    my $version = $self->parse_version("$ext.pm");
	    my $ccflags = $self->{CCFLAGS};
	    $ccflags =~ s/\$\(DEFINE_VERSION\)/\"VERSION_MACRO=\\"\"$version\\"\"/;
	    $ccflags =~ s/\$\(XS_DEFINE_VERSION\)/\"XS_VERSION_MACRO=\\"\"$version\\"\"/;
	    $self->_xsbuild_replace_macro($ccflags, 'xs', $ext, 'INC');
	    $self->_xsbuild_replace_macro($ccflags, 'xs', $ext, 'DEFINE');

	    $frag .= _sprintf562 <<'EOF', $ext, $ccflags;

%1$s$(OBJ_EXT) : %1$s.xs
	$(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs > $(MMS$TARGET_NAME).xsc
	$(MV) $(MMS$TARGET_NAME).xsc $(MMS$TARGET_NAME).c
	$(CC)%2$s$(OPTIMIZE) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT)
EOF
	}
    }
    $frag;
}

=item _xsbuild_replace_macro (override)

There is no simple replacement possible since a qualifier and all its
subqualifiers must be considered together, so we use our own utility
routine for the replacement.

=cut

sub _xsbuild_replace_macro {
    my ($self, undef, $xstype, $ext, $varname) = @_;
    my $value = $self->_xsbuild_value($xstype, $ext, $varname);
    return unless defined $value;
    $_[1] = _vms_replace_qualifier($self, $_[1], $value, $varname);
}

=item _xsbuild_value (override)

Convert the extension spec to Unix format, as that's what will
match what's in the XSBUILD data structure.

=cut

sub _xsbuild_value {
    my ($self, $xstype, $ext, $varname) = @_;
    $ext = unixify($ext);
    return $self->SUPER::_xsbuild_value($xstype, $ext, $varname);
}

sub _vms_replace_qualifier {
    my ($self, $flags, $newflag, $macro) = @_;
    my $qual_type;
    my $type_suffix;
    my $quote_subquals = 0;
    my @subquals_new = split /\s+/, $newflag;

    if ($macro eq 'DEFINE') {
        $qual_type = 'Def';
        $type_suffix = 'ine';
        map { $_ =~ s/^-D// } @subquals_new;
        $quote_subquals = 1;
    }
    elsif ($macro eq 'INC') {
        $qual_type = 'Inc';
        $type_suffix = 'lude';
        map { $_ =~ s/^-I//; $_ = $self->fixpath($_) } @subquals_new;
    }

    my @subquals = ();
    while ($flags =~ m:/${qual_type}\S{0,4}=([^/]+):ig) {
        my $term = $1;
        $term =~ s/\"//g;
        $term =~ s:^\((.+)\)$:$1:;
        push @subquals, split /,/, $term;
    }
    for my $new (@subquals_new) {
        my ($sq_new, $sqval_new) = split /=/, $new;
        my $replaced_old = 0;
        for my $old (@subquals) {
            my ($sq, $sqval) = split /=/, $old;
            if ($sq_new eq $sq) {
                $old = $sq_new;
                $old .= '=' . $sqval_new if defined($sqval_new) and length($sqval_new);
                $replaced_old = 1;
                last;
            }
        }
        push @subquals, $new unless $replaced_old;
    }

    if (@subquals) {
        $flags =~ s:/${qual_type}\S{0,4}=[^/]+::ig;
        # add quotes if requested but not for unexpanded macros
        map { $_ = qq/"$_"/ if $_ !~ m/^\$\(/ } @subquals if $quote_subquals;
        $flags .= "/${qual_type}$type_suffix=(" . join(',',@subquals) . ')';
    }

    return $flags;
}


sub xs_dlsyms_ext {
    '.opt';
}

=item dlsyms (override)

Create VMS linker options files specifying universal symbols for this
extension's shareable image(s), and listing other shareable images or
libraries to which it should be linked.

=cut

sub dlsyms {
    my ($self, %attribs) = @_;
    return '' unless $self->needs_linking;
    $self->xs_dlsyms_iterator;
}

sub xs_make_dlsyms {
    my ($self, $attribs, $target, $dep, $name, $dlbase, $funcs, $funclist, $imports, $vars, $extra) = @_;
    my @m;
    my $instloc;
    if ($self->{XSMULTI}) {
	my ($v, $d, $f) = File::Spec->splitpath($target);
	my @d = File::Spec->splitdir($d);
	shift @d if $d[0] eq 'lib';
	$instloc = $self->catfile('$(INST_ARCHLIB)', 'auto', @d, $f);
	push @m,"\ndynamic :: $instloc\n\t\$(NOECHO) \$(NOOP)\n"
	  unless $self->{SKIPHASH}{'dynamic'};
	push @m,"\nstatic :: $instloc\n\t\$(NOECHO) \$(NOOP)\n"
	  unless $self->{SKIPHASH}{'static'};
	push @m, "\n", sprintf <<'EOF', $instloc, $target;
%s : %s
	$(CP) $(MMS$SOURCE) $(MMS$TARGET)
EOF
    }
    else {
	push @m,"\ndynamic :: \$(INST_ARCHAUTODIR)$self->{BASEEXT}.opt\n\t\$(NOECHO) \$(NOOP)\n"
	  unless $self->{SKIPHASH}{'dynamic'};
	push @m,"\nstatic :: \$(INST_ARCHAUTODIR)$self->{BASEEXT}.opt\n\t\$(NOECHO) \$(NOOP)\n"
	  unless $self->{SKIPHASH}{'static'};
	push @m, "\n", sprintf <<'EOF', $target;
$(INST_ARCHAUTODIR)$(BASEEXT).opt : %s
	$(CP) $(MMS$SOURCE) $(MMS$TARGET)
EOF
    }
    push @m,
     "\n$target : $dep\n\t",
     q!$(PERLRUN) -MExtUtils::Mksymlists -e "Mksymlists('NAME'=>'!, $name,
     q!', 'DLBASE' => '!,$dlbase,
     q!', 'DL_FUNCS' => !,neatvalue($funcs),
     q!, 'FUNCLIST' => !,neatvalue($funclist),
     q!, 'IMPORTS' => !,neatvalue($imports),
     q!, 'DL_VARS' => !, neatvalue($vars);
    push @m, $extra if defined $extra;
    push @m, qq!);"\n\t!;
    # Can't use dlbase as it's been through mod2fname.
    my $olb_base = basename($target, '.opt');
    if ($self->{XSMULTI}) {
        # We've been passed everything but the kitchen sink -- and the location of the
        # static library we're using to build the dynamic library -- so concoct that
        # location from what we do have.
        my $olb_dir = $self->catdir(dirname($instloc), $olb_base);
        push @m, qq!\$(PERL) -e "print ""${olb_dir}${olb_base}\$(LIB_EXT)/Include=!;
        push @m, ($Config{d_vms_case_sensitive_symbols} ? uc($olb_base) : $olb_base);
        push @m, '\n' . $olb_dir . $olb_base . '$(LIB_EXT)/Library\n"";" >>$(MMS$TARGET)',"\n";
    }
    else {
        push @m, qq!\$(PERL) -e "print ""\$(INST_ARCHAUTODIR)${olb_base}\$(LIB_EXT)/Include=!;
        if ($self->{OBJECT} =~ /\bBASEEXT\b/ or
            $self->{OBJECT} =~ /\b$self->{BASEEXT}\b/i) {
            push @m, ($Config{d_vms_case_sensitive_symbols}
	              ? uc($self->{BASEEXT}) :'$(BASEEXT)');
        }
        else {  # We don't have a "main" object file, so pull 'em all in
            # Upcase module names if linker is being case-sensitive
            my($upcase) = $Config{d_vms_case_sensitive_symbols};
            my(@omods) = split ' ', $self->eliminate_macros($self->{OBJECT});
            for (@omods) {
                s/\.[^.]*$//;         # Trim off file type
                s[\$\(\w+_EXT\)][];   # even as a macro
                s/.*[:>\/\]]//;       # Trim off dir spec
                $_ = uc if $upcase;
            };
            my(@lines);
            my $tmp = shift @omods;
            foreach my $elt (@omods) {
                $tmp .= ",$elt";
                if (length($tmp) > 80) { push @lines, $tmp;  $tmp = ''; }
            }
            push @lines, $tmp;
            push @m, '(', join( qq[, -\\n\\t"";" >>\$(MMS\$TARGET)\n\t\$(PERL) -e "print ""], @lines),')';
        }
        push @m, '\n$(INST_ARCHAUTODIR)' . $olb_base . '$(LIB_EXT)/Library\n"";" >>$(MMS$TARGET)',"\n";
    }
    if (length $self->{LDLOADLIBS}) {
        my($line) = '';
        foreach my $lib (split ' ', $self->{LDLOADLIBS}) {
            $lib =~ s%\$%\\\$%g;  # Escape '$' in VMS filespecs
            if (length($line) + length($lib) > 160) {
                push @m, "\t\$(PERL) -e \"print qq{$line}\" >>\$(MMS\$TARGET)\n";
                $line = $lib . '\n';
            }
            else { $line .= $lib . '\n'; }
        }
        push @m, "\t\$(PERL) -e \"print qq{$line}\" >>\$(MMS\$TARGET)\n" if $line;
    }
    join '', @m;
}


=item xs_obj_opt

Override to fixup -o flags.

=cut

sub xs_obj_opt {
    my ($self, $output_file) = @_;
    "/OBJECT=$output_file";
}

=item dynamic_lib (override)

Use VMS Link command.

=cut

sub xs_dynamic_lib_macros {
    my ($self, $attribs) = @_;
    my $otherldflags = $attribs->{OTHERLDFLAGS} || "";
    my $inst_dynamic_dep = $attribs->{INST_DYNAMIC_DEP} || "";
    sprintf <<'EOF', $otherldflags, $inst_dynamic_dep;
# This section creates the dynamically loadable objects from relevant
# objects and possibly $(MYEXTLIB).
OTHERLDFLAGS = %s
INST_DYNAMIC_DEP = %s
EOF
}

sub xs_make_dynamic_lib {
    my ($self, $attribs, $from, $to, $todir, $ldfrom, $exportlist) = @_;
    my $shr = $Config{'dbgprefix'} . 'PerlShr';
    $exportlist =~ s/.def$/.opt/;  # it's a linker options file
    #                    1    2       3            4     5
    _sprintf562 <<'EOF', $to, $todir, $exportlist, $shr, "$shr Sys\$Share:$shr.$Config{'dlext'}";
%1$s : $(INST_STATIC) $(PERL_INC)perlshr_attr.opt %2$s$(DFSEP).exists %3$s $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP)
	If F$TrnLNm("%4$s").eqs."" Then Define/NoLog/User %5$s
	Link $(LDFLAGS) /Shareable=$(MMS$TARGET)$(OTHERLDFLAGS) %3$s/Option,$(PERL_INC)perlshr_attr.opt/Option
EOF
}

=item xs_make_static_lib (override)

Use VMS commands to manipulate object library.

=cut

sub xs_make_static_lib {
    my ($self, $object, $to, $todir) = @_;

    my @objects;
    if ($self->{XSMULTI}) {
        # The extension name should be the main object file name minus file type.
        my $lib = $object;
        $lib =~ s/\$\(OBJ_EXT\)\z//;
        my $override = $self->_xsbuild_value('xs', $lib, 'OBJECT');
        $object = $override if defined $override;
        @objects = map { $self->fixpath($_,0) } split /(?<!\^)\s+/, $object;
    }
    else {
        push @objects, $object;
    }

    my @m;
    for my $obj (@objects) {
        push(@m, sprintf "\n%s : %s\$(DFSEP).exists", $obj, $todir);
    }
    push(@m, sprintf "\n\n%s : %s \$(MYEXTLIB)\n", $to, (join ' ', @objects));

    # If this extension has its own library (eg SDBM_File)
    # then copy that to $(INST_STATIC) and add $(OBJECT) into it.
    push(@m, "\t",'$(CP) $(MYEXTLIB) $(MMS$TARGET)',"\n") if $self->{MYEXTLIB};

    push(@m,"\t",'If F$Search("$(MMS$TARGET)").eqs."" Then Library/Object/Create $(MMS$TARGET)',"\n");

    # if there was a library to copy, then we can't use MMS$SOURCE_LIST,
    # 'cause it's a library and you can't stick them in other libraries.
    # In that case, we use $OBJECT instead and hope for the best
    if ($self->{MYEXTLIB}) {
        for my $obj (@objects) {
            push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) ' . $obj,"\n");
        }
    }
    else {
      push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) $(MMS$SOURCE_LIST)',"\n");
    }

    push @m, "\t\$(NOECHO) \$(PERL) -e 1 >\$(INST_ARCHAUTODIR)extralibs.ld\n";
    foreach my $lib (split ' ', $self->{EXTRALIBS}) {
      push(@m,"\t",'$(NOECHO) $(PERL) -e "print qq{',$lib,'\n}" >>$(INST_ARCHAUTODIR)extralibs.ld',"\n");
    }
    join('',@m);
}


=item static_lib_pure_cmd (override)

Use VMS commands to manipulate object library.

=cut

sub static_lib_pure_cmd {
    my ($self, $from) = @_;

    sprintf <<'MAKE_FRAG', $from;
	If F$Search("$(MMS$TARGET)").eqs."" Then Library/Object/Create $(MMS$TARGET)
	Library/Object/Replace $(MMS$TARGET) %s
MAKE_FRAG
}

=item xs_static_lib_is_xs

=cut

sub xs_static_lib_is_xs {
    return 1;
}

=item extra_clean_files

Clean up some OS specific files.  Plus the temp file used to shorten
a lot of commands.  And the name mangler database.

=cut

sub extra_clean_files {
    return qw(
              *.Map *.Dmp *.Lis *.cpp *.$(DLEXT) *.Opt $(BASEEXT).bso
              .MM_Tmp cxx_repository
             );
}


=item zipfile_target

=item tarfile_target

=item shdist_target

Syntax for invoking shar, tar and zip differs from that for Unix.

=cut

sub zipfile_target {
    my($self) = shift;

    return <<'MAKE_FRAG';
$(DISTVNAME).zip : distdir
	$(PREOP)
	$(ZIP) "$(ZIPFLAGS)" $(MMS$TARGET) [.$(DISTVNAME)...]*.*;
	$(RM_RF) $(DISTVNAME)
	$(POSTOP)
MAKE_FRAG
}

sub tarfile_target {
    my($self) = shift;

    return <<'MAKE_FRAG';
$(DISTVNAME).tar$(SUFFIX) : distdir
	$(PREOP)
	$(TO_UNIX)
	$(TAR) "$(TARFLAGS)" $(DISTVNAME).tar [.$(DISTVNAME)...]
	$(RM_RF) $(DISTVNAME)
	$(COMPRESS) $(DISTVNAME).tar
	$(POSTOP)
MAKE_FRAG
}

sub shdist_target {
    my($self) = shift;

    return <<'MAKE_FRAG';
shdist : distdir
	$(PREOP)
	$(SHAR) [.$(DISTVNAME)...]*.*; $(DISTVNAME).share
	$(RM_RF) $(DISTVNAME)
	$(POSTOP)
MAKE_FRAG
}


# --- Test and Installation Sections ---

=item install (override)

Work around DCL's 255 character limit several times,and use
VMS-style command line quoting in a few cases.

=cut

sub install {
    my($self, %attribs) = @_;
    my(@m);

    push @m, q[
install :: all pure_install doc_install
	$(NOECHO) $(NOOP)

install_perl :: all pure_perl_install doc_perl_install
	$(NOECHO) $(NOOP)

install_site :: all pure_site_install doc_site_install
	$(NOECHO) $(NOOP)

install_vendor :: all pure_vendor_install doc_vendor_install
	$(NOECHO) $(NOOP)

pure_install :: pure_$(INSTALLDIRS)_install
	$(NOECHO) $(NOOP)

doc_install :: doc_$(INSTALLDIRS)_install
	$(NOECHO) $(NOOP)

pure__install : pure_site_install
	$(NOECHO) $(ECHO) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site"

doc__install : doc_site_install
	$(NOECHO) $(ECHO) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site"

# This hack brought to you by DCL's 255-character command line limit
pure_perl_install ::
];
    push @m,
q[	$(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read|'.File::Spec->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').'|'" >.MM_tmp
	$(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write|'.File::Spec->catfile('$(DESTINSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').'|'" >>.MM_tmp
] unless $self->{NO_PACKLIST};

    push @m,
q[	$(NOECHO) $(ECHO_N) "$(INST_LIB)|$(DESTINSTALLPRIVLIB)|" >>.MM_tmp
	$(NOECHO) $(ECHO_N) "$(INST_ARCHLIB)|$(DESTINSTALLARCHLIB)|" >>.MM_tmp
	$(NOECHO) $(ECHO_N) "$(INST_BIN)|$(DESTINSTALLBIN)|" >>.MM_tmp
	$(NOECHO) $(ECHO_N) "$(INST_SCRIPT)|$(DESTINSTALLSCRIPT)|" >>.MM_tmp
	$(NOECHO) $(ECHO_N) "$(INST_MAN1DIR) $(DESTINSTALLMAN1DIR) " >>.MM_tmp
	$(NOECHO) $(ECHO_N) "$(INST_MAN3DIR)|$(DESTINSTALLMAN3DIR)" >>.MM_tmp
	$(NOECHO) $(MOD_INSTALL) <.MM_tmp
	$(NOECHO) $(RM_F) .MM_tmp
	$(NOECHO) $(WARN_IF_OLD_PACKLIST) "].$self->catfile($self->{SITEARCHEXP},'auto',$self->{FULLEXT},'.packlist').q["

# Likewise
pure_site_install ::
];
    push @m,
q[	$(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read|'.File::Spec->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').'|'" >.MM_tmp
	$(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write|'.File::Spec->catfile('$(DESTINSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').'|'" >>.MM_tmp
] unless $self->{NO_PACKLIST};

    push @m,
q[	$(NOECHO) $(ECHO_N) "$(INST_LIB)|$(DESTINSTALLSITELIB)|" >>.MM_tmp
	$(NOECHO) $(ECHO_N) "$(INST_ARCHLIB)|$(DESTINSTALLSITEARCH)|" >>.MM_tmp
	$(NOECHO) $(ECHO_N) "$(INST_BIN)|$(DESTINSTALLSITEBIN)|" >>.MM_tmp
	$(NOECHO) $(ECHO_N) "$(INST_SCRIPT)|$(DESTINSTALLSCRIPT)|" >>.MM_tmp
	$(NOECHO) $(ECHO_N) "$(INST_MAN1DIR)|$(DESTINSTALLSITEMAN1DIR)|" >>.MM_tmp
	$(NOECHO) $(ECHO_N) "$(INST_MAN3DIR)|$(DESTINSTALLSITEMAN3DIR)" >>.MM_tmp
	$(NOECHO) $(MOD_INSTALL) <.MM_tmp
	$(NOECHO) $(RM_F) .MM_tmp
	$(NOECHO) $(WARN_IF_OLD_PACKLIST) "].$self->catfile($self->{PERL_ARCHLIB},'auto',$self->{FULLEXT},'.packlist').q["

pure_vendor_install ::
];
    push @m,
q[	$(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read|'.File::Spec->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').'|'" >.MM_tmp
	$(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write|'.File::Spec->catfile('$(DESTINSTALLVENDORARCH)','auto','$(FULLEXT)','.packlist').'|'" >>.MM_tmp
] unless $self->{NO_PACKLIST};

    push @m,
q[	$(NOECHO) $(ECHO_N) "$(INST_LIB)|$(DESTINSTALLVENDORLIB)|" >>.MM_tmp
	$(NOECHO) $(ECHO_N) "$(INST_ARCHLIB)|$(DESTINSTALLVENDORARCH)|" >>.MM_tmp
	$(NOECHO) $(ECHO_N) "$(INST_BIN)|$(DESTINSTALLVENDORBIN)|" >>.MM_tmp
	$(NOECHO) $(ECHO_N) "$(INST_SCRIPT)|$(DESTINSTALLSCRIPT)|" >>.MM_tmp
	$(NOECHO) $(ECHO_N) "$(INST_MAN1DIR)|$(DESTINSTALLVENDORMAN1DIR)|" >>.MM_tmp
	$(NOECHO) $(ECHO_N) "$(INST_MAN3DIR)|$(DESTINSTALLVENDORMAN3DIR)" >>.MM_tmp
	$(NOECHO) $(MOD_INSTALL) <.MM_tmp
	$(NOECHO) $(RM_F) .MM_tmp

];

    push @m, q[
# Ditto
doc_perl_install ::
	$(NOECHO) $(NOOP)

# And again
doc_site_install ::
	$(NOECHO) $(NOOP)

doc_vendor_install ::
	$(NOECHO) $(NOOP)

] if $self->{NO_PERLLOCAL};

    push @m, q[
# Ditto
doc_perl_install ::
	$(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q["
	$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
	$(NOECHO) $(ECHO_N) "installed into|$(INSTALLPRIVLIB)|" >.MM_tmp
	$(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp
	$(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[
	$(NOECHO) $(RM_F) .MM_tmp

# And again
doc_site_install ::
	$(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q["
	$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
	$(NOECHO) $(ECHO_N) "installed into|$(INSTALLSITELIB)|" >.MM_tmp
	$(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp
	$(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[
	$(NOECHO) $(RM_F) .MM_tmp

doc_vendor_install ::
	$(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q["
	$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
	$(NOECHO) $(ECHO_N) "installed into|$(INSTALLVENDORLIB)|" >.MM_tmp
	$(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp
	$(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[
	$(NOECHO) $(RM_F) .MM_tmp

] unless $self->{NO_PERLLOCAL};

    push @m, q[
uninstall :: uninstall_from_$(INSTALLDIRS)dirs
	$(NOECHO) $(NOOP)

uninstall_from_perldirs ::
	$(NOECHO) $(UNINSTALL) ].$self->catfile($self->{PERL_ARCHLIB},'auto',$self->{FULLEXT},'.packlist').q[

uninstall_from_sitedirs ::
	$(NOECHO) $(UNINSTALL) ].$self->catfile($self->{SITEARCHEXP},'auto',$self->{FULLEXT},'.packlist').q[

uninstall_from_vendordirs ::
	$(NOECHO) $(UNINSTALL) ].$self->catfile($self->{VENDORARCHEXP},'auto',$self->{FULLEXT},'.packlist').q[
];

    join('',@m);
}

=item perldepend (override)

Use VMS-style syntax for files; it's cheaper to just do it directly here
than to have the L<MM_Unix|ExtUtils::MM_Unix> method call C<catfile>
repeatedly.  Also, if we have to rebuild Config.pm, use MM[SK] to do it.

=cut

sub perldepend {
    my($self) = @_;
    my(@m);

    if ($self->{OBJECT}) {
        # Need to add an object file dependency on the perl headers.
        # this is very important for XS modules in perl.git development.

        push @m, $self->_perl_header_files_fragment(""); # empty separator on VMS as its in the $(PERL_INC)
    }

    if ($self->{PERL_SRC}) {
	my(@macros);
	my($mmsquals) = '$(USEMAKEFILE)[.vms]$(FIRST_MAKEFILE)';
	push(@macros,'__AXP__=1') if $Config{'archname'} eq 'VMS_AXP';
	push(@macros,'DECC=1')    if $Config{'vms_cc_type'} eq 'decc';
	push(@macros,'GNUC=1')    if $Config{'vms_cc_type'} eq 'gcc';
	push(@macros,'SOCKET=1')  if $Config{'d_has_sockets'};
	push(@macros,qq["CC=$Config{'cc'}"])  if $Config{'cc'} =~ m!/!;
	$mmsquals .= '$(USEMACROS)' . join(',',@macros) . '$(MACROEND)' if @macros;
	push(@m,q[
# Check for unpropagated config.sh changes. Should never happen.
# We do NOT just update config.h because that is not sufficient.
# An out of date config.h is not fatal but complains loudly!
$(PERL_INC)config.h : $(PERL_SRC)config.sh
	$(NOOP)

$(PERL_ARCHLIB)Config.pm : $(PERL_SRC)config.sh
	$(NOECHO) Write Sys$Error "$(PERL_ARCHLIB)Config.pm may be out of date with config.h or genconfig.pl"
	olddef = F$Environment("Default")
	Set Default $(PERL_SRC)
	$(MMS)],$mmsquals,);
	if ($self->{PERL_ARCHLIB} =~ m|\[-| && $self->{PERL_SRC} =~ m|(\[-+)|) {
	    my($prefix,$target) = ($1,$self->fixpath('$(PERL_ARCHLIB)Config.pm',0));
	    $target =~ s/\Q$prefix/[/;
	    push(@m," $target");
	}
	else { push(@m,' $(MMS$TARGET)'); }
	push(@m,q[
	Set Default 'olddef'
]);
    }

    push(@m, join(" ", map($self->fixpath($_,0),sort values %{$self->{XS}}))." : \$(XSUBPPDEPS)\n")
      if %{$self->{XS}};

    join('',@m);
}


=item makeaperl (override)

Undertake to build a new set of Perl images using VMS commands.  Since
VMS does dynamic loading, it's not necessary to statically link each
extension into the Perl image, so this isn't the normal build path.
Consequently, it hasn't really been tested, and may well be incomplete.

=cut

our %olbs;  # needs to be localized

sub makeaperl {
    my($self, %attribs) = @_;
    my($makefilename, $searchdirs, $static, $extra, $perlinc, $target, $tmpdir, $libperl) =
      @attribs{qw(MAKE DIRS STAT EXTRA INCL TARGET TMP LIBPERL)};
    my(@m);
    push @m, "
# --- MakeMaker makeaperl section ---
MAP_TARGET    = $target
";
    return join '', @m if $self->{PARENT};

    my($dir) = join ":", @{$self->{DIR}};

    unless ($self->{MAKEAPERL}) {
	push @m, q{
$(MAKE_APERL_FILE) : $(FIRST_MAKEFILE)
	$(NOECHO) $(ECHO) "Writing ""$(MMS$TARGET)"" for this $(MAP_TARGET)"
	$(NOECHO) $(PERLRUNINST) \
		Makefile.PL DIR=}, $dir, q{ \
		FIRST_MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \
		MAKEAPERL=1 NORECURS=1 };

	push @m, map(q[ \\\n\t\t"$_"], @ARGV),q{

$(MAP_TARGET) :: $(MAKE_APERL_FILE)
	$(MAKE)$(USEMAKEFILE)$(MAKE_APERL_FILE) static $(MMS$TARGET)
};
	push @m, "\n";

	return join '', @m;
    }


    my($linkcmd,@optlibs,@staticpkgs,$extralist,$targdir,$libperldir,%libseen);
    local($_);

    # The front matter of the linkcommand...
    $linkcmd = join ' ', $Config{'ld'},
	    grep($_, @Config{qw(large split ldflags ccdlflags)});
    $linkcmd =~ s/\s+/ /g;

    # Which *.olb files could we make use of...
    local(%olbs);       # XXX can this be lexical?
    $olbs{$self->{INST_ARCHAUTODIR}} = "$self->{BASEEXT}\$(LIB_EXT)";
    require File::Find;
    File::Find::find(sub {
	return unless m/\Q$self->{LIB_EXT}\E$/;
	return if m/^libperl/;

	if( exists $self->{INCLUDE_EXT} ){
		my $found = 0;

		(my $xx = $File::Find::name) =~ s,.*?/auto/,,;
		$xx =~ s,/?$_,,;
		$xx =~ s,/,::,g;

		# Throw away anything not explicitly marked for inclusion.
		# DynaLoader is implied.
		foreach my $incl ((@{$self->{INCLUDE_EXT}},'DynaLoader')){
			if( $xx eq $incl ){
				$found++;
				last;
			}
		}
		return unless $found;
	}
	elsif( exists $self->{EXCLUDE_EXT} ){
		(my $xx = $File::Find::name) =~ s,.*?/auto/,,;
		$xx =~ s,/?$_,,;
		$xx =~ s,/,::,g;

		# Throw away anything explicitly marked for exclusion
		foreach my $excl (@{$self->{EXCLUDE_EXT}}){
			return if( $xx eq $excl );
		}
	}

	$olbs{$ENV{DEFAULT}} = $_;
    }, grep( -d $_, @{$searchdirs || []}));

    # We trust that what has been handed in as argument will be buildable
    $static = [] unless $static;
    @olbs{@{$static}} = (1) x @{$static};

    $extra = [] unless $extra && ref $extra eq 'ARRAY';
    # Sort the object libraries in inverse order of
    # filespec length to try to insure that dependent extensions
    # will appear before their parents, so the linker will
    # search the parent library to resolve references.
    # (e.g. Intuit::DWIM will precede Intuit, so unresolved
    # references from [.intuit.dwim]dwim.obj can be found
    # in [.intuit]intuit.olb).
    for (sort { length($a) <=> length($b) || $a cmp $b } keys %olbs) {
	next unless $olbs{$_} =~ /\Q$self->{LIB_EXT}\E$/;
	my($dir) = $self->fixpath($_,1);
	my($extralibs) = $dir . "extralibs.ld";
	my($extopt) = $dir . $olbs{$_};
	$extopt =~ s/$self->{LIB_EXT}$/.opt/;
	push @optlibs, "$dir$olbs{$_}";
	# Get external libraries this extension will need
	if (-f $extralibs ) {
	    my %seenthis;
	    open my $list, "<", $extralibs or warn $!,next;
	    while (<$list>) {
		chomp;
		# Include a library in the link only once, unless it's mentioned
		# multiple times within a single extension's options file, in which
		# case we assume the builder needed to search it again later in the
		# link.
		my $skip = exists($libseen{$_}) && !exists($seenthis{$_});
		$libseen{$_}++;  $seenthis{$_}++;
		next if $skip;
		push @$extra,$_;
	    }
	}
	# Get full name of extension for ExtUtils::Miniperl
	if (-f $extopt) {
	    open my $opt, '<', $extopt or die $!;
	    while (<$opt>) {
		next unless /(?:UNIVERSAL|VECTOR)=boot_([\w_]+)/;
		my $pkg = $1;
		$pkg =~ s#__*#::#g;
		push @staticpkgs,$pkg;
	    }
	}
    }
    # Place all of the external libraries after all of the Perl extension
    # libraries in the final link, in order to maximize the opportunity
    # for XS code from multiple extensions to resolve symbols against the
    # same external library while only including that library once.
    push @optlibs, @$extra;

    $target = "Perl$Config{'exe_ext'}" unless $target;
    my $shrtarget;
    ($shrtarget,$targdir) = fileparse($target);
    $shrtarget =~ s/^([^.]*)/$1Shr/;
    $shrtarget = $targdir . $shrtarget;
    $target = "Perlshr.$Config{'dlext'}" unless $target;
    $tmpdir = "[]" unless $tmpdir;
    $tmpdir = $self->fixpath($tmpdir,1);
    if (@optlibs) { $extralist = join(' ',@optlibs); }
    else          { $extralist = ''; }
    # Let ExtUtils::Liblist find the necessary libs for us (but skip PerlShr)
    # that's what we're building here).
    push @optlibs, grep { !/PerlShr/i } split ' ', +($self->ext())[2];
    if ($libperl) {
	unless (-f $libperl || -f ($libperl = $self->catfile($Config{'installarchlib'},'CORE',$libperl))) {
	    print "Warning: $libperl not found\n";
	    undef $libperl;
	}
    }
    unless ($libperl) {
	if (defined $self->{PERL_SRC}) {
	    $libperl = $self->catfile($self->{PERL_SRC},"libperl$self->{LIB_EXT}");
	} elsif (-f ($libperl = $self->catfile($Config{'installarchlib'},'CORE',"libperl$self->{LIB_EXT}")) ) {
	} else {
	    print "Warning: $libperl not found
    If you're going to build a static perl binary, make sure perl is installed
    otherwise ignore this warning\n";
	}
    }
    $libperldir = $self->fixpath((fileparse($libperl))[1],1);

    push @m, '
# Fill in the target you want to produce if it\'s not perl
MAP_TARGET    = ',$self->fixpath($target,0),'
MAP_SHRTARGET = ',$self->fixpath($shrtarget,0),"
MAP_LINKCMD   = $linkcmd
MAP_PERLINC   = ", $perlinc ? map('"$_" ',@{$perlinc}) : '',"
MAP_EXTRA     = $extralist
MAP_LIBPERL = ",$self->fixpath($libperl,0),'
';


    push @m,"\n${tmpdir}Makeaperl.Opt : \$(MAP_EXTRA)\n";
    foreach (@optlibs) {
	push @m,'	$(NOECHO) $(PERL) -e "print q{',$_,'}" >>$(MMS$TARGET)',"\n";
    }
    push @m,"\n${tmpdir}PerlShr.Opt :\n\t";
    push @m,'$(NOECHO) $(PERL) -e "print q{$(MAP_SHRTARGET)}" >$(MMS$TARGET)',"\n";

    push @m,'
$(MAP_SHRTARGET) : $(MAP_LIBPERL) Makeaperl.Opt ',"${libperldir}Perlshr_Attr.Opt",'
	$(MAP_LINKCMD)/Shareable=$(MMS$TARGET) $(MAP_LIBPERL), Makeaperl.Opt/Option ',"${libperldir}Perlshr_Attr.Opt/Option",'
$(MAP_TARGET) : $(MAP_SHRTARGET) ',"${tmpdir}perlmain\$(OBJ_EXT) ${tmpdir}PerlShr.Opt",'
	$(MAP_LINKCMD) ',"${tmpdir}perlmain\$(OBJ_EXT)",', PerlShr.Opt/Option
	$(NOECHO) $(ECHO) "To install the new ""$(MAP_TARGET)"" binary, say"
	$(NOECHO) $(ECHO) "    $(MAKE)$(USEMAKEFILE)$(FIRST_MAKEFILE) inst_perl $(USEMACROS)MAP_TARGET=$(MAP_TARGET)$(ENDMACRO)"
	$(NOECHO) $(ECHO) "To remove the intermediate files, say
	$(NOECHO) $(ECHO) "    $(MAKE)$(USEMAKEFILE)$(FIRST_MAKEFILE) map_clean"
';
    push @m,"\n${tmpdir}perlmain.c : \$(FIRST_MAKEFILE)\n\t\$(NOECHO) \$(PERL) -e 1 >${tmpdir}Writemain.tmp\n";
    push @m, "# More from the 255-char line length limit\n";
    foreach (@staticpkgs) {
	push @m,'	$(NOECHO) $(PERL) -e "print q{',$_,qq[}" >>${tmpdir}Writemain.tmp\n];
    }

    push @m, sprintf <<'MAKE_FRAG', $tmpdir, $tmpdir;
	$(NOECHO) $(PERL) $(MAP_PERLINC) -ane "use ExtUtils::Miniperl; writemain(@F)" %sWritemain.tmp >$(MMS$TARGET)
	$(NOECHO) $(RM_F) %sWritemain.tmp
MAKE_FRAG

    push @m, q[
# Still more from the 255-char line length limit
doc_inst_perl :
	$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
	$(NOECHO) $(ECHO) "Perl binary $(MAP_TARGET)|" >.MM_tmp
	$(NOECHO) $(ECHO) "MAP_STATIC|$(MAP_STATIC)|" >>.MM_tmp
	$(NOECHO) $(PERL) -pl040 -e " " ].$self->catfile('$(INST_ARCHAUTODIR)','extralibs.all'),q[ >>.MM_tmp
	$(NOECHO) $(ECHO) -e "MAP_LIBPERL|$(MAP_LIBPERL)|" >>.MM_tmp
	$(NOECHO) $(DOC_INSTALL) <.MM_tmp >>].$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q[
	$(NOECHO) $(RM_F) .MM_tmp
];

    push @m, "
inst_perl : pure_inst_perl doc_inst_perl
	\$(NOECHO) \$(NOOP)

pure_inst_perl : \$(MAP_TARGET)
	$self->{CP} \$(MAP_SHRTARGET) ",$self->fixpath($Config{'installbin'},1),"
	$self->{CP} \$(MAP_TARGET) ",$self->fixpath($Config{'installbin'},1),"

clean :: map_clean
	\$(NOECHO) \$(NOOP)

map_clean :
	\$(RM_F) ${tmpdir}perlmain\$(OBJ_EXT) ${tmpdir}perlmain.c \$(FIRST_MAKEFILE)
	\$(RM_F) ${tmpdir}Makeaperl.Opt ${tmpdir}PerlShr.Opt \$(MAP_TARGET)
";

    join '', @m;
}


# --- Output postprocessing section ---

=item maketext_filter (override)

Ensure that colons marking targets are preceded by space, in order
to distinguish the target delimiter from a colon appearing as
part of a filespec.

=cut

sub maketext_filter {
    my($self, $text) = @_;

    $text =~ s/^([^\s:=]+)(:+\s)/$1 $2/mg;
    return $text;
}

=item prefixify (override)

prefixifying on VMS is simple.  Each should simply be:

    perl_root:[some.dir]

which can just be converted to:

    volume:[your.prefix.some.dir]

otherwise you get the default layout.

In effect, your search prefix is ignored and $Config{vms_prefix} is
used instead.

=cut

sub prefixify {
    my($self, $var, $sprefix, $rprefix, $default) = @_;

    # Translate $(PERLPREFIX) to a real path.
    $rprefix = $self->eliminate_macros($rprefix);
    $rprefix = vmspath($rprefix) if $rprefix;
    $sprefix = vmspath($sprefix) if $sprefix;

    $default = vmsify($default)
      unless $default =~ /\[.*\]/;

    (my $var_no_install = $var) =~ s/^install//;
    my $path = $self->{uc $var} ||
               $ExtUtils::MM_Unix::Config_Override{lc $var} ||
               $Config{lc $var} || $Config{lc $var_no_install};

    if( !$path ) {
        warn "  no Config found for $var.\n" if $Verbose >= 2;
        $path = $self->_prefixify_default($rprefix, $default);
    }
    elsif( !$self->{ARGS}{PREFIX} || !$self->file_name_is_absolute($path) ) {
        # do nothing if there's no prefix or if its relative
    }
    elsif( $sprefix eq $rprefix ) {
        warn "  no new prefix.\n" if $Verbose >= 2;
    }
    else {

        warn "  prefixify $var => $path\n"     if $Verbose >= 2;
        warn "    from $sprefix to $rprefix\n" if $Verbose >= 2;

        my($path_vol, $path_dirs) = $self->splitpath( $path );
        if( $path_vol eq $Config{vms_prefix}.':' ) {
            warn "  $Config{vms_prefix}: seen\n" if $Verbose >= 2;

            $path_dirs =~ s{^\[}{\[.} unless $path_dirs =~ m{^\[\.};
            $path = $self->_catprefix($rprefix, $path_dirs);
        }
        else {
            $path = $self->_prefixify_default($rprefix, $default);
        }
    }

    print "    now $path\n" if $Verbose >= 2;
    return $self->{uc $var} = $path;
}


sub _prefixify_default {
    my($self, $rprefix, $default) = @_;

    warn "  cannot prefix, using default.\n" if $Verbose >= 2;

    if( !$default ) {
        warn "No default!\n" if $Verbose >= 1;
        return;
    }
    if( !$rprefix ) {
        warn "No replacement prefix!\n" if $Verbose >= 1;
        return '';
    }

    return $self->_catprefix($rprefix, $default);
}

sub _catprefix {
    my($self, $rprefix, $default) = @_;

    my($rvol, $rdirs) = $self->splitpath($rprefix);
    if( $rvol ) {
        return $self->catpath($rvol,
                                   $self->catdir($rdirs, $default),
                                   ''
                                  )
    }
    else {
        return $self->catdir($rdirs, $default);
    }
}


=item cd

=cut

sub cd {
    my($self, $dir, @cmds) = @_;

    $dir = vmspath($dir);

    my $cmd = join "\n\t", map "$_", @cmds;

    # No leading tab makes it look right when embedded
    my $make_frag = sprintf <<'MAKE_FRAG', $dir, $cmd;
startdir = F$Environment("Default")
	Set Default %s
	%s
	Set Default 'startdir'
MAKE_FRAG

    # No trailing newline makes this easier to embed
    chomp $make_frag;

    return $make_frag;
}


=item oneliner

=cut

sub oneliner {
    my($self, $cmd, $switches) = @_;
    $switches = [] unless defined $switches;

    # Strip leading and trailing newlines
    $cmd =~ s{^\n+}{};
    $cmd =~ s{\n+$}{};

    my @cmds = split /\n/, $cmd;
    $cmd = join " \n\t  -e ", map $self->quote_literal($_), @cmds;
    $cmd = $self->escape_newlines($cmd);

    # Switches must be quoted else they will be lowercased.
    $switches = join ' ', map { qq{"$_"} } @$switches;

    return qq{\$(ABSPERLRUN) $switches -e $cmd "--"};
}


=item B<echo>

perl trips up on "<foo>" thinking it's an input redirect.  So we use the
native Write command instead.  Besides, it's faster.

=cut

sub echo {
    my($self, $text, $file, $opts) = @_;

    # Compatibility with old options
    if( !ref $opts ) {
        my $append = $opts;
        $opts = { append => $append || 0 };
    }
    my $opencmd = $opts->{append} ? 'Open/Append' : 'Open/Write';

    $opts->{allow_variables} = 0 unless defined $opts->{allow_variables};

    my $ql_opts = { allow_variables => $opts->{allow_variables} };

    my @cmds = ("\$(NOECHO) $opencmd MMECHOFILE $file ");
    push @cmds, map { '$(NOECHO) Write MMECHOFILE '.$self->quote_literal($_, $ql_opts) }
                split /\n/, $text;
    push @cmds, '$(NOECHO) Close MMECHOFILE';
    return @cmds;
}


=item quote_literal

=cut

sub quote_literal {
    my($self, $text, $opts) = @_;
    $opts->{allow_variables} = 1 unless defined $opts->{allow_variables};

    # I believe this is all we should need.
    $text =~ s{"}{""}g;

    $text = $opts->{allow_variables}
      ? $self->escape_dollarsigns($text) : $self->escape_all_dollarsigns($text);

    return qq{"$text"};
}

=item escape_dollarsigns

Quote, don't escape.

=cut

sub escape_dollarsigns {
    my($self, $text) = @_;

    # Quote dollar signs which are not starting a variable
    $text =~ s{\$ (?!\() }{"\$"}gx;

    return $text;
}


=item escape_all_dollarsigns

Quote, don't escape.

=cut

sub escape_all_dollarsigns {
    my($self, $text) = @_;

    # Quote dollar signs
    $text =~ s{\$}{"\$\"}gx;

    return $text;
}

=item escape_newlines

=cut

sub escape_newlines {
    my($self, $text) = @_;

    $text =~ s{\n}{-\n}g;

    return $text;
}

=item max_exec_len

256 characters.

=cut

sub max_exec_len {
    my $self = shift;

    return $self->{_MAX_EXEC_LEN} ||= 256;
}

=item init_linker

=cut

sub init_linker {
    my $self = shift;
    $self->{EXPORT_LIST} ||= '$(BASEEXT).opt';

    my $shr = $Config{dbgprefix} . 'PERLSHR';
    if ($self->{PERL_SRC}) {
        $self->{PERL_ARCHIVE} ||=
          $self->catfile($self->{PERL_SRC}, "$shr.$Config{'dlext'}");
    }
    else {
        $self->{PERL_ARCHIVE} ||=
          $ENV{$shr} ? $ENV{$shr} : "Sys\$Share:$shr.$Config{'dlext'}";
    }

    $self->{PERL_ARCHIVEDEP} ||= '';
    $self->{PERL_ARCHIVE_AFTER} ||= '';
}


=item catdir (override)

=item catfile (override)

Eliminate the macros in the output to the MMS/MMK file.

(L<File::Spec::VMS> used to do this for us, but it's being removed)

=cut

sub catdir {
    my $self = shift;

    # Process the macros on VMS MMS/MMK
    my @args = map { m{\$\(} ? $self->eliminate_macros($_) : $_  } @_;

    my $dir = $self->SUPER::catdir(@args);

    # Fix up the directory and force it to VMS format.
    $dir = $self->fixpath($dir, 1);

    return $dir;
}

sub catfile {
    my $self = shift;

    # Process the macros on VMS MMS/MMK
    my @args = map { m{\$\(} ? $self->eliminate_macros($_) : $_  } @_;

    my $file = $self->SUPER::catfile(@args);

    $file = vmsify($file);

    return $file
}


=item eliminate_macros

Expands MM[KS]/Make macros in a text string, using the contents of
identically named elements of C<%$self>, and returns the result
as a file specification in Unix syntax.

NOTE:  This is the canonical version of the method.  The version in
L<File::Spec::VMS> is deprecated.

=cut

sub eliminate_macros {
    my($self,$path) = @_;
    return '' unless $path;
    $self = {} unless ref $self;

    my($npath) = unixify($path);
    # sometimes unixify will return a string with an off-by-one trailing null
    $npath =~ s{\0$}{};

    my($complex) = 0;
    my($head,$macro,$tail);

    # perform m##g in scalar context so it acts as an iterator
    while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) {
        if (defined $self->{$2}) {
            ($head,$macro,$tail) = ($1,$2,$3);
            if (ref $self->{$macro}) {
                if (ref $self->{$macro} eq 'ARRAY') {
                    $macro = join ' ', @{$self->{$macro}};
                }
                else {
                    print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
                          "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
                    $macro = "\cB$macro\cB";
                    $complex = 1;
                }
            }
            else {
                $macro = $self->{$macro};
                # Don't unixify if there is unescaped whitespace
                $macro = unixify($macro) unless ($macro =~ /(?<!\^)\s/);
                $macro =~ s#/\Z(?!\n)##;
            }
            $npath = "$head$macro$tail";
        }
    }
    if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
    $npath;
}

=item fixpath

   my $path = $mm->fixpath($path);
   my $path = $mm->fixpath($path, $is_dir);

Catchall routine to clean up problem MM[SK]/Make macros.  Expands macros
in any directory specification, in order to avoid juxtaposing two
VMS-syntax directories when MM[SK] is run.  Also expands expressions which
are all macro, so that we can tell how long the expansion is, and avoid
overrunning DCL's command buffer when MM[KS] is running.

fixpath() checks to see whether the result matches the name of a
directory in the current default directory and returns a directory or
file specification accordingly.  C<$is_dir> can be set to true to
force fixpath() to consider the path to be a directory or false to force
it to be a file.

NOTE:  This is the canonical version of the method.  The version in
L<File::Spec::VMS> is deprecated.

=cut

sub fixpath {
    my($self,$path,$force_path) = @_;
    return '' unless $path;
    $self = bless {}, $self unless ref $self;
    my($fixedpath,$prefix,$name);

    if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) {
        if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) {
            $fixedpath = vmspath($self->eliminate_macros($path));
        }
        else {
            $fixedpath = vmsify($self->eliminate_macros($path));
        }
    }
    elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) {
        my($vmspre) = $self->eliminate_macros("\$($prefix)");
        # is it a dir or just a name?
        $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : '';
        $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
        $fixedpath = vmspath($fixedpath) if $force_path;
    }
    else {
        $fixedpath = $path;
        $fixedpath = vmspath($fixedpath) if $force_path;
    }
    # No hints, so we try to guess
    if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
        $fixedpath = vmspath($fixedpath) if -d $fixedpath;
    }

    # Trim off root dirname if it's had other dirs inserted in front of it.
    $fixedpath =~ s/\.000000([\]>])/$1/;
    # Special case for VMS absolute directory specs: these will have had device
    # prepended during trip through Unix syntax in eliminate_macros(), since
    # Unix syntax has no way to express "absolute from the top of this device's
    # directory tree".
    if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }

    return $fixedpath;
}


=item os_flavor

VMS is VMS.

=cut

sub os_flavor {
    return('VMS');
}


=item is_make_type (override)

None of the make types being checked for is viable on VMS,
plus our $self->{MAKE} is an unexpanded (and unexpandable)
macro whose value is known only to the make utility itself.

=cut

sub is_make_type {
    my($self, $type) = @_;
    return 0;
}


=item make_type (override)

Returns a suitable string describing the type of makefile being written.

=cut

sub make_type { "$Config{make}-style"; }


=back


=head1 AUTHOR

Original author Charles Bailey F<bailey@newman.upenn.edu>

Maintained by Michael G Schwern F<schwern@pobox.com>

See L<ExtUtils::MakeMaker> for patching and contact information.


=cut

1;

PK       ! !�[  �[    perl5/ExtUtils/Manifest.pmnu ��6�$        package ExtUtils::Manifest;

require Exporter;
use Config;
use File::Basename;
use File::Copy 'copy';
use File::Find;
use File::Spec 0.8;
use Carp;
use strict;
use warnings;

our $VERSION = '1.70';
our @ISA = ('Exporter');
our @EXPORT_OK = qw(mkmanifest
                manicheck  filecheck  fullcheck  skipcheck
                manifind   maniread   manicopy   maniadd
                maniskip
               );

our $Is_MacOS = $^O eq 'MacOS';
our $Is_VMS   = $^O eq 'VMS';
our $Is_VMS_mode = 0;
our $Is_VMS_lc = 0;
our $Is_VMS_nodot = 0;  # No dots in dir names or double dots in files

if ($Is_VMS) {
    require VMS::Filespec if $Is_VMS;
    my $vms_unix_rpt;
    my $vms_efs;
    my $vms_case;

    $Is_VMS_mode = 1;
    $Is_VMS_lc = 1;
    $Is_VMS_nodot = 1;
    if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
        $vms_unix_rpt = VMS::Feature::current("filename_unix_report");
        $vms_efs = VMS::Feature::current("efs_charset");
        $vms_case = VMS::Feature::current("efs_case_preserve");
    } else {
        my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
        my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || '';
        my $efs_case = $ENV{'DECC$EFS_CASE_PRESERVE'} || '';
        $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i;
        $vms_efs = $efs_charset =~ /^[ET1]/i;
        $vms_case = $efs_case =~ /^[ET1]/i;
    }
    $Is_VMS_lc = 0 if ($vms_case);
    $Is_VMS_mode = 0 if ($vms_unix_rpt);
    $Is_VMS_nodot = 0 if ($vms_efs);
}

our $Debug   = $ENV{PERL_MM_MANIFEST_DEBUG} || 0;
our $Verbose = defined $ENV{PERL_MM_MANIFEST_VERBOSE} ?
                   $ENV{PERL_MM_MANIFEST_VERBOSE} : 1;
our $Quiet = 0;
our $MANIFEST = 'MANIFEST';

our $DEFAULT_MSKIP = File::Spec->catfile( dirname(__FILE__), "$MANIFEST.SKIP" );


=head1 NAME

ExtUtils::Manifest - utilities to write and check a MANIFEST file

=head1 VERSION

version 1.70

=head1 SYNOPSIS

    use ExtUtils::Manifest qw(...funcs to import...);

    mkmanifest();

    my @missing_files    = manicheck;
    my @skipped          = skipcheck;
    my @extra_files      = filecheck;
    my($missing, $extra) = fullcheck;

    my $found    = manifind();

    my $manifest = maniread();

    manicopy($read,$target);

    maniadd({$file => $comment, ...});


=head1 DESCRIPTION

=head2 Functions

ExtUtils::Manifest exports no functions by default.  The following are
exported on request

=over 4

=item mkmanifest

    mkmanifest();

Writes all files in and below the current directory to your F<MANIFEST>.
It works similar to the result of the Unix command

    find . > MANIFEST

All files that match any regular expression in a file F<MANIFEST.SKIP>
(if it exists) are ignored.

Any existing F<MANIFEST> file will be saved as F<MANIFEST.bak>.

=cut

sub _sort {
    return sort { lc $a cmp lc $b } @_;
}

sub mkmanifest {
    my $manimiss = 0;
    my $read = (-r 'MANIFEST' && maniread()) or $manimiss++;
    $read = {} if $manimiss;
    local *M;
    my $bakbase = $MANIFEST;
    $bakbase =~ s/\./_/g if $Is_VMS_nodot; # avoid double dots
    rename $MANIFEST, "$bakbase.bak" unless $manimiss;
    open M, "> $MANIFEST" or die "Could not open $MANIFEST: $!";
    binmode M, ':raw';
    my $skip = maniskip();
    my $found = manifind();
    my($key,$val,$file,%all);
    %all = (%$found, %$read);
    $all{$MANIFEST} = ($Is_VMS_mode ? "$MANIFEST\t\t" : '') .
                     'This list of files'
        if $manimiss; # add new MANIFEST to known file list
    foreach $file (_sort keys %all) {
	if ($skip->($file)) {
	    # Policy: only remove files if they're listed in MANIFEST.SKIP.
	    # Don't remove files just because they don't exist.
	    warn "Removed from $MANIFEST: $file\n" if $Verbose and exists $read->{$file};
	    next;
	}
	if ($Verbose){
	    warn "Added to $MANIFEST: $file\n" unless exists $read->{$file};
	}
	my $text = $all{$file};
	$file = _unmacify($file);
	my $tabs = (5 - (length($file)+1)/8);
	$tabs = 1 if $tabs < 1;
	$tabs = 0 unless $text;
        if ($file =~ /\s/) {
            $file =~ s/([\\'])/\\$1/g;
            $file = "'$file'";
        }
	print M $file, "\t" x $tabs, $text, "\n";
    }
    close M;
}

# Geez, shouldn't this use File::Spec or File::Basename or something?
# Why so careful about dependencies?
sub clean_up_filename {
  my $filename = shift;
  $filename =~ s|^\./||;
  $filename =~ s/^:([^:]+)$/$1/ if $Is_MacOS;
  if ( $Is_VMS ) {
      $filename =~ s/\.$//;                           # trim trailing dot
      $filename = VMS::Filespec::unixify($filename);  # unescape spaces, etc.
      if( $Is_VMS_lc ) {
          $filename = lc($filename);
          $filename = uc($filename) if $filename =~ /^MANIFEST(\.SKIP)?$/i;
      }
  }
  return $filename;
}


=item manifind

    my $found = manifind();

returns a hash reference. The keys of the hash are the files found
below the current directory.

=cut

sub manifind {
    my $p = shift || {};
    my $found = {};

    my $wanted = sub {
	my $name = clean_up_filename($File::Find::name);
	warn "Debug: diskfile $name\n" if $Debug;
	return if -d $_;
	$found->{$name} = "";
    };

    # We have to use "$File::Find::dir/$_" in preprocess, because
    # $File::Find::name is unavailable.
    # Also, it's okay to use / here, because MANIFEST files use Unix-style
    # paths.
    find({wanted => $wanted, follow_fast => 1},
	 $Is_MacOS ? ":" : ".");

    return $found;
}


=item manicheck

    my @missing_files = manicheck();

checks if all the files within a C<MANIFEST> in the current directory
really do exist. If C<MANIFEST> and the tree below the current
directory are in sync it silently returns an empty list.
Otherwise it returns a list of files which are listed in the
C<MANIFEST> but missing from the directory, and by default also
outputs these names to STDERR.

=cut

sub manicheck {
    return _check_files();
}


=item filecheck

    my @extra_files = filecheck();

finds files below the current directory that are not mentioned in the
C<MANIFEST> file. An optional file C<MANIFEST.SKIP> will be
consulted. Any file matching a regular expression in such a file will
not be reported as missing in the C<MANIFEST> file. The list of any
extraneous files found is returned, and by default also reported to
STDERR.

=cut

sub filecheck {
    return _check_manifest();
}


=item fullcheck

    my($missing, $extra) = fullcheck();

does both a manicheck() and a filecheck(), returning then as two array
refs.

=cut

sub fullcheck {
    return [_check_files()], [_check_manifest()];
}


=item skipcheck

    my @skipped = skipcheck();

lists all the files that are skipped due to your C<MANIFEST.SKIP>
file.

=cut

sub skipcheck {
    my($p) = @_;
    my $found = manifind();
    my $matches = maniskip();

    my @skipped = ();
    foreach my $file (_sort keys %$found){
        if (&$matches($file)){
            warn "Skipping $file\n" unless $Quiet;
            push @skipped, $file;
            next;
        }
    }

    return @skipped;
}


sub _check_files {
    my $p = shift;
    my $dosnames=(defined(&Dos::UseLFN) && Dos::UseLFN()==0);
    my $read = maniread() || {};
    my $found = manifind($p);

    my(@missfile) = ();
    foreach my $file (_sort keys %$read){
        warn "Debug: manicheck checking from $MANIFEST $file\n" if $Debug;
        if ($dosnames){
            $file = lc $file;
            $file =~ s=(\.(\w|-)+)=substr ($1,0,4)=ge;
            $file =~ s=((\w|-)+)=substr ($1,0,8)=ge;
        }
        unless ( exists $found->{$file} ) {
            warn "No such file: $file\n" unless $Quiet;
            push @missfile, $file;
        }
    }

    return @missfile;
}


sub _check_manifest {
    my($p) = @_;
    my $read = maniread() || {};
    my $found = manifind($p);
    my $skip  = maniskip();

    my @missentry = ();
    foreach my $file (_sort keys %$found){
        next if $skip->($file);
        warn "Debug: manicheck checking from disk $file\n" if $Debug;
        unless ( exists $read->{$file} ) {
            my $canon = $Is_MacOS ? "\t" . _unmacify($file) : '';
            warn "Not in $MANIFEST: $file$canon\n" unless $Quiet;
            push @missentry, $file;
        }
    }

    return @missentry;
}


=item maniread

    my $manifest = maniread();
    my $manifest = maniread($manifest_file);

reads a named C<MANIFEST> file (defaults to C<MANIFEST> in the current
directory) and returns a HASH reference with files being the keys and
comments being the values of the HASH.  Blank lines and lines which
start with C<#> in the C<MANIFEST> file are discarded.

=cut

sub maniread {
    my ($mfile) = @_;
    $mfile ||= $MANIFEST;
    my $read = {};
    local *M;
    unless (open M, "< $mfile"){
        warn "Problem opening $mfile: $!";
        return $read;
    }
    local $_;
    while (<M>){
        chomp;
        next if /^\s*#/;

        my($file, $comment);

        # filename may contain spaces if enclosed in ''
        # (in which case, \\ and \' are escapes)
        if (($file, $comment) = /^'((?:\\[\\']|.+)+)'\s*(.*)/) {
            $file =~ s/\\([\\'])/$1/g;
        }
        else {
            ($file, $comment) = /^(\S+)\s*(.*)/;
        }
        next unless $file;

        if ($Is_MacOS) {
            $file = _macify($file);
            $file =~ s/\\([0-3][0-7][0-7])/sprintf("%c", oct($1))/ge;
        }
        elsif ($Is_VMS_mode) {
            require File::Basename;
            my($base,$dir) = File::Basename::fileparse($file);
            # Resolve illegal file specifications in the same way as tar
            if ($Is_VMS_nodot) {
                $dir =~ tr/./_/;
                my(@pieces) = split(/\./,$base);
                if (@pieces > 2)
                    { $base = shift(@pieces) . '.' . join('_',@pieces); }
                my $okfile = "$dir$base";
                warn "Debug: Illegal name $file changed to $okfile\n" if $Debug;
                $file = $okfile;
            }
            if( $Is_VMS_lc ) {
                $file = lc($file);
                $file = uc($file) if $file =~ /^MANIFEST(\.SKIP)?$/i;
            }
        }

        $read->{$file} = $comment;
    }
    close M;
    $read;
}

=item maniskip

    my $skipchk = maniskip();
    my $skipchk = maniskip($manifest_skip_file);

    if ($skipchk->($file)) { .. }

reads a named C<MANIFEST.SKIP> file (defaults to C<MANIFEST.SKIP> in
the current directory) and returns a CODE reference that tests whether
a given filename should be skipped.

=cut

# returns an anonymous sub that decides if an argument matches
sub maniskip {
    my @skip ;
    my $mfile = shift || "$MANIFEST.SKIP";
    _check_mskip_directives($mfile) if -f $mfile;
    local(*M, $_);
    open M, "< $mfile" or open M, "< $DEFAULT_MSKIP" or return sub {0};
    while (<M>){
      chomp;
      s/\r//;
      $_ =~ qr{^\s*(?:(?:'([^\\']*(?:\\.[^\\']*)*)')|([^#\s]\S*))?(?:(?:\s*)|(?:\s+(.*?)\s*))$};
      #my $comment = $3;
      my $filename = $2;
      if ( defined($1) ) {
        $filename = $1;
        $filename =~ s/\\(['\\])/$1/g;
      }
      next if (not defined($filename) or not $filename);
      push @skip, _macify($filename);
    }
    close M;
    return sub {0} unless (scalar @skip > 0);

    my $opts = $Is_VMS_mode ? '(?i)' : '';

    # Make sure each entry is isolated in its own parentheses, in case
    # any of them contain alternations
    my $regex = join '|', map "(?:$_)", @skip;

    return sub { $_[0] =~ qr{$opts$regex} };
}

# checks for the special directives
#   #!include_default
#   #!include /path/to/some/manifest.skip
# in a custom MANIFEST.SKIP for, for including
# the content of, respectively, the default MANIFEST.SKIP
# and an external manifest.skip file
sub _check_mskip_directives {
    my $mfile = shift;
    local (*M, $_);
    my @lines = ();
    my $flag = 0;
    unless (open M, "< $mfile") {
        warn "Problem opening $mfile: $!";
        return;
    }
    while (<M>) {
        if (/^#!include_default\s*$/) {
	    if (my @default = _include_mskip_file()) {
	        push @lines, @default;
		warn "Debug: Including default MANIFEST.SKIP\n" if $Debug;
		$flag++;
	    }
	    next;
        }
	if (/^#!include\s+(.*)\s*$/) {
	    my $external_file = $1;
	    if (my @external = _include_mskip_file($external_file)) {
	        push @lines, @external;
		warn "Debug: Including external $external_file\n" if $Debug;
		$flag++;
	    }
            next;
        }
        push @lines, $_;
    }
    close M;
    return unless $flag;
    my $bakbase = $mfile;
    $bakbase =~ s/\./_/g if $Is_VMS_nodot;  # avoid double dots
    rename $mfile, "$bakbase.bak";
    warn "Debug: Saving original $mfile as $bakbase.bak\n" if $Debug;
    unless (open M, "> $mfile") {
        warn "Problem opening $mfile: $!";
        return;
    }
    binmode M, ':raw';
    print M $_ for (@lines);
    close M;
    return;
}

# returns an array containing the lines of an external
# manifest.skip file, if given, or $DEFAULT_MSKIP
sub _include_mskip_file {
    my $mskip = shift || $DEFAULT_MSKIP;
    unless (-f $mskip) {
        warn qq{Included file "$mskip" not found - skipping};
        return;
    }
    local (*M, $_);
    unless (open M, "< $mskip") {
        warn "Problem opening $mskip: $!";
        return;
    }
    my @lines = ();
    push @lines, "\n#!start included $mskip\n";
    push @lines, $_ while <M>;
    close M;
    push @lines, "#!end included $mskip\n\n";
    return @lines;
}

=item manicopy

    manicopy(\%src, $dest_dir);
    manicopy(\%src, $dest_dir, $how);

Copies the files that are the keys in %src to the $dest_dir.  %src is
typically returned by the maniread() function.

    manicopy( maniread(), $dest_dir );

This function is useful for producing a directory tree identical to the
intended distribution tree.

$how can be used to specify a different methods of "copying".  Valid
values are C<cp>, which actually copies the files, C<ln> which creates
hard links, and C<best> which mostly links the files but copies any
symbolic link to make a tree without any symbolic link.  C<cp> is the
default.

=cut

sub manicopy {
    my($read,$target,$how)=@_;
    croak "manicopy() called without target argument" unless defined $target;
    $how ||= 'cp';
    require File::Path;
    require File::Basename;

    $target = VMS::Filespec::unixify($target) if $Is_VMS_mode;
    File::Path::mkpath([ $target ],! $Quiet,$Is_VMS ? undef : 0755);
    foreach my $file (keys %$read){
	if ($Is_MacOS) {
	    if ($file =~ m!:!) {
		my $dir = _maccat($target, $file);
		$dir =~ s/[^:]+$//;
		File::Path::mkpath($dir,1,0755);
	    }
	    cp_if_diff($file, _maccat($target, $file), $how);
	} else {
	    $file = VMS::Filespec::unixify($file) if $Is_VMS_mode;
	    if ($file =~ m!/!) { # Ilya, that hurts, I fear, or maybe not?
		my $dir = File::Basename::dirname($file);
		$dir = VMS::Filespec::unixify($dir) if $Is_VMS_mode;
		File::Path::mkpath(["$target/$dir"],! $Quiet,$Is_VMS ? undef : 0755);
	    }
	    cp_if_diff($file, "$target/$file", $how);
	}
    }
}

sub cp_if_diff {
    my($from, $to, $how)=@_;
    if (! -f $from) {
        carp "$from not found";
        return;
    }
    my($diff) = 0;
    local(*F,*T);
    open(F,"< $from\0") or die "Can't read $from: $!\n";
    if (open(T,"< $to\0")) {
        local $_;
	while (<F>) { $diff++,last if $_ ne <T>; }
	$diff++ unless eof(T);
	close T;
    }
    else { $diff++; }
    close F;
    if ($diff) {
	if (-e $to) {
	    unlink($to) or confess "unlink $to: $!";
	}
        STRICT_SWITCH: {
	    best($from,$to), last STRICT_SWITCH if $how eq 'best';
	    cp($from,$to), last STRICT_SWITCH if $how eq 'cp';
	    ln($from,$to), last STRICT_SWITCH if $how eq 'ln';
	    croak("ExtUtils::Manifest::cp_if_diff " .
		  "called with illegal how argument [$how]. " .
		  "Legal values are 'best', 'cp', and 'ln'.");
	}
    }
}

sub cp {
    my ($srcFile, $dstFile) = @_;
    my ($access,$mod) = (stat $srcFile)[8,9];

    copy($srcFile,$dstFile);
    utime $access, $mod + ($Is_VMS ? 1 : 0), $dstFile;
    _manicopy_chmod($srcFile, $dstFile);
}


sub ln {
    my ($srcFile, $dstFile) = @_;
    # Fix-me - VMS can support links.
    return &cp if $Is_VMS or ($^O eq 'MSWin32' and Win32::IsWin95());
    link($srcFile, $dstFile);

    unless( _manicopy_chmod($srcFile, $dstFile) ) {
        unlink $dstFile;
        return;
    }
    1;
}

# 1) Strip off all group and world permissions.
# 2) Let everyone read it.
# 3) If the owner can execute it, everyone can.
sub _manicopy_chmod {
    my($srcFile, $dstFile) = @_;

    my $perm = 0444 | (stat $srcFile)[2] & 0700;
    chmod( $perm | ( $perm & 0100 ? 0111 : 0 ), $dstFile );
}

# Files that are often modified in the distdir.  Don't hard link them.
my @Exceptions = qw(MANIFEST META.yml SIGNATURE);
sub best {
    my ($srcFile, $dstFile) = @_;

    my $is_exception = grep $srcFile =~ /$_/, @Exceptions;
    if ($is_exception or !$Config{d_link} or -l $srcFile) {
	cp($srcFile, $dstFile);
    } else {
	ln($srcFile, $dstFile) or cp($srcFile, $dstFile);
    }
}

sub _macify {
    my($file) = @_;

    return $file unless $Is_MacOS;

    $file =~ s|^\./||;
    if ($file =~ m|/|) {
	$file =~ s|/+|:|g;
	$file = ":$file";
    }

    $file;
}

sub _maccat {
    my($f1, $f2) = @_;

    return "$f1/$f2" unless $Is_MacOS;

    $f1 .= ":$f2";
    $f1 =~ s/([^:]:):/$1/g;
    return $f1;
}

sub _unmacify {
    my($file) = @_;

    return $file unless $Is_MacOS;

    $file =~ s|^:||;
    $file =~ s|([/ \n])|sprintf("\\%03o", unpack("c", $1))|ge;
    $file =~ y|:|/|;

    $file;
}


=item maniadd

  maniadd({ $file => $comment, ...});

Adds an entry to an existing F<MANIFEST> unless its already there.

$file will be normalized (ie. Unixified).  B<UNIMPLEMENTED>

=cut

sub maniadd {
    my($additions) = shift;

    _normalize($additions);
    _fix_manifest($MANIFEST);

    my $manifest = maniread();
    my @needed = grep { !exists $manifest->{$_} } keys %$additions;
    return 1 unless @needed;

    open(MANIFEST, ">>$MANIFEST") or
      die "maniadd() could not open $MANIFEST: $!";
    binmode MANIFEST, ':raw';

    foreach my $file (_sort @needed) {
        my $comment = $additions->{$file} || '';
        if ($file =~ /\s/) {
            $file =~ s/([\\'])/\\$1/g;
            $file = "'$file'";
        }
        printf MANIFEST "%-40s %s\n", $file, $comment;
    }
    close MANIFEST or die "Error closing $MANIFEST: $!";

    return 1;
}


# Make sure this MANIFEST is consistently written with native
# newlines and has a terminal newline.
sub _fix_manifest {
    my $manifest_file = shift;

    open MANIFEST, $MANIFEST or die "Could not open $MANIFEST: $!";
    local $/;
    my @manifest = split /(\015\012|\012|\015)/, <MANIFEST>, -1;
    close MANIFEST;
    my $must_rewrite = "";
    if ($manifest[-1] eq ""){
        # sane case: last line had a terminal newline
        pop @manifest;
        for (my $i=1; $i<=$#manifest; $i+=2) {
            unless ($manifest[$i] eq "\n") {
                $must_rewrite = "not a newline at pos $i";
                last;
            }
        }
    } else {
        $must_rewrite = "last line without newline";
    }

    if ( $must_rewrite ) {
        1 while unlink $MANIFEST; # avoid multiple versions on VMS
        open MANIFEST, ">", $MANIFEST or die "(must_rewrite=$must_rewrite) Could not open >$MANIFEST: $!";
	binmode MANIFEST, ':raw';
        for (my $i=0; $i<=$#manifest; $i+=2) {
            print MANIFEST "$manifest[$i]\n";
        }
        close MANIFEST or die "could not write $MANIFEST: $!";
    }
}


# UNIMPLEMENTED
sub _normalize {
    return;
}


=back

=head2 MANIFEST

A list of files in the distribution, one file per line.  The MANIFEST
always uses Unix filepath conventions even if you're not on Unix.  This
means F<foo/bar> style not F<foo\bar>.

Anything between white space and an end of line within a C<MANIFEST>
file is considered to be a comment.  Any line beginning with # is also
a comment. Beginning with ExtUtils::Manifest 1.52, a filename may
contain whitespace characters if it is enclosed in single quotes; single
quotes or backslashes in that filename must be backslash-escaped.

    # this a comment
    some/file
    some/other/file            comment about some/file
    'some/third file'          comment


=head2 MANIFEST.SKIP

The file MANIFEST.SKIP may contain regular expressions of files that
should be ignored by mkmanifest() and filecheck(). The regular
expressions should appear one on each line. Blank lines and lines
which start with C<#> are skipped.  Use C<\#> if you need a regular
expression to start with a C<#>.

For example:

    # Version control files and dirs.
    \bRCS\b
    \bCVS\b
    ,v$
    \B\.svn\b

    # Makemaker generated files and dirs.
    ^MANIFEST\.
    ^Makefile$
    ^blib/
    ^MakeMaker-\d

    # Temp, old and emacs backup files.
    ~$
    \.old$
    ^#.*#$
    ^\.#

If no MANIFEST.SKIP file is found, a default set of skips will be
used, similar to the example above.  If you want nothing skipped,
simply make an empty MANIFEST.SKIP file.

In one's own MANIFEST.SKIP file, certain directives
can be used to include the contents of other MANIFEST.SKIP
files. At present two such directives are recognized.

=over 4

=item #!include_default

This inserts the contents of the default MANIFEST.SKIP file

=item #!include /Path/to/another/manifest.skip

This inserts the contents of the specified external file

=back

The included contents will be inserted into the MANIFEST.SKIP
file in between I<#!start included /path/to/manifest.skip>
and I<#!end included /path/to/manifest.skip> markers.
The original MANIFEST.SKIP is saved as MANIFEST.SKIP.bak.

=head2 EXPORT_OK

C<&mkmanifest>, C<&manicheck>, C<&filecheck>, C<&fullcheck>,
C<&maniread>, and C<&manicopy> are exportable.

=head2 GLOBAL VARIABLES

C<$ExtUtils::Manifest::MANIFEST> defaults to C<MANIFEST>. Changing it
results in both a different C<MANIFEST> and a different
C<MANIFEST.SKIP> file. This is useful if you want to maintain
different distributions for different audiences (say a user version
and a developer version including RCS).

C<$ExtUtils::Manifest::Quiet> defaults to 0. If set to a true value,
all functions act silently.

C<$ExtUtils::Manifest::Debug> defaults to 0.  If set to a true value,
or if PERL_MM_MANIFEST_DEBUG is true, debugging output will be
produced.

=head1 DIAGNOSTICS

All diagnostic output is sent to C<STDERR>.

=over 4

=item C<Not in MANIFEST:> I<file>

is reported if a file is found which is not in C<MANIFEST>.

=item C<Skipping> I<file>

is reported if a file is skipped due to an entry in C<MANIFEST.SKIP>.

=item C<No such file:> I<file>

is reported if a file mentioned in a C<MANIFEST> file does not
exist.

=item C<MANIFEST:> I<$!>

is reported if C<MANIFEST> could not be opened.

=item C<Added to MANIFEST:> I<file>

is reported by mkmanifest() if $Verbose is set and a file is added
to MANIFEST. $Verbose is set to 1 by default.

=back

=head1 ENVIRONMENT

=over 4

=item B<PERL_MM_MANIFEST_DEBUG>

Turns on debugging

=back

=head1 SEE ALSO

L<ExtUtils::MakeMaker> which has handy targets for most of the functionality.

=head1 AUTHOR

Andreas Koenig C<andreas.koenig@anima.de>

Currently maintained by the Perl Toolchain Gang.

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 1996- by Andreas Koenig.

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

=cut

1;
PK       ! �h,�  �    perl5/ExtUtils/MM.pmnu ��6�$        package ExtUtils::MM;

use strict;
use warnings;
use ExtUtils::MakeMaker::Config;

our $VERSION = '7.50';
$VERSION =~ tr/_//d;

require ExtUtils::Liblist;
require ExtUtils::MakeMaker;
our @ISA = qw(ExtUtils::Liblist ExtUtils::MakeMaker);

=head1 NAME

ExtUtils::MM - OS adjusted ExtUtils::MakeMaker subclass

=head1 SYNOPSIS

  require ExtUtils::MM;
  my $mm = MM->new(...);

=head1 DESCRIPTION

B<FOR INTERNAL USE ONLY>

ExtUtils::MM is a subclass of L<ExtUtils::MakeMaker> which automatically
chooses the appropriate OS specific subclass for you
(ie. L<ExtUtils::MM_Unix>, etc...).

It also provides a convenient alias via the MM class (I didn't want
MakeMaker modules outside of ExtUtils/).

This class might turn out to be a temporary solution, but MM won't go
away.

=cut

{
    # Convenient alias.
    package MM;
    our @ISA = qw(ExtUtils::MM);
    sub DESTROY {}
}

sub _is_win95 {
    # miniperl might not have the Win32 functions available and we need
    # to run in miniperl.
    my $have_win32 = eval { require Win32 };
    return $have_win32 && defined &Win32::IsWin95 ? Win32::IsWin95()
                                                  : ! defined $ENV{SYSTEMROOT};
}

my %Is = ();
$Is{VMS}    = $^O eq 'VMS';
$Is{OS2}    = $^O eq 'os2';
$Is{MacOS}  = $^O eq 'MacOS';
if( $^O eq 'MSWin32' ) {
    _is_win95() ? $Is{Win95} = 1 : $Is{Win32} = 1;
}
$Is{UWIN}   = $^O =~ /^uwin(-nt)?$/;
$Is{Cygwin} = $^O eq 'cygwin';
$Is{NW5}    = $Config{osname} eq 'NetWare';  # intentional
$Is{BeOS}   = ($^O =~ /beos/i or $^O eq 'haiku');
$Is{DOS}    = $^O eq 'dos';
if( $Is{NW5} ) {
    $^O = 'NetWare';
    delete $Is{Win32};
}
$Is{VOS}    = $^O eq 'vos';
$Is{QNX}    = $^O eq 'qnx';
$Is{AIX}    = $^O eq 'aix';
$Is{Darwin} = $^O eq 'darwin';
$Is{OS390}  = $^O eq 'os390';

$Is{Unix}   = !grep { $_ } values %Is;

map { delete $Is{$_} unless $Is{$_} } keys %Is;
_assert( keys %Is == 1 );
my($OS) = keys %Is;


my $class = "ExtUtils::MM_$OS";
eval "require $class" unless $INC{"ExtUtils/MM_$OS.pm"}; ## no critic
die $@ if $@;
unshift @ISA, $class;


sub _assert {
    my $sanity = shift;
    die sprintf "Assert failed at %s line %d\n", (caller)[1,2] unless $sanity;
    return;
}
PK       ! Z�X��  �    perl5/ExtUtils/MM_OS390.pmnu ��6�$        package ExtUtils::MM_OS390;

use strict;
use warnings;
our $VERSION = '7.50';
$VERSION =~ tr/_//d;

use ExtUtils::MakeMaker::Config;
require ExtUtils::MM_Unix;
our @ISA = qw(ExtUtils::MM_Unix);

=head1 NAME

ExtUtils::MM_OS390 - OS390 specific subclass of ExtUtils::MM_Unix

=head1 SYNOPSIS

  Don't use this module directly.
  Use ExtUtils::MM and let it choose.

=head1 DESCRIPTION

This is a subclass of L<ExtUtils::MM_Unix> which contains functionality for
OS390.

Unless otherwise stated it works just like ExtUtils::MM_Unix.

=head2 Overriden methods

=over

=item xs_make_dynamic_lib

Defines the recipes for the C<dynamic_lib> section.

=cut

sub xs_make_dynamic_lib {
    my ($self, $attribs, $object, $to, $todir, $ldfrom, $exportlist, $dlsyms) = @_;
    $exportlist = '' if $exportlist ne '$(EXPORT_LIST)';
    my $armaybe = $self->_xs_armaybe($attribs);
    my @m = sprintf '%s : %s $(MYEXTLIB) %s$(DFSEP).exists %s $(PERL_ARCHIVEDEP) $(PERL_ARCHIVE_AFTER) $(INST_DYNAMIC_DEP) %s'."\n", $to, $object, $todir, $exportlist, ($dlsyms || '');
    my $dlsyms_arg = $self->xs_dlsyms_arg($dlsyms);
    if ($armaybe ne ':'){
        $ldfrom = 'tmp$(LIB_EXT)';
        push(@m,"	\$(ARMAYBE) cr $ldfrom $object\n");
        push(@m,"	\$(RANLIB) $ldfrom\n");
    }

    # For example in AIX the shared objects/libraries from previous builds
    # linger quite a while in the shared dynalinker cache even when nobody
    # is using them.  This is painful if one for instance tries to restart
    # a failed build because the link command will fail unnecessarily 'cos
    # the shared object/library is 'busy'.
    push(@m,"	\$(RM_F) \$\@\n");

    my $libs = '$(LDLOADLIBS)';

    my $ld_run_path_shell = "";
    if ($self->{LD_RUN_PATH} ne "") {
        $ld_run_path_shell = 'LD_RUN_PATH="$(LD_RUN_PATH)" ';
    }

    push @m, sprintf <<'MAKE', $ld_run_path_shell, $dlsyms_arg, $self->xs_obj_opt('$@'), $ldfrom, $libs, $exportlist;
	%s$(LD) $(LDDLFLAGS) %s $(OTHERLDFLAGS) %s $(MYEXTLIB) %s \
	  $(PERL_ARCHIVE) %s $(PERL_ARCHIVE_AFTER) %s \
	  $(INST_DYNAMIC_FIX)
	$(CHMOD) $(PERM_RWX) $@
MAKE
    join '', @m;
}

1;

=back

=head1 AUTHOR

Michael G Schwern <schwern@pobox.com> with code from ExtUtils::MM_Unix

=head1 SEE ALSO

L<ExtUtils::MakeMaker>

=cut
__END__
PK       !  ���  �    perl5/ExtUtils/MANIFEST.SKIPnu ��6�$        # Avoid version control files.
\bRCS\b
\bCVS\b
\bSCCS\b
,v$
\B\.svn\b
\B\.git\b
\B\.gitignore\b
\b_darcs\b
\B\.cvsignore$

# Avoid VMS specific MakeMaker generated files
\bDescrip.MMS$
\bDESCRIP.MMS$
\bdescrip.mms$

# Avoid Makemaker generated and utility files.
\bMANIFEST\.bak
\bMakefile$
\bblib/
\bMakeMaker-\d
\bpm_to_blib\.ts$
\bpm_to_blib$
\bblibdirs\.ts$         # 6.18 through 6.25 generated this
\b_eumm/                # 7.05_05 and above

# Avoid Module::Build generated and utility files.
\bBuild$
\b_build/
\bBuild.bat$
\bBuild.COM$
\bBUILD.COM$
\bbuild.com$

# and Module::Build::Tiny generated files
\b_build_params$

# Avoid temp and backup files.
~$
\.old$
\#$
\b\.#
\.bak$
\.tmp$
\.#
\.rej$
\..*\.sw.?$

# Avoid OS-specific files/dirs
# Mac OSX metadata
\B\.DS_Store
# Mac OSX SMB mount metadata files
\B\._

# Avoid Devel::Cover and Devel::CoverX::Covered files.
\bcover_db\b
\bcovered\b

# Avoid prove files
\B\.prove$

# Avoid MYMETA files
^MYMETA\.
PK       ! آ~<&  &    perl5/ExtUtils/MM_BeOS.pmnu ��6�$        package ExtUtils::MM_BeOS;

use strict;
use warnings;

=head1 NAME

ExtUtils::MM_BeOS - methods to override UN*X behaviour in ExtUtils::MakeMaker

=head1 SYNOPSIS

 use ExtUtils::MM_BeOS;	# Done internally by ExtUtils::MakeMaker if needed

=head1 DESCRIPTION

See L<ExtUtils::MM_Unix> for a documentation of the methods provided
there. This package overrides the implementation of these methods, not
the semantics.

=over 4

=cut

use ExtUtils::MakeMaker::Config;
use File::Spec;
require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;

our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );
our $VERSION = '7.50';
$VERSION =~ tr/_//d;


=item os_flavor

BeOS is BeOS.

=cut

sub os_flavor {
    return('BeOS');
}

=item init_linker

libperl.a equivalent to be linked to dynamic extensions.

=cut

sub init_linker {
    my($self) = shift;

    $self->{PERL_ARCHIVE} ||=
      File::Spec->catdir('$(PERL_INC)',$Config{libperl});
    $self->{PERL_ARCHIVEDEP} ||= '';
    $self->{PERL_ARCHIVE_AFTER} ||= '';
    $self->{EXPORT_LIST}  ||= '';
}

=back

=cut

1;
__END__

PK       ! ђ�C6  6    perl5/ExtUtils/ParseXS.podnu ��6�$        =head1 NAME

ExtUtils::ParseXS - converts Perl XS code into C code

=head1 SYNOPSIS

  use ExtUtils::ParseXS;

  my $pxs = ExtUtils::ParseXS->new;
  $pxs->process_file( filename => 'foo.xs' );

  $pxs->process_file( filename => 'foo.xs',
                      output => 'bar.c',
                      'C++' => 1,
                      typemap => 'path/to/typemap',
                      hiertype => 1,
                      except => 1,
                      versioncheck => 1,
                      linenumbers => 1,
                      optimize => 1,
                      prototypes => 1,
                    );

  # Legacy non-OO interface using a singleton:
  use ExtUtils::ParseXS qw(process_file);
  process_file( filename => 'foo.xs' );

=head1 DESCRIPTION

C<ExtUtils::ParseXS> will compile XS code into C code by embedding the constructs
necessary to let C functions manipulate Perl values and creates the glue
necessary to let Perl access those functions.  The compiler uses typemaps to
determine how to map C function parameters and variables to Perl values.

The compiler will search for typemap files called I<typemap>.  It will use
the following search path to find default typemaps, with the rightmost
typemap taking precedence.

    ../../../typemap:../../typemap:../typemap:typemap

=head1 EXPORT

None by default.  C<process_file()> and/or C<report_error_count()>
may be exported upon request. Using the functional interface is
discouraged.

=head1 METHODS

=over 4

=item $pxs->new()

Returns a new, empty XS parser/compiler object.

=item $pxs->process_file()

This method processes an XS file and sends output to a C file.
The method may be called as a function (this is the legacy
interface) and will then use a singleton as invocant.

Named parameters control how the processing is done.
The following parameters are accepted:

=over 4

=item B<C++>

Adds C<extern "C"> to the C code.  Default is false.

=item B<hiertype>

Retains C<::> in type names so that C++ hierarchical types can be
mapped.  Default is false.

=item B<except>

Adds exception handling stubs to the C code.  Default is false.

=item B<typemap>

Indicates that a user-supplied typemap should take precedence over the
default typemaps.  A single typemap may be specified as a string, or
multiple typemaps can be specified in an array reference, with the
last typemap having the highest precedence.

=item B<prototypes>

Generates prototype code for all xsubs.  Default is false.

=item B<versioncheck>

Makes sure at run time that the object file (derived from the C<.xs>
file) and the C<.pm> files have the same version number.  Default is
true.

=item B<linenumbers>

Adds C<#line> directives to the C output so error messages will look
like they came from the original XS file.  Default is true.

=item B<optimize>

Enables certain optimizations.  The only optimization that is currently
affected is the use of I<target>s by the output C code (see L<perlguts>).
Not optimizing may significantly slow down the generated code, but this is the way
B<xsubpp> of 5.005 and earlier operated.  Default is to optimize.

=item B<inout>

Enable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST>
declarations.  Default is true.

=item B<argtypes>

Enable recognition of ANSI-like descriptions of function signature.
Default is true.

=item B<s>

I<Maintainer note:> I have no clue what this does.  Strips function prefixes?

=back

=item $pxs->report_error_count()

This method returns the number of [a certain kind of] errors
encountered during processing of the XS file.

The method may be called as a function (this is the legacy
interface) and will then use a singleton as invocant.

=back

=head1 AUTHOR

Based on xsubpp code, written by Larry Wall.

Maintained by:

=over 4

=item *

Ken Williams, <ken@mathforum.org>

=item *

David Golden, <dagolden@cpan.org>

=item *

James Keenan, <jkeenan@cpan.org>

=item *

Steffen Mueller, <smueller@cpan.org>

=back

=head1 COPYRIGHT

Copyright 2002-2014 by Ken Williams, David Golden and other contributors.  All
rights reserved.

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

Based on the C<ExtUtils::xsubpp> code by Larry Wall and the Perl 5
Porters, which was released under the same license terms.

=head1 SEE ALSO

L<perl>, ExtUtils::xsubpp, ExtUtils::MakeMaker, L<perlxs>, L<perlxstut>.

=cut


PK       ! 3^�h  �h    perl5/ExtUtils/Typemaps.pmnu ��6�$        package ExtUtils::Typemaps;
use 5.006001;
use strict;
use warnings;
our $VERSION = '3.35';

require ExtUtils::ParseXS;
require ExtUtils::ParseXS::Constants;
require ExtUtils::Typemaps::InputMap;
require ExtUtils::Typemaps::OutputMap;
require ExtUtils::Typemaps::Type;

=head1 NAME

ExtUtils::Typemaps - Read/Write/Modify Perl/XS typemap files

=head1 SYNOPSIS

  # read/create file
  my $typemap = ExtUtils::Typemaps->new(file => 'typemap');
  # alternatively create an in-memory typemap
  # $typemap = ExtUtils::Typemaps->new();
  # alternatively create an in-memory typemap by parsing a string
  # $typemap = ExtUtils::Typemaps->new(string => $sometypemap);

  # add a mapping
  $typemap->add_typemap(ctype => 'NV', xstype => 'T_NV');
  $typemap->add_inputmap(
     xstype => 'T_NV', code => '$var = ($type)SvNV($arg);'
  );
  $typemap->add_outputmap(
     xstype => 'T_NV', code => 'sv_setnv($arg, (NV)$var);'
  );
  $typemap->add_string(string => $typemapstring);
                                           # will be parsed and merged

  # remove a mapping (same for remove_typemap and remove_outputmap...)
  $typemap->remove_inputmap(xstype => 'SomeType');

  # save a typemap to a file
  $typemap->write(file => 'anotherfile.map');

  # merge the other typemap into this one
  $typemap->merge(typemap => $another_typemap);

=head1 DESCRIPTION

This module can read, modify, create and write Perl XS typemap files. If you don't know
what a typemap is, please confer the L<perlxstut> and L<perlxs> manuals.

The module is not entirely round-trip safe: For example it currently simply strips all comments.
The order of entries in the maps is, however, preserved.

We check for duplicate entries in the typemap, but do not check for missing
C<TYPEMAP> entries for C<INPUTMAP> or C<OUTPUTMAP> entries since these might be hidden
in a different typemap.

=head1 METHODS

=cut

=head2 new

Returns a new typemap object. Takes an optional C<file> parameter.
If set, the given file will be read. If the file doesn't exist, an empty typemap
is returned.

Alternatively, if the C<string> parameter is given, the supplied
string will be parsed instead of a file.

=cut

sub new {
  my $class = shift;
  my %args = @_;

  if (defined $args{file} and defined $args{string}) {
    die("Cannot handle both 'file' and 'string' arguments to constructor");
  }

  my $self = bless {
    file            => undef,
    %args,
    typemap_section => [],
    typemap_lookup  => {},
    input_section   => [],
    input_lookup    => {},
    output_section  => [],
    output_lookup   => {},
  } => $class;

  $self->_init();

  return $self;
}

sub _init {
  my $self = shift;
  if (defined $self->{string}) {
    $self->_parse(\($self->{string}), $self->{lineno_offset}, $self->{fake_filename});
    delete $self->{string};
  }
  elsif (defined $self->{file} and -e $self->{file}) {
    open my $fh, '<', $self->{file}
      or die "Cannot open typemap file '"
             . $self->{file} . "' for reading: $!";
    local $/ = undef;
    my $string = <$fh>;
    $self->_parse(\$string, $self->{lineno_offset}, $self->{file});
  }
}


=head2 file

Get/set the file that the typemap is written to when the
C<write> method is called.

=cut

sub file {
  $_[0]->{file} = $_[1] if @_ > 1;
  $_[0]->{file}
}

=head2 add_typemap

Add a C<TYPEMAP> entry to the typemap.

Required named arguments: The C<ctype> (e.g. C<ctype =E<gt> 'double'>)
and the C<xstype> (e.g. C<xstype =E<gt> 'T_NV'>).

Optional named arguments: C<replace =E<gt> 1> forces removal/replacement of
existing C<TYPEMAP> entries of the same C<ctype>. C<skip =E<gt> 1>
triggers a I<"first come first serve"> logic by which new entries that conflict
with existing entries are silently ignored.

As an alternative to the named parameters usage, you may pass in
an C<ExtUtils::Typemaps::Type> object as first argument, a copy of which will be
added to the typemap. In that case, only the C<replace> or C<skip> named parameters
may be used after the object. Example:

  $map->add_typemap($type_obj, replace => 1);

=cut

sub add_typemap {
  my $self = shift;
  my $type;
  my %args;

  if ((@_ % 2) == 1) {
    my $orig = shift;
    $type = $orig->new();
    %args = @_;
  }
  else {
    %args = @_;
    my $ctype = $args{ctype};
    die("Need ctype argument") if not defined $ctype;
    my $xstype = $args{xstype};
    die("Need xstype argument") if not defined $xstype;

    $type = ExtUtils::Typemaps::Type->new(
      xstype      => $xstype,
      'prototype' => $args{'prototype'},
      ctype       => $ctype,
    );
  }

  if ($args{skip} and $args{replace}) {
    die("Cannot use both 'skip' and 'replace'");
  }

  if ($args{replace}) {
    $self->remove_typemap(ctype => $type->ctype);
  }
  elsif ($args{skip}) {
    return() if exists $self->{typemap_lookup}{$type->ctype};
  }
  else {
    $self->validate(typemap_xstype => $type->xstype, ctype => $type->ctype);
  }

  # store
  push @{$self->{typemap_section}}, $type;
  # remember type for lookup, too.
  $self->{typemap_lookup}{$type->tidy_ctype} = $#{$self->{typemap_section}};

  return 1;
}

=head2 add_inputmap

Add an C<INPUT> entry to the typemap.

Required named arguments:
The C<xstype> (e.g. C<xstype =E<gt> 'T_NV'>)
and the C<code> to associate with it for input.

Optional named arguments: C<replace =E<gt> 1> forces removal/replacement of
existing C<INPUT> entries of the same C<xstype>. C<skip =E<gt> 1>
triggers a I<"first come first serve"> logic by which new entries that conflict
with existing entries are silently ignored.

As an alternative to the named parameters usage, you may pass in
an C<ExtUtils::Typemaps::InputMap> object as first argument, a copy of which will be
added to the typemap. In that case, only the C<replace> or C<skip> named parameters
may be used after the object. Example:

  $map->add_inputmap($type_obj, replace => 1);

=cut

sub add_inputmap {
  my $self = shift;
  my $input;
  my %args;

  if ((@_ % 2) == 1) {
    my $orig = shift;
    $input = $orig->new();
    %args = @_;
  }
  else {
    %args = @_;
    my $xstype = $args{xstype};
    die("Need xstype argument") if not defined $xstype;
    my $code = $args{code};
    die("Need code argument") if not defined $code;

    $input = ExtUtils::Typemaps::InputMap->new(
      xstype => $xstype,
      code   => $code,
    );
  }

  if ($args{skip} and $args{replace}) {
    die("Cannot use both 'skip' and 'replace'");
  }

  if ($args{replace}) {
    $self->remove_inputmap(xstype => $input->xstype);
  }
  elsif ($args{skip}) {
    return() if exists $self->{input_lookup}{$input->xstype};
  }
  else {
    $self->validate(inputmap_xstype => $input->xstype);
  }

  # store
  push @{$self->{input_section}}, $input;
  # remember type for lookup, too.
  $self->{input_lookup}{$input->xstype} = $#{$self->{input_section}};

  return 1;
}

=head2 add_outputmap

Add an C<OUTPUT> entry to the typemap.
Works exactly the same as C<add_inputmap>.

=cut

sub add_outputmap {
  my $self = shift;
  my $output;
  my %args;

  if ((@_ % 2) == 1) {
    my $orig = shift;
    $output = $orig->new();
    %args = @_;
  }
  else {
    %args = @_;
    my $xstype = $args{xstype};
    die("Need xstype argument") if not defined $xstype;
    my $code = $args{code};
    die("Need code argument") if not defined $code;

    $output = ExtUtils::Typemaps::OutputMap->new(
      xstype => $xstype,
      code   => $code,
    );
  }

  if ($args{skip} and $args{replace}) {
    die("Cannot use both 'skip' and 'replace'");
  }

  if ($args{replace}) {
    $self->remove_outputmap(xstype => $output->xstype);
  }
  elsif ($args{skip}) {
    return() if exists $self->{output_lookup}{$output->xstype};
  }
  else {
    $self->validate(outputmap_xstype => $output->xstype);
  }

  # store
  push @{$self->{output_section}}, $output;
  # remember type for lookup, too.
  $self->{output_lookup}{$output->xstype} = $#{$self->{output_section}};

  return 1;
}

=head2 add_string

Parses a string as a typemap and merge it into the typemap object.

Required named argument: C<string> to specify the string to parse.

=cut

sub add_string {
  my $self = shift;
  my %args = @_;
  die("Need 'string' argument") if not defined $args{string};

  # no, this is not elegant.
  my $other = ExtUtils::Typemaps->new(string => $args{string});
  $self->merge(typemap => $other);
}

=head2 remove_typemap

Removes a C<TYPEMAP> entry from the typemap.

Required named argument: C<ctype> to specify the entry to remove from the typemap.

Alternatively, you may pass a single C<ExtUtils::Typemaps::Type> object.

=cut

sub remove_typemap {
  my $self = shift;
  my $ctype;
  if (@_ > 1) {
    my %args = @_;
    $ctype = $args{ctype};
    die("Need ctype argument") if not defined $ctype;
    $ctype = tidy_type($ctype);
  }
  else {
    $ctype = $_[0]->tidy_ctype;
  }

  return $self->_remove($ctype, $self->{typemap_section}, $self->{typemap_lookup});
}

=head2 remove_inputmap

Removes an C<INPUT> entry from the typemap.

Required named argument: C<xstype> to specify the entry to remove from the typemap.

Alternatively, you may pass a single C<ExtUtils::Typemaps::InputMap> object.

=cut

sub remove_inputmap {
  my $self = shift;
  my $xstype;
  if (@_ > 1) {
    my %args = @_;
    $xstype = $args{xstype};
    die("Need xstype argument") if not defined $xstype;
  }
  else {
    $xstype = $_[0]->xstype;
  }
  
  return $self->_remove($xstype, $self->{input_section}, $self->{input_lookup});
}

=head2 remove_inputmap

Removes an C<OUTPUT> entry from the typemap.

Required named argument: C<xstype> to specify the entry to remove from the typemap.

Alternatively, you may pass a single C<ExtUtils::Typemaps::OutputMap> object.

=cut

sub remove_outputmap {
  my $self = shift;
  my $xstype;
  if (@_ > 1) {
    my %args = @_;
    $xstype = $args{xstype};
    die("Need xstype argument") if not defined $xstype;
  }
  else {
    $xstype = $_[0]->xstype;
  }
  
  return $self->_remove($xstype, $self->{output_section}, $self->{output_lookup});
}

sub _remove {
  my $self   = shift;
  my $rm     = shift;
  my $array  = shift;
  my $lookup = shift;

  # Just fetch the index of the item from the lookup table
  my $index = $lookup->{$rm};
  return() if not defined $index;

  # Nuke the item from storage
  splice(@$array, $index, 1);

  # Decrement the storage position of all items thereafter
  foreach my $key (keys %$lookup) {
    if ($lookup->{$key} > $index) {
      $lookup->{$key}--;
    }
  }
  return();
}

=head2 get_typemap

Fetches an entry of the TYPEMAP section of the typemap.

Mandatory named arguments: The C<ctype> of the entry.

Returns the C<ExtUtils::Typemaps::Type>
object for the entry if found.

=cut

sub get_typemap {
  my $self = shift;
  die("Need named parameters, got uneven number") if @_ % 2;

  my %args = @_;
  my $ctype = $args{ctype};
  die("Need ctype argument") if not defined $ctype;
  $ctype = tidy_type($ctype);

  my $index = $self->{typemap_lookup}{$ctype};
  return() if not defined $index;
  return $self->{typemap_section}[$index];
}

=head2 get_inputmap

Fetches an entry of the INPUT section of the
typemap.

Mandatory named arguments: The C<xstype> of the
entry or the C<ctype> of the typemap that can be used to find
the C<xstype>. To wit, the following pieces of code
are equivalent:

  my $type = $typemap->get_typemap(ctype => $ctype)
  my $input_map = $typemap->get_inputmap(xstype => $type->xstype);

  my $input_map = $typemap->get_inputmap(ctype => $ctype);

Returns the C<ExtUtils::Typemaps::InputMap>
object for the entry if found.

=cut

sub get_inputmap {
  my $self = shift;
  die("Need named parameters, got uneven number") if @_ % 2;

  my %args = @_;
  my $xstype = $args{xstype};
  my $ctype  = $args{ctype};
  die("Need xstype or ctype argument")
    if not defined $xstype
    and not defined $ctype;
  die("Need xstype OR ctype arguments, not both")
    if defined $xstype and defined $ctype;

  if (defined $ctype) {
    my $tm = $self->get_typemap(ctype => $ctype);
    $xstype = $tm && $tm->xstype;
    return() if not defined $xstype;
  }

  my $index = $self->{input_lookup}{$xstype};
  return() if not defined $index;
  return $self->{input_section}[$index];
}

=head2 get_outputmap

Fetches an entry of the OUTPUT section of the
typemap.

Mandatory named arguments: The C<xstype> of the
entry or the C<ctype> of the typemap that can be used to
resolve the C<xstype>. (See above for an example.)

Returns the C<ExtUtils::Typemaps::InputMap>
object for the entry if found.

=cut

sub get_outputmap {
  my $self = shift;
  die("Need named parameters, got uneven number") if @_ % 2;

  my %args = @_;
  my $xstype = $args{xstype};
  my $ctype  = $args{ctype};
  die("Need xstype or ctype argument")
    if not defined $xstype
    and not defined $ctype;
  die("Need xstype OR ctype arguments, not both")
    if defined $xstype and defined $ctype;

  if (defined $ctype) {
    my $tm = $self->get_typemap(ctype => $ctype);
    $xstype = $tm && $tm->xstype;
    return() if not defined $xstype;
  }

  my $index = $self->{output_lookup}{$xstype};
  return() if not defined $index;
  return $self->{output_section}[$index];
}

=head2 write

Write the typemap to a file. Optionally takes a C<file> argument. If given, the
typemap will be written to the specified file. If not, the typemap is written
to the currently stored file name (see L</file> above, this defaults to the file
it was read from if any).

=cut

sub write {
  my $self = shift;
  my %args = @_;
  my $file = defined $args{file} ? $args{file} : $self->file();
  die("write() needs a file argument (or set the file name of the typemap using the 'file' method)")
    if not defined $file;

  open my $fh, '>', $file
    or die "Cannot open typemap file '$file' for writing: $!";
  print $fh $self->as_string();
  close $fh;
}

=head2 as_string

Generates and returns the string form of the typemap.

=cut

sub as_string {
  my $self = shift;
  my $typemap = $self->{typemap_section};
  my @code;
  push @code, "TYPEMAP\n";
  foreach my $entry (@$typemap) {
    # type kind proto
    # /^(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)$/o
    push @code, $entry->ctype . "\t" . $entry->xstype
              . ($entry->proto ne '' ? "\t".$entry->proto : '') . "\n";
  }

  my $input = $self->{input_section};
  if (@$input) {
    push @code, "\nINPUT\n";
    foreach my $entry (@$input) {
      push @code, $entry->xstype, "\n", $entry->code, "\n";
    }
  }

  my $output = $self->{output_section};
  if (@$output) {
    push @code, "\nOUTPUT\n";
    foreach my $entry (@$output) {
      push @code, $entry->xstype, "\n", $entry->code, "\n";
    }
  }
  return join '', @code;
}

=head2 as_embedded_typemap

Generates and returns the string form of the typemap with the
appropriate prefix around it for verbatim inclusion into an
XS file as an embedded typemap. This will return a string like

  TYPEMAP: <<END_OF_TYPEMAP
  ... typemap here (see as_string) ...
  END_OF_TYPEMAP

The method takes care not to use a HERE-doc end marker that
appears in the typemap string itself.

=cut

sub as_embedded_typemap {
  my $self = shift;
  my $string = $self->as_string;

  my @ident_cand = qw(END_TYPEMAP END_OF_TYPEMAP END);
  my $icand = 0;
  my $cand_suffix = "";
  while ($string =~ /^\Q$ident_cand[$icand]$cand_suffix\E\s*$/m) {
    $icand++;
    if ($icand == @ident_cand) {
      $icand = 0;
      ++$cand_suffix;
    }
  }

  my $marker = "$ident_cand[$icand]$cand_suffix";
  return "TYPEMAP: <<$marker;\n$string\n$marker\n";
}

=head2 merge

Merges a given typemap into the object. Note that a failed merge
operation leaves the object in an inconsistent state so clone it if necessary.

Mandatory named arguments: Either C<typemap =E<gt> $another_typemap_obj>
or C<file =E<gt> $path_to_typemap_file> but not both.

Optional arguments: C<replace =E<gt> 1> to force replacement
of existing typemap entries without warning or C<skip =E<gt> 1>
to skip entries that exist already in the typemap.

=cut

sub merge {
  my $self = shift;
  my %args = @_;

  if (exists $args{typemap} and exists $args{file}) {
    die("Need {file} OR {typemap} argument. Not both!");
  }
  elsif (not exists $args{typemap} and not exists $args{file}) {
    die("Need {file} or {typemap} argument!");
  }

  my @params;
  push @params, 'replace' => $args{replace} if exists $args{replace};
  push @params, 'skip' => $args{skip} if exists $args{skip};

  my $typemap = $args{typemap};
  if (not defined $typemap) {
    $typemap = ref($self)->new(file => $args{file}, @params);
  }

  # FIXME breaking encapsulation. Add accessor code.
  foreach my $entry (@{$typemap->{typemap_section}}) {
    $self->add_typemap( $entry, @params );
  }

  foreach my $entry (@{$typemap->{input_section}}) {
    $self->add_inputmap( $entry, @params );
  }

  foreach my $entry (@{$typemap->{output_section}}) {
    $self->add_outputmap( $entry, @params );
  }

  return 1;
}

=head2 is_empty

Returns a bool indicating whether this typemap is entirely empty.

=cut

sub is_empty {
  my $self = shift;

  return @{ $self->{typemap_section} } == 0
      && @{ $self->{input_section} } == 0
      && @{ $self->{output_section} } == 0;
}

=head2 list_mapped_ctypes

Returns a list of the C types that are mappable by
this typemap object.

=cut

sub list_mapped_ctypes {
  my $self = shift;
  return sort keys %{ $self->{typemap_lookup} };
}

=head2 _get_typemap_hash

Returns a hash mapping the C types to the XS types:

  {
    'char **' => 'T_PACKEDARRAY',
    'bool_t' => 'T_IV',
    'AV *' => 'T_AVREF',
    'InputStream' => 'T_IN',
    'double' => 'T_DOUBLE',
    # ...
  }

This is documented because it is used by C<ExtUtils::ParseXS>,
but it's not intended for general consumption. May be removed
at any time.

=cut

sub _get_typemap_hash {
  my $self = shift;
  my $lookup  = $self->{typemap_lookup};
  my $storage = $self->{typemap_section};

  my %rv;
  foreach my $ctype (keys %$lookup) {
    $rv{$ctype} = $storage->[ $lookup->{$ctype} ]->xstype;
  }

  return \%rv;
}

=head2 _get_inputmap_hash

Returns a hash mapping the XS types (identifiers) to the
corresponding INPUT code:

  {
    'T_CALLBACK' => '   $var = make_perl_cb_$type($arg)
  ',
    'T_OUT' => '    $var = IoOFP(sv_2io($arg))
  ',
    'T_REF_IV_PTR' => '   if (sv_isa($arg, \\"${ntype}\\")) {
    # ...
  }

This is documented because it is used by C<ExtUtils::ParseXS>,
but it's not intended for general consumption. May be removed
at any time.

=cut

sub _get_inputmap_hash {
  my $self = shift;
  my $lookup  = $self->{input_lookup};
  my $storage = $self->{input_section};

  my %rv;
  foreach my $xstype (keys %$lookup) {
    $rv{$xstype} = $storage->[ $lookup->{$xstype} ]->code;

    # Squash trailing whitespace to one line break
    # This isn't strictly necessary, but makes the output more similar
    # to the original ExtUtils::ParseXS.
    $rv{$xstype} =~ s/\s*\z/\n/;
  }

  return \%rv;
}


=head2 _get_outputmap_hash

Returns a hash mapping the XS types (identifiers) to the
corresponding OUTPUT code:

  {
    'T_CALLBACK' => '   sv_setpvn($arg, $var.context.value().chp(),
                $var.context.value().size());
  ',
    'T_OUT' => '    {
            GV *gv = newGVgen("$Package");
            if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) )
                sv_setsv(
                  $arg,
                  sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))
                );
            else
                $arg = &PL_sv_undef;
         }
  ',
    # ...
  }

This is documented because it is used by C<ExtUtils::ParseXS>,
but it's not intended for general consumption. May be removed
at any time.

=cut

sub _get_outputmap_hash {
  my $self = shift;
  my $lookup  = $self->{output_lookup};
  my $storage = $self->{output_section};

  my %rv;
  foreach my $xstype (keys %$lookup) {
    $rv{$xstype} = $storage->[ $lookup->{$xstype} ]->code;

    # Squash trailing whitespace to one line break
    # This isn't strictly necessary, but makes the output more similar
    # to the original ExtUtils::ParseXS.
    $rv{$xstype} =~ s/\s*\z/\n/;
  }

  return \%rv;
}

=head2 _get_prototype_hash

Returns a hash mapping the C types of the typemap to their
corresponding prototypes.

  {
    'char **' => '$',
    'bool_t' => '$',
    'AV *' => '$',
    'InputStream' => '$',
    'double' => '$',
    # ...
  }

This is documented because it is used by C<ExtUtils::ParseXS>,
but it's not intended for general consumption. May be removed
at any time.

=cut

sub _get_prototype_hash {
  my $self = shift;
  my $lookup  = $self->{typemap_lookup};
  my $storage = $self->{typemap_section};

  my %rv;
  foreach my $ctype (keys %$lookup) {
    $rv{$ctype} = $storage->[ $lookup->{$ctype} ]->proto || '$';
  }

  return \%rv;
}


# make sure that the provided types wouldn't collide with what's
# in the object already.
sub validate {
  my $self = shift;
  my %args = @_;

  if ( exists $args{ctype}
       and exists $self->{typemap_lookup}{tidy_type($args{ctype})} )
  {
    die("Multiple definition of ctype '$args{ctype}' in TYPEMAP section");
  }

  if ( exists $args{inputmap_xstype}
       and exists $self->{input_lookup}{$args{inputmap_xstype}} )
  {
    die("Multiple definition of xstype '$args{inputmap_xstype}' in INPUTMAP section");
  }

  if ( exists $args{outputmap_xstype}
       and exists $self->{output_lookup}{$args{outputmap_xstype}} )
  {
    die("Multiple definition of xstype '$args{outputmap_xstype}' in OUTPUTMAP section");
  }

  return 1;
}

=head2 clone

Creates and returns a clone of a full typemaps object.

Takes named parameters: If C<shallow> is true,
the clone will share the actual individual type/input/outputmap objects,
but not share their storage. Use with caution. Without C<shallow>,
the clone will be fully independent.

=cut

sub clone {
  my $proto = shift;
  my %args = @_;

  my $self;
  if ($args{shallow}) {
    $self = bless( {
      %$proto,
      typemap_section => [@{$proto->{typemap_section}}],
      typemap_lookup  => {%{$proto->{typemap_lookup}}},
      input_section   => [@{$proto->{input_section}}],
      input_lookup    => {%{$proto->{input_lookup}}},
      output_section  => [@{$proto->{output_section}}],
      output_lookup   => {%{$proto->{output_lookup}}},
    } => ref($proto) );
  }
  else {
    $self = bless( {
      %$proto,
      typemap_section => [map $_->new, @{$proto->{typemap_section}}],
      typemap_lookup  => {%{$proto->{typemap_lookup}}},
      input_section   => [map $_->new, @{$proto->{input_section}}],
      input_lookup    => {%{$proto->{input_lookup}}},
      output_section  => [map $_->new, @{$proto->{output_section}}],
      output_lookup   => {%{$proto->{output_lookup}}},
    } => ref($proto) );
  }

  return $self;
}

=head2 tidy_type

Function to (heuristically) canonicalize a C type. Works to some
degree with C++ types.

    $halfway_canonical_type = tidy_type($ctype);

Moved from C<ExtUtils::ParseXS>.

=cut

sub tidy_type {
  local $_ = shift;

  # for templated C++ types, do some bit of flawed canonicalization
  # wrt. templates at least
  if (/[<>]/) {
    s/\s*([<>])\s*/$1/g;
    s/>>/> >/g;
  }

  # rationalise any '*' by joining them into bunches and removing whitespace
  s#\s*(\*+)\s*#$1#g;
  s#(\*+)# $1 #g ;

  # trim leading & trailing whitespace
  s/^\s+//; s/\s+$//;

  # change multiple whitespace into a single space
  s/\s+/ /g;

  $_;
}


sub _parse {
  my $self = shift;
  my $stringref = shift;
  my $lineno_offset = shift;
  $lineno_offset = 0 if not defined $lineno_offset;
  my $filename = shift;
  $filename = '<string>' if not defined $filename;

  my $replace = $self->{replace};
  my $skip    = $self->{skip};
  die "Can only replace OR skip" if $replace and $skip;
  my @add_params;
  push @add_params, replace => 1 if $replace;
  push @add_params, skip    => 1 if $skip;

  # TODO comments should round-trip, currently ignoring
  # TODO order of sections, multiple sections of same type
  # Heavily influenced by ExtUtils::ParseXS
  my $section = 'typemap';
  my $lineno = $lineno_offset;
  my $junk = "";
  my $current = \$junk;
  my @input_expr;
  my @output_expr;
  while ($$stringref =~ /^(.*)$/gcm) {
    local $_ = $1;
    ++$lineno;
    chomp;
    next if /^\s*#/;
    if (/^INPUT\s*$/) {
      $section = 'input';
      $current = \$junk;
      next;
    }
    elsif (/^OUTPUT\s*$/) {
      $section = 'output';
      $current = \$junk;
      next;
    }
    elsif (/^TYPEMAP\s*$/) {
      $section = 'typemap';
      $current = \$junk;
      next;
    }
    
    if ($section eq 'typemap') {
      my $line = $_;
      s/^\s+//; s/\s+$//;
      next if $_ eq '' or /^#/;
      my($type, $kind, $proto) = /^(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)$/o
        or warn("Warning: File '$filename' Line $lineno '$line' TYPEMAP entry needs 2 or 3 columns\n"),
           next;
      # prototype defaults to '$'
      $proto = '$' unless $proto;
      warn("Warning: File '$filename' Line $lineno '$line' Invalid prototype '$proto'\n")
        unless _valid_proto_string($proto);
      $self->add_typemap(
        ExtUtils::Typemaps::Type->new(
          xstype => $kind, proto => $proto, ctype => $type
        ),
        @add_params
      );
    } elsif (/^\s/) {
      s/\s+$//;
      $$current .= $$current eq '' ? $_ : "\n".$_;
    } elsif ($_ eq '') {
      next;
    } elsif ($section eq 'input') {
      s/\s+$//;
      push @input_expr, {xstype => $_, code => ''};
      $current = \$input_expr[-1]{code};
    } else { # output section
      s/\s+$//;
      push @output_expr, {xstype => $_, code => ''};
      $current = \$output_expr[-1]{code};
    }

  } # end while lines

  foreach my $inexpr (@input_expr) {
    $self->add_inputmap( ExtUtils::Typemaps::InputMap->new(%$inexpr), @add_params );
  }
  foreach my $outexpr (@output_expr) {
    $self->add_outputmap( ExtUtils::Typemaps::OutputMap->new(%$outexpr), @add_params );
  }

  return 1;
}

# taken from ExtUtils::ParseXS
sub _valid_proto_string {
  my $string = shift;
  if ($string =~ /^$ExtUtils::ParseXS::Constants::PrototypeRegexp+$/o) {
    return $string;
  }

  return 0 ;
}

# taken from ExtUtils::ParseXS (C_string)
sub _escape_backslashes {
  my $string = shift;
  $string =~ s[\\][\\\\]g;
  $string;
}

=head1 CAVEATS

Inherits some evil code from C<ExtUtils::ParseXS>.

=head1 SEE ALSO

The parser is heavily inspired from the one in L<ExtUtils::ParseXS>.

For details on typemaps: L<perlxstut>, L<perlxs>.

=head1 AUTHOR

Steffen Mueller C<<smueller@cpan.org>>

=head1 COPYRIGHT & LICENSE

Copyright 2009, 2010, 2011, 2012, 2013 Steffen Mueller

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

=cut

1;

PK       ! $�=��  �    perl5/ExtUtils/MM_QNX.pmnu ��6�$        package ExtUtils::MM_QNX;

use strict;
use warnings;
our $VERSION = '7.50';
$VERSION =~ tr/_//d;

require ExtUtils::MM_Unix;
our @ISA = qw(ExtUtils::MM_Unix);


=head1 NAME

ExtUtils::MM_QNX - QNX specific subclass of ExtUtils::MM_Unix

=head1 SYNOPSIS

  Don't use this module directly.
  Use ExtUtils::MM and let it choose.

=head1 DESCRIPTION

This is a subclass of L<ExtUtils::MM_Unix> which contains functionality for
QNX.

Unless otherwise stated it works just like ExtUtils::MM_Unix.

=head2 Overridden methods

=head3 extra_clean_files

Add .err files corresponding to each .c file.

=cut

sub extra_clean_files {
    my $self = shift;

    my @errfiles = @{$self->{C}};
    for ( @errfiles ) {
	s/.c$/.err/;
    }

    return( @errfiles, 'perlmain.err' );
}


=head1 AUTHOR

Michael G Schwern <schwern@pobox.com> with code from ExtUtils::MM_Unix

=head1 SEE ALSO

L<ExtUtils::MakeMaker>

=cut


1;
PK       ! ���� ��   perl5/ExtUtils/MM_Unix.pmnu ��6�$        package ExtUtils::MM_Unix;

require 5.006;

use strict;
use warnings;

use Carp;
use ExtUtils::MakeMaker::Config;
use File::Basename qw(basename dirname);

our %Config_Override;

use ExtUtils::MakeMaker qw($Verbose neatvalue _sprintf562);

# If we make $VERSION an our variable parse_version() breaks
use vars qw($VERSION);
$VERSION = '7.50';
$VERSION =~ tr/_//d;

require ExtUtils::MM_Any;
our @ISA = qw(ExtUtils::MM_Any);

my %Is;
BEGIN {
    $Is{OS2}     = $^O eq 'os2';
    $Is{Win32}   = $^O eq 'MSWin32' || $Config{osname} eq 'NetWare';
    $Is{Dos}     = $^O eq 'dos';
    $Is{VMS}     = $^O eq 'VMS';
    $Is{OSF}     = $^O eq 'dec_osf';
    $Is{IRIX}    = $^O eq 'irix';
    $Is{NetBSD}  = $^O eq 'netbsd';
    $Is{Interix} = $^O eq 'interix';
    $Is{SunOS4}  = $^O eq 'sunos';
    $Is{Solaris} = $^O eq 'solaris';
    $Is{SunOS}   = $Is{SunOS4} || $Is{Solaris};
    $Is{BSD}     = ($^O =~ /^(?:free|net|open)bsd$/ or
                   grep( $^O eq $_, qw(bsdos interix dragonfly) )
                  );
    $Is{Android} = $^O =~ /android/;
    if ( $^O eq 'darwin' && $^X eq '/usr/bin/perl' ) {
      my @osvers = split /\./, $Config{osvers};
      $Is{ApplCor} = ( $osvers[0] >= 18 );
    }
}

BEGIN {
    if( $Is{VMS} ) {
        # For things like vmsify()
        require VMS::Filespec;
        VMS::Filespec->import;
    }
}


=head1 NAME

ExtUtils::MM_Unix - methods used by ExtUtils::MakeMaker

=head1 SYNOPSIS

  require ExtUtils::MM_Unix;

=head1 DESCRIPTION

The methods provided by this package are designed to be used in
conjunction with L<ExtUtils::MakeMaker>. When MakeMaker writes a
Makefile, it creates one or more objects that inherit their methods
from a package L<MM|ExtUtils::MM>. MM itself doesn't provide any methods, but
it ISA ExtUtils::MM_Unix class. The inheritance tree of MM lets operating
specific packages take the responsibility for all the methods provided
by MM_Unix. We are trying to reduce the number of the necessary
overrides by defining rather primitive operations within
ExtUtils::MM_Unix.

If you are going to write a platform specific MM package, please try
to limit the necessary overrides to primitive methods, and if it is not
possible to do so, let's work out how to achieve that gain.

If you are overriding any of these methods in your Makefile.PL (in the
MY class), please report that to the makemaker mailing list. We are
trying to minimize the necessary method overrides and switch to data
driven Makefile.PLs wherever possible. In the long run less methods
will be overridable via the MY class.

=head1 METHODS

The following description of methods is still under
development. Please refer to the code for not suitably documented
sections and complain loudly to the makemaker@perl.org mailing list.
Better yet, provide a patch.

Not all of the methods below are overridable in a
Makefile.PL. Overridable methods are marked as (o). All methods are
overridable by a platform specific MM_*.pm file.

Cross-platform methods are being moved into L<MM_Any|ExtUtils::MM_Any>.
If you can't find something that used to be in here, look in MM_Any.

=cut

# So we don't have to keep calling the methods over and over again,
# we have these globals to cache the values.  Faster and shrtr.
my $Curdir  = __PACKAGE__->curdir;
my $Updir   = __PACKAGE__->updir;


=head2 Methods

=over 4

=item os_flavor

Simply says that we're Unix.

=cut

sub os_flavor {
    return('Unix');
}


=item c_o (o)

Defines the suffix rules to compile different flavors of C files to
object files.

=cut

sub c_o {
# --- Translation Sections ---

    my($self) = shift;
    return '' unless $self->needs_linking();
    my(@m);

    my $command = '$(CCCMD)';
    my $flags   = '$(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) $(DEFINE)';

    if ( $Is{ApplCor} ) {
        $flags =~ s/"-I(\$\(PERL_INC\))"/-iwithsysroot "$1"/;
    }

    if (my $cpp = $Config{cpprun}) {
        my $cpp_cmd = $self->const_cccmd;
        $cpp_cmd =~ s/^CCCMD\s*=\s*\$\(CC\)/$cpp/;
        push @m, qq{
.c.i:
	$cpp_cmd $flags \$*.c > \$*.i
};
    }

    my $m_o = $self->{XSMULTI} ? $self->xs_obj_opt('$*.s') : '';
    push @m, sprintf <<'EOF', $command, $flags, $m_o;

.c.s :
	%s -S %s $*.c %s
EOF

    my @exts = qw(c cpp cxx cc);
    push @exts, 'C' if !$Is{OS2} and !$Is{Win32} and !$Is{Dos}; #Case-specific
    $m_o = $self->{XSMULTI} ? $self->xs_obj_opt('$*$(OBJ_EXT)') : '';
    my $dbgout = $self->dbgoutflag;
    for my $ext (@exts) {
	push @m, "\n.$ext\$(OBJ_EXT) :\n\t$command $flags "
            .($dbgout?"$dbgout ":'')
            ."\$*.$ext" . ( $m_o ? " $m_o" : '' ) . "\n";
    }
    return join "", @m;
}


=item xs_obj_opt

Takes the object file as an argument, and returns the portion of compile
command-line that will output to the specified object file.

=cut

sub xs_obj_opt {
    my ($self, $output_file) = @_;
    "-o $output_file";
}

=item dbgoutflag

Returns a CC flag that tells the CC to emit a separate debugging symbol file
when compiling an object file.

=cut

sub dbgoutflag {
    '';
}

=item cflags (o)

Does very much the same as the cflags script in the perl
distribution. It doesn't return the whole compiler command line, but
initializes all of its parts. The const_cccmd method then actually
returns the definition of the CCCMD macro which uses these parts.

=cut

#'

sub cflags {
    my($self,$libperl)=@_;
    return $self->{CFLAGS} if $self->{CFLAGS};
    return '' unless $self->needs_linking();

    my($prog, $uc, $perltype, %cflags);
    $libperl ||= $self->{LIBPERL_A} || "libperl$self->{LIB_EXT}" ;
    $libperl =~ s/\.\$\(A\)$/$self->{LIB_EXT}/;

    @cflags{qw(cc ccflags optimize shellflags)}
	= @Config{qw(cc ccflags optimize shellflags)};

    # Perl 5.21.4 adds the (gcc) warning (-Wall ...) and std (-std=c89)
    # flags to the %Config, and the modules in the core should be built
    # with the warning flags, but NOT the -std=c89 flags (the latter
    # would break using any system header files that are strict C99).
    my @ccextraflags = qw(ccwarnflags);
    if ($ENV{PERL_CORE}) {
      for my $x (@ccextraflags) {
        if (exists $Config{$x}) {
          $cflags{$x} = $Config{$x};
        }
      }
    }

    my($optdebug) = "";

    $cflags{shellflags} ||= '';

    my(%map) =  (
		D =>   '-DDEBUGGING',
		E =>   '-DEMBED',
		DE =>  '-DDEBUGGING -DEMBED',
		M =>   '-DEMBED -DMULTIPLICITY',
		DM =>  '-DDEBUGGING -DEMBED -DMULTIPLICITY',
		);

    if ($libperl =~ /libperl(\w*)\Q$self->{LIB_EXT}/){
	$uc = uc($1);
    } else {
	$uc = ""; # avoid warning
    }
    $perltype = $map{$uc} ? $map{$uc} : "";

    if ($uc =~ /^D/) {
	$optdebug = "-g";
    }


    my($name);
    ( $name = $self->{NAME} . "_cflags" ) =~ s/:/_/g ;
    if ($prog = $Config{$name}) {
	# Expand hints for this extension via the shell
	print "Processing $name hint:\n" if $Verbose;
	my(@o)=`cc=\"$cflags{cc}\"
	  ccflags=\"$cflags{ccflags}\"
	  optimize=\"$cflags{optimize}\"
	  perltype=\"$cflags{perltype}\"
	  optdebug=\"$cflags{optdebug}\"
	  eval '$prog'
	  echo cc=\$cc
	  echo ccflags=\$ccflags
	  echo optimize=\$optimize
	  echo perltype=\$perltype
	  echo optdebug=\$optdebug
	  `;
	foreach my $line (@o){
	    chomp $line;
	    if ($line =~ /(.*?)=\s*(.*)\s*$/){
		$cflags{$1} = $2;
		print "	$1 = $2\n" if $Verbose;
	    } else {
		print "Unrecognised result from hint: '$line'\n";
	    }
	}
    }

    if ($optdebug) {
	$cflags{optimize} = $optdebug;
    }

    for (qw(ccflags optimize perltype)) {
        $cflags{$_} ||= '';
	$cflags{$_} =~ s/^\s+//;
	$cflags{$_} =~ s/\s+/ /g;
	$cflags{$_} =~ s/\s+$//;
	$self->{uc $_} ||= $cflags{$_};
    }

    if ($self->{POLLUTE}) {
	$self->{CCFLAGS} .= ' -DPERL_POLLUTE ';
    }

    for my $x (@ccextraflags) {
      next unless exists $cflags{$x};
      $self->{CCFLAGS} .= $cflags{$x} =~ m!^\s! ? $cflags{$x} : ' ' . $cflags{$x};
    }

    my $pollute = '';
    if ($Config{usemymalloc} and not $Config{bincompat5005}
	and not $Config{ccflags} =~ /-DPERL_POLLUTE_MALLOC\b/
	and $self->{PERL_MALLOC_OK}) {
	$pollute = '$(PERL_MALLOC_DEF)';
    }

    return $self->{CFLAGS} = qq{
CCFLAGS = $self->{CCFLAGS}
OPTIMIZE = $self->{OPTIMIZE}
PERLTYPE = $self->{PERLTYPE}
MPOLLUTE = $pollute
};

}


=item const_cccmd (o)

Returns the full compiler call for C programs and stores the
definition in CONST_CCCMD.

=cut

sub const_cccmd {
    my($self,$libperl)=@_;
    return $self->{CONST_CCCMD} if $self->{CONST_CCCMD};
    return '' unless $self->needs_linking();
    return $self->{CONST_CCCMD} =
	q{CCCMD = $(CC) -c $(PASTHRU_INC) $(INC) \\
	$(CCFLAGS) $(OPTIMIZE) \\
	$(PERLTYPE) $(MPOLLUTE) $(DEFINE_VERSION) \\
	$(XS_DEFINE_VERSION)};
}

=item const_config (o)

Sets SHELL if needed, then defines a couple of constants in the Makefile
that are imported from %Config.

=cut

sub const_config {
# --- Constants Sections ---

    my($self) = shift;
    my @m = $self->specify_shell(); # Usually returns empty string
    push @m, <<"END";

# These definitions are from config.sh (via $INC{'Config.pm'}).
# They may have been overridden via Makefile.PL or on the command line.
END

    my(%once_only);
    foreach my $key (@{$self->{CONFIG}}){
        # SITE*EXP macros are defined in &constants; avoid duplicates here
        next if $once_only{$key};
        push @m, uc($key) , ' = ' , $self->{uc $key}, "\n";
        $once_only{$key} = 1;
    }
    join('', @m);
}

=item const_loadlibs (o)

Defines EXTRALIBS, LDLOADLIBS, BSLOADLIBS, LD_RUN_PATH. See
L<ExtUtils::Liblist> for details.

=cut

sub const_loadlibs {
    my($self) = shift;
    return "" unless $self->needs_linking;
    my @m;
    push @m, qq{
# $self->{NAME} might depend on some other libraries:
# See ExtUtils::Liblist for details
#
};
    for my $tmp (qw/
         EXTRALIBS LDLOADLIBS BSLOADLIBS
         /) {
        next unless defined $self->{$tmp};
        push @m, "$tmp = $self->{$tmp}\n";
    }
    # don't set LD_RUN_PATH if empty
    for my $tmp (qw/
         LD_RUN_PATH
         /) {
        next unless $self->{$tmp};
        push @m, "$tmp = $self->{$tmp}\n";
    }
    return join "", @m;
}

=item constants (o)

  my $make_frag = $mm->constants;

Prints out macros for lots of constants.

=cut

sub constants {
    my($self) = @_;
    my @m = ();

    $self->{DFSEP} = '$(DIRFILESEP)';  # alias for internal use

    for my $macro (qw(

              AR_STATIC_ARGS DIRFILESEP DFSEP
              NAME NAME_SYM
              VERSION    VERSION_MACRO    VERSION_SYM DEFINE_VERSION
              XS_VERSION XS_VERSION_MACRO             XS_DEFINE_VERSION
              INST_ARCHLIB INST_SCRIPT INST_BIN INST_LIB
              INST_MAN1DIR INST_MAN3DIR
              MAN1EXT      MAN3EXT
              MAN1SECTION  MAN3SECTION
              INSTALLDIRS INSTALL_BASE DESTDIR PREFIX
              PERLPREFIX      SITEPREFIX      VENDORPREFIX
                   ),
                   (map { ("INSTALL".$_,
                          "DESTINSTALL".$_)
                        } $self->installvars),
                   qw(
              PERL_LIB
              PERL_ARCHLIB PERL_ARCHLIBDEP
              LIBPERL_A MYEXTLIB
              FIRST_MAKEFILE MAKEFILE_OLD MAKE_APERL_FILE
              PERLMAINCC PERL_SRC PERL_INC PERL_INCDEP
              PERL            FULLPERL          ABSPERL
              PERLRUN         FULLPERLRUN       ABSPERLRUN
              PERLRUNINST     FULLPERLRUNINST   ABSPERLRUNINST
              PERL_CORE
              PERM_DIR PERM_RW PERM_RWX

	      ) )
    {
	next unless defined $self->{$macro};

        # pathnames can have sharp signs in them; escape them so
        # make doesn't think it is a comment-start character.
        $self->{$macro} =~ s/#/\\#/g;
	$self->{$macro} = $self->quote_dep($self->{$macro})
	  if $ExtUtils::MakeMaker::macro_dep{$macro};
	push @m, "$macro = $self->{$macro}\n";
    }

    push @m, qq{
MAKEMAKER   = $self->{MAKEMAKER}
MM_VERSION  = $self->{MM_VERSION}
MM_REVISION = $self->{MM_REVISION}
};

    push @m, q{
# FULLEXT = Pathname for extension directory (eg Foo/Bar/Oracle).
# BASEEXT = Basename part of FULLEXT. May be just equal FULLEXT. (eg Oracle)
# PARENT_NAME = NAME without BASEEXT and no trailing :: (eg Foo::Bar)
# DLBASE  = Basename part of dynamic library. May be just equal BASEEXT.
};

    for my $macro (qw/
              MAKE
	      FULLEXT BASEEXT PARENT_NAME DLBASE VERSION_FROM INC DEFINE OBJECT
	      LDFROM LINKTYPE BOOTDEP
	      /	)
    {
	next unless defined $self->{$macro};
	push @m, "$macro = $self->{$macro}\n";
    }

    push @m, "
# Handy lists of source code files:
XS_FILES = ".$self->wraplist(sort keys %{$self->{XS}})."
C_FILES  = ".$self->wraplist(sort @{$self->{C}})."
O_FILES  = ".$self->wraplist(sort @{$self->{O_FILES}})."
H_FILES  = ".$self->wraplist(sort @{$self->{H}})."
MAN1PODS = ".$self->wraplist(sort keys %{$self->{MAN1PODS}})."
MAN3PODS = ".$self->wraplist(sort keys %{$self->{MAN3PODS}})."
";

    push @m, q{
SDKROOT := $(shell xcrun --show-sdk-path)
PERL_SYSROOT = $(SDKROOT)
} if $Is{ApplCor} && $self->{'PERL_INC'} =~ m!^/System/Library/Perl/!;

    push @m, q{
# Where is the Config information that we are using/depend on
CONFIGDEP = $(PERL_ARCHLIBDEP)$(DFSEP)Config.pm $(PERL_SYSROOT)$(PERL_INCDEP)$(DFSEP)config.h
} if $Is{ApplCor};

    push @m, q{
# Where is the Config information that we are using/depend on
CONFIGDEP = $(PERL_ARCHLIBDEP)$(DFSEP)Config.pm $(PERL_INCDEP)$(DFSEP)config.h
} if -e $self->catfile( $self->{PERL_INC}, 'config.h' ) && !$Is{ApplCor};

    push @m, qq{
# Where to build things
INST_LIBDIR      = $self->{INST_LIBDIR}
INST_ARCHLIBDIR  = $self->{INST_ARCHLIBDIR}

INST_AUTODIR     = $self->{INST_AUTODIR}
INST_ARCHAUTODIR = $self->{INST_ARCHAUTODIR}

INST_STATIC      = $self->{INST_STATIC}
INST_DYNAMIC     = $self->{INST_DYNAMIC}
INST_BOOT        = $self->{INST_BOOT}
};

    push @m, qq{
# Extra linker info
EXPORT_LIST        = $self->{EXPORT_LIST}
PERL_ARCHIVE       = $self->{PERL_ARCHIVE}
PERL_ARCHIVEDEP    = $self->{PERL_ARCHIVEDEP}
PERL_ARCHIVE_AFTER = $self->{PERL_ARCHIVE_AFTER}
};

    push @m, "

TO_INST_PM = ".$self->wraplist(map $self->quote_dep($_), sort keys %{$self->{PM}})."\n";

    join('',@m);
}


=item depend (o)

Same as macro for the depend attribute.

=cut

sub depend {
    my($self,%attribs) = @_;
    my(@m,$key,$val);
    for my $key (sort keys %attribs){
	my $val = $attribs{$key};
	next unless defined $key and defined $val;
	push @m, "$key : $val\n";
    }
    join "", @m;
}


=item init_DEST

  $mm->init_DEST

Defines the DESTDIR and DEST* variables paralleling the INSTALL*.

=cut

sub init_DEST {
    my $self = shift;

    # Initialize DESTDIR
    $self->{DESTDIR} ||= '';

    # Make DEST variables.
    foreach my $var ($self->installvars) {
        my $destvar = 'DESTINSTALL'.$var;
        $self->{$destvar} ||= '$(DESTDIR)$(INSTALL'.$var.')';
    }
}


=item init_dist

  $mm->init_dist;

Defines a lot of macros for distribution support.

  macro         description                     default

  TAR           tar command to use              tar
  TARFLAGS      flags to pass to TAR            cvf

  ZIP           zip command to use              zip
  ZIPFLAGS      flags to pass to ZIP            -r

  COMPRESS      compression command to          gzip --best
                use for tarfiles
  SUFFIX        suffix to put on                .gz
                compressed files

  SHAR          shar command to use             shar

  PREOP         extra commands to run before
                making the archive
  POSTOP        extra commands to run after
                making the archive

  TO_UNIX       a command to convert linefeeds
                to Unix style in your archive

  CI            command to checkin your         ci -u
                sources to version control
  RCS_LABEL     command to label your sources   rcs -Nv$(VERSION_SYM): -q
                just after CI is run

  DIST_CP       $how argument to manicopy()     best
                when the distdir is created

  DIST_DEFAULT  default target to use to        tardist
                create a distribution

  DISTVNAME     name of the resulting archive   $(DISTNAME)-$(VERSION)
                (minus suffixes)

=cut

sub init_dist {
    my $self = shift;

    $self->{TAR}      ||= 'tar';
    $self->{TARFLAGS} ||= 'cvf';
    $self->{ZIP}      ||= 'zip';
    $self->{ZIPFLAGS} ||= '-r';
    $self->{COMPRESS} ||= 'gzip --best';
    $self->{SUFFIX}   ||= '.gz';
    $self->{SHAR}     ||= 'shar';
    $self->{PREOP}    ||= '$(NOECHO) $(NOOP)'; # eg update MANIFEST
    $self->{POSTOP}   ||= '$(NOECHO) $(NOOP)'; # eg remove the distdir
    $self->{TO_UNIX}  ||= '$(NOECHO) $(NOOP)';

    $self->{CI}       ||= 'ci -u';
    $self->{RCS_LABEL}||= 'rcs -Nv$(VERSION_SYM): -q';
    $self->{DIST_CP}  ||= 'best';
    $self->{DIST_DEFAULT} ||= 'tardist';

    ($self->{DISTNAME} = $self->{NAME}) =~ s{::}{-}g unless $self->{DISTNAME};
    $self->{DISTVNAME} ||= $self->{DISTNAME}.'-'.$self->{VERSION};
}

=item dist (o)

  my $dist_macros = $mm->dist(%overrides);

Generates a make fragment defining all the macros initialized in
init_dist.

%overrides can be used to override any of the above.

=cut

sub dist {
    my($self, %attribs) = @_;

    my $make = '';
    if ( $attribs{SUFFIX} && $attribs{SUFFIX} !~ m!^\.! ) {
      $attribs{SUFFIX} = '.' . $attribs{SUFFIX};
    }
    foreach my $key (qw(
            TAR TARFLAGS ZIP ZIPFLAGS COMPRESS SUFFIX SHAR
            PREOP POSTOP TO_UNIX
            CI RCS_LABEL DIST_CP DIST_DEFAULT
            DISTNAME DISTVNAME
           ))
    {
        my $value = $attribs{$key} || $self->{$key};
        $make .= "$key = $value\n";
    }

    return $make;
}

=item dist_basics (o)

Defines the targets distclean, distcheck, skipcheck, manifest, veryclean.

=cut

sub dist_basics {
    my($self) = shift;

    return <<'MAKE_FRAG';
distclean :: realclean distcheck
	$(NOECHO) $(NOOP)

distcheck :
	$(PERLRUN) "-MExtUtils::Manifest=fullcheck" -e fullcheck

skipcheck :
	$(PERLRUN) "-MExtUtils::Manifest=skipcheck" -e skipcheck

manifest :
	$(PERLRUN) "-MExtUtils::Manifest=mkmanifest" -e mkmanifest

veryclean : realclean
	$(RM_F) *~ */*~ *.orig */*.orig *.bak */*.bak *.old */*.old

MAKE_FRAG

}

=item dist_ci (o)

Defines a check in target for RCS.

=cut

sub dist_ci {
    my($self) = shift;
    return sprintf "ci :\n\t%s\n", $self->oneliner(<<'EOF', [qw(-MExtUtils::Manifest=maniread)]);
@all = sort keys %{ maniread() };
print(qq{Executing $(CI) @all\n});
system(qq{$(CI) @all}) == 0 or die $!;
print(qq{Executing $(RCS_LABEL) ...\n});
system(qq{$(RCS_LABEL) @all}) == 0 or die $!;
EOF
}

=item dist_core (o)

  my $dist_make_fragment = $MM->dist_core;

Puts the targets necessary for 'make dist' together into one make
fragment.

=cut

sub dist_core {
    my($self) = shift;

    my $make_frag = '';
    foreach my $target (qw(dist tardist uutardist tarfile zipdist zipfile
                           shdist))
    {
        my $method = $target.'_target';
        $make_frag .= "\n";
        $make_frag .= $self->$method();
    }

    return $make_frag;
}


=item B<dist_target>

  my $make_frag = $MM->dist_target;

Returns the 'dist' target to make an archive for distribution.  This
target simply checks to make sure the Makefile is up-to-date and
depends on $(DIST_DEFAULT).

=cut

sub dist_target {
    my($self) = shift;

    my $date_check = $self->oneliner(<<'CODE', ['-l']);
print 'Warning: Makefile possibly out of date with $(VERSION_FROM)'
    if -e '$(VERSION_FROM)' and -M '$(VERSION_FROM)' < -M '$(FIRST_MAKEFILE)';
CODE

    return sprintf <<'MAKE_FRAG', $date_check;
dist : $(DIST_DEFAULT) $(FIRST_MAKEFILE)
	$(NOECHO) %s
MAKE_FRAG
}

=item B<tardist_target>

  my $make_frag = $MM->tardist_target;

Returns the 'tardist' target which is simply so 'make tardist' works.
The real work is done by the dynamically named tardistfile_target()
method, tardist should have that as a dependency.

=cut

sub tardist_target {
    my($self) = shift;

    return <<'MAKE_FRAG';
tardist : $(DISTVNAME).tar$(SUFFIX)
	$(NOECHO) $(NOOP)
MAKE_FRAG
}

=item B<zipdist_target>

  my $make_frag = $MM->zipdist_target;

Returns the 'zipdist' target which is simply so 'make zipdist' works.
The real work is done by the dynamically named zipdistfile_target()
method, zipdist should have that as a dependency.

=cut

sub zipdist_target {
    my($self) = shift;

    return <<'MAKE_FRAG';
zipdist : $(DISTVNAME).zip
	$(NOECHO) $(NOOP)
MAKE_FRAG
}

=item B<tarfile_target>

  my $make_frag = $MM->tarfile_target;

The name of this target is the name of the tarball generated by
tardist.  This target does the actual work of turning the distdir into
a tarball.

=cut

sub tarfile_target {
    my($self) = shift;

    return <<'MAKE_FRAG';
$(DISTVNAME).tar$(SUFFIX) : distdir
	$(PREOP)
	$(TO_UNIX)
	$(TAR) $(TARFLAGS) $(DISTVNAME).tar $(DISTVNAME)
	$(RM_RF) $(DISTVNAME)
	$(COMPRESS) $(DISTVNAME).tar
	$(NOECHO) $(ECHO) 'Created $(DISTVNAME).tar$(SUFFIX)'
	$(POSTOP)
MAKE_FRAG
}

=item zipfile_target

  my $make_frag = $MM->zipfile_target;

The name of this target is the name of the zip file generated by
zipdist.  This target does the actual work of turning the distdir into
a zip file.

=cut

sub zipfile_target {
    my($self) = shift;

    return <<'MAKE_FRAG';
$(DISTVNAME).zip : distdir
	$(PREOP)
	$(ZIP) $(ZIPFLAGS) $(DISTVNAME).zip $(DISTVNAME)
	$(RM_RF) $(DISTVNAME)
	$(NOECHO) $(ECHO) 'Created $(DISTVNAME).zip'
	$(POSTOP)
MAKE_FRAG
}

=item uutardist_target

  my $make_frag = $MM->uutardist_target;

Converts the tarfile into a uuencoded file

=cut

sub uutardist_target {
    my($self) = shift;

    return <<'MAKE_FRAG';
uutardist : $(DISTVNAME).tar$(SUFFIX)
	uuencode $(DISTVNAME).tar$(SUFFIX) $(DISTVNAME).tar$(SUFFIX) > $(DISTVNAME).tar$(SUFFIX)_uu
	$(NOECHO) $(ECHO) 'Created $(DISTVNAME).tar$(SUFFIX)_uu'
MAKE_FRAG
}


=item shdist_target

  my $make_frag = $MM->shdist_target;

Converts the distdir into a shell archive.

=cut

sub shdist_target {
    my($self) = shift;

    return <<'MAKE_FRAG';
shdist : distdir
	$(PREOP)
	$(SHAR) $(DISTVNAME) > $(DISTVNAME).shar
	$(RM_RF) $(DISTVNAME)
	$(NOECHO) $(ECHO) 'Created $(DISTVNAME).shar'
	$(POSTOP)
MAKE_FRAG
}


=item dlsyms (o)

Used by some OS' to define DL_FUNCS and DL_VARS and write the *.exp files.

Normally just returns an empty string.

=cut

sub dlsyms {
    return '';
}


=item dynamic_bs (o)

Defines targets for bootstrap files.

=cut

sub dynamic_bs {
    my($self, %attribs) = @_;
    return "\nBOOTSTRAP =\n" unless $self->has_link_code();
    my @exts;
    if ($self->{XSMULTI}) {
	@exts = $self->_xs_list_basenames;
    } else {
	@exts = '$(BASEEXT)';
    }
    return join "\n",
        "BOOTSTRAP = @{[map { qq{$_.bs} } @exts]}\n",
        map { $self->_xs_make_bs($_) } @exts;
}

sub _xs_make_bs {
    my ($self, $basename) = @_;
    my ($v, $d, $f) = File::Spec->splitpath($basename);
    my @d = File::Spec->splitdir($d);
    shift @d if $self->{XSMULTI} and $d[0] eq 'lib';
    my $instdir = $self->catdir('$(INST_ARCHLIB)', 'auto', @d, $f);
    $instdir = '$(INST_ARCHAUTODIR)' if $basename eq '$(BASEEXT)';
    my $instfile = $self->catfile($instdir, "$f.bs");
    my $exists = "$instdir\$(DFSEP).exists"; # match blibdirs_target
    #                                 1          2          3
    return _sprintf562 <<'MAKE_FRAG', $basename, $instfile, $exists;
# As Mkbootstrap might not write a file (if none is required)
# we use touch to prevent make continually trying to remake it.
# The DynaLoader only reads a non-empty file.
%1$s.bs : $(FIRST_MAKEFILE) $(BOOTDEP)
	$(NOECHO) $(ECHO) "Running Mkbootstrap for %1$s ($(BSLOADLIBS))"
	$(NOECHO) $(PERLRUN) \
		"-MExtUtils::Mkbootstrap" \
		-e "Mkbootstrap('%1$s','$(BSLOADLIBS)');"
	$(NOECHO) $(TOUCH) "%1$s.bs"
	$(CHMOD) $(PERM_RW) "%1$s.bs"

%2$s : %1$s.bs %3$s
	$(NOECHO) $(RM_RF) %2$s
	- $(CP_NONEMPTY) %1$s.bs %2$s $(PERM_RW)
MAKE_FRAG
}

=item dynamic_lib (o)

Defines how to produce the *.so (or equivalent) files.

=cut

sub dynamic_lib {
    my($self, %attribs) = @_;
    return '' unless $self->needs_linking(); #might be because of a subdir
    return '' unless $self->has_link_code;
    my @m = $self->xs_dynamic_lib_macros(\%attribs);
    my @libs;
    my $dlsyms_ext = eval { $self->xs_dlsyms_ext };
    if ($self->{XSMULTI}) {
        my @exts = $self->_xs_list_basenames;
        for my $ext (@exts) {
            my ($v, $d, $f) = File::Spec->splitpath($ext);
            my @d = File::Spec->splitdir($d);
            shift @d if $d[0] eq 'lib';
            pop @d if $d[$#d] eq '';
            my $instdir = $self->catdir('$(INST_ARCHLIB)', 'auto', @d, $f);

            # Dynamic library names may need special handling.
            eval { require DynaLoader };
            if (defined &DynaLoader::mod2fname) {
                $f = &DynaLoader::mod2fname([@d, $f]);
            }

            my $instfile = $self->catfile($instdir, "$f.\$(DLEXT)");
            my $objfile = $self->_xsbuild_value('xs', $ext, 'OBJECT');
            $objfile = "$ext\$(OBJ_EXT)" unless defined $objfile;
            my $ldfrom = $self->_xsbuild_value('xs', $ext, 'LDFROM');
            $ldfrom = $objfile unless defined $ldfrom;
            my $exportlist = "$ext.def";
            my @libchunk = ($objfile, $instfile, $instdir, $ldfrom, $exportlist);
            push @libchunk, $dlsyms_ext ? $ext.$dlsyms_ext : undef;
            push @libs, \@libchunk;
        }
    } else {
        my @libchunk = qw($(OBJECT) $(INST_DYNAMIC) $(INST_ARCHAUTODIR) $(LDFROM) $(EXPORT_LIST));
        push @libchunk, $dlsyms_ext ? '$(BASEEXT)'.$dlsyms_ext : undef;
        @libs = (\@libchunk);
    }
    push @m, map { $self->xs_make_dynamic_lib(\%attribs, @$_); } @libs;

    return join("\n",@m);
}

=item xs_dynamic_lib_macros

Defines the macros for the C<dynamic_lib> section.

=cut

sub xs_dynamic_lib_macros {
    my ($self, $attribs) = @_;
    my $otherldflags = $attribs->{OTHERLDFLAGS} || "";
    my $inst_dynamic_dep = $attribs->{INST_DYNAMIC_DEP} || "";
    my $armaybe = $self->_xs_armaybe($attribs);
    my $ld_opt = $Is{OS2} ? '$(OPTIMIZE) ' : ''; # Useful on other systems too?
    my $ld_fix = $Is{OS2} ? '|| ( $(RM_F) $@ && sh -c false )' : '';
    sprintf <<'EOF', $armaybe, $ld_opt.$otherldflags, $inst_dynamic_dep, $ld_fix;
# This section creates the dynamically loadable objects from relevant
# objects and possibly $(MYEXTLIB).
ARMAYBE = %s
OTHERLDFLAGS = %s
INST_DYNAMIC_DEP = %s
INST_DYNAMIC_FIX = %s
EOF
}

sub _xs_armaybe {
    my ($self, $attribs) = @_;
    my $armaybe = $attribs->{ARMAYBE} || $self->{ARMAYBE} || ":";
    $armaybe = 'ar' if ($Is{OSF} and $armaybe eq ':');
    $armaybe;
}

=item xs_make_dynamic_lib

Defines the recipes for the C<dynamic_lib> section.

=cut

sub xs_make_dynamic_lib {
    my ($self, $attribs, $object, $to, $todir, $ldfrom, $exportlist, $dlsyms) = @_;
    $exportlist = '' if $exportlist ne '$(EXPORT_LIST)';
    my $armaybe = $self->_xs_armaybe($attribs);
    my @m = sprintf '%s : %s $(MYEXTLIB) %s$(DFSEP).exists %s $(PERL_ARCHIVEDEP) $(PERL_ARCHIVE_AFTER) $(INST_DYNAMIC_DEP) %s'."\n", $to, $object, $todir, $exportlist, ($dlsyms || '');
    my $dlsyms_arg = $self->xs_dlsyms_arg($dlsyms);
    if ($armaybe ne ':'){
        $ldfrom = 'tmp$(LIB_EXT)';
        push(@m,"	\$(ARMAYBE) cr $ldfrom $object\n");
        push(@m,"	\$(RANLIB) $ldfrom\n");
    }
    $ldfrom = "-all $ldfrom -none" if $Is{OSF};

    # The IRIX linker doesn't use LD_RUN_PATH
    my $ldrun = $Is{IRIX} && $self->{LD_RUN_PATH} ?
                       qq{-rpath "$self->{LD_RUN_PATH}"} : '';

    # For example in AIX the shared objects/libraries from previous builds
    # linger quite a while in the shared dynalinker cache even when nobody
    # is using them.  This is painful if one for instance tries to restart
    # a failed build because the link command will fail unnecessarily 'cos
    # the shared object/library is 'busy'.
    push(@m,"	\$(RM_F) \$\@\n");

    my $libs = '$(LDLOADLIBS)';
    if (($Is{NetBSD} || $Is{Interix} || $Is{Android}) && $Config{'useshrplib'} eq 'true') {
        # Use nothing on static perl platforms, and to the flags needed
        # to link against the shared libperl library on shared perl
        # platforms.  We peek at lddlflags to see if we need -Wl,-R
        # or -R to add paths to the run-time library search path.
        if ($Config{'lddlflags'} =~ /-Wl,-R/) {
            $libs .= ' "-L$(PERL_INC)" "-Wl,-R$(INSTALLARCHLIB)/CORE" "-Wl,-R$(PERL_ARCHLIB)/CORE" -lperl';
        } elsif ($Config{'lddlflags'} =~ /-R/) {
            $libs .= ' "-L$(PERL_INC)" "-R$(INSTALLARCHLIB)/CORE" "-R$(PERL_ARCHLIB)/CORE" -lperl';
        } elsif ( $Is{Android} ) {
            # The Android linker will not recognize symbols from
            # libperl unless the module explicitly depends on it.
            $libs .= ' "-L$(PERL_INC)" -lperl';
        }
    }

    my $ld_run_path_shell = "";
    if ($self->{LD_RUN_PATH} ne "") {
        $ld_run_path_shell = 'LD_RUN_PATH="$(LD_RUN_PATH)" ';
    }

    push @m, sprintf <<'MAKE', $ld_run_path_shell, $ldrun, $dlsyms_arg, $ldfrom, $self->xs_obj_opt('$@'), $libs, $exportlist;
	%s$(LD) %s $(LDDLFLAGS) %s %s $(OTHERLDFLAGS) %s $(MYEXTLIB) \
	  $(PERL_ARCHIVE) %s $(PERL_ARCHIVE_AFTER) %s \
	  $(INST_DYNAMIC_FIX)
	$(CHMOD) $(PERM_RWX) $@
MAKE
    join '', @m;
}

=item exescan

Deprecated method. Use libscan instead.

=cut

sub exescan {
    my($self,$path) = @_;
    $path;
}

=item extliblist

Called by init_others, and calls ext ExtUtils::Liblist. See
L<ExtUtils::Liblist> for details.

=cut

sub extliblist {
    my($self,$libs) = @_;
    require ExtUtils::Liblist;
    $self->ext($libs, $Verbose);
}

=item find_perl

Finds the executables PERL and FULLPERL

=cut

sub find_perl {
    my($self, $ver, $names, $dirs, $trace) = @_;
    if ($trace >= 2){
        print "Looking for perl $ver by these names:
@$names
in these dirs:
@$dirs
";
    }

    my $stderr_duped = 0;
    local *STDERR_COPY;

    unless ($Is{BSD}) {
        # >& and lexical filehandles together give 5.6.2 indigestion
        if( open(STDERR_COPY, '>&STDERR') ) {  ## no critic
            $stderr_duped = 1;
        }
        else {
            warn <<WARNING;
find_perl() can't dup STDERR: $!
You might see some garbage while we search for Perl
WARNING
        }
    }

    foreach my $name (@$names){
        my ($abs, $use_dir);
        if ($self->file_name_is_absolute($name)) {     # /foo/bar
            $abs = $name;
        } elsif ($self->canonpath($name) eq
                 $self->canonpath(basename($name))) {  # foo
            $use_dir = 1;
        } else {                                            # foo/bar
            $abs = $self->catfile($Curdir, $name);
        }
        foreach my $dir ($use_dir ? @$dirs : 1){
            next unless defined $dir; # $self->{PERL_SRC} may be undefined

            $abs = $self->catfile($dir, $name)
                if $use_dir;

            print "Checking $abs\n" if ($trace >= 2);
            next unless $self->maybe_command($abs);
            print "Executing $abs\n" if ($trace >= 2);

            my $val;
            my $version_check = qq{"$abs" -le "require $ver; print qq{VER_OK}"};

            # To avoid using the unportable 2>&1 to suppress STDERR,
            # we close it before running the command.
            # However, thanks to a thread library bug in many BSDs
            # ( http://www.freebsd.org/cgi/query-pr.cgi?pr=51535 )
            # we cannot use the fancier more portable way in here
            # but instead need to use the traditional 2>&1 construct.
            if ($Is{BSD}) {
                $val = `$version_check 2>&1`;
            } else {
                close STDERR if $stderr_duped;
                $val = `$version_check`;

                # 5.6.2's 3-arg open doesn't work with >&
                open STDERR, ">&STDERR_COPY"  ## no critic
                        if $stderr_duped;
            }

            if ($val =~ /^VER_OK/m) {
                print "Using PERL=$abs\n" if $trace;
                return $abs;
            } elsif ($trace >= 2) {
                print "Result: '$val' ".($? >> 8)."\n";
            }
        }
    }
    print "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n";
    0; # false and not empty
}


=item fixin

  $mm->fixin(@files);

Inserts the sharpbang or equivalent magic number to a set of @files.

=cut

sub fixin {    # stolen from the pink Camel book, more or less
    my ( $self, @files ) = @_;

    for my $file (@files) {
        my $file_new = "$file.new";
        my $file_bak = "$file.bak";

        open( my $fixin, '<', $file ) or croak "Can't process '$file': $!";
        local $/ = "\n";
        chomp( my $line = <$fixin> );
        next unless $line =~ s/^\s*\#!\s*//;    # Not a shebang file.

        my $shb = $self->_fixin_replace_shebang( $file, $line );
        next unless defined $shb;

        open( my $fixout, ">", "$file_new" ) or do {
            warn "Can't create new $file: $!\n";
            next;
        };

        # Print out the new #! line (or equivalent).
        local $\;
        local $/;
        print $fixout $shb, <$fixin>;
        close $fixin;
        close $fixout;

        chmod 0666, $file_bak;
        unlink $file_bak;
        unless ( _rename( $file, $file_bak ) ) {
            warn "Can't rename $file to $file_bak: $!";
            next;
        }
        unless ( _rename( $file_new, $file ) ) {
            warn "Can't rename $file_new to $file: $!";
            unless ( _rename( $file_bak, $file ) ) {
                warn "Can't rename $file_bak back to $file either: $!";
                warn "Leaving $file renamed as $file_bak\n";
            }
            next;
        }
        unlink $file_bak;
    }
    continue {
        system("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
    }
}


sub _rename {
    my($old, $new) = @_;

    foreach my $file ($old, $new) {
        if( $Is{VMS} and basename($file) !~ /\./ ) {
            # rename() in 5.8.0 on VMS will not rename a file if it
            # does not contain a dot yet it returns success.
            $file = "$file.";
        }
    }

    return rename($old, $new);
}

sub _fixin_replace_shebang {
    my ( $self, $file, $line ) = @_;

    # Now figure out the interpreter name.
    my ( $origcmd, $arg ) = split ' ', $line, 2;
    (my $cmd = $origcmd) =~ s!^.*/!!;

    # Now look (in reverse) for interpreter in absolute PATH (unless perl).
    my $interpreter;
    if ( defined $ENV{PERL_MM_SHEBANG} && $ENV{PERL_MM_SHEBANG} eq "relocatable" ) {
        $interpreter = "/usr/bin/env perl";
    }
    elsif ( $cmd =~ m{^perl(?:\z|[^a-z])} ) {
        if ( $Config{startperl} =~ m,^\#!.*/perl, ) {
            $interpreter = $Config{startperl};
            $interpreter =~ s,^\#!,,;
        }
        else {
            $interpreter = $Config{perlpath};
        }
    }
    else {
        my (@absdirs)
            = reverse grep { $self->file_name_is_absolute($_) } $self->path;
        $interpreter = '';

        foreach my $dir (@absdirs) {
            my $maybefile = $self->catfile($dir,$cmd);
            if ( $self->maybe_command($maybefile) ) {
                warn "Ignoring $interpreter in $file\n"
                    if $Verbose && $interpreter;
                $interpreter = $maybefile;
            }
        }

        # If the shebang is absolute and exists in PATH, but was not
        # the first one found, leave it alone if it's actually the
        # same file as first one.  This avoids packages built on
        # merged-/usr systems with /usr/bin before /bin in the path
        # breaking when installed on systems without merged /usr
        if ($origcmd ne $interpreter and $self->file_name_is_absolute($origcmd)) {
            my $origdir = dirname($origcmd);
            if ($self->maybe_command($origcmd) && grep { $_ eq $origdir } @absdirs) {
                my ($odev, $oino) = stat $origcmd;
                my ($idev, $iino) = stat $interpreter;
                if ($odev == $idev && $oino == $iino) {
                    warn "$origcmd is the same as $interpreter, leaving alone"
                        if $Verbose;
                    $interpreter = $origcmd;
                }
            }
        }
    }

    # Figure out how to invoke interpreter on this machine.

    my ($does_shbang) = $Config{'sharpbang'} =~ /^\s*\#\!/;
    my ($shb) = "";
    if ($interpreter) {
        print "Changing sharpbang in $file to $interpreter"
            if $Verbose;
         # this is probably value-free on DOSISH platforms
        if ($does_shbang) {
            $shb .= "$Config{'sharpbang'}$interpreter";
            $shb .= ' ' . $arg if defined $arg;
            $shb .= "\n";
        }
    }
    else {
        warn "Can't find $cmd in PATH, $file unchanged"
            if $Verbose;
        return;
    }
    return $shb
}

=item force (o)

Writes an empty FORCE: target.

=cut

sub force {
    my($self) = shift;
    '# Phony target to force checking subdirectories.
FORCE :
	$(NOECHO) $(NOOP)
';
}

=item guess_name

Guess the name of this package by examining the working directory's
name. MakeMaker calls this only if the developer has not supplied a
NAME attribute.

=cut

# ';

sub guess_name {
    my($self) = @_;
    use Cwd 'cwd';
    my $name = basename(cwd());
    $name =~ s|[\-_][\d\.\-]+\z||;  # this is new with MM 5.00, we
                                    # strip minus or underline
                                    # followed by a float or some such
    print "Warning: Guessing NAME [$name] from current directory name.\n";
    $name;
}

=item has_link_code

Returns true if C, XS, MYEXTLIB or similar objects exist within this
object that need a compiler. Does not descend into subdirectories as
needs_linking() does.

=cut

sub has_link_code {
    my($self) = shift;
    return $self->{HAS_LINK_CODE} if defined $self->{HAS_LINK_CODE};
    if ($self->{OBJECT} or @{$self->{C} || []} or $self->{MYEXTLIB}){
	$self->{HAS_LINK_CODE} = 1;
	return 1;
    }
    return $self->{HAS_LINK_CODE} = 0;
}


=item init_dirscan

Scans the directory structure and initializes DIR, XS, XS_FILES,
C, C_FILES, O_FILES, H, H_FILES, PL_FILES, EXE_FILES.

Called by init_main.

=cut

sub init_dirscan {	# --- File and Directory Lists (.xs .pm .pod etc)
    my($self) = @_;
    my(%dir, %xs, %c, %o, %h, %pl_files, %pm);

    my %ignore = map {( $_ => 1 )} qw(Makefile.PL Build.PL test.pl t);

    # ignore the distdir
    $Is{VMS} ? $ignore{"$self->{DISTVNAME}.dir"} = 1
            : $ignore{$self->{DISTVNAME}} = 1;

    my $distprefix = $Is{VMS} ? qr/^\Q$self->{DISTNAME}\E-v?[\d\.]+\.dir$/i
                              : qr/^\Q$self->{DISTNAME}\E-v?[\d\.]+$/;

    @ignore{map lc, keys %ignore} = values %ignore if $Is{VMS};

    if ( defined $self->{XS} and !defined $self->{C} ) {
	my @c_files = grep { m/\.c(pp|xx)?\z/i } values %{$self->{XS}};
	my @o_files = grep { m/(?:.(?:o(?:bj)?)|\$\(OBJ_EXT\))\z/i } values %{$self->{XS}};
	%c = map { $_ => 1 } @c_files;
	%o = map { $_ => 1 } @o_files;
    }

    foreach my $name ($self->lsdir($Curdir)){
	next if $name =~ /\#/;
	next if $name =~ $distprefix && -d $name;
	$name = lc($name) if $Is{VMS};
	next if $name eq $Curdir or $name eq $Updir or $ignore{$name};
	next unless $self->libscan($name);
	if (-d $name){
	    next if -l $name; # We do not support symlinks at all
            next if $self->{NORECURS};
	    $dir{$name} = $name if (-f $self->catfile($name,"Makefile.PL"));
	} elsif ($name =~ /\.xs\z/){
	    my($c); ($c = $name) =~ s/\.xs\z/.c/;
	    $xs{$name} = $c;
	    $c{$c} = 1;
	} elsif ($name =~ /\.c(pp|xx|c)?\z/i){  # .c .C .cpp .cxx .cc
	    $c{$name} = 1
		unless $name =~ m/perlmain\.c/; # See MAP_TARGET
	} elsif ($name =~ /\.h\z/i){
	    $h{$name} = 1;
	} elsif ($name =~ /\.PL\z/) {
	    ($pl_files{$name} = $name) =~ s/\.PL\z// ;
	} elsif (($Is{VMS} || $Is{Dos}) && $name =~ /[._]pl$/i) {
	    # case-insensitive filesystem, one dot per name, so foo.h.PL
	    # under Unix appears as foo.h_pl under VMS or fooh.pl on Dos
	    local($/); open(my $pl, '<', $name); my $txt = <$pl>; close $pl;
	    if ($txt =~ /Extracting \S+ \(with variable substitutions/) {
		($pl_files{$name} = $name) =~ s/[._]pl\z//i ;
	    }
	    else {
                $pm{$name} = $self->catfile($self->{INST_LIBDIR},$name);
            }
	} elsif ($name =~ /\.(p[ml]|pod)\z/){
	    $pm{$name} = $self->catfile($self->{INST_LIBDIR},$name);
	}
    }

    $self->{PL_FILES}   ||= \%pl_files;
    $self->{DIR}        ||= [sort keys %dir];
    $self->{XS}         ||= \%xs;
    $self->{C}          ||= [sort keys %c];
    $self->{H}          ||= [sort keys %h];
    $self->{PM}         ||= \%pm;

    my @o_files = @{$self->{C}};
    %o = (%o, map { $_ => 1 } grep s/\.c(pp|xx|c)?\z/$self->{OBJ_EXT}/i, @o_files);
    $self->{O_FILES} = [sort keys %o];
}


=item init_MANPODS

Determines if man pages should be generated and initializes MAN1PODS
and MAN3PODS as appropriate.

=cut

sub init_MANPODS {
    my $self = shift;

    # Set up names of manual pages to generate from pods
    foreach my $man (qw(MAN1 MAN3)) {
        if ( $self->{"${man}PODS"}
             or $self->{"INSTALL${man}DIR"} =~ /^(none|\s*)$/
        ) {
            $self->{"${man}PODS"} ||= {};
        }
        else {
            my $init_method = "init_${man}PODS";
            $self->$init_method();
        }
    }

    # logic similar to picking man${num}ext in perl's Configure script
    foreach my $num (1,3) {
        my $installdirs = uc $self->{INSTALLDIRS};
        $installdirs = '' if $installdirs eq 'PERL';
        my @mandirs = File::Spec->splitdir( $self->_expand_macros(
            $self->{ "INSTALL${installdirs}MAN${num}DIR" } ) );
        my $mandir = pop @mandirs;
        my $section = $num;

        foreach ($num, "${num}p", "${num}pm", qw< l n o C L >, "L$num") {
            if ( $mandir =~ /^(?:man|cat)$_$/ ) {
                $section = $_;
                last;
            }
        }

        $self->{"MAN${num}SECTION"} = $section;
    }
}


sub _has_pod {
    my($self, $file) = @_;

    my($ispod)=0;
    if (open( my $fh, '<', $file )) {
        while (<$fh>) {
            if (/^=(?:head\d+|item|pod)\b/) {
                $ispod=1;
                last;
            }
        }
        close $fh;
    } else {
        # If it doesn't exist yet, we assume, it has pods in it
        $ispod = 1;
    }

    return $ispod;
}


=item init_MAN1PODS

Initializes MAN1PODS from the list of EXE_FILES.

=cut

sub init_MAN1PODS {
    my($self) = @_;

    if ( exists $self->{EXE_FILES} ) {
	foreach my $name (@{$self->{EXE_FILES}}) {
	    next unless $self->_has_pod($name);

	    $self->{MAN1PODS}->{$name} =
		$self->catfile("\$(INST_MAN1DIR)",
			       basename($name).".\$(MAN1EXT)");
	}
    }
}


=item init_MAN3PODS

Initializes MAN3PODS from the list of PM files.

=cut

sub init_MAN3PODS {
    my $self = shift;

    my %manifypods = (); # we collect the keys first, i.e. the files
                         # we have to convert to pod

    foreach my $name (keys %{$self->{PM}}) {
	if ($name =~ /\.pod\z/ ) {
	    $manifypods{$name} = $self->{PM}{$name};
	} elsif ($name =~ /\.p[ml]\z/ ) {
	    if( $self->_has_pod($name) ) {
		$manifypods{$name} = $self->{PM}{$name};
	    }
	}
    }

    my $parentlibs_re = join '|', @{$self->{PMLIBPARENTDIRS}};

    # Remove "Configure.pm" and similar, if it's not the only pod listed
    # To force inclusion, just name it "Configure.pod", or override
    # MAN3PODS
    foreach my $name (keys %manifypods) {
	if (
            ($self->{PERL_CORE} and $name =~ /(config|setup).*\.pm/is) or
            ( $name =~ m/^README\.pod$/i ) # don't manify top-level README.pod
        ) {
	    delete $manifypods{$name};
	    next;
	}
	my($manpagename) = $name;
	$manpagename =~ s/\.p(od|m|l)\z//;
	# everything below lib is ok
	unless($manpagename =~ s!^\W*($parentlibs_re)\W+!!s) {
	    $manpagename = $self->catfile(
	        split(/::/,$self->{PARENT_NAME}),$manpagename
	    );
	}
	$manpagename = $self->replace_manpage_separator($manpagename);
	$self->{MAN3PODS}->{$name} =
	    $self->catfile("\$(INST_MAN3DIR)", "$manpagename.\$(MAN3EXT)");
    }
}


=item init_PM

Initializes PMLIBDIRS and PM from PMLIBDIRS.

=cut

sub init_PM {
    my $self = shift;

    # Some larger extensions often wish to install a number of *.pm/pl
    # files into the library in various locations.

    # The attribute PMLIBDIRS holds an array reference which lists
    # subdirectories which we should search for library files to
    # install. PMLIBDIRS defaults to [ 'lib', $self->{BASEEXT} ].  We
    # recursively search through the named directories (skipping any
    # which don't exist or contain Makefile.PL files).

    # For each *.pm or *.pl file found $self->libscan() is called with
    # the default installation path in $_[1]. The return value of
    # libscan defines the actual installation location.  The default
    # libscan function simply returns the path.  The file is skipped
    # if libscan returns false.

    # The default installation location passed to libscan in $_[1] is:
    #
    #  ./*.pm		=> $(INST_LIBDIR)/*.pm
    #  ./xyz/...	=> $(INST_LIBDIR)/xyz/...
    #  ./lib/...	=> $(INST_LIB)/...
    #
    # In this way the 'lib' directory is seen as the root of the actual
    # perl library whereas the others are relative to INST_LIBDIR
    # (which includes PARENT_NAME). This is a subtle distinction but one
    # that's important for nested modules.

    unless( $self->{PMLIBDIRS} ) {
        if( $Is{VMS} ) {
            # Avoid logical name vs directory collisions
            $self->{PMLIBDIRS} = ['./lib', "./$self->{BASEEXT}"];
        }
        else {
            $self->{PMLIBDIRS} = ['lib', $self->{BASEEXT}];
        }
    }

    #only existing directories that aren't in $dir are allowed

    # Avoid $_ wherever possible:
    # @{$self->{PMLIBDIRS}} = grep -d && !$dir{$_}, @{$self->{PMLIBDIRS}};
    my (@pmlibdirs) = @{$self->{PMLIBDIRS}};
    @{$self->{PMLIBDIRS}} = ();
    my %dir = map { ($_ => $_) } @{$self->{DIR}};
    foreach my $pmlibdir (@pmlibdirs) {
	-d $pmlibdir && !$dir{$pmlibdir} && push @{$self->{PMLIBDIRS}}, $pmlibdir;
    }

    unless( $self->{PMLIBPARENTDIRS} ) {
	@{$self->{PMLIBPARENTDIRS}} = ('lib');
    }

    return if $self->{PM} and $self->{ARGS}{PM};

    if (@{$self->{PMLIBDIRS}}){
	print "Searching PMLIBDIRS: @{$self->{PMLIBDIRS}}\n"
	    if ($Verbose >= 2);
	require File::Find;
        File::Find::find(sub {
            if (-d $_){
                unless ($self->libscan($_)){
                    $File::Find::prune = 1;
                }
                return;
            }
            return if /\#/;
            return if /~$/;             # emacs temp files
            return if /,v$/;            # RCS files
            return if m{\.swp$};        # vim swap files

	    my $path   = $File::Find::name;
            my $prefix = $self->{INST_LIBDIR};
            my $striplibpath;

	    my $parentlibs_re = join '|', @{$self->{PMLIBPARENTDIRS}};
	    $prefix =  $self->{INST_LIB}
                if ($striplibpath = $path) =~ s{^(\W*)($parentlibs_re)\W}
	                                       {$1}i;

	    my($inst) = $self->catfile($prefix,$striplibpath);
	    local($_) = $inst; # for backwards compatibility
	    $inst = $self->libscan($inst);
	    print "libscan($path) => '$inst'\n" if ($Verbose >= 2);
	    return unless $inst;
	    if ($self->{XSMULTI} and $inst =~ /\.xs\z/) {
		my($base); ($base = $path) =~ s/\.xs\z//;
		$self->{XS}{$path} = "$base.c";
		push @{$self->{C}}, "$base.c";
		push @{$self->{O_FILES}}, "$base$self->{OBJ_EXT}";
	    } else {
		$self->{PM}{$path} = $inst;
	    }
	}, @{$self->{PMLIBDIRS}});
    }
}


=item init_DIRFILESEP

Using / for Unix.  Called by init_main.

=cut

sub init_DIRFILESEP {
    my($self) = shift;

    $self->{DIRFILESEP} = '/';
}


=item init_main

Initializes AR, AR_STATIC_ARGS, BASEEXT, CONFIG, DISTNAME, DLBASE,
EXE_EXT, FULLEXT, FULLPERL, FULLPERLRUN, FULLPERLRUNINST, INST_*,
INSTALL*, INSTALLDIRS, LIB_EXT, LIBPERL_A, MAP_TARGET, NAME,
OBJ_EXT, PARENT_NAME, PERL, PERL_ARCHLIB, PERL_INC, PERL_LIB,
PERL_SRC, PERLRUN, PERLRUNINST, PREFIX, VERSION,
VERSION_SYM, XS_VERSION.

=cut

sub init_main {
    my($self) = @_;

    # --- Initialize Module Name and Paths

    # NAME    = Foo::Bar::Oracle
    # FULLEXT = Foo/Bar/Oracle
    # BASEEXT = Oracle
    # PARENT_NAME = Foo::Bar
### Only UNIX:
###    ($self->{FULLEXT} =
###     $self->{NAME}) =~ s!::!/!g ; #eg. BSD/Foo/Socket
    $self->{FULLEXT} = $self->catdir(split /::/, $self->{NAME});


    # Copied from DynaLoader:

    my(@modparts) = split(/::/,$self->{NAME});
    my($modfname) = $modparts[-1];

    # Some systems have restrictions on files names for DLL's etc.
    # mod2fname returns appropriate file base name (typically truncated)
    # It may also edit @modparts if required.
    # We require DynaLoader to make sure that mod2fname is loaded
    eval { require DynaLoader };
    if (defined &DynaLoader::mod2fname) {
        $modfname = &DynaLoader::mod2fname(\@modparts);
    }

    ($self->{PARENT_NAME}, $self->{BASEEXT}) = $self->{NAME} =~ m!(?:([\w:]+)::)?(\w+)\z! ;
    $self->{PARENT_NAME} ||= '';

    if (defined &DynaLoader::mod2fname) {
	# As of 5.001m, dl_os2 appends '_'
	$self->{DLBASE} = $modfname;
    } else {
	$self->{DLBASE} = '$(BASEEXT)';
    }


    # --- Initialize PERL_LIB, PERL_SRC

    # *Real* information: where did we get these two from? ...
    my $inc_config_dir = dirname($INC{'Config.pm'});
    my $inc_carp_dir   = dirname($INC{'Carp.pm'});

    unless ($self->{PERL_SRC}){
        foreach my $dir_count (1..8) { # 8 is the VMS limit for nesting
            my $dir = $self->catdir(($Updir) x $dir_count);

            if (-f $self->catfile($dir,"config_h.SH")   &&
                -f $self->catfile($dir,"perl.h")        &&
                -f $self->catfile($dir,"lib","strict.pm")
            ) {
                $self->{PERL_SRC}=$dir ;
                last;
            }
        }
    }

    warn "PERL_CORE is set but I can't find your PERL_SRC!\n" if
      $self->{PERL_CORE} and !$self->{PERL_SRC};

    if ($self->{PERL_SRC}){
	$self->{PERL_LIB}     ||= $self->catdir("$self->{PERL_SRC}","lib");

        $self->{PERL_ARCHLIB} = $self->{PERL_LIB};
        $self->{PERL_INC}     = ($Is{Win32}) ?
            $self->catdir($self->{PERL_LIB},"CORE") : $self->{PERL_SRC};

	# catch a situation that has occurred a few times in the past:
	unless (
		-s $self->catfile($self->{PERL_SRC},'cflags')
		or
		$Is{VMS}
		&&
		-s $self->catfile($self->{PERL_SRC},'vmsish.h')
		or
		$Is{Win32}
	       ){
	    warn qq{
You cannot build extensions below the perl source tree after executing
a 'make clean' in the perl source tree.

To rebuild extensions distributed with the perl source you should
simply Configure (to include those extensions) and then build perl as
normal. After installing perl the source tree can be deleted. It is
not needed for building extensions by running 'perl Makefile.PL'
usually without extra arguments.

It is recommended that you unpack and build additional extensions away
from the perl source tree.
};
	}
    } else {
	# we should also consider $ENV{PERL5LIB} here
        my $old = $self->{PERL_LIB} || $self->{PERL_ARCHLIB} || $self->{PERL_INC};
	$self->{PERL_LIB}     ||= $Config{privlibexp};
	$self->{PERL_ARCHLIB} ||= $Config{archlibexp};
	$self->{PERL_INC}     = $self->catdir("$self->{PERL_ARCHLIB}","CORE"); # wild guess for now
	my $perl_h;

	if (not -f ($perl_h = $self->catfile($self->{PERL_INC},"perl.h"))
	    and not $old){
	    # Maybe somebody tries to build an extension with an
	    # uninstalled Perl outside of Perl build tree
	    my $lib;
	    for my $dir (@INC) {
	      $lib = $dir, last if -e $self->catfile($dir, "Config.pm");
	    }
	    if ($lib) {
              # Win32 puts its header files in /perl/src/lib/CORE.
              # Unix leaves them in /perl/src.
	      my $inc = $Is{Win32} ? $self->catdir($lib, "CORE" )
                                  : dirname $lib;
	      if (-e $self->catfile($inc, "perl.h")) {
		$self->{PERL_LIB}	   = $lib;
		$self->{PERL_ARCHLIB}	   = $lib;
		$self->{PERL_INC}	   = $inc;
		$self->{UNINSTALLED_PERL}  = 1;
		print <<EOP;
... Detected uninstalled Perl.  Trying to continue.
EOP
	      }
	    }
	}
    }

    if ($Is{Android}) {
    	# Android fun times!
    	# ../../perl -I../../lib -MFile::Glob -e1 works
    	# ../../../perl -I../../../lib -MFile::Glob -e1 fails to find
    	# the .so for File::Glob.
    	# This always affects core perl, but may also affect an installed
    	# perl built with -Duserelocatableinc.
    	$self->{PERL_LIB} = File::Spec->rel2abs($self->{PERL_LIB});
    	$self->{PERL_ARCHLIB} = File::Spec->rel2abs($self->{PERL_ARCHLIB});
    }
    $self->{PERL_INCDEP} = $self->{PERL_INC};
    $self->{PERL_ARCHLIBDEP} = $self->{PERL_ARCHLIB};

    # We get SITELIBEXP and SITEARCHEXP directly via
    # Get_from_Config. When we are running standard modules, these
    # won't matter, we will set INSTALLDIRS to "perl". Otherwise we
    # set it to "site". I prefer that INSTALLDIRS be set from outside
    # MakeMaker.
    $self->{INSTALLDIRS} ||= "site";

    $self->{MAN1EXT} ||= $Config{man1ext};
    $self->{MAN3EXT} ||= $Config{man3ext};

    # Get some stuff out of %Config if we haven't yet done so
    print "CONFIG must be an array ref\n"
        if ($self->{CONFIG} and ref $self->{CONFIG} ne 'ARRAY');
    $self->{CONFIG} = [] unless (ref $self->{CONFIG});
    push(@{$self->{CONFIG}}, @ExtUtils::MakeMaker::Get_from_Config);
    push(@{$self->{CONFIG}}, 'shellflags') if $Config{shellflags};
    my(%once_only);
    foreach my $m (@{$self->{CONFIG}}){
        next if $once_only{$m};
        print "CONFIG key '$m' does not exist in Config.pm\n"
                unless exists $Config{$m};
        $self->{uc $m} ||= $Config{$m};
        $once_only{$m} = 1;
    }

# This is too dangerous:
#    if ($^O eq "next") {
#	$self->{AR} = "libtool";
#	$self->{AR_STATIC_ARGS} = "-o";
#    }
# But I leave it as a placeholder

    $self->{AR_STATIC_ARGS} ||= "cr";

    # These should never be needed
    $self->{OBJ_EXT} ||= '.o';
    $self->{LIB_EXT} ||= '.a';

    $self->{MAP_TARGET} ||= "perl";

    $self->{LIBPERL_A} ||= "libperl$self->{LIB_EXT}";

    # make a simple check if we find strict
    warn "Warning: PERL_LIB ($self->{PERL_LIB}) seems not to be a perl library directory
        (strict.pm not found)"
        unless -f $self->catfile("$self->{PERL_LIB}","strict.pm") ||
               $self->{NAME} eq "ExtUtils::MakeMaker";
}

=item init_tools

Initializes tools to use their common (and faster) Unix commands.

=cut

sub init_tools {
    my $self = shift;

    $self->{ECHO}       ||= 'echo';
    $self->{ECHO_N}     ||= 'echo -n';
    $self->{RM_F}       ||= "rm -f";
    $self->{RM_RF}      ||= "rm -rf";
    $self->{TOUCH}      ||= "touch";
    $self->{TEST_F}     ||= "test -f";
    $self->{TEST_S}     ||= "test -s";
    $self->{CP}         ||= "cp";
    $self->{MV}         ||= "mv";
    $self->{CHMOD}      ||= "chmod";
    $self->{FALSE}      ||= 'false';
    $self->{TRUE}       ||= 'true';

    $self->{LD}         ||= 'ld';

    return $self->SUPER::init_tools(@_);

    # After SUPER::init_tools so $Config{shell} has a
    # chance to get set.
    $self->{SHELL}      ||= '/bin/sh';

    return;
}


=item init_linker

Unix has no need of special linker flags.

=cut

sub init_linker {
    my($self) = shift;
    $self->{PERL_ARCHIVE} ||= '';
    $self->{PERL_ARCHIVEDEP} ||= '';
    $self->{PERL_ARCHIVE_AFTER} ||= '';
    $self->{EXPORT_LIST}  ||= '';
}


=begin _protected

=item init_lib2arch

    $mm->init_lib2arch

=end _protected

=cut

sub init_lib2arch {
    my($self) = shift;

    # The user who requests an installation directory explicitly
    # should not have to tell us an architecture installation directory
    # as well. We look if a directory exists that is named after the
    # architecture. If not we take it as a sign that it should be the
    # same as the requested installation directory. Otherwise we take
    # the found one.
    for my $libpair ({l=>"privlib",   a=>"archlib"},
                     {l=>"sitelib",   a=>"sitearch"},
                     {l=>"vendorlib", a=>"vendorarch"},
                    )
    {
        my $lib = "install$libpair->{l}";
        my $Lib = uc $lib;
        my $Arch = uc "install$libpair->{a}";
        if( $self->{$Lib} && ! $self->{$Arch} ){
            my($ilib) = $Config{$lib};

            $self->prefixify($Arch,$ilib,$self->{$Lib});

            unless (-d $self->{$Arch}) {
                print "Directory $self->{$Arch} not found\n"
                  if $Verbose;
                $self->{$Arch} = $self->{$Lib};
            }
            print "Defaulting $Arch to $self->{$Arch}\n" if $Verbose;
        }
    }
}


=item init_PERL

    $mm->init_PERL;

Called by init_main.  Sets up ABSPERL, PERL, FULLPERL and all the
*PERLRUN* permutations.

    PERL is allowed to be miniperl
    FULLPERL must be a complete perl

    ABSPERL is PERL converted to an absolute path

    *PERLRUN contains everything necessary to run perl, find it's
         libraries, etc...

    *PERLRUNINST is *PERLRUN + everything necessary to find the
         modules being built.

=cut

sub init_PERL {
    my($self) = shift;

    my @defpath = ();
    foreach my $component ($self->{PERL_SRC}, $self->path(),
                           $Config{binexp})
    {
	push @defpath, $component if defined $component;
    }

    # Build up a set of file names (not command names).
    my $thisperl = $self->canonpath($^X);
    $thisperl .= $Config{exe_ext} unless
                # VMS might have a file version # at the end
      $Is{VMS} ? $thisperl =~ m/$Config{exe_ext}(;\d+)?$/i
              : $thisperl =~ m/$Config{exe_ext}$/i;

    # We need a relative path to perl when in the core.
    $thisperl = $self->abs2rel($thisperl) if $self->{PERL_CORE};

    my @perls = ($thisperl);
    push @perls, map { "$_$Config{exe_ext}" }
                     ("perl$Config{version}", 'perl5', 'perl');

    # miniperl has priority over all but the canonical perl when in the
    # core.  Otherwise its a last resort.
    my $miniperl = "miniperl$Config{exe_ext}";
    if( $self->{PERL_CORE} ) {
        splice @perls, 1, 0, $miniperl;
    }
    else {
        push @perls, $miniperl;
    }

    $self->{PERL} ||=
        $self->find_perl(5.0, \@perls, \@defpath, $Verbose );

    my $perl = $self->{PERL};
    $perl =~ s/^"//;
    my $has_mcr = $perl =~ s/^MCR\s*//;
    my $perlflags = '';
    my $stripped_perl;
    while ($perl) {
	($stripped_perl = $perl) =~ s/"$//;
	last if -x $stripped_perl;
	last unless $perl =~ s/(\s+\S+)$//;
	$perlflags = $1.$perlflags;
    }
    $self->{PERL} = $stripped_perl;
    $self->{PERL} = 'MCR '.$self->{PERL} if $has_mcr || $Is{VMS};

    # When built for debugging, VMS doesn't create perl.exe but ndbgperl.exe.
    my $perl_name = 'perl';
    $perl_name = 'ndbgperl' if $Is{VMS} &&
      defined $Config{usevmsdebug} && $Config{usevmsdebug} eq 'define';

    # XXX This logic is flawed.  If "miniperl" is anywhere in the path
    # it will get confused.  It should be fixed to work only on the filename.
    # Define 'FULLPERL' to be a non-miniperl (used in test: target)
    unless ($self->{FULLPERL}) {
      ($self->{FULLPERL} = $self->{PERL}) =~ s/\Q$miniperl\E$/$perl_name$Config{exe_ext}/i;
      $self->{FULLPERL} = qq{"$self->{FULLPERL}"}.$perlflags;
    }
    # Can't have an image name with quotes, and findperl will have
    # already escaped spaces.
    $self->{FULLPERL} =~ tr/"//d if $Is{VMS};

    # `dmake` can fail for image (aka, executable) names which start with double-quotes
    # * push quote inward by at least one character (or the drive prefix, if present)
    # * including any initial directory separator preserves the `file_name_is_absolute` property
    $self->{FULLPERL} =~ s/^"(\S(:\\|:)?)/$1"/ if $self->is_make_type('dmake');

    # Little hack to get around VMS's find_perl putting "MCR" in front
    # sometimes.
    $self->{ABSPERL} = $self->{PERL};
    $has_mcr = $self->{ABSPERL} =~ s/^MCR\s*//;
    if( $self->file_name_is_absolute($self->{ABSPERL}) ) {
        $self->{ABSPERL} = '$(PERL)';
    }
    else {
        $self->{ABSPERL} = $self->rel2abs($self->{ABSPERL});

        # Quote the perl command if it contains whitespace
        $self->{ABSPERL} = $self->quote_literal($self->{ABSPERL})
          if $self->{ABSPERL} =~ /\s/;

        $self->{ABSPERL} = 'MCR '.$self->{ABSPERL} if $has_mcr;
    }
    $self->{PERL} = qq{"$self->{PERL}"}.$perlflags;

    # Can't have an image name with quotes, and findperl will have
    # already escaped spaces.
    $self->{PERL} =~ tr/"//d if $Is{VMS};

    # `dmake` can fail for image (aka, executable) names which start with double-quotes
    # * push quote inward by at least one character (or the drive prefix, if present)
    # * including any initial directory separator preserves the `file_name_is_absolute` property
    $self->{PERL} =~ s/^"(\S(:\\|:)?)/$1"/ if $self->is_make_type('dmake');

    # Are we building the core?
    $self->{PERL_CORE} = $ENV{PERL_CORE} unless exists $self->{PERL_CORE};
    $self->{PERL_CORE} = 0               unless defined $self->{PERL_CORE};

    # Make sure perl can find itself before it's installed.
    my $lib_paths = $self->{UNINSTALLED_PERL} || $self->{PERL_CORE}
        ? ( $self->{PERL_ARCHLIB} && $self->{PERL_LIB} && $self->{PERL_ARCHLIB} ne $self->{PERL_LIB} ) ?
            q{ "-I$(PERL_LIB)" "-I$(PERL_ARCHLIB)"} : q{ "-I$(PERL_LIB)"}
        : undef;
    my $inst_lib_paths = $self->{INST_ARCHLIB} ne $self->{INST_LIB}
        ? 'RUN)'.$perlflags.' "-I$(INST_ARCHLIB)" "-I$(INST_LIB)"'
        : 'RUN)'.$perlflags.' "-I$(INST_LIB)"';
    # How do we run perl?
    foreach my $perl (qw(PERL FULLPERL ABSPERL)) {
        my $run  = $perl.'RUN';

        $self->{$run}  = qq{\$($perl)};
        $self->{$run} .= $lib_paths if $lib_paths;

        $self->{$perl.'RUNINST'} = '$('.$perl.$inst_lib_paths;
    }

    return 1;
}


=item init_platform

=item platform_constants

Add MM_Unix_VERSION.

=cut

sub init_platform {
    my($self) = shift;

    $self->{MM_Unix_VERSION} = $VERSION;
    $self->{PERL_MALLOC_DEF} = '-DPERL_EXTMALLOC_DEF -Dmalloc=Perl_malloc '.
                               '-Dfree=Perl_mfree -Drealloc=Perl_realloc '.
                               '-Dcalloc=Perl_calloc';

}

sub platform_constants {
    my($self) = shift;
    my $make_frag = '';

    foreach my $macro (qw(MM_Unix_VERSION PERL_MALLOC_DEF))
    {
        next unless defined $self->{$macro};
        $make_frag .= "$macro = $self->{$macro}\n";
    }

    return $make_frag;
}


=item init_PERM

  $mm->init_PERM

Called by init_main.  Initializes PERL_*

=cut

sub init_PERM {
    my($self) = shift;

    $self->{PERM_DIR} = 755  unless defined $self->{PERM_DIR};
    $self->{PERM_RW}  = 644  unless defined $self->{PERM_RW};
    $self->{PERM_RWX} = 755  unless defined $self->{PERM_RWX};

    return 1;
}


=item init_xs

    $mm->init_xs

Sets up macros having to do with XS code.  Currently just INST_STATIC,
INST_DYNAMIC and INST_BOOT.

=cut

sub init_xs {
    my $self = shift;

    if ($self->has_link_code()) {
        $self->{INST_STATIC}  =
          $self->catfile('$(INST_ARCHAUTODIR)', '$(BASEEXT)$(LIB_EXT)');
        $self->{INST_DYNAMIC} =
          $self->catfile('$(INST_ARCHAUTODIR)', '$(DLBASE).$(DLEXT)');
        $self->{INST_BOOT}    =
          $self->catfile('$(INST_ARCHAUTODIR)', '$(BASEEXT).bs');
	if ($self->{XSMULTI}) {
	    my @exts = $self->_xs_list_basenames;
	    my (@statics, @dynamics, @boots);
	    for my $ext (@exts) {
		my ($v, $d, $f) = File::Spec->splitpath($ext);
		my @d = File::Spec->splitdir($d);
		shift @d if defined $d[0] and $d[0] eq 'lib';
		pop @d if $d[$#d] eq '';
		my $instdir = $self->catdir('$(INST_ARCHLIB)', 'auto', @d, $f);
		my $instfile = $self->catfile($instdir, $f);
		push @statics, "$instfile\$(LIB_EXT)";

                # Dynamic library names may need special handling.
                my $dynfile = $instfile;
                eval { require DynaLoader };
                if (defined &DynaLoader::mod2fname) {
                    $dynfile = $self->catfile($instdir, &DynaLoader::mod2fname([@d, $f]));
                }

		push @dynamics, "$dynfile.\$(DLEXT)";
		push @boots, "$instfile.bs";
	    }
	    $self->{INST_STATIC} = join ' ', @statics;
	    $self->{INST_DYNAMIC} = join ' ', @dynamics;
	    $self->{INST_BOOT} = join ' ', @boots;
	}
    } else {
        $self->{INST_STATIC}  = '';
        $self->{INST_DYNAMIC} = '';
        $self->{INST_BOOT}    = '';
    }
}

=item install (o)

Defines the install target.

=cut

sub install {
    my($self, %attribs) = @_;
    my(@m);

    push @m, q{
install :: pure_install doc_install
	$(NOECHO) $(NOOP)

install_perl :: pure_perl_install doc_perl_install
	$(NOECHO) $(NOOP)

install_site :: pure_site_install doc_site_install
	$(NOECHO) $(NOOP)

install_vendor :: pure_vendor_install doc_vendor_install
	$(NOECHO) $(NOOP)

pure_install :: pure_$(INSTALLDIRS)_install
	$(NOECHO) $(NOOP)

doc_install :: doc_$(INSTALLDIRS)_install
	$(NOECHO) $(NOOP)

pure__install : pure_site_install
	$(NOECHO) $(ECHO) INSTALLDIRS not defined, defaulting to INSTALLDIRS=site

doc__install : doc_site_install
	$(NOECHO) $(ECHO) INSTALLDIRS not defined, defaulting to INSTALLDIRS=site

pure_perl_install :: all
	$(NOECHO) $(MOD_INSTALL) \
};

    push @m,
q{		read "}.$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q{" \
		write "}.$self->catfile('$(DESTINSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').q{" \
} unless $self->{NO_PACKLIST};

    push @m,
q{		"$(INST_LIB)" "$(DESTINSTALLPRIVLIB)" \
		"$(INST_ARCHLIB)" "$(DESTINSTALLARCHLIB)" \
		"$(INST_BIN)" "$(DESTINSTALLBIN)" \
		"$(INST_SCRIPT)" "$(DESTINSTALLSCRIPT)" \
		"$(INST_MAN1DIR)" "$(DESTINSTALLMAN1DIR)" \
		"$(INST_MAN3DIR)" "$(DESTINSTALLMAN3DIR)"
	$(NOECHO) $(WARN_IF_OLD_PACKLIST) \
		"}.$self->catdir('$(SITEARCHEXP)','auto','$(FULLEXT)').q{"


pure_site_install :: all
	$(NOECHO) $(MOD_INSTALL) \
};
    push @m,
q{		read "}.$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{" \
		write "}.$self->catfile('$(DESTINSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').q{" \
} unless $self->{NO_PACKLIST};

    push @m,
q{		"$(INST_LIB)" "$(DESTINSTALLSITELIB)" \
		"$(INST_ARCHLIB)" "$(DESTINSTALLSITEARCH)" \
		"$(INST_BIN)" "$(DESTINSTALLSITEBIN)" \
		"$(INST_SCRIPT)" "$(DESTINSTALLSITESCRIPT)" \
		"$(INST_MAN1DIR)" "$(DESTINSTALLSITEMAN1DIR)" \
		"$(INST_MAN3DIR)" "$(DESTINSTALLSITEMAN3DIR)"
	$(NOECHO) $(WARN_IF_OLD_PACKLIST) \
		"}.$self->catdir('$(PERL_ARCHLIB)','auto','$(FULLEXT)').q{"

pure_vendor_install :: all
	$(NOECHO) $(MOD_INSTALL) \
};
    push @m,
q{		read "}.$self->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').q{" \
		write "}.$self->catfile('$(DESTINSTALLVENDORARCH)','auto','$(FULLEXT)','.packlist').q{" \
} unless $self->{NO_PACKLIST};

    push @m,
q{		"$(INST_LIB)" "$(DESTINSTALLVENDORLIB)" \
		"$(INST_ARCHLIB)" "$(DESTINSTALLVENDORARCH)" \
		"$(INST_BIN)" "$(DESTINSTALLVENDORBIN)" \
		"$(INST_SCRIPT)" "$(DESTINSTALLVENDORSCRIPT)" \
		"$(INST_MAN1DIR)" "$(DESTINSTALLVENDORMAN1DIR)" \
		"$(INST_MAN3DIR)" "$(DESTINSTALLVENDORMAN3DIR)"

};

    push @m, q{
doc_perl_install :: all
	$(NOECHO) $(NOOP)

doc_site_install :: all
	$(NOECHO) $(NOOP)

doc_vendor_install :: all
	$(NOECHO) $(NOOP)

} if $self->{NO_PERLLOCAL};

    push @m, q{
doc_perl_install :: all
	$(NOECHO) $(ECHO) Appending installation info to "$(DESTINSTALLARCHLIB)/perllocal.pod"
	-$(NOECHO) $(MKPATH) "$(DESTINSTALLARCHLIB)"
	-$(NOECHO) $(DOC_INSTALL) \
		"Module" "$(NAME)" \
		"installed into" "$(INSTALLPRIVLIB)" \
		LINKTYPE "$(LINKTYPE)" \
		VERSION "$(VERSION)" \
		EXE_FILES "$(EXE_FILES)" \
		>> "}.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{"

doc_site_install :: all
	$(NOECHO) $(ECHO) Appending installation info to "$(DESTINSTALLARCHLIB)/perllocal.pod"
	-$(NOECHO) $(MKPATH) "$(DESTINSTALLARCHLIB)"
	-$(NOECHO) $(DOC_INSTALL) \
		"Module" "$(NAME)" \
		"installed into" "$(INSTALLSITELIB)" \
		LINKTYPE "$(LINKTYPE)" \
		VERSION "$(VERSION)" \
		EXE_FILES "$(EXE_FILES)" \
		>> "}.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{"

doc_vendor_install :: all
	$(NOECHO) $(ECHO) Appending installation info to "$(DESTINSTALLARCHLIB)/perllocal.pod"
	-$(NOECHO) $(MKPATH) "$(DESTINSTALLARCHLIB)"
	-$(NOECHO) $(DOC_INSTALL) \
		"Module" "$(NAME)" \
		"installed into" "$(INSTALLVENDORLIB)" \
		LINKTYPE "$(LINKTYPE)" \
		VERSION "$(VERSION)" \
		EXE_FILES "$(EXE_FILES)" \
		>> "}.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{"

} unless $self->{NO_PERLLOCAL};

    push @m, q{
uninstall :: uninstall_from_$(INSTALLDIRS)dirs
	$(NOECHO) $(NOOP)

uninstall_from_perldirs ::
	$(NOECHO) $(UNINSTALL) "}.$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q{"

uninstall_from_sitedirs ::
	$(NOECHO) $(UNINSTALL) "}.$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{"

uninstall_from_vendordirs ::
	$(NOECHO) $(UNINSTALL) "}.$self->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').q{"
};

    join("",@m);
}

=item installbin (o)

Defines targets to make and to install EXE_FILES.

=cut

sub installbin {
    my($self) = shift;

    return "" unless $self->{EXE_FILES} && ref $self->{EXE_FILES} eq "ARRAY";
    my @exefiles = sort @{$self->{EXE_FILES}};
    return "" unless @exefiles;

    @exefiles = map vmsify($_), @exefiles if $Is{VMS};

    my %fromto;
    for my $from (@exefiles) {
	my($path)= $self->catfile('$(INST_SCRIPT)', basename($from));

	local($_) = $path; # for backwards compatibility
	my $to = $self->libscan($path);
	print "libscan($from) => '$to'\n" if ($Verbose >=2);

        $to = vmsify($to) if $Is{VMS};
	$fromto{$from} = $to;
    }
    my @to   = sort values %fromto;

    my @m;
    push(@m, qq{
EXE_FILES = @exefiles

pure_all :: @to
	\$(NOECHO) \$(NOOP)

realclean ::
});

    # realclean can get rather large.
    push @m, map "\t$_\n", $self->split_command('$(RM_F)', @to);
    push @m, "\n";

    # A target for each exe file.
    my @froms = sort keys %fromto;
    for my $from (@froms) {
        #                              1      2
        push @m, _sprintf562 <<'MAKE', $from, $fromto{$from};
%2$s : %1$s $(FIRST_MAKEFILE) $(INST_SCRIPT)$(DFSEP).exists $(INST_BIN)$(DFSEP).exists
	$(NOECHO) $(RM_F) %2$s
	$(CP) %1$s %2$s
	$(FIXIN) %2$s
	-$(NOECHO) $(CHMOD) $(PERM_RWX) %2$s

MAKE

    }

    join "", @m;
}

=item linkext (o)

Defines the linkext target which in turn defines the LINKTYPE.

=cut

# LINKTYPE => static or dynamic or ''
sub linkext {
    my($self, %attribs) = @_;
    my $linktype = $attribs{LINKTYPE};
    $linktype = $self->{LINKTYPE} unless defined $linktype;
    if (defined $linktype and $linktype eq '') {
        warn "Warning: LINKTYPE set to '', no longer necessary\n";
    }
    $linktype = '$(LINKTYPE)' unless defined $linktype;
    "
linkext :: $linktype
	\$(NOECHO) \$(NOOP)
";
}

=item lsdir

Takes as arguments a directory name and a regular expression. Returns
all entries in the directory that match the regular expression.

=cut

sub lsdir {
    #  $self
    my(undef, $dir, $regex) = @_;
    opendir(my $dh, defined($dir) ? $dir : ".")
        or return;
    my @ls = readdir $dh;
    closedir $dh;
    @ls = grep(/$regex/, @ls) if defined $regex;
    @ls;
}

=item macro (o)

Simple subroutine to insert the macros defined by the macro attribute
into the Makefile.

=cut

sub macro {
    my($self,%attribs) = @_;
    my @m;
    foreach my $key (sort keys %attribs) {
	my $val = $attribs{$key};
	push @m, "$key = $val\n";
    }
    join "", @m;
}

=item makeaperl (o)

Called by staticmake. Defines how to write the Makefile to produce a
static new perl.

By default the Makefile produced includes all the static extensions in
the perl library. (Purified versions of library files, e.g.,
DynaLoader_pure_p1_c0_032.a are automatically ignored to avoid link errors.)

=cut

sub makeaperl {
    my($self, %attribs) = @_;
    my($makefilename, $searchdirs, $static, $extra, $perlinc, $target, $tmp, $libperl) =
	@attribs{qw(MAKE DIRS STAT EXTRA INCL TARGET TMP LIBPERL)};
    s/^(.*)/"-I$1"/ for @{$perlinc || []};
    my(@m);
    push @m, "
# --- MakeMaker makeaperl section ---
MAP_TARGET    = $target
FULLPERL      = $self->{FULLPERL}
MAP_PERLINC   = @{$perlinc || []}
";
    return join '', @m if $self->{PARENT};

    my($dir) = join ":", @{$self->{DIR}};

    unless ($self->{MAKEAPERL}) {
	push @m, q{
$(MAP_TARGET) :: $(MAKE_APERL_FILE)
	$(MAKE) $(USEMAKEFILE) $(MAKE_APERL_FILE) $@

$(MAKE_APERL_FILE) : static $(FIRST_MAKEFILE) pm_to_blib
	$(NOECHO) $(ECHO) Writing \"$(MAKE_APERL_FILE)\" for this $(MAP_TARGET)
	$(NOECHO) $(PERLRUNINST) \
		Makefile.PL DIR="}, $dir, q{" \
		MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \
		MAKEAPERL=1 NORECURS=1 CCCDLFLAGS=};

	foreach (@ARGV){
		my $arg = $_; # avoid lvalue aliasing
		if ( $arg =~ /(^.*?=)(.*['\s].*)/ ) {
			$arg = $1 . $self->quote_literal($2);
		}
		push @m, " \\\n\t\t$arg";
	}
	push @m, "\n";

	return join '', @m;
    }

    my $cccmd = $self->const_cccmd($libperl);
    $cccmd =~ s/^CCCMD\s*=\s*//;
    $cccmd =~ s/\$\(INC\)/ "-I$self->{PERL_INC}" /;
    $cccmd .= " $Config{cccdlflags}"
	if ($Config{useshrplib} eq 'true');
    $cccmd =~ s/\(CC\)/\(PERLMAINCC\)/;

    # The front matter of the linkcommand...
    my $linkcmd = join ' ', "\$(CC)",
	    grep($_, @Config{qw(ldflags ccdlflags)});
    $linkcmd =~ s/\s+/ /g;
    $linkcmd =~ s,(perl\.exp),\$(PERL_INC)/$1,;

    # Which *.a files could we make use of...
    my $staticlib21 = $self->_find_static_libs($searchdirs);
    # We trust that what has been handed in as argument, will be buildable
    $static = [] unless $static;
    @$staticlib21{@{$static}} = (1) x @{$static};

    $extra = [] unless $extra && ref $extra eq 'ARRAY';
    for (sort keys %$staticlib21) {
	next unless /\Q$self->{LIB_EXT}\E\z/;
	$_ = dirname($_) . "/extralibs.ld";
	push @$extra, $_;
    }

    s/^(.*)/"-I$1"/ for @{$perlinc || []};

    $target ||= "perl";
    $tmp    ||= ".";

# MAP_STATIC doesn't look into subdirs yet. Once "all" is made and we
# regenerate the Makefiles, MAP_STATIC and the dependencies for
# extralibs.all are computed correctly
    my @map_static = reverse sort keys %$staticlib21;
    push @m, "
MAP_LINKCMD   = $linkcmd
MAP_STATIC    = ", join(" \\\n\t", map { qq{"$_"} } @map_static), "
MAP_STATICDEP = ", join(' ', map { $self->quote_dep($_) } @map_static), "

MAP_PRELIBS   = $Config{perllibs} $Config{cryptlib}
";

    my $lperl;
    if (defined $libperl) {
	($lperl = $libperl) =~ s/\$\(A\)/$self->{LIB_EXT}/;
    }
    unless ($libperl && -f $lperl) { # Ilya's code...
	my $dir = $self->{PERL_SRC} || "$self->{PERL_ARCHLIB}/CORE";
	$dir = "$self->{PERL_ARCHLIB}/.." if $self->{UNINSTALLED_PERL};
	$libperl ||= "libperl$self->{LIB_EXT}";
	$libperl   = "$dir/$libperl";
	$lperl   ||= "libperl$self->{LIB_EXT}";
	$lperl     = "$dir/$lperl";

        if (! -f $libperl and ! -f $lperl) {
          # We did not find a static libperl. Maybe there is a shared one?
          if ($Is{SunOS}) {
            $lperl  = $libperl = "$dir/$Config{libperl}";
            # SUNOS ld does not take the full path to a shared library
            $libperl = '' if $Is{SunOS4};
          }
        }

	print <<EOF unless -f $lperl || defined($self->{PERL_SRC});
Warning: $libperl not found
If you're going to build a static perl binary, make sure perl is installed
otherwise ignore this warning
EOF
    }

    # SUNOS ld does not take the full path to a shared library
    my $llibperl = $libperl ? '$(MAP_LIBPERL)' : '-lperl';
    my $libperl_dep = $self->quote_dep($libperl);

    push @m, "
MAP_LIBPERL = $libperl
MAP_LIBPERLDEP = $libperl_dep
LLIBPERL    = $llibperl
";

    push @m, '
$(INST_ARCHAUTODIR)/extralibs.all : $(INST_ARCHAUTODIR)$(DFSEP).exists '.join(" \\\n\t", @$extra).'
	$(NOECHO) $(RM_F)  $@
	$(NOECHO) $(TOUCH) $@
';

    foreach my $catfile (@$extra){
	push @m, "\tcat $catfile >> \$\@\n";
    }

    my $ldfrom = $self->{XSMULTI} ? '' : '$(LDFROM)';
    #                             1     2                        3        4
    push @m, _sprintf562 <<'EOF', $tmp, $ldfrom, $self->xs_obj_opt('$@'), $makefilename;
$(MAP_TARGET) :: %1$s/perlmain$(OBJ_EXT) $(MAP_LIBPERLDEP) $(MAP_STATICDEP) $(INST_ARCHAUTODIR)/extralibs.all
	$(MAP_LINKCMD) %2$s $(OPTIMIZE) %1$s/perlmain$(OBJ_EXT) %3$s $(MAP_STATIC) "$(LLIBPERL)" `cat $(INST_ARCHAUTODIR)/extralibs.all` $(MAP_PRELIBS)
	$(NOECHO) $(ECHO) "To install the new '$(MAP_TARGET)' binary, call"
	$(NOECHO) $(ECHO) "    $(MAKE) $(USEMAKEFILE) %4$s inst_perl MAP_TARGET=$(MAP_TARGET)"
	$(NOECHO) $(ECHO) "    $(MAKE) $(USEMAKEFILE) %4$s map_clean"

%1$s/perlmain\$(OBJ_EXT): %1$s/perlmain.c
EOF
    push @m, "\t".$self->cd($tmp, qq[$cccmd "-I\$(PERL_INC)" perlmain.c])."\n";

    my $maybe_DynaLoader = $Config{usedl} ? 'q(DynaLoader)' : '';
    push @m, _sprintf562 <<'EOF', $tmp, $makefilename, $maybe_DynaLoader;

%1$s/perlmain.c: %2$s
	$(NOECHO) $(ECHO) Writing $@
	$(NOECHO) $(PERL) $(MAP_PERLINC) "-MExtUtils::Miniperl" \
		-e "writemain(grep(s#.*/auto/##s, @ARGV), %3$s)" $(MAP_STATIC) > $@t
	$(MV) $@t $@

EOF
    push @m, "\t", q{$(NOECHO) $(PERL) "$(INSTALLSCRIPT)/fixpmain"
} if (defined (&Dos::UseLFN) && Dos::UseLFN()==0);


    push @m, q{
doc_inst_perl :
	$(NOECHO) $(ECHO) Appending installation info to "$(DESTINSTALLARCHLIB)/perllocal.pod"
	-$(NOECHO) $(MKPATH) "$(DESTINSTALLARCHLIB)"
	-$(NOECHO) $(DOC_INSTALL) \
		"Perl binary" "$(MAP_TARGET)" \
		MAP_STATIC "$(MAP_STATIC)" \
		MAP_EXTRA "`cat $(INST_ARCHAUTODIR)/extralibs.all`" \
		MAP_LIBPERL "$(MAP_LIBPERL)" \
		>> "}.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{"

};

    push @m, q{
inst_perl : pure_inst_perl doc_inst_perl

pure_inst_perl : $(MAP_TARGET)
	}.$self->{CP}.q{ $(MAP_TARGET) "}.$self->catfile('$(DESTINSTALLBIN)','$(MAP_TARGET)').q{"

clean :: map_clean

map_clean :
	}.$self->{RM_F}.qq{ $tmp/perlmain\$(OBJ_EXT) $tmp/perlmain.c \$(MAP_TARGET) $makefilename \$(INST_ARCHAUTODIR)/extralibs.all
};

    join '', @m;
}

# utility method
sub _find_static_libs {
    my ($self, $searchdirs) = @_;
    # don't use File::Spec here because on Win32 F::F still uses "/"
    my $installed_version = join('/',
	'auto', $self->{FULLEXT}, "$self->{BASEEXT}$self->{LIB_EXT}"
    );
    my %staticlib21;
    require File::Find;
    File::Find::find(sub {
	if ($File::Find::name =~ m{/auto/share\z}) {
	    # in a subdir of auto/share, prune because e.g.
	    # Alien::pkgconfig uses File::ShareDir to put .a files
	    # there. do not want
	    $File::Find::prune = 1;
	    return;
	}

	return unless m/\Q$self->{LIB_EXT}\E$/;

	return unless -f 'extralibs.ld'; # this checks is a "proper" XS installation

        # Skip perl's libraries.
        return if m/^libperl/ or m/^perl\Q$self->{LIB_EXT}\E$/;

	# Skip purified versions of libraries
        # (e.g., DynaLoader_pure_p1_c0_032.a)
	return if m/_pure_\w+_\w+_\w+\.\w+$/ and -f "$File::Find::dir/.pure";

	if( exists $self->{INCLUDE_EXT} ){
		my $found = 0;

		(my $xx = $File::Find::name) =~ s,.*?/auto/,,s;
		$xx =~ s,/?$_,,;
		$xx =~ s,/,::,g;

		# Throw away anything not explicitly marked for inclusion.
		# DynaLoader is implied.
		foreach my $incl ((@{$self->{INCLUDE_EXT}},'DynaLoader')){
			if( $xx eq $incl ){
				$found++;
				last;
			}
		}
		return unless $found;
	}
	elsif( exists $self->{EXCLUDE_EXT} ){
		(my $xx = $File::Find::name) =~ s,.*?/auto/,,s;
		$xx =~ s,/?$_,,;
		$xx =~ s,/,::,g;

		# Throw away anything explicitly marked for exclusion
		foreach my $excl (@{$self->{EXCLUDE_EXT}}){
			return if( $xx eq $excl );
		}
	}

	# don't include the installed version of this extension. I
	# leave this line here, although it is not necessary anymore:
	# I patched minimod.PL instead, so that Miniperl.pm won't
	# include duplicates

	# Once the patch to minimod.PL is in the distribution, I can
	# drop it
	return if $File::Find::name =~ m:\Q$installed_version\E\z:;
	return if !$self->xs_static_lib_is_xs($_);
	use Cwd 'cwd';
	$staticlib21{cwd() . "/" . $_}++;
    }, grep( -d $_, map { $self->catdir($_, 'auto') } @{$searchdirs || []}) );
    return \%staticlib21;
}

=item xs_static_lib_is_xs (o)

Called by a utility method of makeaperl. Checks whether a given file
is an XS library by seeing whether it defines any symbols starting
with C<boot_> (with an optional leading underscore - needed on MacOS).

=cut

sub xs_static_lib_is_xs {
    my ($self, $libfile) = @_;
    my $devnull = File::Spec->devnull;
    return `nm $libfile 2>$devnull` =~ /\b_?boot_/;
}

=item makefile (o)

Defines how to rewrite the Makefile.

=cut

sub makefile {
    my($self) = shift;
    my $m;
    # We do not know what target was originally specified so we
    # must force a manual rerun to be sure. But as it should only
    # happen very rarely it is not a significant problem.
    $m = '
$(OBJECT) : $(FIRST_MAKEFILE)

' if $self->{OBJECT};

    my $newer_than_target = $Is{VMS} ? '$(MMS$SOURCE_LIST)' : '$?';
    my $mpl_args = join " ", map qq["$_"], @ARGV;
    my $cross = '';
    if (defined $::Cross::platform) {
        # Inherited from win32/buildext.pl
        $cross = "-MCross=$::Cross::platform ";
    }
    $m .= sprintf <<'MAKE_FRAG', $newer_than_target, $cross, $mpl_args;
# We take a very conservative approach here, but it's worth it.
# We move Makefile to Makefile.old here to avoid gnu make looping.
$(FIRST_MAKEFILE) : Makefile.PL $(CONFIGDEP)
	$(NOECHO) $(ECHO) "Makefile out-of-date with respect to %s"
	$(NOECHO) $(ECHO) "Cleaning current config before rebuilding Makefile..."
	-$(NOECHO) $(RM_F) $(MAKEFILE_OLD)
	-$(NOECHO) $(MV)   $(FIRST_MAKEFILE) $(MAKEFILE_OLD)
	- $(MAKE) $(USEMAKEFILE) $(MAKEFILE_OLD) clean $(DEV_NULL)
	$(PERLRUN) %sMakefile.PL %s
	$(NOECHO) $(ECHO) "==> Your Makefile has been rebuilt. <=="
	$(NOECHO) $(ECHO) "==> Please rerun the $(MAKE) command.  <=="
	$(FALSE)

MAKE_FRAG

    return $m;
}


=item maybe_command

Returns true, if the argument is likely to be a command.

=cut

sub maybe_command {
    my($self,$file) = @_;
    return $file if -x $file && ! -d $file;
    return;
}


=item needs_linking (o)

Does this module need linking? Looks into subdirectory objects (see
also has_link_code())

=cut

sub needs_linking {
    my($self) = shift;

    my $caller = (caller(0))[3];
    confess("needs_linking called too early") if
      $caller =~ /^ExtUtils::MakeMaker::/;
    return $self->{NEEDS_LINKING} if defined $self->{NEEDS_LINKING};
    if ($self->has_link_code or $self->{MAKEAPERL}){
	$self->{NEEDS_LINKING} = 1;
	return 1;
    }
    foreach my $child (keys %{$self->{CHILDREN}}) {
	if ($self->{CHILDREN}->{$child}->needs_linking) {
	    $self->{NEEDS_LINKING} = 1;
	    return 1;
	}
    }
    return $self->{NEEDS_LINKING} = 0;
}


=item parse_abstract

parse a file and return what you think is the ABSTRACT

=cut

sub parse_abstract {
    my($self,$parsefile) = @_;
    my $result;

    local $/ = "\n";
    open(my $fh, '<', $parsefile) or die "Could not open '$parsefile': $!";
    binmode $fh;
    my $inpod = 0;
    my $pod_encoding;
    my $package = $self->{DISTNAME};
    $package =~ s/-/::/g;
    while (<$fh>) {
        $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;
        next if !$inpod;
        s#\r*\n\z##; # handle CRLF input

        if ( /^=encoding\s*(.*)$/i ) {
            $pod_encoding = $1;
        }

        if ( /^($package(?:\.pm)? \s+ -+ \s+)(.*)/x ) {
          $result = $2;
          next;
        }
        next unless $result;

        if ( $result && ( /^\s*$/ || /^\=/ ) ) {
          last;
        }
        $result = join ' ', $result, $_;
    }
    close $fh;

    if ( $pod_encoding and !( "$]" < 5.008 or !$Config{useperlio} ) ) {
        # Have to wrap in an eval{} for when running under PERL_CORE
        # Encode isn't available during build phase and parsing
        # ABSTRACT isn't important there
        eval {
          require Encode;
          $result = Encode::decode($pod_encoding, $result);
        }
    }

    return $result;
}

=item parse_version

    my $version = MM->parse_version($file);

Parse a $file and return what $VERSION is set to by the first assignment.
It will return the string "undef" if it can't figure out what $VERSION
is. $VERSION should be for all to see, so C<our $VERSION> or plain $VERSION
are okay, but C<my $VERSION> is not.

C<package Foo VERSION> is also checked for.  The first version
declaration found is used, but this may change as it differs from how
Perl does it.

parse_version() will try to C<use version> before checking for
C<$VERSION> so the following will work.

    $VERSION = qv(1.2.3);

=cut

sub parse_version {
    my($self,$parsefile) = @_;
    my $result;

    local $/ = "\n";
    local $_;
    open(my $fh, '<', $parsefile) or die "Could not open '$parsefile': $!";
    my $inpod = 0;
    while (<$fh>) {
        $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;
        next if $inpod || /^\s*#/;
        chop;
        next if /^\s*(if|unless|elsif)/;
        if ( m{^ \s* package \s+ \w[\w\:\']* \s+ (v?[0-9._]+) \s* (;|\{)  }x ) {
            no warnings;
            $result = $1;
        }
        elsif ( m{(?<!\\) ([\$*]) (([\w\:\']*) \bVERSION)\b .* (?<![<>=!])\=[^=]}x ) {
			$result = $self->get_version($parsefile, $1, $2);
        }
        else {
          next;
        }
        last if defined $result;
    }
    close $fh;

    if ( defined $result && $result !~ /^v?[\d_\.]+$/ ) {
      require version;
      my $normal = eval { version->new( $result ) };
      $result = $normal if defined $normal;
    }
    if ( defined $result ) {
      $result = "undef" unless $result =~ m!^v?[\d_\.\-]+$!
                        or eval { version->parse( $result ) };
    }
    $result = "undef" unless defined $result;
    return $result;
}

sub get_version {
    my ($self, $parsefile, $sigil, $name) = @_;
    my $line = $_; # from the while() loop in parse_version
    {
        package ExtUtils::MakeMaker::_version;
        undef *version; # in case of unexpected version() sub
        eval {
            require version;
            version::->import;
        };
        no strict;
        no warnings;
        local *{$name};
        $line = $1 if $line =~ m{^(.+)}s;
        eval($line); ## no critic
        return ${$name};
    }
}

=item pasthru (o)

Defines the string that is passed to recursive make calls in
subdirectories. The variables like C<PASTHRU_DEFINE> are used in each
level, and passed downwards on the command-line with e.g. the value of
that level's DEFINE. Example:

    # Level 0 has DEFINE = -Dfunky
    # This code will define level 0's PASTHRU=PASTHRU_DEFINE="$(DEFINE)
    #     $(PASTHRU_DEFINE)"
    # Level 0's $(CCCMD) will include macros $(DEFINE) and $(PASTHRU_DEFINE)
    # So will level 1's, so when level 1 compiles, it will get right values
    # And so ad infinitum

=cut

sub pasthru {
    my($self) = shift;
    my(@m);

    my(@pasthru);
    my($sep) = $Is{VMS} ? ',' : '';
    $sep .= "\\\n\t";

    foreach my $key (qw(LIB LIBPERL_A LINKTYPE OPTIMIZE
                     PREFIX INSTALL_BASE)
                 )
    {
        next unless defined $self->{$key};
	push @pasthru, "$key=\"\$($key)\"";
    }

    foreach my $key (qw(DEFINE INC)) {
        # default to the make var
        my $val = qq{\$($key)};
        # expand within perl if given since need to use quote_literal
        # since INC might include space-protecting ""!
        chomp($val = $self->{$key}) if defined $self->{$key};
        $val .= " \$(PASTHRU_$key)";
        my $quoted = $self->quote_literal($val);
        push @pasthru, qq{PASTHRU_$key=$quoted};
    }

    push @m, "\nPASTHRU = ", join ($sep, @pasthru), "\n";
    join "", @m;
}

=item perl_script

Takes one argument, a file name, and returns the file name, if the
argument is likely to be a perl script. On MM_Unix this is true for
any ordinary, readable file.

=cut

sub perl_script {
    my($self,$file) = @_;
    return $file if -r $file && -f _;
    return;
}

=item perldepend (o)

Defines the dependency from all *.h files that come with the perl
distribution.

=cut

sub perldepend {
    my($self) = shift;
    my(@m);

    my $make_config = $self->cd('$(PERL_SRC)', '$(MAKE) lib/Config.pm');

    push @m, sprintf <<'MAKE_FRAG', $make_config if $self->{PERL_SRC};
# Check for unpropogated config.sh changes. Should never happen.
# We do NOT just update config.h because that is not sufficient.
# An out of date config.h is not fatal but complains loudly!
$(PERL_INCDEP)/config.h: $(PERL_SRC)/config.sh
	-$(NOECHO) $(ECHO) "Warning: $(PERL_INC)/config.h out of date with $(PERL_SRC)/config.sh"; $(FALSE)

$(PERL_ARCHLIB)/Config.pm: $(PERL_SRC)/config.sh
	$(NOECHO) $(ECHO) "Warning: $(PERL_ARCHLIB)/Config.pm may be out of date with $(PERL_SRC)/config.sh"
	%s
MAKE_FRAG

    return join "", @m unless $self->needs_linking;

    if ($self->{OBJECT}) {
        # Need to add an object file dependency on the perl headers.
        # this is very important for XS modules in perl.git development.
        push @m, $self->_perl_header_files_fragment("/"); # Directory separator between $(PERL_INC)/header.h
    }

    push @m, join(" ", sort values %{$self->{XS}})." : \$(XSUBPPDEPS)\n"  if %{$self->{XS}};

    return join "\n", @m;
}


=item pm_to_blib

Defines target that copies all files in the hash PM to their
destination and autosplits them. See L<ExtUtils::Install/DESCRIPTION>

=cut

sub pm_to_blib {
    my $self = shift;
    my($autodir) = $self->catdir('$(INST_LIB)','auto');
    my $r = q{
pm_to_blib : $(FIRST_MAKEFILE) $(TO_INST_PM)
};

    # VMS will swallow '' and PM_FILTER is often empty.  So use q[]
    my $pm_to_blib = $self->oneliner(<<CODE, ['-MExtUtils::Install']);
pm_to_blib({\@ARGV}, '$autodir', q[\$(PM_FILTER)], '\$(PERM_DIR)')
CODE

    my @cmds = $self->split_command($pm_to_blib,
                  map { ($self->quote_literal($_) => $self->quote_literal($self->{PM}->{$_})) } sort keys %{$self->{PM}});

    $r .= join '', map { "\t\$(NOECHO) $_\n" } @cmds;
    $r .= qq{\t\$(NOECHO) \$(TOUCH) pm_to_blib\n};

    return $r;
}

# transform dot-separated version string into comma-separated quadruple
# examples:  '1.2.3.4.5' => '1,2,3,4'
#            '1.2.3'     => '1,2,3,0'
sub _ppd_version {
    my ($self, $string) = @_;
    return join ',', ((split /\./, $string), (0) x 4)[0..3];
}

=item ppd

Defines target that creates a PPD (Perl Package Description) file
for a binary distribution.

=cut

sub ppd {
    my($self) = @_;

    my $abstract = $self->{ABSTRACT} || '';
    $abstract =~ s/\n/\\n/sg;
    $abstract =~ s/</&lt;/g;
    $abstract =~ s/>/&gt;/g;

    my $author = join(', ',@{ ref $self->{AUTHOR} eq 'ARRAY' ? $self->{AUTHOR} : [ $self->{AUTHOR} || '']});
    $author =~ s/</&lt;/g;
    $author =~ s/>/&gt;/g;

    my $ppd_file = "$self->{DISTNAME}.ppd";

    my @ppd_chunks = qq(<SOFTPKG NAME="$self->{DISTNAME}" VERSION="$self->{VERSION}">\n);

    push @ppd_chunks, sprintf <<'PPD_HTML', $abstract, $author;
    <ABSTRACT>%s</ABSTRACT>
    <AUTHOR>%s</AUTHOR>
PPD_HTML

    push @ppd_chunks, "    <IMPLEMENTATION>\n";
    if ( $self->{MIN_PERL_VERSION} ) {
        my $min_perl_version = $self->_ppd_version($self->{MIN_PERL_VERSION});
        push @ppd_chunks, sprintf <<'PPD_PERLVERS', $min_perl_version;
        <PERLCORE VERSION="%s" />
PPD_PERLVERS

    }

    # Don't add "perl" to requires.  perl dependencies are
    # handles by ARCHITECTURE.
    my %prereqs = %{$self->{PREREQ_PM}};
    delete $prereqs{perl};

    # Build up REQUIRE
    foreach my $prereq (sort keys %prereqs) {
        my $name = $prereq;
        $name .= '::' unless $name =~ /::/;
        my $version = $prereqs{$prereq};

        my %attrs = ( NAME => $name );
        $attrs{VERSION} = $version if $version;
        my $attrs = join " ", map { qq[$_="$attrs{$_}"] } sort keys %attrs;
        push @ppd_chunks, qq(        <REQUIRE $attrs />\n);
    }

    my $archname = $Config{archname};

    # archname did not change from 5.6 to 5.8, but those versions may
    # not be not binary compatible so now we append the part of the
    # version that changes when binary compatibility may change
    if ("$]" >= 5.008) {
        $archname .= "-$Config{api_revision}.$Config{api_version}";
    }
    push @ppd_chunks, sprintf <<'PPD_OUT', $archname;
        <ARCHITECTURE NAME="%s" />
PPD_OUT

    if ($self->{PPM_INSTALL_SCRIPT}) {
        if ($self->{PPM_INSTALL_EXEC}) {
            push @ppd_chunks, sprintf qq{        <INSTALL EXEC="%s">%s</INSTALL>\n},
                  $self->{PPM_INSTALL_EXEC}, $self->{PPM_INSTALL_SCRIPT};
        }
        else {
            push @ppd_chunks, sprintf qq{        <INSTALL>%s</INSTALL>\n},
                  $self->{PPM_INSTALL_SCRIPT};
        }
    }

    if ($self->{PPM_UNINSTALL_SCRIPT}) {
        if ($self->{PPM_UNINSTALL_EXEC}) {
            push @ppd_chunks, sprintf qq{        <UNINSTALL EXEC="%s">%s</UNINSTALL>\n},
                  $self->{PPM_UNINSTALL_EXEC}, $self->{PPM_UNINSTALL_SCRIPT};
        }
        else {
            push @ppd_chunks, sprintf qq{        <UNINSTALL>%s</UNINSTALL>\n},
                  $self->{PPM_UNINSTALL_SCRIPT};
        }
    }

    my ($bin_location) = $self->{BINARY_LOCATION} || '';
    $bin_location =~ s/\\/\\\\/g;

    push @ppd_chunks, sprintf <<'PPD_XML', $bin_location;
        <CODEBASE HREF="%s" />
    </IMPLEMENTATION>
</SOFTPKG>
PPD_XML

    my @ppd_cmds = $self->stashmeta(join('', @ppd_chunks), $ppd_file);

    return sprintf <<'PPD_OUT', join "\n\t", @ppd_cmds;
# Creates a PPD (Perl Package Description) for a binary distribution.
ppd :
	%s
PPD_OUT

}

=item prefixify

  $MM->prefixify($var, $prefix, $new_prefix, $default);

Using either $MM->{uc $var} || $Config{lc $var}, it will attempt to
replace it's $prefix with a $new_prefix.

Should the $prefix fail to match I<AND> a PREFIX was given as an
argument to WriteMakefile() it will set it to the $new_prefix +
$default.  This is for systems whose file layouts don't neatly fit into
our ideas of prefixes.

This is for heuristics which attempt to create directory structures
that mirror those of the installed perl.

For example:

    $MM->prefixify('installman1dir', '/usr', '/home/foo', 'man/man1');

this will attempt to remove '/usr' from the front of the
$MM->{INSTALLMAN1DIR} path (initializing it to $Config{installman1dir}
if necessary) and replace it with '/home/foo'.  If this fails it will
simply use '/home/foo/man/man1'.

=cut

sub prefixify {
    my($self,$var,$sprefix,$rprefix,$default) = @_;

    my $path = $self->{uc $var} ||
               $Config_Override{lc $var} || $Config{lc $var} || '';

    $rprefix .= '/' if $sprefix =~ m|/$|;

    warn "  prefixify $var => $path\n" if $Verbose >= 2;
    warn "    from $sprefix to $rprefix\n" if $Verbose >= 2;

    if( $self->{ARGS}{PREFIX} &&
        $path !~ s{^\Q$sprefix\E\b}{$rprefix}s )
    {

        warn "    cannot prefix, using default.\n" if $Verbose >= 2;
        warn "    no default!\n" if !$default && $Verbose >= 2;

        $path = $self->catdir($rprefix, $default) if $default;
    }

    print "    now $path\n" if $Verbose >= 2;
    return $self->{uc $var} = $path;
}


=item processPL (o)

Defines targets to run *.PL files.

=cut

sub processPL {
    my $self = shift;
    my $pl_files = $self->{PL_FILES};

    return "" unless $pl_files;

    my $m = '';
    foreach my $plfile (sort keys %$pl_files) {
        my $targets = $pl_files->{$plfile};
        my $list =
            ref($targets) eq 'HASH'  ? [ sort keys %$targets ] :
            ref($targets) eq 'ARRAY' ? $pl_files->{$plfile}   :
            [$pl_files->{$plfile}];

        foreach my $target (@$list) {
            if( $Is{VMS} ) {
                $plfile = vmsify($self->eliminate_macros($plfile));
                $target = vmsify($self->eliminate_macros($target));
            }

            # Normally a .PL file runs AFTER pm_to_blib so it can have
            # blib in its @INC and load the just built modules.  BUT if
            # the generated module is something in $(TO_INST_PM) which
            # pm_to_blib depends on then it can't depend on pm_to_blib
            # else we have a dependency loop.
            my $pm_dep;
            my $perlrun;
            if( defined $self->{PM}{$target} ) {
                $pm_dep  = '';
                $perlrun = 'PERLRUN';
            }
            else {
                $pm_dep  = 'pm_to_blib';
                $perlrun = 'PERLRUNINST';
            }

            my $extra_inputs = '';
            if( ref($targets) eq 'HASH' ) {
                my $inputs = ref($targets->{$target})
                    ? $targets->{$target}
                    : [$targets->{$target}];

                for my $input (@$inputs) {
                    if( $Is{VMS} ) {
                        $input = vmsify($self->eliminate_macros($input));
                    }
                    $extra_inputs .= ' '.$input;
                }
            }

            $m .= <<MAKE_FRAG;

pure_all :: $target
	\$(NOECHO) \$(NOOP)

$target :: $plfile $pm_dep $extra_inputs
	\$($perlrun) $plfile $target $extra_inputs
MAKE_FRAG

        }
    }

    return $m;
}

=item specify_shell

Specify SHELL if needed - not done on Unix.

=cut

sub specify_shell {
  return '';
}

=item quote_paren

Backslashes parentheses C<()> in command line arguments.
Doesn't handle recursive Makefile C<$(...)> constructs,
but handles simple ones.

=cut

sub quote_paren {
    my $arg = shift;
    $arg =~ s{\$\((.+?)\)}{\$\\\\($1\\\\)}g;	# protect $(...)
    $arg =~ s{(?<!\\)([()])}{\\$1}g;		# quote unprotected
    $arg =~ s{\$\\\\\((.+?)\\\\\)}{\$($1)}g;	# unprotect $(...)
    return $arg;
}

=item replace_manpage_separator

  my $man_name = $MM->replace_manpage_separator($file_path);

Takes the name of a package, which may be a nested package, in the
form 'Foo/Bar.pm' and replaces the slash with C<::> or something else
safe for a man page file name.  Returns the replacement.

=cut

sub replace_manpage_separator {
    my($self,$man) = @_;

    $man =~ s,/+,::,g;
    return $man;
}


=item cd

=cut

sub cd {
    my($self, $dir, @cmds) = @_;

    # No leading tab and no trailing newline makes for easier embedding
    my $make_frag = join "\n\t", map { "cd $dir && $_" } @cmds;

    return $make_frag;
}

=item oneliner

=cut

sub oneliner {
    my($self, $cmd, $switches) = @_;
    $switches = [] unless defined $switches;

    # Strip leading and trailing newlines
    $cmd =~ s{^\n+}{};
    $cmd =~ s{\n+$}{};

    my @cmds = split /\n/, $cmd;
    $cmd = join " \n\t  -e ", map $self->quote_literal($_), @cmds;
    $cmd = $self->escape_newlines($cmd);

    $switches = join ' ', @$switches;

    return qq{\$(ABSPERLRUN) $switches -e $cmd --};
}


=item quote_literal

Quotes macro literal value suitable for being used on a command line so
that when expanded by make, will be received by command as given to
this method:

  my $quoted = $mm->quote_literal(q{it isn't});
  # returns:
  #   'it isn'\''t'
  print MAKEFILE "target:\n\techo $quoted\n";
  # when run "make target", will output:
  #   it isn't

=cut

sub quote_literal {
    my($self, $text, $opts) = @_;
    $opts->{allow_variables} = 1 unless defined $opts->{allow_variables};

    # Quote single quotes
    $text =~ s{'}{'\\''}g;

    $text = $opts->{allow_variables}
      ? $self->escape_dollarsigns($text) : $self->escape_all_dollarsigns($text);

    return "'$text'";
}


=item escape_newlines

=cut

sub escape_newlines {
    my($self, $text) = @_;

    $text =~ s{\n}{\\\n}g;

    return $text;
}


=item max_exec_len

Using L<POSIX>::ARG_MAX.  Otherwise falling back to 4096.

=cut

sub max_exec_len {
    my $self = shift;

    if (!defined $self->{_MAX_EXEC_LEN}) {
        if (my $arg_max = eval { require POSIX;  &POSIX::ARG_MAX }) {
            $self->{_MAX_EXEC_LEN} = $arg_max;
        }
        else {      # POSIX minimum exec size
            $self->{_MAX_EXEC_LEN} = 4096;
        }
    }

    return $self->{_MAX_EXEC_LEN};
}


=item static (o)

Defines the static target.

=cut

sub static {
# --- Static Loading Sections ---

    my($self) = shift;
    '
## $(INST_PM) has been moved to the all: target.
## It remains here for awhile to allow for old usage: "make static"
static :: $(FIRST_MAKEFILE) $(INST_STATIC)
	$(NOECHO) $(NOOP)
';
}

sub static_lib {
    my($self) = @_;
    return '' unless $self->has_link_code;
    my(@m);
    my @libs;
    if ($self->{XSMULTI}) {
	for my $ext ($self->_xs_list_basenames) {
	    my ($v, $d, $f) = File::Spec->splitpath($ext);
	    my @d = File::Spec->splitdir($d);
	    shift @d if $d[0] eq 'lib';
	    my $instdir = $self->catdir('$(INST_ARCHLIB)', 'auto', @d, $f);
	    my $instfile = $self->catfile($instdir, "$f\$(LIB_EXT)");
	    my $objfile = "$ext\$(OBJ_EXT)";
	    push @libs, [ $objfile, $instfile, $instdir ];
	}
    } else {
	@libs = ([ qw($(OBJECT) $(INST_STATIC) $(INST_ARCHAUTODIR)) ]);
    }
    push @m, map { $self->xs_make_static_lib(@$_); } @libs;
    join "\n", @m;
}

=item xs_make_static_lib

Defines the recipes for the C<static_lib> section.

=cut

sub xs_make_static_lib {
    my ($self, $from, $to, $todir) = @_;
    my @m = sprintf '%s: %s $(MYEXTLIB) %s$(DFSEP).exists'."\n", $to, $from, $todir;
    push @m, "\t\$(RM_F) \"\$\@\"\n";
    push @m, $self->static_lib_fixtures;
    push @m, $self->static_lib_pure_cmd($from);
    push @m, "\t\$(CHMOD) \$(PERM_RWX) \$\@\n";
    push @m, $self->static_lib_closures($todir);
    join '', @m;
}

=item static_lib_closures

Records C<$(EXTRALIBS)> in F<extralibs.ld> and F<$(PERL_SRC)/ext.libs>.

=cut

sub static_lib_closures {
    my ($self, $todir) = @_;
    my @m = sprintf <<'MAKE_FRAG', $todir;
	$(NOECHO) $(ECHO) "$(EXTRALIBS)" > %s$(DFSEP)extralibs.ld
MAKE_FRAG
    # Old mechanism - still available:
    push @m, <<'MAKE_FRAG' if $self->{PERL_SRC} && $self->{EXTRALIBS};
	$(NOECHO) $(ECHO) "$(EXTRALIBS)" >> $(PERL_SRC)$(DFSEP)ext.libs
MAKE_FRAG
    @m;
}

=item static_lib_fixtures

Handles copying C<$(MYEXTLIB)> as starter for final static library that
then gets added to.

=cut

sub static_lib_fixtures {
    my ($self) = @_;
    # If this extension has its own library (eg SDBM_File)
    # then copy that to $(INST_STATIC) and add $(OBJECT) into it.
    return unless $self->{MYEXTLIB};
    "\t\$(CP) \$(MYEXTLIB) \"\$\@\"\n";
}

=item static_lib_pure_cmd

Defines how to run the archive utility.

=cut

sub static_lib_pure_cmd {
    my ($self, $from) = @_;
    my $ar;
    if (exists $self->{FULL_AR} && -x $self->{FULL_AR}) {
        # Prefer the absolute pathed ar if available so that PATH
        # doesn't confuse us.  Perl itself is built with the full_ar.
        $ar = 'FULL_AR';
    } else {
        $ar = 'AR';
    }
    sprintf <<'MAKE_FRAG', $ar, $from;
	$(%s) $(AR_STATIC_ARGS) "$@" %s
	$(RANLIB) "$@"
MAKE_FRAG
}

=item staticmake (o)

Calls makeaperl.

=cut

sub staticmake {
    my($self, %attribs) = @_;
    my(@static);

    my(@searchdirs)=($self->{PERL_ARCHLIB}, $self->{SITEARCHEXP},  $self->{INST_ARCHLIB});

    # And as it's not yet built, we add the current extension
    # but only if it has some C code (or XS code, which implies C code)
    if (@{$self->{C}}) {
	@static = $self->catfile($self->{INST_ARCHLIB},
				 "auto",
				 $self->{FULLEXT},
				 "$self->{BASEEXT}$self->{LIB_EXT}"
				);
    }

    # Either we determine now, which libraries we will produce in the
    # subdirectories or we do it at runtime of the make.

    # We could ask all subdir objects, but I cannot imagine, why it
    # would be necessary.

    # Instead we determine all libraries for the new perl at
    # runtime.
    my(@perlinc) = ($self->{INST_ARCHLIB}, $self->{INST_LIB}, $self->{PERL_ARCHLIB}, $self->{PERL_LIB});

    $self->makeaperl(MAKE	=> $self->{MAKEFILE},
		     DIRS	=> \@searchdirs,
		     STAT	=> \@static,
		     INCL	=> \@perlinc,
		     TARGET	=> $self->{MAP_TARGET},
		     TMP	=> "",
		     LIBPERL	=> $self->{LIBPERL_A}
		    );
}

=item subdir_x (o)

Helper subroutine for subdirs

=cut

sub subdir_x {
    my($self, $subdir) = @_;

    my $subdir_cmd = $self->cd($subdir,
      '$(MAKE) $(USEMAKEFILE) $(FIRST_MAKEFILE) all $(PASTHRU)'
    );
    return sprintf <<'EOT', $subdir_cmd;

subdirs ::
	$(NOECHO) %s
EOT

}

=item subdirs (o)

Defines targets to process subdirectories.

=cut

sub subdirs {
# --- Sub-directory Sections ---
    my($self) = shift;
    my(@m);
    # This method provides a mechanism to automatically deal with
    # subdirectories containing further Makefile.PL scripts.
    # It calls the subdir_x() method for each subdirectory.
    foreach my $dir (@{$self->{DIR}}){
	push @m, $self->subdir_x($dir);
####	print "Including $dir subdirectory\n";
    }
    if (@m){
	unshift @m, <<'EOF';

# The default clean, realclean and test targets in this Makefile
# have automatically been given entries for each subdir.

EOF
    } else {
	push(@m, "\n# none")
    }
    join('',@m);
}

=item test (o)

Defines the test targets.

=cut

sub test {
    my($self, %attribs) = @_;
    my $tests = $attribs{TESTS} || '';
    if (!$tests && -d 't' && defined $attribs{RECURSIVE_TEST_FILES}) {
        $tests = $self->find_tests_recursive;
    }
    elsif (!$tests && -d 't') {
        $tests = $self->find_tests;
    }
    # have to do this because nmake is broken
    $tests =~ s!/!\\!g if $self->is_make_type('nmake');
    # note: 'test.pl' name is also hardcoded in init_dirscan()
    my @m;
    my $default_testtype = $Config{usedl} ? 'dynamic' : 'static';
    push @m, <<EOF;
TEST_VERBOSE=0
TEST_TYPE=test_\$(LINKTYPE)
TEST_FILE = test.pl
TEST_FILES = $tests
TESTDB_SW = -d

testdb :: testdb_\$(LINKTYPE)
	\$(NOECHO) \$(NOOP)

test :: \$(TEST_TYPE)
	\$(NOECHO) \$(NOOP)

# Occasionally we may face this degenerate target:
test_ : test_$default_testtype
	\$(NOECHO) \$(NOOP)

EOF

    for my $linktype (qw(dynamic static)) {
        my $directdeps = join ' ', grep !$self->{SKIPHASH}{$_}, $linktype, "pure_all"; # no depend on a linktype if SKIPped
        push @m, "subdirs-test_$linktype :: $directdeps\n";
        foreach my $dir (@{ $self->{DIR} }) {
            my $test = $self->cd($dir, "\$(MAKE) test_$linktype \$(PASTHRU)");
            push @m, "\t\$(NOECHO) $test\n";
        }
        push @m, "\n";
        if ($tests or -f "test.pl") {
            for my $testspec ([ '', '' ], [ 'db', ' $(TESTDB_SW)' ]) {
                my ($db, $switch) = @$testspec;
                my ($command, $deps);
                # if testdb, build all but don't test all
                $deps = $db eq 'db' ? $directdeps : "subdirs-test_$linktype";
                if ($linktype eq 'static' and $self->needs_linking) {
                    my $target = File::Spec->rel2abs('$(MAP_TARGET)');
                    $command = qq{"$target" \$(MAP_PERLINC)};
                    $deps .= ' $(MAP_TARGET)';
                } else {
                    $command = '$(FULLPERLRUN)' . $switch;
                }
                push @m, "test${db}_$linktype :: $deps\n";
                if ($db eq 'db') {
                    push @m, $self->test_via_script($command, '$(TEST_FILE)')
                } else {
                    push @m, $self->test_via_script($command, '$(TEST_FILE)')
                        if -f "test.pl";
                    push @m, $self->test_via_harness($command, '$(TEST_FILES)')
                        if $tests;
                }
                push @m, "\n";
            }
        } else {
            push @m, _sprintf562 <<'EOF', $linktype;
testdb_%1$s test_%1$s :: subdirs-test_%1$s
	$(NOECHO) $(ECHO) 'No tests defined for $(NAME) extension.'

EOF
        }
    }

    join "", @m;
}

=item test_via_harness (override)

For some reason which I forget, Unix machines like to have
PERL_DL_NONLAZY set for tests.

=cut

sub test_via_harness {
    my($self, $perl, $tests) = @_;
    return $self->SUPER::test_via_harness("PERL_DL_NONLAZY=1 $perl", $tests);
}

=item test_via_script (override)

Again, the PERL_DL_NONLAZY thing.

=cut

sub test_via_script {
    my($self, $perl, $script) = @_;
    return $self->SUPER::test_via_script("PERL_DL_NONLAZY=1 $perl", $script);
}


=item tool_xsubpp (o)

Determines typemaps, xsubpp version, prototype behaviour.

=cut

sub tool_xsubpp {
    my($self) = shift;
    return "" unless $self->needs_linking;

    my $xsdir;
    my @xsubpp_dirs = @INC;

    # Make sure we pick up the new xsubpp if we're building perl.
    unshift @xsubpp_dirs, $self->{PERL_LIB} if $self->{PERL_CORE};

    my $foundxsubpp = 0;
    foreach my $dir (@xsubpp_dirs) {
        $xsdir = $self->catdir($dir, 'ExtUtils');
        if( -r $self->catfile($xsdir, "xsubpp") ) {
            $foundxsubpp = 1;
            last;
        }
    }
    die "ExtUtils::MM_Unix::tool_xsubpp : Can't find xsubpp" if !$foundxsubpp;

    my $tmdir   = $self->catdir($self->{PERL_LIB},"ExtUtils");
    my(@tmdeps) = $self->catfile($tmdir,'typemap');
    if( $self->{TYPEMAPS} ){
        foreach my $typemap (@{$self->{TYPEMAPS}}){
            if( ! -f  $typemap ) {
                warn "Typemap $typemap not found.\n";
            }
            else {
                $typemap = vmsify($typemap) if $Is{VMS};
                push(@tmdeps, $typemap);
            }
        }
    }
    push(@tmdeps, "typemap") if -f "typemap";
    # absolutised because with deep-located typemaps, eg "lib/XS/typemap",
    # if xsubpp is called from top level with
    #     $(XSUBPP) ... -typemap "lib/XS/typemap" "lib/XS/Test.xs"
    # it says:
    #     Can't find lib/XS/type map in (fulldir)/lib/XS
    # because ExtUtils::ParseXS::process_file chdir's to .xs file's
    # location. This is the only way to get all specified typemaps used,
    # wherever located.
    my @tmargs = map { '-typemap '.$self->quote_literal(File::Spec->rel2abs($_)) } @tmdeps;
    $_ = $self->quote_dep($_) for @tmdeps;
    if( exists $self->{XSOPT} ){
        unshift( @tmargs, $self->{XSOPT} );
    }

    if ($Is{VMS}                          &&
        $Config{'ldflags'}               &&
        $Config{'ldflags'} =~ m!/Debug!i &&
        (!exists($self->{XSOPT}) || $self->{XSOPT} !~ /linenumbers/)
       )
    {
        unshift(@tmargs,'-nolinenumbers');
    }


    $self->{XSPROTOARG} = "" unless defined $self->{XSPROTOARG};
    my $xsdirdep = $self->quote_dep($xsdir);
    # -dep for use when dependency not command

    return qq{
XSUBPPDIR = $xsdir
XSUBPP = "\$(XSUBPPDIR)\$(DFSEP)xsubpp"
XSUBPPRUN = \$(PERLRUN) \$(XSUBPP)
XSPROTOARG = $self->{XSPROTOARG}
XSUBPPDEPS = @tmdeps $xsdirdep\$(DFSEP)xsubpp
XSUBPPARGS = @tmargs
XSUBPP_EXTRA_ARGS =
};
}


=item all_target

Build man pages, too

=cut

sub all_target {
    my $self = shift;

    return <<'MAKE_EXT';
all :: pure_all manifypods
	$(NOECHO) $(NOOP)
MAKE_EXT
}

=item top_targets (o)

Defines the targets all, subdirs, config, and O_FILES

=cut

sub top_targets {
# --- Target Sections ---

    my($self) = shift;
    my(@m);

    push @m, $self->all_target, "\n" unless $self->{SKIPHASH}{'all'};

    push @m, sprintf <<'EOF';
pure_all :: config pm_to_blib subdirs linkext
	$(NOECHO) $(NOOP)

subdirs :: $(MYEXTLIB)
	$(NOECHO) $(NOOP)

config :: $(FIRST_MAKEFILE) blibdirs
	$(NOECHO) $(NOOP)
EOF

    push @m, '
$(O_FILES) : $(H_FILES)
' if @{$self->{O_FILES} || []} && @{$self->{H} || []};

    push @m, q{
help :
	perldoc ExtUtils::MakeMaker
};

    join('',@m);
}

=item writedoc

Obsolete, deprecated method. Not used since Version 5.21.

=cut

sub writedoc {
# --- perllocal.pod section ---
    my($self,$what,$name,@attribs)=@_;
    my $time = gmtime($ENV{SOURCE_DATE_EPOCH} || time);
    print "=head2 $time: $what C<$name>\n\n=over 4\n\n=item *\n\n";
    print join "\n\n=item *\n\n", map("C<$_>",@attribs);
    print "\n\n=back\n\n";
}

=item xs_c (o)

Defines the suffix rules to compile XS files to C.

=cut

sub xs_c {
    my($self) = shift;
    return '' unless $self->needs_linking();
    '
.xs.c:
	$(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(XSUBPP_EXTRA_ARGS) $*.xs > $*.xsc
	$(MV) $*.xsc $*.c
';
}

=item xs_cpp (o)

Defines the suffix rules to compile XS files to C++.

=cut

sub xs_cpp {
    my($self) = shift;
    return '' unless $self->needs_linking();
    '
.xs.cpp:
	$(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc
	$(MV) $*.xsc $*.cpp
';
}

=item xs_o (o)

Defines suffix rules to go from XS to object files directly. This was
originally only intended for broken make implementations, but is now
necessary for per-XS file under C<XSMULTI>, since each XS file might
have an individual C<$(VERSION)>.

=cut

sub xs_o {
    my ($self) = @_;
    return '' unless $self->needs_linking();
    my $m_o = $self->{XSMULTI} ? $self->xs_obj_opt('$*$(OBJ_EXT)') : '';
    my $dbgout = $self->dbgoutflag;
    $dbgout = $dbgout ? "$dbgout " : '';
    my $frag = '';
    # dmake makes noise about ambiguous rule
    $frag .= sprintf <<'EOF', $dbgout, $m_o unless $self->is_make_type('dmake');
.xs$(OBJ_EXT) :
	$(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc
	$(MV) $*.xsc $*.c
	$(CCCMD) $(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) $(DEFINE) %s$*.c %s
EOF
    if ($self->{XSMULTI}) {
	for my $ext ($self->_xs_list_basenames) {
	    my $pmfile = "$ext.pm";
	    croak "$ext.xs has no matching $pmfile: $!" unless -f $pmfile;
	    my $version = $self->parse_version($pmfile);
	    my $cccmd = $self->{CONST_CCCMD};
	    $cccmd =~ s/^\s*CCCMD\s*=\s*//;
	    $cccmd =~ s/\$\(DEFINE_VERSION\)/-DVERSION=\\"$version\\"/;
	    $cccmd =~ s/\$\(XS_DEFINE_VERSION\)/-DXS_VERSION=\\"$version\\"/;
            $self->_xsbuild_replace_macro($cccmd, 'xs', $ext, 'INC');
            my $define = '$(DEFINE)';
            $self->_xsbuild_replace_macro($define, 'xs', $ext, 'DEFINE');
            #                             1     2       3     4        5
            $frag .= _sprintf562 <<'EOF', $ext, $cccmd, $m_o, $define, $dbgout;

%1$s$(OBJ_EXT): %1$s.xs
	$(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc
	$(MV) $*.xsc $*.c
	%2$s $(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) %4$s %5$s$*.c %3$s
EOF
	}
    }
    $frag =~ s/"-I(\$\(PERL_INC\))"/-iwithsysroot "$1"/sg if $Is{ApplCor};
    $frag;
}

# param gets modified
sub _xsbuild_replace_macro {
    my ($self, undef, $xstype, $ext, $varname) = @_;
    my $value = $self->_xsbuild_value($xstype, $ext, $varname);
    return unless defined $value;
    $_[1] =~ s/\$\($varname\)/$value/;
}

sub _xsbuild_value {
    my ($self, $xstype, $ext, $varname) = @_;
    return $self->{XSBUILD}{$xstype}{$ext}{$varname}
        if $self->{XSBUILD}{$xstype}{$ext}{$varname};
    return $self->{XSBUILD}{$xstype}{all}{$varname}
        if $self->{XSBUILD}{$xstype}{all}{$varname};
    ();
}

1;

=back

=head1 SEE ALSO

L<ExtUtils::MakeMaker>

=cut

__END__
PK       ! b?o^+  +    perl5/ExtUtils/Mksymlists.pmnu ��6�$        package ExtUtils::Mksymlists;

use 5.006;
use strict qw[ subs refs ];
# no strict 'vars';  # until filehandles are exempted
use warnings;

use Carp;
use Exporter;
use Config;

our @ISA = qw(Exporter);
our @EXPORT = qw(&Mksymlists);
our $VERSION = '7.50';
$VERSION =~ tr/_//d;

sub Mksymlists {
    my(%spec) = @_;
    my($osname) = $^O;

    croak("Insufficient information specified to Mksymlists")
        unless ( $spec{NAME} or
                 ($spec{FILE} and ($spec{DL_FUNCS} or $spec{FUNCLIST})) );

    $spec{DL_VARS} = [] unless $spec{DL_VARS};
    ($spec{FILE} = $spec{NAME}) =~ s/.*::// unless $spec{FILE};
    $spec{FUNCLIST} = [] unless $spec{FUNCLIST};
    $spec{DL_FUNCS} = { $spec{NAME} => [] }
        unless ( ($spec{DL_FUNCS} and keys %{$spec{DL_FUNCS}}) or
                 @{$spec{FUNCLIST}});
    if (defined $spec{DL_FUNCS}) {
        foreach my $package (sort keys %{$spec{DL_FUNCS}}) {
            my($packprefix,$bootseen);
            ($packprefix = $package) =~ s/\W/_/g;
            foreach my $sym (@{$spec{DL_FUNCS}->{$package}}) {
                if ($sym =~ /^boot_/) {
                    push(@{$spec{FUNCLIST}},$sym);
                    $bootseen++;
                }
                else {
                    push(@{$spec{FUNCLIST}},"XS_${packprefix}_$sym");
                }
            }
            push(@{$spec{FUNCLIST}},"boot_$packprefix") unless $bootseen;
        }
    }

#    We'll need this if we ever add any OS which uses mod2fname
#    not as pseudo-builtin.
#    require DynaLoader;
    if (defined &DynaLoader::mod2fname and not $spec{DLBASE}) {
        $spec{DLBASE} = DynaLoader::mod2fname([ split(/::/,$spec{NAME}) ]);
    }

    if    ($osname eq 'aix') { _write_aix(\%spec); }
    elsif ($osname eq 'MacOS'){ _write_aix(\%spec) }
    elsif ($osname eq 'VMS') { _write_vms(\%spec) }
    elsif ($osname eq 'os2') { _write_os2(\%spec) }
    elsif ($osname eq 'MSWin32') { _write_win32(\%spec) }
    else {
        croak("Don't know how to create linker option file for $osname\n");
    }
}


sub _write_aix {
    my($data) = @_;

    rename "$data->{FILE}.exp", "$data->{FILE}.exp_old";

    open( my $exp, ">", "$data->{FILE}.exp")
        or croak("Can't create $data->{FILE}.exp: $!\n");
    print $exp join("\n",@{$data->{DL_VARS}}, "\n") if @{$data->{DL_VARS}};
    print $exp join("\n",@{$data->{FUNCLIST}}, "\n") if @{$data->{FUNCLIST}};
    close $exp;
}


sub _write_os2 {
    my($data) = @_;
    require Config;
    my $threaded = ($Config::Config{archname} =~ /-thread/ ? " threaded" : "");

    if (not $data->{DLBASE}) {
        ($data->{DLBASE} = $data->{NAME}) =~ s/.*:://;
        $data->{DLBASE} = substr($data->{DLBASE},0,7) . '_';
    }
    my $distname = $data->{DISTNAME} || $data->{NAME};
    $distname = "Distribution $distname";
    my $patchlevel = " pl$Config{perl_patchlevel}" || '';
    my $comment = sprintf "Perl (v%s%s%s) module %s",
      $Config::Config{version}, $threaded, $patchlevel, $data->{NAME};
    chomp $comment;
    if ($data->{INSTALLDIRS} and $data->{INSTALLDIRS} eq 'perl') {
        $distname = 'perl5-porters@perl.org';
        $comment = "Core $comment";
    }
    $comment = "$comment (Perl-config: $Config{config_args})";
    $comment = substr($comment, 0, 200) . "...)" if length $comment > 203;
    rename "$data->{FILE}.def", "$data->{FILE}_def.old";

    open(my $def, ">", "$data->{FILE}.def")
        or croak("Can't create $data->{FILE}.def: $!\n");
    print $def "LIBRARY '$data->{DLBASE}' INITINSTANCE TERMINSTANCE\n";
    print $def "DESCRIPTION '\@#$distname:$data->{VERSION}#\@ $comment'\n";
    print $def "CODE LOADONCALL\n";
    print $def "DATA LOADONCALL NONSHARED MULTIPLE\n";
    print $def "EXPORTS\n  ";
    print $def join("\n  ",@{$data->{DL_VARS}}, "\n") if @{$data->{DL_VARS}};
    print $def join("\n  ",@{$data->{FUNCLIST}}, "\n") if @{$data->{FUNCLIST}};
    _print_imports($def, $data);
    close $def;
}

sub _print_imports {
    my ($def, $data)= @_;
    my $imports= $data->{IMPORTS}
        or return;
    if ( keys %$imports ) {
        print $def "IMPORTS\n";
        foreach my $name (sort keys %$imports) {
            print $def "  $name=$imports->{$name}\n";
        }
    }
}

sub _write_win32 {
    my($data) = @_;

    require Config;
    if (not $data->{DLBASE}) {
        ($data->{DLBASE} = $data->{NAME}) =~ s/.*:://;
        $data->{DLBASE} = substr($data->{DLBASE},0,7) . '_';
    }
    rename "$data->{FILE}.def", "$data->{FILE}_def.old";

    open( my $def, ">", "$data->{FILE}.def" )
        or croak("Can't create $data->{FILE}.def: $!\n");
    # put library name in quotes (it could be a keyword, like 'Alias')
    if ($Config::Config{'cc'} !~ /\bgcc/i) {
        print $def "LIBRARY \"$data->{DLBASE}\"\n";
    }
    print $def "EXPORTS\n  ";
    my @syms;
    # Export public symbols both with and without underscores to
    # ensure compatibility between DLLs from Borland C and Visual C
    # NOTE: DynaLoader itself only uses the names without underscores,
    # so this is only to cover the case when the extension DLL may be
    # linked to directly from C. GSAR 97-07-10

    #bcc dropped in 5.16, so dont create useless extra symbols for export table
    unless("$]" >= 5.016) {
        if ($Config::Config{'cc'} =~ /^bcc/i) {
            push @syms, "_$_", "$_ = _$_"
                for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}});
        }
        else {
            push @syms, "$_", "_$_ = $_"
                for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}});
        }
    } else {
        push @syms, "$_"
            for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}});
    }
    print $def join("\n  ",@syms, "\n") if @syms;
    _print_imports($def, $data);
    close $def;
}


sub _write_vms {
    my($data) = @_;

    require Config; # a reminder for once we do $^O
    require ExtUtils::XSSymSet;

    my($isvax) = $Config::Config{'archname'} =~ /VAX/i;
    my($set) = new ExtUtils::XSSymSet;

    rename "$data->{FILE}.opt", "$data->{FILE}.opt_old";

    open(my $opt,">", "$data->{FILE}.opt")
        or croak("Can't create $data->{FILE}.opt: $!\n");

    # Options file declaring universal symbols
    # Used when linking shareable image for dynamic extension,
    # or when linking PerlShr into which we've added this package
    # as a static extension
    # We don't do anything to preserve order, so we won't relax
    # the GSMATCH criteria for a dynamic extension

    print $opt "case_sensitive=yes\n"
        if $Config::Config{d_vms_case_sensitive_symbols};

    foreach my $sym (@{$data->{FUNCLIST}}) {
        my $safe = $set->addsym($sym);
        if ($isvax) { print $opt "UNIVERSAL=$safe\n" }
        else        { print $opt "SYMBOL_VECTOR=($safe=PROCEDURE)\n"; }
    }

    foreach my $sym (@{$data->{DL_VARS}}) {
        my $safe = $set->addsym($sym);
        print $opt "PSECT_ATTR=${sym},PIC,OVR,RD,NOEXE,WRT,NOSHR\n";
        if ($isvax) { print $opt "UNIVERSAL=$safe\n" }
        else        { print $opt "SYMBOL_VECTOR=($safe=DATA)\n"; }
    }

    close $opt;
}

1;

__END__

=head1 NAME

ExtUtils::Mksymlists - write linker options files for dynamic extension

=head1 SYNOPSIS

    use ExtUtils::Mksymlists;
    Mksymlists(  NAME     => $name ,
                 DL_VARS  => [ $var1, $var2, $var3 ],
                 DL_FUNCS => { $pkg1 => [ $func1, $func2 ],
                               $pkg2 => [ $func3 ] );

=head1 DESCRIPTION

C<ExtUtils::Mksymlists> produces files used by the linker under some OSs
during the creation of shared libraries for dynamic extensions.  It is
normally called from a MakeMaker-generated Makefile when the extension
is built.  The linker option file is generated by calling the function
C<Mksymlists>, which is exported by default from C<ExtUtils::Mksymlists>.
It takes one argument, a list of key-value pairs, in which the following
keys are recognized:

=over 4

=item DLBASE

This item specifies the name by which the linker knows the
extension, which may be different from the name of the
extension itself (for instance, some linkers add an '_' to the
name of the extension).  If it is not specified, it is derived
from the NAME attribute.  It is presently used only by OS2 and Win32.

=item DL_FUNCS

This is identical to the DL_FUNCS attribute available via MakeMaker,
from which it is usually taken.  Its value is a reference to an
associative array, in which each key is the name of a package, and
each value is an a reference to an array of function names which
should be exported by the extension.  For instance, one might say
C<DL_FUNCS =E<gt> { Homer::Iliad =E<gt> [ qw(trojans greeks) ],
Homer::Odyssey =E<gt> [ qw(travellers family suitors) ] }>.  The
function names should be identical to those in the XSUB code;
C<Mksymlists> will alter the names written to the linker option
file to match the changes made by F<xsubpp>.  In addition, if
none of the functions in a list begin with the string B<boot_>,
C<Mksymlists> will add a bootstrap function for that package,
just as xsubpp does.  (If a B<boot_E<lt>pkgE<gt>> function is
present in the list, it is passed through unchanged.)  If
DL_FUNCS is not specified, it defaults to the bootstrap
function for the extension specified in NAME.

=item DL_VARS

This is identical to the DL_VARS attribute available via MakeMaker,
and, like DL_FUNCS, it is usually specified via MakeMaker.  Its
value is a reference to an array of variable names which should
be exported by the extension.

=item FILE

This key can be used to specify the name of the linker option file
(minus the OS-specific extension), if for some reason you do not
want to use the default value, which is the last word of the NAME
attribute (I<e.g.> for C<Tk::Canvas>, FILE defaults to C<Canvas>).

=item FUNCLIST

This provides an alternate means to specify function names to be
exported from the extension.  Its value is a reference to an
array of function names to be exported by the extension.  These
names are passed through unaltered to the linker options file.
Specifying a value for the FUNCLIST attribute suppresses automatic
generation of the bootstrap function for the package. To still create
the bootstrap name you have to specify the package name in the
DL_FUNCS hash:

    Mksymlists(  NAME     => $name ,
		 FUNCLIST => [ $func1, $func2 ],
                 DL_FUNCS => { $pkg => [] } );


=item IMPORTS

This attribute is used to specify names to be imported into the
extension. It is currently only used by OS/2 and Win32.

=item NAME

This gives the name of the extension (I<e.g.> C<Tk::Canvas>) for which
the linker option file will be produced.

=back

When calling C<Mksymlists>, one should always specify the NAME
attribute.  In most cases, this is all that's necessary.  In
the case of unusual extensions, however, the other attributes
can be used to provide additional information to the linker.

=head1 AUTHOR

Charles Bailey I<E<lt>bailey@newman.upenn.eduE<gt>>

=head1 REVISION

Last revised 14-Feb-1996, for Perl 5.002.
PK       ! ��S      perl5/ExtUtils/MM_Win95.pmnu ��6�$        package ExtUtils::MM_Win95;

use strict;
use warnings;

our $VERSION = '7.50';
$VERSION =~ tr/_//d;

require ExtUtils::MM_Win32;
our @ISA = qw(ExtUtils::MM_Win32);

use ExtUtils::MakeMaker::Config;


=head1 NAME

ExtUtils::MM_Win95 - method to customize MakeMaker for Win9X

=head1 SYNOPSIS

  You should not be using this module directly.

=head1 DESCRIPTION

This is a subclass of L<ExtUtils::MM_Win32> containing changes necessary
to get MakeMaker playing nice with command.com and other Win9Xisms.

=head2 Overridden methods

Most of these make up for limitations in the Win9x/nmake command shell.

=over 4


=item max_exec_len

Win98 chokes on things like Encode if we set the max length to nmake's max
of 2K.  So we go for a more conservative value of 1K.

=cut

sub max_exec_len {
    my $self = shift;

    return $self->{_MAX_EXEC_LEN} ||= 1024;
}


=item os_flavor

Win95 and Win98 and WinME are collectively Win9x and Win32

=cut

sub os_flavor {
    my $self = shift;
    return ($self->SUPER::os_flavor, 'Win9x');
}


=back


=head1 AUTHOR

Code originally inside MM_Win32.  Original author unknown.

Currently maintained by Michael G Schwern C<schwern@pobox.com>.

Send patches and ideas to C<makemaker@perl.org>.

See https://metacpan.org/release/ExtUtils-MakeMaker.

=cut


1;
PK       ! ^�sX      perl5/ExtUtils/MM_Cygwin.pmnu ��6�$        package ExtUtils::MM_Cygwin;

use strict;
use warnings;

use ExtUtils::MakeMaker::Config;
use File::Spec;

require ExtUtils::MM_Unix;
require ExtUtils::MM_Win32;
our @ISA = qw( ExtUtils::MM_Unix );

our $VERSION = '7.50';
$VERSION =~ tr/_//d;


=head1 NAME

ExtUtils::MM_Cygwin - methods to override UN*X behaviour in ExtUtils::MakeMaker

=head1 SYNOPSIS

 use ExtUtils::MM_Cygwin; # Done internally by ExtUtils::MakeMaker if needed

=head1 DESCRIPTION

See L<ExtUtils::MM_Unix> for a documentation of the methods provided there.

=over 4

=item os_flavor

We're Unix and Cygwin.

=cut

sub os_flavor {
    return('Unix', 'Cygwin');
}

=item cflags

if configured for dynamic loading, triggers #define EXT in EXTERN.h

=cut

sub cflags {
    my($self,$libperl)=@_;
    return $self->{CFLAGS} if $self->{CFLAGS};
    return '' unless $self->needs_linking();

    my $base = $self->SUPER::cflags($libperl);
    foreach (split /\n/, $base) {
        /^(\S*)\s*=\s*(\S*)$/ and $self->{$1} = $2;
    };
    $self->{CCFLAGS} .= " -DUSEIMPORTLIB" if ($Config{useshrplib} eq 'true');

    return $self->{CFLAGS} = qq{
CCFLAGS = $self->{CCFLAGS}
OPTIMIZE = $self->{OPTIMIZE}
PERLTYPE = $self->{PERLTYPE}
};

}


=item replace_manpage_separator

replaces strings '::' with '.' in MAN*POD man page names

=cut

sub replace_manpage_separator {
    my($self, $man) = @_;
    $man =~ s{/+}{.}g;
    return $man;
}

=item init_linker

points to libperl.a

=cut

sub init_linker {
    my $self = shift;

    if ($Config{useshrplib} eq 'true') {
        my $libperl = '$(PERL_INC)' .'/'. "$Config{libperl}";
        if( "$]" >= 5.006002 ) {
            $libperl =~ s/(dll\.)?a$/dll.a/;
        }
        $self->{PERL_ARCHIVE} = $libperl;
    } else {
        $self->{PERL_ARCHIVE} =
          '$(PERL_INC)' .'/'. ("$Config{libperl}" or "libperl.a");
    }

    $self->{PERL_ARCHIVEDEP} ||= '';
    $self->{PERL_ARCHIVE_AFTER} ||= '';
    $self->{EXPORT_LIST}  ||= '';
}

sub init_others {
    my $self = shift;

    $self->SUPER::init_others;

    $self->{LDLOADLIBS} ||= $Config{perllibs};

    return;
}

=item maybe_command

Determine whether a file is native to Cygwin by checking whether it
resides inside the Cygwin installation (using Windows paths). If so,
use L<ExtUtils::MM_Unix> to determine if it may be a command.
Otherwise use the tests from L<ExtUtils::MM_Win32>.

=cut

sub maybe_command {
    my ($self, $file) = @_;

    my $cygpath = Cygwin::posix_to_win_path('/', 1);
    my $filepath = Cygwin::posix_to_win_path($file, 1);

    return (substr($filepath,0,length($cygpath)) eq $cygpath)
    ? $self->SUPER::maybe_command($file) # Unix
    : ExtUtils::MM_Win32->maybe_command($file); # Win32
}

=item dynamic_lib

Use the default to produce the *.dll's.
But for new archdir dll's use the same rebase address if the old exists.

=cut

sub dynamic_lib {
    my($self, %attribs) = @_;
    my $s = ExtUtils::MM_Unix::dynamic_lib($self, %attribs);
    return '' unless $s;
    return $s unless %{$self->{XS}};

    # do an ephemeral rebase so the new DLL fits to the current rebase map
    $s .= "\t/bin/find \$\(INST_ARCHLIB\)/auto -xdev -name \\*.$self->{DLEXT} | /bin/rebase -sOT -" if (( $Config{myarchname} eq 'i686-cygwin' ) and not ( exists $ENV{CYGPORT_PACKAGE_VERSION} ));
    $s;
}

=item install

Rebase dll's with the global rebase database after installation.

=cut

sub install {
    my($self, %attribs) = @_;
    my $s = ExtUtils::MM_Unix::install($self, %attribs);
    return '' unless $s;
    return $s unless %{$self->{XS}};

    my $INSTALLDIRS = $self->{INSTALLDIRS};
    my $INSTALLLIB = $self->{"INSTALL". ($INSTALLDIRS eq 'perl' ? 'ARCHLIB' : uc($INSTALLDIRS)."ARCH")};
    my $dop = "\$\(DESTDIR\)$INSTALLLIB/auto/";
    my $dll = "$dop/$self->{FULLEXT}/$self->{BASEEXT}.$self->{DLEXT}";
    $s =~ s|^(pure_install :: pure_\$\(INSTALLDIRS\)_install\n\t)\$\(NOECHO\) \$\(NOOP\)\n|$1\$(CHMOD) \$(PERM_RWX) $dll\n\t/bin/find $dop -xdev -name \\*.$self->{DLEXT} \| /bin/rebase -sOT -\n|m if (( $Config{myarchname} eq 'i686-cygwin') and not ( exists $ENV{CYGPORT_PACKAGE_VERSION} ));
    $s;
}

=back

=cut

1;
PK       ! 8�A�  �  )  perl5/ExtUtils/MakeMaker/version/regex.pmnu ��6�$        #--------------------------------------------------------------------------#
# This is a modified copy of version.pm 0.9909, bundled exclusively for
# use by ExtUtils::Makemaker and its dependencies to bootstrap when
# version.pm is not available.  It should not be used by ordinary modules.
#--------------------------------------------------------------------------#

package ExtUtils::MakeMaker::version::regex;

use strict;
use warnings;

use vars qw($VERSION $CLASS $STRICT $LAX);

$VERSION = '7.50';
$VERSION =~ tr/_//d;

#--------------------------------------------------------------------------#
# Version regexp components
#--------------------------------------------------------------------------#

# Fraction part of a decimal version number.  This is a common part of
# both strict and lax decimal versions

my $FRACTION_PART = qr/\.[0-9]+/;

# First part of either decimal or dotted-decimal strict version number.
# Unsigned integer with no leading zeroes (except for zero itself) to
# avoid confusion with octal.

my $STRICT_INTEGER_PART = qr/0|[1-9][0-9]*/;

# First part of either decimal or dotted-decimal lax version number.
# Unsigned integer, but allowing leading zeros.  Always interpreted
# as decimal.  However, some forms of the resulting syntax give odd
# results if used as ordinary Perl expressions, due to how perl treats
# octals.  E.g.
#   version->new("010" ) == 10
#   version->new( 010  ) == 8
#   version->new( 010.2) == 82  # "8" . "2"

my $LAX_INTEGER_PART = qr/[0-9]+/;

# Second and subsequent part of a strict dotted-decimal version number.
# Leading zeroes are permitted, and the number is always decimal.
# Limited to three digits to avoid overflow when converting to decimal
# form and also avoid problematic style with excessive leading zeroes.

my $STRICT_DOTTED_DECIMAL_PART = qr/\.[0-9]{1,3}/;

# Second and subsequent part of a lax dotted-decimal version number.
# Leading zeroes are permitted, and the number is always decimal.  No
# limit on the numerical value or number of digits, so there is the
# possibility of overflow when converting to decimal form.

my $LAX_DOTTED_DECIMAL_PART = qr/\.[0-9]+/;

# Alpha suffix part of lax version number syntax.  Acts like a
# dotted-decimal part.

my $LAX_ALPHA_PART = qr/_[0-9]+/;

#--------------------------------------------------------------------------#
# Strict version regexp definitions
#--------------------------------------------------------------------------#

# Strict decimal version number.

my $STRICT_DECIMAL_VERSION =
    qr/ $STRICT_INTEGER_PART $FRACTION_PART? /x;

# Strict dotted-decimal version number.  Must have both leading "v" and
# at least three parts, to avoid confusion with decimal syntax.

my $STRICT_DOTTED_DECIMAL_VERSION =
    qr/ v $STRICT_INTEGER_PART $STRICT_DOTTED_DECIMAL_PART{2,} /x;

# Complete strict version number syntax -- should generally be used
# anchored: qr/ \A $STRICT \z /x

$STRICT =
    qr/ $STRICT_DECIMAL_VERSION | $STRICT_DOTTED_DECIMAL_VERSION /x;

#--------------------------------------------------------------------------#
# Lax version regexp definitions
#--------------------------------------------------------------------------#

# Lax decimal version number.  Just like the strict one except for
# allowing an alpha suffix or allowing a leading or trailing
# decimal-point

my $LAX_DECIMAL_VERSION =
    qr/ $LAX_INTEGER_PART (?: \. | $FRACTION_PART $LAX_ALPHA_PART? )?
	|
	$FRACTION_PART $LAX_ALPHA_PART?
    /x;

# Lax dotted-decimal version number.  Distinguished by having either
# leading "v" or at least three non-alpha parts.  Alpha part is only
# permitted if there are at least two non-alpha parts. Strangely
# enough, without the leading "v", Perl takes .1.2 to mean v0.1.2,
# so when there is no "v", the leading part is optional

my $LAX_DOTTED_DECIMAL_VERSION =
    qr/
	v $LAX_INTEGER_PART (?: $LAX_DOTTED_DECIMAL_PART+ $LAX_ALPHA_PART? )?
	|
	$LAX_INTEGER_PART? $LAX_DOTTED_DECIMAL_PART{2,} $LAX_ALPHA_PART?
    /x;

# Complete lax version number syntax -- should generally be used
# anchored: qr/ \A $LAX \z /x
#
# The string 'undef' is a special case to make for easier handling
# of return values from ExtUtils::MM->parse_version

$LAX =
    qr/ undef | $LAX_DECIMAL_VERSION | $LAX_DOTTED_DECIMAL_VERSION /x;

#--------------------------------------------------------------------------#

# Preloaded methods go here.
sub is_strict	{ defined $_[0] && $_[0] =~ qr/ \A $STRICT \z /x }
sub is_lax	{ defined $_[0] && $_[0] =~ qr/ \A $LAX \z /x }

1;
PK       ! d+�~Z  Z  '  perl5/ExtUtils/MakeMaker/version/vpp.pmnu ��6�$        #--------------------------------------------------------------------------#
# This is a modified copy of version.pm 0.9909, bundled exclusively for
# use by ExtUtils::Makemaker and its dependencies to bootstrap when
# version.pm is not available.  It should not be used by ordinary modules.
#--------------------------------------------------------------------------#

package ExtUtils::MakeMaker::charstar;
# a little helper class to emulate C char* semantics in Perl
# so that prescan_version can use the same code as in C

use overload (
    '""'	=> \&thischar,
    '0+'	=> \&thischar,
    '++'	=> \&increment,
    '--'	=> \&decrement,
    '+'		=> \&plus,
    '-'		=> \&minus,
    '*'		=> \&multiply,
    'cmp'	=> \&cmp,
    '<=>'	=> \&spaceship,
    'bool'	=> \&thischar,
    '='		=> \&clone,
);

sub new {
    my ($self, $string) = @_;
    my $class = ref($self) || $self;

    my $obj = {
	string  => [split(//,$string)],
	current => 0,
    };
    return bless $obj, $class;
}

sub thischar {
    my ($self) = @_;
    my $last = $#{$self->{string}};
    my $curr = $self->{current};
    if ($curr >= 0 && $curr <= $last) {
	return $self->{string}->[$curr];
    }
    else {
	return '';
    }
}

sub increment {
    my ($self) = @_;
    $self->{current}++;
}

sub decrement {
    my ($self) = @_;
    $self->{current}--;
}

sub plus {
    my ($self, $offset) = @_;
    my $rself = $self->clone;
    $rself->{current} += $offset;
    return $rself;
}

sub minus {
    my ($self, $offset) = @_;
    my $rself = $self->clone;
    $rself->{current} -= $offset;
    return $rself;
}

sub multiply {
    my ($left, $right, $swapped) = @_;
    my $char = $left->thischar();
    return $char * $right;
}

sub spaceship {
    my ($left, $right, $swapped) = @_;
    unless (ref($right)) { # not an object already
	$right = $left->new($right);
    }
    return $left->{current} <=> $right->{current};
}

sub cmp {
    my ($left, $right, $swapped) = @_;
    unless (ref($right)) { # not an object already
	if (length($right) == 1) { # comparing single character only
	    return $left->thischar cmp $right;
	}
	$right = $left->new($right);
    }
    return $left->currstr cmp $right->currstr;
}

sub bool {
    my ($self) = @_;
    my $char = $self->thischar;
    return ($char ne '');
}

sub clone {
    my ($left, $right, $swapped) = @_;
    $right = {
	string  => [@{$left->{string}}],
	current => $left->{current},
    };
    return bless $right, ref($left);
}

sub currstr {
    my ($self, $s) = @_;
    my $curr = $self->{current};
    my $last = $#{$self->{string}};
    if (defined($s) && $s->{current} < $last) {
	$last = $s->{current};
    }

    my $string = join('', @{$self->{string}}[$curr..$last]);
    return $string;
}

package ExtUtils::MakeMaker::version::vpp;

use 5.006001;
use strict;
use warnings;

use Config;
use vars qw($VERSION $CLASS @ISA $LAX $STRICT);
$VERSION = '7.50';
$VERSION =~ tr/_//d;
$CLASS = 'ExtUtils::MakeMaker::version::vpp';

require ExtUtils::MakeMaker::version::regex;
*ExtUtils::MakeMaker::version::vpp::is_strict = \&ExtUtils::MakeMaker::version::regex::is_strict;
*ExtUtils::MakeMaker::version::vpp::is_lax = \&ExtUtils::MakeMaker::version::regex::is_lax;
*LAX = \$ExtUtils::MakeMaker::version::regex::LAX;
*STRICT = \$ExtUtils::MakeMaker::version::regex::STRICT;

use overload (
    '""'       => \&stringify,
    '0+'       => \&numify,
    'cmp'      => \&vcmp,
    '<=>'      => \&vcmp,
    'bool'     => \&vbool,
    '+'        => \&vnoop,
    '-'        => \&vnoop,
    '*'        => \&vnoop,
    '/'        => \&vnoop,
    '+='        => \&vnoop,
    '-='        => \&vnoop,
    '*='        => \&vnoop,
    '/='        => \&vnoop,
    'abs'      => \&vnoop,
);

eval "use warnings";
if ($@) {
    eval '
	package
	warnings;
	sub enabled {return $^W;}
	1;
    ';
}

sub import {
    no strict 'refs';
    my ($class) = shift;

    # Set up any derived class
    unless ($class eq $CLASS) {
	no warnings;
	*{$class.'::declare'} =  \&{$CLASS.'::declare'};
	*{$class.'::qv'} = \&{$CLASS.'::qv'};
    }

    my %args;
    if (@_) { # any remaining terms are arguments
	map { $args{$_} = 1 } @_
    }
    else { # no parameters at all on use line
	%args =
	(
	    qv => 1,
	    'UNIVERSAL::VERSION' => 1,
	);
    }

    my $callpkg = caller();

    if (exists($args{declare})) {
	*{$callpkg.'::declare'} =
	    sub {return $class->declare(shift) }
	  unless defined(&{$callpkg.'::declare'});
    }

    if (exists($args{qv})) {
	*{$callpkg.'::qv'} =
	    sub {return $class->qv(shift) }
	  unless defined(&{$callpkg.'::qv'});
    }

    if (exists($args{'UNIVERSAL::VERSION'})) {
	no warnings;
	*UNIVERSAL::VERSION
		= \&{$CLASS.'::_VERSION'};
    }

    if (exists($args{'VERSION'})) {
	*{$callpkg.'::VERSION'} = \&{$CLASS.'::_VERSION'};
    }

    if (exists($args{'is_strict'})) {
	*{$callpkg.'::is_strict'} = \&{$CLASS.'::is_strict'}
	  unless defined(&{$callpkg.'::is_strict'});
    }

    if (exists($args{'is_lax'})) {
	*{$callpkg.'::is_lax'} = \&{$CLASS.'::is_lax'}
	  unless defined(&{$callpkg.'::is_lax'});
    }
}

my $VERSION_MAX = 0x7FFFFFFF;

# implement prescan_version as closely to the C version as possible
use constant TRUE  => 1;
use constant FALSE => 0;

sub isDIGIT {
    my ($char) = shift->thischar();
    return ($char =~ /\d/);
}

sub isALPHA {
    my ($char) = shift->thischar();
    return ($char =~ /[a-zA-Z]/);
}

sub isSPACE {
    my ($char) = shift->thischar();
    return ($char =~ /\s/);
}

sub BADVERSION {
    my ($s, $errstr, $error) = @_;
    if ($errstr) {
	$$errstr = $error;
    }
    return $s;
}

sub prescan_version {
    my ($s, $strict, $errstr, $sqv, $ssaw_decimal, $swidth, $salpha) = @_;
    my $qv          = defined $sqv          ? $$sqv          : FALSE;
    my $saw_decimal = defined $ssaw_decimal ? $$ssaw_decimal : 0;
    my $width       = defined $swidth       ? $$swidth       : 3;
    my $alpha       = defined $salpha       ? $$salpha       : FALSE;

    my $d = $s;

    if ($qv && isDIGIT($d)) {
	goto dotted_decimal_version;
    }

    if ($d eq 'v') { # explicit v-string
	$d++;
	if (isDIGIT($d)) {
	    $qv = TRUE;
	}
	else { # degenerate v-string
	    # requires v1.2.3
	    return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
	}

dotted_decimal_version:
	if ($strict && $d eq '0' && isDIGIT($d+1)) {
	    # no leading zeros allowed
	    return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)");
	}

	while (isDIGIT($d)) { 	# integer part
	    $d++;
	}

	if ($d eq '.')
	{
	    $saw_decimal++;
	    $d++; 		# decimal point
	}
	else
	{
	    if ($strict) {
		# require v1.2.3
		return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
	    }
	    else {
		goto version_prescan_finish;
	    }
	}

	{
	    my $i = 0;
	    my $j = 0;
	    while (isDIGIT($d)) {	# just keep reading
		$i++;
		while (isDIGIT($d)) {
		    $d++; $j++;
		    # maximum 3 digits between decimal
		    if ($strict && $j > 3) {
			return BADVERSION($s,$errstr,"Invalid version format (maximum 3 digits between decimals)");
		    }
		}
		if ($d eq '_') {
		    if ($strict) {
			return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
		    }
		    if ( $alpha ) {
			return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)");
		    }
		    $d++;
		    $alpha = TRUE;
		}
		elsif ($d eq '.') {
		    if ($alpha) {
			return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)");
		    }
		    $saw_decimal++;
		    $d++;
		}
		elsif (!isDIGIT($d)) {
		    last;
		}
		$j = 0;
	    }

	    if ($strict && $i < 2) {
		# requires v1.2.3
		return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
	    }
	}
    } 					# end if dotted-decimal
    else
    {					# decimal versions
	my $j = 0;
	# special $strict case for leading '.' or '0'
	if ($strict) {
	    if ($d eq '.') {
		return BADVERSION($s,$errstr,"Invalid version format (0 before decimal required)");
	    }
	    if ($d eq '0' && isDIGIT($d+1)) {
		return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)");
	    }
	}

	# and we never support negative version numbers
	if ($d eq '-') {
	    return BADVERSION($s,$errstr,"Invalid version format (negative version number)");
	}

	# consume all of the integer part
	while (isDIGIT($d)) {
	    $d++;
	}

	# look for a fractional part
	if ($d eq '.') {
	    # we found it, so consume it
	    $saw_decimal++;
	    $d++;
	}
	elsif (!$d || $d eq ';' || isSPACE($d) || $d eq '}') {
	    if ( $d == $s ) {
		# found nothing
		return BADVERSION($s,$errstr,"Invalid version format (version required)");
	    }
	    # found just an integer
	    goto version_prescan_finish;
	}
	elsif ( $d == $s ) {
	    # didn't find either integer or period
	    return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
	}
	elsif ($d eq '_') {
	    # underscore can't come after integer part
	    if ($strict) {
		return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
	    }
	    elsif (isDIGIT($d+1)) {
		return BADVERSION($s,$errstr,"Invalid version format (alpha without decimal)");
	    }
	    else {
		return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)");
	    }
	}
	elsif ($d) {
	    # anything else after integer part is just invalid data
	    return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
	}

	# scan the fractional part after the decimal point
	if ($d && !isDIGIT($d) && ($strict || ! ($d eq ';' || isSPACE($d) || $d eq '}') )) {
		# $strict or lax-but-not-the-end
		return BADVERSION($s,$errstr,"Invalid version format (fractional part required)");
	}

	while (isDIGIT($d)) {
	    $d++; $j++;
	    if ($d eq '.' && isDIGIT($d-1)) {
		if ($alpha) {
		    return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)");
		}
		if ($strict) {
		    return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
		}
		$d = $s; # start all over again
		$qv = TRUE;
		goto dotted_decimal_version;
	    }
	    if ($d eq '_') {
		if ($strict) {
		    return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
		}
		if ( $alpha ) {
		    return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)");
		}
		if ( ! isDIGIT($d+1) ) {
		    return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)");
		}
		$width = $j;
		$d++;
		$alpha = TRUE;
	    }
	}
    }

version_prescan_finish:
    while (isSPACE($d)) {
	$d++;
    }

    if ($d && !isDIGIT($d) && (! ($d eq ';' || $d eq '}') )) {
	# trailing non-numeric data
	return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
    }

    if (defined $sqv) {
	$$sqv = $qv;
    }
    if (defined $swidth) {
	$$swidth = $width;
    }
    if (defined $ssaw_decimal) {
	$$ssaw_decimal = $saw_decimal;
    }
    if (defined $salpha) {
	$$salpha = $alpha;
    }
    return $d;
}

sub scan_version {
    my ($s, $rv, $qv) = @_;
    my $start;
    my $pos;
    my $last;
    my $errstr;
    my $saw_decimal = 0;
    my $width = 3;
    my $alpha = FALSE;
    my $vinf = FALSE;
    my @av;

    $s = new ExtUtils::MakeMaker::charstar $s;

    while (isSPACE($s)) { # leading whitespace is OK
	$s++;
    }

    $last = prescan_version($s, FALSE, \$errstr, \$qv, \$saw_decimal,
	\$width, \$alpha);

    if ($errstr) {
	# 'undef' is a special case and not an error
	if ( $s ne 'undef') {
	    require Carp;
	    Carp::croak($errstr);
	}
    }

    $start = $s;
    if ($s eq 'v') {
	$s++;
    }
    $pos = $s;

    if ( $qv ) {
	$$rv->{qv} = $qv;
    }
    if ( $alpha ) {
	$$rv->{alpha} = $alpha;
    }
    if ( !$qv && $width < 3 ) {
	$$rv->{width} = $width;
    }

    while (isDIGIT($pos)) {
	$pos++;
    }
    if (!isALPHA($pos)) {
	my $rev;

	for (;;) {
	    $rev = 0;
	    {
  		# this is atoi() that delimits on underscores
  		my $end = $pos;
  		my $mult = 1;
		my $orev;

		#  the following if() will only be true after the decimal
		#  point of a version originally created with a bare
		#  floating point number, i.e. not quoted in any way
		#
 		if ( !$qv && $s > $start && $saw_decimal == 1 ) {
		    $mult *= 100;
 		    while ( $s < $end ) {
			$orev = $rev;
 			$rev += $s * $mult;
 			$mult /= 10;
			if (   (abs($orev) > abs($rev))
			    || (abs($rev) > $VERSION_MAX )) {
			    warn("Integer overflow in version %d",
					   $VERSION_MAX);
			    $s = $end - 1;
			    $rev = $VERSION_MAX;
			    $vinf = 1;
			}
 			$s++;
			if ( $s eq '_' ) {
			    $s++;
			}
 		    }
  		}
 		else {
 		    while (--$end >= $s) {
			$orev = $rev;
 			$rev += $end * $mult;
 			$mult *= 10;
			if (   (abs($orev) > abs($rev))
			    || (abs($rev) > $VERSION_MAX )) {
			    warn("Integer overflow in version");
			    $end = $s - 1;
			    $rev = $VERSION_MAX;
			    $vinf = 1;
			}
 		    }
 		}
  	    }

  	    # Append revision
	    push @av, $rev;
	    if ( $vinf ) {
		$s = $last;
		last;
	    }
	    elsif ( $pos eq '.' ) {
		$s = ++$pos;
	    }
	    elsif ( $pos eq '_' && isDIGIT($pos+1) ) {
		$s = ++$pos;
	    }
	    elsif ( $pos eq ',' && isDIGIT($pos+1) ) {
		$s = ++$pos;
	    }
	    elsif ( isDIGIT($pos) ) {
		$s = $pos;
	    }
	    else {
		$s = $pos;
		last;
	    }
	    if ( $qv ) {
		while ( isDIGIT($pos) ) {
		    $pos++;
		}
	    }
	    else {
		my $digits = 0;
		while ( ( isDIGIT($pos) || $pos eq '_' ) && $digits < 3 ) {
		    if ( $pos ne '_' ) {
			$digits++;
		    }
		    $pos++;
		}
	    }
	}
    }
    if ( $qv ) { # quoted versions always get at least three terms
	my $len = $#av;
	#  This for loop appears to trigger a compiler bug on OS X, as it
	#  loops infinitely. Yes, len is negative. No, it makes no sense.
	#  Compiler in question is:
	#  gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
	#  for ( len = 2 - len; len > 0; len-- )
	#  av_push(MUTABLE_AV(sv), newSViv(0));
	#
	$len = 2 - $len;
	while ($len-- > 0) {
	    push @av, 0;
	}
    }

    # need to save off the current version string for later
    if ( $vinf ) {
	$$rv->{original} = "v.Inf";
	$$rv->{vinf} = 1;
    }
    elsif ( $s > $start ) {
	$$rv->{original} = $start->currstr($s);
	if ( $qv && $saw_decimal == 1 && $start ne 'v' ) {
	    # need to insert a v to be consistent
	    $$rv->{original} = 'v' . $$rv->{original};
	}
    }
    else {
	$$rv->{original} = '0';
	push(@av, 0);
    }

    # And finally, store the AV in the hash
    $$rv->{version} = \@av;

    # fix RT#19517 - special case 'undef' as string
    if ($s eq 'undef') {
	$s += 5;
    }

    return $s;
}

sub new {
    my $class = shift;
    unless (defined $class or $#_ > 1) {
	require Carp;
	Carp::croak('Usage: version::new(class, version)');
    }

    my $self = bless ({}, ref ($class) || $class);
    my $qv = FALSE;

    if ( $#_ == 1 ) { # must be CVS-style
	$qv = TRUE;
    }
    my $value = pop; # always going to be the last element

    if ( ref($value) && eval('$value->isa("version")') ) {
	# Can copy the elements directly
	$self->{version} = [ @{$value->{version} } ];
	$self->{qv} = 1 if $value->{qv};
	$self->{alpha} = 1 if $value->{alpha};
	$self->{original} = ''.$value->{original};
	return $self;
    }

    if ( not defined $value or $value =~ /^undef$/ ) {
	# RT #19517 - special case for undef comparison
	# or someone forgot to pass a value
	push @{$self->{version}}, 0;
	$self->{original} = "0";
	return ($self);
    }


    if (ref($value) =~ m/ARRAY|HASH/) {
	require Carp;
	Carp::croak("Invalid version format (non-numeric data)");
    }

    $value = _un_vstring($value);

    if ($Config{d_setlocale} && eval { require POSIX } ) {
      require locale;
	my $currlocale = POSIX::setlocale(&POSIX::LC_ALL);

	# if the current locale uses commas for decimal points, we
	# just replace commas with decimal places, rather than changing
	# locales
	if ( POSIX::localeconv()->{decimal_point} eq ',' ) {
	    $value =~ tr/,/./;
	}
    }

    # exponential notation
    if ( $value =~ /\d+.?\d*e[-+]?\d+/ ) {
	$value = sprintf("%.9f",$value);
	$value =~ s/(0+)$//; # trim trailing zeros
    }

    my $s = scan_version($value, \$self, $qv);

    if ($s) { # must be something left over
	warn("Version string '%s' contains invalid data; "
		   ."ignoring: '%s'", $value, $s);
    }

    return ($self);
}

*parse = \&new;

sub numify {
    my ($self) = @_;
    unless (_verify($self)) {
	require Carp;
	Carp::croak("Invalid version object");
    }
    my $width = $self->{width} || 3;
    my $alpha = $self->{alpha} || "";
    my $len = $#{$self->{version}};
    my $digit = $self->{version}[0];
    my $string = sprintf("%d.", $digit );

    for ( my $i = 1 ; $i < $len ; $i++ ) {
	$digit = $self->{version}[$i];
	if ( $width < 3 ) {
	    my $denom = 10**(3-$width);
	    my $quot = int($digit/$denom);
	    my $rem = $digit - ($quot * $denom);
	    $string .= sprintf("%0".$width."d_%d", $quot, $rem);
	}
	else {
	    $string .= sprintf("%03d", $digit);
	}
    }

    if ( $len > 0 ) {
	$digit = $self->{version}[$len];
	if ( $alpha && $width == 3 ) {
	    $string .= "_";
	}
	$string .= sprintf("%0".$width."d", $digit);
    }
    else # $len = 0
    {
	$string .= sprintf("000");
    }

    return $string;
}

sub normal {
    my ($self) = @_;
    unless (_verify($self)) {
	require Carp;
	Carp::croak("Invalid version object");
    }
    my $alpha = $self->{alpha} || "";
    my $len = $#{$self->{version}};
    my $digit = $self->{version}[0];
    my $string = sprintf("v%d", $digit );

    for ( my $i = 1 ; $i < $len ; $i++ ) {
	$digit = $self->{version}[$i];
	$string .= sprintf(".%d", $digit);
    }

    if ( $len > 0 ) {
	$digit = $self->{version}[$len];
	if ( $alpha ) {
	    $string .= sprintf("_%0d", $digit);
	}
	else {
	    $string .= sprintf(".%0d", $digit);
	}
    }

    if ( $len <= 2 ) {
	for ( $len = 2 - $len; $len != 0; $len-- ) {
	    $string .= sprintf(".%0d", 0);
	}
    }

    return $string;
}

sub stringify {
    my ($self) = @_;
    unless (_verify($self)) {
	require Carp;
	Carp::croak("Invalid version object");
    }
    return exists $self->{original}
    	? $self->{original}
	: exists $self->{qv}
	    ? $self->normal
	    : $self->numify;
}

sub vcmp {
    require UNIVERSAL;
    my ($left,$right,$swap) = @_;
    my $class = ref($left);
    unless ( UNIVERSAL::isa($right, $class) ) {
	$right = $class->new($right);
    }

    if ( $swap ) {
	($left, $right) = ($right, $left);
    }
    unless (_verify($left)) {
	require Carp;
	Carp::croak("Invalid version object");
    }
    unless (_verify($right)) {
	require Carp;
	Carp::croak("Invalid version format");
    }
    my $l = $#{$left->{version}};
    my $r = $#{$right->{version}};
    my $m = $l < $r ? $l : $r;
    my $lalpha = $left->is_alpha;
    my $ralpha = $right->is_alpha;
    my $retval = 0;
    my $i = 0;
    while ( $i <= $m && $retval == 0 ) {
	$retval = $left->{version}[$i] <=> $right->{version}[$i];
	$i++;
    }

    # tiebreaker for alpha with identical terms
    if ( $retval == 0
	&& $l == $r
	&& $left->{version}[$m] == $right->{version}[$m]
	&& ( $lalpha || $ralpha ) ) {

	if ( $lalpha && !$ralpha ) {
	    $retval = -1;
	}
	elsif ( $ralpha && !$lalpha) {
	    $retval = +1;
	}
    }

    # possible match except for trailing 0's
    if ( $retval == 0 && $l != $r ) {
	if ( $l < $r ) {
	    while ( $i <= $r && $retval == 0 ) {
		if ( $right->{version}[$i] != 0 ) {
		    $retval = -1; # not a match after all
		}
		$i++;
	    }
	}
	else {
	    while ( $i <= $l && $retval == 0 ) {
		if ( $left->{version}[$i] != 0 ) {
		    $retval = +1; # not a match after all
		}
		$i++;
	    }
	}
    }

    return $retval;
}

sub vbool {
    my ($self) = @_;
    return vcmp($self,$self->new("0"),1);
}

sub vnoop {
    require Carp;
    Carp::croak("operation not supported with version object");
}

sub is_alpha {
    my ($self) = @_;
    return (exists $self->{alpha});
}

sub qv {
    my $value = shift;
    my $class = $CLASS;
    if (@_) {
	$class = ref($value) || $value;
	$value = shift;
    }

    $value = _un_vstring($value);
    $value = 'v'.$value unless $value =~ /(^v|\d+\.\d+\.\d)/;
    my $obj = $CLASS->new($value);
    return bless $obj, $class;
}

*declare = \&qv;

sub is_qv {
    my ($self) = @_;
    return (exists $self->{qv});
}


sub _verify {
    my ($self) = @_;
    if ( ref($self)
	&& eval { exists $self->{version} }
	&& ref($self->{version}) eq 'ARRAY'
	) {
	return 1;
    }
    else {
	return 0;
    }
}

sub _is_non_alphanumeric {
    my $s = shift;
    $s = new ExtUtils::MakeMaker::charstar $s;
    while ($s) {
	return 0 if isSPACE($s); # early out
	return 1 unless (isALPHA($s) || isDIGIT($s) || $s =~ /[.-]/);
	$s++;
    }
    return 0;
}

sub _un_vstring {
    my $value = shift;
    # may be a v-string
    if ( length($value) >= 3 && $value !~ /[._]/
	&& _is_non_alphanumeric($value)) {
	my $tvalue;
	if ( "$]" >= 5.008_001 ) {
	    $tvalue = _find_magic_vstring($value);
	    $value = $tvalue if length $tvalue;
	}
	elsif ( "$]" >= 5.006_000 ) {
	    $tvalue = sprintf("v%vd",$value);
	    if ( $tvalue =~ /^v\d+(\.\d+){2,}$/ ) {
		# must be a v-string
		$value = $tvalue;
	    }
	}
    }
    return $value;
}

sub _find_magic_vstring {
    my $value = shift;
    my $tvalue = '';
    require B;
    my $sv = B::svref_2object(\$value);
    my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef;
    while ( $magic ) {
	if ( $magic->TYPE eq 'V' ) {
	    $tvalue = $magic->PTR;
	    $tvalue =~ s/^v?(.+)$/v$1/;
	    last;
	}
	else {
	    $magic = $magic->MOREMAGIC;
	}
    }
    return $tvalue;
}

sub _VERSION {
    my ($obj, $req) = @_;
    my $class = ref($obj) || $obj;

    no strict 'refs';
    if ( exists $INC{"$class.pm"} and not %{"$class\::"} and "$]" >= 5.008) {
	 # file but no package
	require Carp;
	Carp::croak( "$class defines neither package nor VERSION"
	    ."--version check failed");
    }

    my $version = eval "\$$class\::VERSION";
    if ( defined $version ) {
	local $^W if "$]" <= 5.008;
	$version = ExtUtils::MakeMaker::version::vpp->new($version);
    }

    if ( defined $req ) {
	unless ( defined $version ) {
	    require Carp;
	    my $msg = "$]" < 5.006
	    ? "$class version $req required--this is only version "
	    : "$class does not define \$$class\::VERSION"
	      ."--version check failed";

	    if ( $ENV{VERSION_DEBUG} ) {
		Carp::confess($msg);
	    }
	    else {
		Carp::croak($msg);
	    }
	}

	$req = ExtUtils::MakeMaker::version::vpp->new($req);

	if ( $req > $version ) {
	    require Carp;
	    if ( $req->is_qv ) {
		Carp::croak(
		    sprintf ("%s version %s required--".
			"this is only version %s", $class,
			$req->normal, $version->normal)
		);
	    }
	    else {
		Carp::croak(
		    sprintf ("%s version %s required--".
			"this is only version %s", $class,
			$req->stringify, $version->stringify)
		);
	    }
	}
    }

    return defined $version ? $version->stringify : undef;
}

1; #this line is important and will help the module return a true value
PK       ! �E�$4  $4  "  perl5/ExtUtils/MakeMaker/Locale.pmnu ��6�$        package ExtUtils::MakeMaker::Locale;

use strict;
use warnings;
our $VERSION = "7.50";
$VERSION =~ tr/_//d;

use base 'Exporter';
our @EXPORT_OK = qw(
    decode_argv env
    $ENCODING_LOCALE $ENCODING_LOCALE_FS
    $ENCODING_CONSOLE_IN $ENCODING_CONSOLE_OUT
);

use Encode ();
use Encode::Alias ();

our $ENCODING_LOCALE;
our $ENCODING_LOCALE_FS;
our $ENCODING_CONSOLE_IN;
our $ENCODING_CONSOLE_OUT;

sub DEBUG () { 0 }

sub _init {
    if ($^O eq "MSWin32") {
	unless ($ENCODING_LOCALE) {
	    # Try to obtain what the Windows ANSI code page is
	    eval {
		unless (defined &GetConsoleCP) {
		    require Win32;
                    # manually "import" it since Win32->import refuses
		    *GetConsoleCP = sub { &Win32::GetConsoleCP } if defined &Win32::GetConsoleCP;
		}
		unless (defined &GetConsoleCP) {
		    require Win32::API;
		    Win32::API->Import('kernel32', 'int GetConsoleCP()');
		}
		if (defined &GetConsoleCP) {
		    my $cp = GetConsoleCP();
		    $ENCODING_LOCALE = "cp$cp" if $cp;
		}
	    };
	}

	unless ($ENCODING_CONSOLE_IN) {
            # only test one since set together
            unless (defined &GetInputCP) {
                eval {
                    require Win32;
                    eval {
                        local $SIG{__WARN__} = sub {} if ( "$]" < 5.014 ); # suppress deprecation warning for inherited AUTOLOAD of Win32::GetConsoleCP()
                        Win32::GetConsoleCP();
                    };
                    # manually "import" it since Win32->import refuses
                    *GetInputCP = sub { &Win32::GetConsoleCP } if defined &Win32::GetConsoleCP;
                    *GetOutputCP = sub { &Win32::GetConsoleOutputCP } if defined &Win32::GetConsoleOutputCP;
                };
                unless (defined &GetInputCP) {
                    eval {
                        # try Win32::Console module for codepage to use
                        require Win32::Console;
                        *GetInputCP = sub { &Win32::Console::InputCP }
                            if defined &Win32::Console::InputCP;
                        *GetOutputCP = sub { &Win32::Console::OutputCP }
                            if defined &Win32::Console::OutputCP;
                    };
                }
                unless (defined &GetInputCP) {
                    # final fallback
                    *GetInputCP = *GetOutputCP = sub {
                        # another fallback that could work is:
                        # reg query HKLM\System\CurrentControlSet\Control\Nls\CodePage /v ACP
                        ((qx(chcp) || '') =~ /^Active code page: (\d+)/)
                            ? $1 : ();
                    };
                }
	    }
            my $cp = GetInputCP();
            $ENCODING_CONSOLE_IN = "cp$cp" if $cp;
            $cp = GetOutputCP();
            $ENCODING_CONSOLE_OUT = "cp$cp" if $cp;
	}
    }

    unless ($ENCODING_LOCALE) {
	eval {
	    require I18N::Langinfo;
	    $ENCODING_LOCALE = I18N::Langinfo::langinfo(I18N::Langinfo::CODESET());

	    # Workaround of Encode < v2.25.  The "646" encoding  alias was
	    # introduced in Encode-2.25, but we don't want to require that version
	    # quite yet.  Should avoid the CPAN testers failure reported from
	    # openbsd-4.7/perl-5.10.0 combo.
	    $ENCODING_LOCALE = "ascii" if $ENCODING_LOCALE eq "646";

	    # https://rt.cpan.org/Ticket/Display.html?id=66373
	    $ENCODING_LOCALE = "hp-roman8" if $^O eq "hpux" && $ENCODING_LOCALE eq "roman8";
	};
	$ENCODING_LOCALE ||= $ENCODING_CONSOLE_IN;
    }

    # Workaround of Encode < v2.71 for "cp65000" and "cp65001"
    # The "cp65000" and "cp65001" aliases were added in [Encode v2.71](https://github.com/dankogai/p5-encode/commit/7874bd95aa10967a3b5dbae333d16bcd703ac6c6)
    # via commit <https://github.com/dankogai/p5-encode/commit/84b9c1101d5251d37e226f80d1c6781718779047>.
    # This will avoid test failures for Win32 machines using the UTF-7 or UTF-8 code pages.
    $ENCODING_LOCALE = 'UTF-7' if $ENCODING_LOCALE && lc($ENCODING_LOCALE) eq "cp65000";
    $ENCODING_LOCALE = 'utf-8-strict' if $ENCODING_LOCALE && lc($ENCODING_LOCALE) eq "cp65001";

    if ($^O eq "darwin") {
	$ENCODING_LOCALE_FS ||= "UTF-8";
    }

    # final fallback
    $ENCODING_LOCALE ||= $^O eq "MSWin32" ? "cp1252" : "UTF-8";
    $ENCODING_LOCALE_FS ||= $ENCODING_LOCALE;
    $ENCODING_CONSOLE_IN ||= $ENCODING_LOCALE;
    $ENCODING_CONSOLE_OUT ||= $ENCODING_CONSOLE_IN;

    unless (Encode::find_encoding($ENCODING_LOCALE)) {
	my $foundit;
	if (lc($ENCODING_LOCALE) eq "gb18030") {
	    eval {
		require Encode::HanExtra;
	    };
	    if ($@) {
		die "Need Encode::HanExtra to be installed to support locale codeset ($ENCODING_LOCALE), stopped";
	    }
	    $foundit++ if Encode::find_encoding($ENCODING_LOCALE);
	}
	die "The locale codeset ($ENCODING_LOCALE) isn't one that perl can decode, stopped"
	    unless $foundit;

    }

    # use Data::Dump; ddx $ENCODING_LOCALE, $ENCODING_LOCALE_FS, $ENCODING_CONSOLE_IN, $ENCODING_CONSOLE_OUT;
}

_init();
Encode::Alias::define_alias(sub {
    no strict 'refs';
    no warnings 'once';
    return ${"ENCODING_" . uc(shift)};
}, "locale");

sub _flush_aliases {
    no strict 'refs';
    for my $a (sort keys %Encode::Alias::Alias) {
	if (defined ${"ENCODING_" . uc($a)}) {
	    delete $Encode::Alias::Alias{$a};
	    warn "Flushed alias cache for $a" if DEBUG;
	}
    }
}

sub reinit {
    $ENCODING_LOCALE = shift;
    $ENCODING_LOCALE_FS = shift;
    $ENCODING_CONSOLE_IN = $ENCODING_LOCALE;
    $ENCODING_CONSOLE_OUT = $ENCODING_LOCALE;
    _init();
    _flush_aliases();
}

sub decode_argv {
    die if defined wantarray;
    for (@ARGV) {
	$_ = Encode::decode(locale => $_, @_);
    }
}

sub env {
    my $k = Encode::encode(locale => shift);
    my $old = $ENV{$k};
    if (@_) {
	my $v = shift;
	if (defined $v) {
	    $ENV{$k} = Encode::encode(locale => $v);
	}
	else {
	    delete $ENV{$k};
	}
    }
    return Encode::decode(locale => $old) if defined wantarray;
}

1;

__END__

=head1 NAME

ExtUtils::MakeMaker::Locale - bundled Encode::Locale

=head1 SYNOPSIS

  use Encode::Locale;
  use Encode;

  $string = decode(locale => $bytes);
  $bytes = encode(locale => $string);

  if (-t) {
      binmode(STDIN, ":encoding(console_in)");
      binmode(STDOUT, ":encoding(console_out)");
      binmode(STDERR, ":encoding(console_out)");
  }

  # Processing file names passed in as arguments
  my $uni_filename = decode(locale => $ARGV[0]);
  open(my $fh, "<", encode(locale_fs => $uni_filename))
     || die "Can't open '$uni_filename': $!";
  binmode($fh, ":encoding(locale)");
  ...

=head1 DESCRIPTION

In many applications it's wise to let Perl use Unicode for the strings it
processes.  Most of the interfaces Perl has to the outside world are still byte
based.  Programs therefore need to decode byte strings that enter the program
from the outside and encode them again on the way out.

The POSIX locale system is used to specify both the language conventions
requested by the user and the preferred character set to consume and
output.  The C<Encode::Locale> module looks up the charset and encoding (called
a CODESET in the locale jargon) and arranges for the L<Encode> module to know
this encoding under the name "locale".  It means bytes obtained from the
environment can be converted to Unicode strings by calling C<<
Encode::encode(locale => $bytes) >> and converted back again with C<<
Encode::decode(locale => $string) >>.

Where file systems interfaces pass file names in and out of the program we also
need care.  The trend is for operating systems to use a fixed file encoding
that don't actually depend on the locale; and this module determines the most
appropriate encoding for file names. The L<Encode> module will know this
encoding under the name "locale_fs".  For traditional Unix systems this will
be an alias to the same encoding as "locale".

For programs running in a terminal window (called a "Console" on some systems)
the "locale" encoding is usually a good choice for what to expect as input and
output.  Some systems allows us to query the encoding set for the terminal and
C<Encode::Locale> will do that if available and make these encodings known
under the C<Encode> aliases "console_in" and "console_out".  For systems where
we can't determine the terminal encoding these will be aliased as the same
encoding as "locale".  The advice is to use "console_in" for input known to
come from the terminal and "console_out" for output to the terminal.

In addition to arranging for various Encode aliases the following functions and
variables are provided:

=over

=item decode_argv( )

=item decode_argv( Encode::FB_CROAK )

This will decode the command line arguments to perl (the C<@ARGV> array) in-place.

The function will by default replace characters that can't be decoded by
"\x{FFFD}", the Unicode replacement character.

Any argument provided is passed as CHECK to underlying Encode::decode() call.
Pass the value C<Encode::FB_CROAK> to have the decoding croak if not all the
command line arguments can be decoded.  See L<Encode/"Handling Malformed Data">
for details on other options for CHECK.

=item env( $uni_key )

=item env( $uni_key => $uni_value )

Interface to get/set environment variables.  Returns the current value as a
Unicode string. The $uni_key and $uni_value arguments are expected to be
Unicode strings as well.  Passing C<undef> as $uni_value deletes the
environment variable named $uni_key.

The returned value will have the characters that can't be decoded replaced by
"\x{FFFD}", the Unicode replacement character.

There is no interface to request alternative CHECK behavior as for
decode_argv().  If you need that you need to call encode/decode yourself.
For example:

    my $key = Encode::encode(locale => $uni_key, Encode::FB_CROAK);
    my $uni_value = Encode::decode(locale => $ENV{$key}, Encode::FB_CROAK);

=item reinit( )

=item reinit( $encoding )

Reinitialize the encodings from the locale.  You want to call this function if
you changed anything in the environment that might influence the locale.

This function will croak if the determined encoding isn't recognized by
the Encode module.

With argument force $ENCODING_... variables to set to the given value.

=item $ENCODING_LOCALE

The encoding name determined to be suitable for the current locale.
L<Encode> know this encoding as "locale".

=item $ENCODING_LOCALE_FS

The encoding name determined to be suitable for file system interfaces
involving file names.
L<Encode> know this encoding as "locale_fs".

=item $ENCODING_CONSOLE_IN

=item $ENCODING_CONSOLE_OUT

The encodings to be used for reading and writing output to the a console.
L<Encode> know these encodings as "console_in" and "console_out".

=back

=head1 NOTES

This table summarizes the mapping of the encodings set up
by the C<Encode::Locale> module:

  Encode      |         |              |
  Alias       | Windows | Mac OS X     | POSIX
  ------------+---------+--------------+------------
  locale      | ANSI    | nl_langinfo  | nl_langinfo
  locale_fs   | ANSI    | UTF-8        | nl_langinfo
  console_in  | OEM     | nl_langinfo  | nl_langinfo
  console_out | OEM     | nl_langinfo  | nl_langinfo

=head2 Windows

Windows has basically 2 sets of APIs.  A wide API (based on passing UTF-16
strings) and a byte based API based a character set called ANSI.  The
regular Perl interfaces to the OS currently only uses the ANSI APIs.
Unfortunately ANSI is not a single character set.

The encoding that corresponds to ANSI varies between different editions of
Windows.  For many western editions of Windows ANSI corresponds to CP-1252
which is a character set similar to ISO-8859-1.  Conceptually the ANSI
character set is a similar concept to the POSIX locale CODESET so this module
figures out what the ANSI code page is and make this available as
$ENCODING_LOCALE and the "locale" Encoding alias.

Windows systems also operate with another byte based character set.
It's called the OEM code page.  This is the encoding that the Console
takes as input and output.  It's common for the OEM code page to
differ from the ANSI code page.

=head2 Mac OS X

On Mac OS X the file system encoding is always UTF-8 while the locale
can otherwise be set up as normal for POSIX systems.

File names on Mac OS X will at the OS-level be converted to
NFD-form.  A file created by passing a NFC-filename will come
in NFD-form from readdir().  See L<Unicode::Normalize> for details
of NFD/NFC.

Actually, Apple does not follow the Unicode NFD standard since not all
character ranges are decomposed.  The claim is that this avoids problems with
round trip conversions from old Mac text encodings.  See L<Encode::UTF8Mac> for
details.

=head2 POSIX (Linux and other Unixes)

File systems might vary in what encoding is to be used for
filenames.  Since this module has no way to actually figure out
what the is correct it goes with the best guess which is to
assume filenames are encoding according to the current locale.
Users are advised to always specify UTF-8 as the locale charset.

=head1 SEE ALSO

L<I18N::Langinfo>, L<Encode>, L<Term::Encoding>

=head1 AUTHOR

Copyright 2010 Gisle Aas <gisle@aas.no>.

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

=cut
PK       ! oL��Z  Z  "  perl5/ExtUtils/MakeMaker/Config.pmnu ��6�$        package ExtUtils::MakeMaker::Config;

use strict;
use warnings;

our $VERSION = '7.50';
$VERSION =~ tr/_//d;

use Config ();

# Give us an overridable config.
our %Config = %Config::Config;

sub import {
    my $caller = caller;

    no strict 'refs';   ## no critic
    *{$caller.'::Config'} = \%Config;
}

1;


=head1 NAME

ExtUtils::MakeMaker::Config - Wrapper around Config.pm


=head1 SYNOPSIS

  use ExtUtils::MakeMaker::Config;
  print $Config{installbin};  # or whatever


=head1 DESCRIPTION

B<FOR INTERNAL USE ONLY>

A very thin wrapper around Config.pm so MakeMaker is easier to test.

=cut
PK       ! �?�JO  JO     perl5/ExtUtils/MakeMaker/FAQ.podnu ��6�$        package ExtUtils::MakeMaker::FAQ;

our $VERSION = '7.50';
$VERSION =~ tr/_//d;

1;
__END__

=head1 NAME

ExtUtils::MakeMaker::FAQ - Frequently Asked Questions About MakeMaker

=head1 DESCRIPTION

FAQs, tricks and tips for L<ExtUtils::MakeMaker>.


=head2 Module Installation

=over 4

=item How do I install a module into my home directory?

If you're not the Perl administrator you probably don't have
permission to install a module to its default location. Ways of handling
this with a B<lot> less manual effort on your part are L<perlbrew>
and L<local::lib>.

Otherwise, you can install it for your own use into your home directory
like so:

    # Non-unix folks, replace ~ with /path/to/your/home/dir
    perl Makefile.PL INSTALL_BASE=~

This will put modules into F<~/lib/perl5>, man pages into F<~/man> and
programs into F<~/bin>.

To ensure your Perl programs can see these newly installed modules,
set your C<PERL5LIB> environment variable to F<~/lib/perl5> or tell
each of your programs to look in that directory with the following:

    use lib "$ENV{HOME}/lib/perl5";

or if $ENV{HOME} isn't set and you don't want to set it for some
reason, do it the long way.

    use lib "/path/to/your/home/dir/lib/perl5";

=item How do I get MakeMaker and Module::Build to install to the same place?

Module::Build, as of 0.28, supports two ways to install to the same
location as MakeMaker.

We highly recommend the install_base method, its the simplest and most
closely approximates the expected behavior of an installation prefix.

1) Use INSTALL_BASE / C<--install_base>

MakeMaker (as of 6.31) and Module::Build (as of 0.28) both can install
to the same locations using the "install_base" concept.  See
L<ExtUtils::MakeMaker/INSTALL_BASE> for details.  To get MM and MB to
install to the same location simply set INSTALL_BASE in MM and
C<--install_base> in MB to the same location.

    perl Makefile.PL INSTALL_BASE=/whatever
    perl Build.PL    --install_base /whatever

This works most like other language's behavior when you specify a
prefix.  We recommend this method.

2) Use PREFIX / C<--prefix>

Module::Build 0.28 added support for C<--prefix> which works like
MakeMaker's PREFIX.

    perl Makefile.PL PREFIX=/whatever
    perl Build.PL    --prefix /whatever

We highly discourage this method.  It should only be used if you know
what you're doing and specifically need the PREFIX behavior.  The
PREFIX algorithm is complicated and focused on matching the system
installation.

=item How do I keep from installing man pages?

Recent versions of MakeMaker will only install man pages on Unix-like
operating systems by default. To generate manpages on non-Unix operating
systems, make the "manifypods" target.

For an individual module:

        perl Makefile.PL INSTALLMAN1DIR=none INSTALLMAN3DIR=none

If you want to suppress man page installation for all modules you have
to reconfigure Perl and tell it 'none' when it asks where to install
man pages.


=item How do I use a module without installing it?

Two ways.  One is to build the module normally...

        perl Makefile.PL
        make
        make test

...and then use L<blib> to point Perl at the built but uninstalled module:

	perl -Mblib script.pl
	perl -Mblib -e '...'

The other is to install the module in a temporary location.

        perl Makefile.PL INSTALL_BASE=~/tmp
        make
        make test
        make install

And then set PERL5LIB to F<~/tmp/lib/perl5>.  This works well when you
have multiple modules to work with.  It also ensures that the module
goes through its full installation process which may modify it.
Again, L<local::lib> may assist you here.

=item How can I organize tests into subdirectories and have them run?

Let's take the following test directory structure:

    t/foo/sometest.t
    t/bar/othertest.t
    t/bar/baz/anothertest.t

Now, inside of the C<WriteMakeFile()> function in your F<Makefile.PL>, specify
where your tests are located with the C<test> directive:

    test => {TESTS => 't/*.t t/*/*.t t/*/*/*.t'}

The first entry in the string will run all tests in the top-level F<t/> 
directory. The second will run all test files located in any subdirectory under
F<t/>. The third, runs all test files within any subdirectory within any other
subdirectory located under F<t/>.

Note that you do not have to use wildcards. You can specify explicitly which
subdirectories to run tests in:

    test => {TESTS => 't/*.t t/foo/*.t t/bar/baz/*.t'}

=item PREFIX vs INSTALL_BASE from Module::Build::Cookbook

The behavior of PREFIX is complicated and depends closely on how your
Perl is configured. The resulting installation locations will vary
from machine to machine and even different installations of Perl on the
same machine.  Because of this, its difficult to document where prefix
will place your modules.

In contrast, INSTALL_BASE has predictable, easy to explain installation
locations.  Now that Module::Build and MakeMaker both have INSTALL_BASE
there is little reason to use PREFIX other than to preserve your existing
installation locations. If you are starting a fresh Perl installation we
encourage you to use INSTALL_BASE. If you have an existing installation
installed via PREFIX, consider moving it to an installation structure
matching INSTALL_BASE and using that instead.

=item Generating *.pm files with substitutions eg of $VERSION

If you want to configure your module files for local conditions, or to
automatically insert a version number, you can use EUMM's C<PL_FILES>
capability, where it will automatically run each F<*.PL> it finds to
generate its basename. For instance:

    # Makefile.PL:
    require 'common.pl';
    my $version = get_version();
    my @pms = qw(Foo.pm);
    WriteMakefile(
      NAME => 'Foo',
      VERSION => $version,
      PM => { map { ($_ => "\$(INST_LIB)/$_") } @pms },
      clean => { FILES => join ' ', @pms },
    );

    # common.pl:
    sub get_version { '0.04' }
    sub process { my $v = get_version(); s/__VERSION__/$v/g; }
    1;

    # Foo.pm.PL:
    require 'common.pl';
    $_ = join '', <DATA>;
    process();
    my $file = shift;
    open my $fh, '>', $file or die "$file: $!";
    print $fh $_;
    __DATA__
    package Foo;
    our $VERSION = '__VERSION__';
    1;

You may notice that C<PL_FILES> is not specified above, since the default
of mapping each .PL file to its basename works well.

If the generated module were architecture-specific, you could replace
C<$(INST_LIB)> above with C<$(INST_ARCHLIB)>, although if you locate
modules under F<lib>, that would involve ensuring any C<lib/> in front
of the module location were removed.

=back

=head2 Common errors and problems

=over 4

=item "No rule to make target `/usr/lib/perl5/CORE/config.h', needed by `Makefile'"

Just what it says, you're missing that file.  MakeMaker uses it to
determine if perl has been rebuilt since the Makefile was made.  It's
a bit of a bug that it halts installation.

Some operating systems don't ship the CORE directory with their base
perl install.  To solve the problem, you likely need to install a perl
development package such as perl-devel (CentOS, Fedora and other
Redhat systems) or perl (Ubuntu and other Debian systems).

=back

=head2 Philosophy and History

=over 4

=item Why not just use <insert other build config tool here>?

Why did MakeMaker reinvent the build configuration wheel?  Why not
just use autoconf or automake or ppm or Ant or ...

There are many reasons, but the major one is cross-platform
compatibility.

Perl is one of the most ported pieces of software ever.  It works on
operating systems I've never even heard of (see perlport for details).
It needs a build tool that can work on all those platforms and with
any wacky C compilers and linkers they might have.

No such build tool exists.  Even make itself has wildly different
dialects.  So we have to build our own.


=item What is Module::Build and how does it relate to MakeMaker?

Module::Build is a project by Ken Williams to supplant MakeMaker.
Its primary advantages are:

=over 8

=item * pure perl.  no make, no shell commands

=item * easier to customize

=item * cleaner internals

=item * less cruft

=back

Module::Build was long the official heir apparent to MakeMaker.  The
rate of both its development and adoption has slowed in recent years,
though, and it is unclear what the future holds for it.  That said,
Module::Build set the stage for I<something> to become the heir to
MakeMaker.  MakeMaker's maintainers have long said that it is a dead
end and should be kept functioning, while being cautious about extending
with new features.

=back

=head2 Module Writing

=over 4

=item How do I keep my $VERSION up to date without resetting it manually?

Often you want to manually set the $VERSION in the main module
distribution because this is the version that everybody sees on CPAN
and maybe you want to customize it a bit.  But for all the other
modules in your dist, $VERSION is really just bookkeeping and all that's
important is it goes up every time the module is changed.  Doing this
by hand is a pain and you often forget.

Probably the easiest way to do this is using F<perl-reversion> in
L<Perl::Version>:

  perl-reversion -bump

If your version control system supports revision numbers (git doesn't
easily), the simplest way to do it automatically is to use its revision
number (you are using version control, right?).

In CVS, RCS and SVN you use $Revision$ (see the documentation of your
version control system for details).  Every time the file is checked
in the $Revision$ will be updated, updating your $VERSION.

SVN uses a simple integer for $Revision$ so you can adapt it for your
$VERSION like so:

    ($VERSION) = q$Revision$ =~ /(\d+)/;

In CVS and RCS version 1.9 is followed by 1.10.  Since CPAN compares
version numbers numerically we use a sprintf() to convert 1.9 to 1.009
and 1.10 to 1.010 which compare properly.

    $VERSION = sprintf "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/g;

If branches are involved (ie. $Revision: 1.5.3.4$) it's a little more
complicated.

    # must be all on one line or MakeMaker will get confused.
    $VERSION = do { my @r = (q$Revision$ =~ /\d+/g); sprintf "%d."."%03d" x $#r, @r };

In SVN, $Revision$ should be the same for every file in the project so
they would all have the same $VERSION.  CVS and RCS have a different
$Revision$ per file so each file will have a different $VERSION.
Distributed version control systems, such as SVK, may have a different
$Revision$ based on who checks out the file, leading to a different $VERSION
on each machine!  Finally, some distributed version control systems, such
as darcs, have no concept of revision number at all.


=item What's this F<META.yml> thing and how did it get in my F<MANIFEST>?!

F<META.yml> is a module meta-data file pioneered by Module::Build and
automatically generated as part of the 'distdir' target (and thus
'dist').  See L<ExtUtils::MakeMaker/"Module Meta-Data">.

To shut off its generation, pass the C<NO_META> flag to C<WriteMakefile()>.


=item How do I delete everything not in my F<MANIFEST>?

Some folks are surprised that C<make distclean> does not delete
everything not listed in their MANIFEST (thus making a clean
distribution) but only tells them what they need to delete.  This is
done because it is considered too dangerous.  While developing your
module you might write a new file, not add it to the MANIFEST, then
run a C<distclean> and be sad because your new work was deleted.

If you really want to do this, you can use
C<ExtUtils::Manifest::manifind()> to read the MANIFEST and File::Find
to delete the files.  But you have to be careful.  Here's a script to
do that.  Use at your own risk.  Have fun blowing holes in your foot.

    #!/usr/bin/perl -w

    use strict;

    use File::Spec;
    use File::Find;
    use ExtUtils::Manifest qw(maniread);

    my %manifest = map  {( $_ => 1 )}
                   grep { File::Spec->canonpath($_) }
                        keys %{ maniread() };

    if( !keys %manifest ) {
        print "No files found in MANIFEST.  Stopping.\n";
        exit;
    }

    find({
          wanted   => sub {
              my $path = File::Spec->canonpath($_);

              return unless -f $path;
              return if exists $manifest{ $path };

              print "unlink $path\n";
              unlink $path;
          },
          no_chdir => 1
         },
         "."
    );


=item Which tar should I use on Windows?

We recommend ptar from Archive::Tar not older than 1.66 with '-C' option.

=item Which zip should I use on Windows for '[ndg]make zipdist'?

We recommend InfoZIP: L<http://www.info-zip.org/Zip.html>


=back

=head2 XS

=over 4

=item How do I prevent "object version X.XX does not match bootstrap parameter Y.YY" errors?

XS code is very sensitive to the module version number and will
complain if the version number in your Perl module doesn't match.  If
you change your module's version # without rerunning Makefile.PL the old
version number will remain in the Makefile, causing the XS code to be built
with the wrong number.

To avoid this, you can force the Makefile to be rebuilt whenever you
change the module containing the version number by adding this to your
WriteMakefile() arguments.

    depend => { '$(FIRST_MAKEFILE)' => '$(VERSION_FROM)' }


=item How do I make two or more XS files coexist in the same directory?

Sometimes you need to have two and more XS files in the same package.
There are three ways: C<XSMULTI>, separate directories, and bootstrapping
one XS from another.

=over 8

=item XSMULTI

Structure your modules so they are all located under F<lib>, such that
C<Foo::Bar> is in F<lib/Foo/Bar.pm> and F<lib/Foo/Bar.xs>, etc. Have your
top-level C<WriteMakefile> set the variable C<XSMULTI> to a true value.

Er, that's it.

=item Separate directories

Put each XS files into separate directories, each with their own
F<Makefile.PL>. Make sure each of those F<Makefile.PL>s has the correct
C<CFLAGS>, C<INC>, C<LIBS> etc. You will need to make sure the top-level
F<Makefile.PL> refers to each of these using C<DIR>.

=item Bootstrapping

Let's assume that we have a package C<Cool::Foo>, which includes
C<Cool::Foo> and C<Cool::Bar> modules each having a separate XS
file. First we use the following I<Makefile.PL>:

  use ExtUtils::MakeMaker;

  WriteMakefile(
      NAME		=> 'Cool::Foo',
      VERSION_FROM	=> 'Foo.pm',
      OBJECT              => q/$(O_FILES)/,
      # ... other attrs ...
  );

Notice the C<OBJECT> attribute. MakeMaker generates the following
variables in I<Makefile>:

  # Handy lists of source code files:
  XS_FILES= Bar.xs \
  	Foo.xs
  C_FILES = Bar.c \
  	Foo.c
  O_FILES = Bar.o \
  	Foo.o

Therefore we can use the C<O_FILES> variable to tell MakeMaker to use
these objects into the shared library.

That's pretty much it. Now write I<Foo.pm> and I<Foo.xs>, I<Bar.pm>
and I<Bar.xs>, where I<Foo.pm> bootstraps the shared library and
I<Bar.pm> simply loading I<Foo.pm>.

The only issue left is to how to bootstrap I<Bar.xs>. This is done
from I<Foo.xs>:

  MODULE = Cool::Foo PACKAGE = Cool::Foo

  BOOT:
  # boot the second XS file
  boot_Cool__Bar(aTHX_ cv);

If you have more than two files, this is the place where you should
boot extra XS files from.

The following four files sum up all the details discussed so far.

  Foo.pm:
  -------
  package Cool::Foo;

  require DynaLoader;

  our @ISA = qw(DynaLoader);
  our $VERSION = '0.01';
  bootstrap Cool::Foo $VERSION;

  1;

  Bar.pm:
  -------
  package Cool::Bar;

  use Cool::Foo; # bootstraps Bar.xs

  1;

  Foo.xs:
  -------
  #include "EXTERN.h"
  #include "perl.h"
  #include "XSUB.h"

  MODULE = Cool::Foo  PACKAGE = Cool::Foo

  BOOT:
  # boot the second XS file
  boot_Cool__Bar(aTHX_ cv);

  MODULE = Cool::Foo  PACKAGE = Cool::Foo  PREFIX = cool_foo_

  void
  cool_foo_perl_rules()

      CODE:
      fprintf(stderr, "Cool::Foo says: Perl Rules\n");

  Bar.xs:
  -------
  #include "EXTERN.h"
  #include "perl.h"
  #include "XSUB.h"

  MODULE = Cool::Bar  PACKAGE = Cool::Bar PREFIX = cool_bar_

  void
  cool_bar_perl_rules()

      CODE:
      fprintf(stderr, "Cool::Bar says: Perl Rules\n");

And of course a very basic test:

  t/cool.t:
  --------
  use Test;
  BEGIN { plan tests => 1 };
  use Cool::Foo;
  use Cool::Bar;
  Cool::Foo::perl_rules();
  Cool::Bar::perl_rules();
  ok 1;

This tip has been brought to you by Nick Ing-Simmons and Stas Bekman.

An alternative way to achieve this can be seen in L<Gtk2::CodeGen>
and L<Glib::CodeGen>.

=back

=back

=head1 DESIGN

=head2 MakeMaker object hierarchy (simplified)

What most people need to know (superclasses on top.)

        ExtUtils::MM_Any
                |
        ExtUtils::MM_Unix
                |
        ExtUtils::MM_{Current OS}
                |
        ExtUtils::MakeMaker
                |
               MY

The object actually used is of the class L<MY|ExtUtils::MY> which allows you to
override bits of MakeMaker inside your Makefile.PL by declaring
MY::foo() methods.

=head2 MakeMaker object hierarchy (real)

Here's how it really works:

                                    ExtUtils::MM_Any
                                            |
                                    ExtUtils::MM_Unix
                                            |
    ExtUtils::Liblist::Kid          ExtUtils::MM_{Current OS} (if necessary)
          |                                          |
    ExtUtils::Liblist     ExtUtils::MakeMaker        |
                    |     |                          |   
                    |     |   |-----------------------
                   ExtUtils::MM
                   |          |
        ExtUtils::MY         MM (created by ExtUtils::MM)
        |                                   |
        MY (created by ExtUtils::MY)        |
                    .                       |
                 (mixin)                    |
                    .                       |
               PACK### (created each call to ExtUtils::MakeMaker->new)

NOTE: Yes, this is a mess.  See
L<http://archive.develooper.com/makemaker@perl.org/msg00134.html>
for some history.

NOTE: When L<ExtUtils::MM> is loaded it chooses a superclass for MM from
amongst the ExtUtils::MM_* modules based on the current operating
system.

NOTE: ExtUtils::MM_{Current OS} represents one of the ExtUtils::MM_*
modules except L<ExtUtils::MM_Any> chosen based on your operating system.

NOTE: The main object used by MakeMaker is a PACK### object, *not*
L<ExtUtils::MakeMaker>.  It is, effectively, a subclass of L<MY|ExtUtils::MY>,
L<ExtUtils::MakeMaker>, L<ExtUtils::Liblist> and ExtUtils::MM_{Current OS}

NOTE: The methods in L<MY|ExtUtils::MY> are simply copied into PACK### rather
than MY being a superclass of PACK###.  I don't remember the rationale.

NOTE: L<ExtUtils::Liblist> should be removed from the inheritance hiearchy
and simply be called as functions.

NOTE: Modules like L<File::Spec> and L<Exporter> have been omitted for clarity.


=head2 The MM_* hierarchy

                                MM_Win95   MM_NW5
                                     \      /
 MM_BeOS  MM_Cygwin  MM_OS2  MM_VMS  MM_Win32  MM_DOS  MM_UWIN
       \        |      |         |        /      /      /
        ------------------------------------------------
                           |       |
                        MM_Unix    |
                              |    |
                              MM_Any

NOTE: Each direct L<MM_Unix|ExtUtils::MM_Unix> subclass is also an
L<MM_Any|ExtUtils::MM_Any> subclass.  This
is a temporary hack because MM_Unix overrides some MM_Any methods with
Unix specific code.  It allows the non-Unix modules to see the
original MM_Any implementations.

NOTE: Modules like L<File::Spec> and L<Exporter> have been omitted for clarity.

=head1 PATCHING

If you have a question you'd like to see added to the FAQ (whether or
not you have the answer) please either:

=over 2

=item * make a pull request on the MakeMaker github repository

=item * raise a issue on the MakeMaker github repository

=item * file an RT ticket

=item * email makemaker@perl.org

=back

=head1 AUTHOR

The denizens of makemaker@perl.org.

=head1 SEE ALSO

L<ExtUtils::MakeMaker>

=cut
PK       ! &�ƛU	  U	  #  perl5/ExtUtils/MakeMaker/version.pmnu ��6�$        #--------------------------------------------------------------------------#
# This is a modified copy of version.pm 0.9909, bundled exclusively for
# use by ExtUtils::Makemaker and its dependencies to bootstrap when
# version.pm is not available.  It should not be used by ordinary modules.
#
# When loaded, it will try to load version.pm.  If that fails, it will load
# ExtUtils::MakeMaker::version::vpp and alias various *version functions
# to functions in that module.  It will also override UNIVERSAL::VERSION.
#--------------------------------------------------------------------------#

package ExtUtils::MakeMaker::version;

use 5.006001;
use strict;
use warnings;

use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);

$VERSION = '7.50';
$VERSION =~ tr/_//d;
$CLASS = 'version';

{
    local $SIG{'__DIE__'};
    eval "use version";
    if ( $@ ) { # don't have any version.pm installed
        eval "use ExtUtils::MakeMaker::version::vpp";
        die "$@" if ( $@ );
        no warnings;
        delete $INC{'version.pm'};
        $INC{'version.pm'} = $INC{'ExtUtils/MakeMaker/version.pm'};
        push @version::ISA, "ExtUtils::MakeMaker::version::vpp";
        $version::VERSION = $VERSION;
        *version::qv = \&ExtUtils::MakeMaker::version::vpp::qv;
        *version::declare = \&ExtUtils::MakeMaker::version::vpp::declare;
        *version::_VERSION = \&ExtUtils::MakeMaker::version::vpp::_VERSION;
        *version::vcmp = \&ExtUtils::MakeMaker::version::vpp::vcmp;
        *version::new = \&ExtUtils::MakeMaker::version::vpp::new;
        if ("$]" >= 5.009000) {
            no strict 'refs';
            *version::stringify = \&ExtUtils::MakeMaker::version::vpp::stringify;
            *{'version::(""'} = \&ExtUtils::MakeMaker::version::vpp::stringify;
            *{'version::(<=>'} = \&ExtUtils::MakeMaker::version::vpp::vcmp;
            *version::parse = \&ExtUtils::MakeMaker::version::vpp::parse;
        }
        require ExtUtils::MakeMaker::version::regex;
        *version::is_lax = \&ExtUtils::MakeMaker::version::regex::is_lax;
        *version::is_strict = \&ExtUtils::MakeMaker::version::regex::is_strict;
        *LAX = \$ExtUtils::MakeMaker::version::regex::LAX;
        *STRICT = \$ExtUtils::MakeMaker::version::regex::STRICT;
    }
    elsif ( ! version->can('is_qv') ) {
        *version::is_qv = sub { exists $_[0]->{qv} };
    }
}

1;
PK       ! �~��s  s  %  perl5/ExtUtils/MakeMaker/Tutorial.podnu ��6�$        package ExtUtils::MakeMaker::Tutorial;

our $VERSION = '7.50';
$VERSION =~ tr/_//d;


=head1 NAME

ExtUtils::MakeMaker::Tutorial - Writing a module with MakeMaker

=head1 SYNOPSIS

    use ExtUtils::MakeMaker;

    WriteMakefile(
        NAME            => 'Your::Module',
        VERSION_FROM    => 'lib/Your/Module.pm'
    );

=head1 DESCRIPTION

This is a short tutorial on writing a simple module with MakeMaker.
It's really not that hard.


=head2 The Mantra

MakeMaker modules are installed using this simple mantra

        perl Makefile.PL
        make
        make test
        make install

There are lots more commands and options, but the above will do it.


=head2 The Layout

The basic files in a module look something like this.

        Makefile.PL
        MANIFEST
        lib/Your/Module.pm

That's all that's strictly necessary.  There's additional files you might
want:

        lib/Your/Other/Module.pm
        t/some_test.t
        t/some_other_test.t
        Changes
        README
        INSTALL
        MANIFEST.SKIP
        bin/some_program

=over 4

=item Makefile.PL

When you run Makefile.PL, it makes a Makefile.  That's the whole point of
MakeMaker.  The Makefile.PL is a simple program which loads
ExtUtils::MakeMaker and runs the WriteMakefile() function to generate a
Makefile.

Here's an example of what you need for a simple module:

    use ExtUtils::MakeMaker;

    WriteMakefile(
        NAME            => 'Your::Module',
        VERSION_FROM    => 'lib/Your/Module.pm'
    );

NAME is the top-level namespace of your module.  VERSION_FROM is the file
which contains the $VERSION variable for the entire distribution.  Typically
this is the same as your top-level module.


=item MANIFEST

A simple listing of all the files in your distribution.

        Makefile.PL
        MANIFEST
        lib/Your/Module.pm

File paths in a MANIFEST always use Unix conventions (ie. /) even if you're
not on Unix.

You can write this by hand or generate it with 'make manifest'.

See L<ExtUtils::Manifest> for more details.


=item lib/

This is the directory where the .pm and .pod files you wish to have
installed go.  They are laid out according to namespace.  So Foo::Bar
is F<lib/Foo/Bar.pm>.


=item t/

Tests for your modules go here.  Each test filename ends with a .t.
So F<t/foo.t>  'make test' will run these tests.

Typically, the F<t/> test directory is flat, with all test files located
directly within it. However, you can nest tests within subdirectories, for
example:

    t/foo/subdir_test.t

To do this, you need to inform C<WriteMakeFile()> in your I<Makefile.PL> file
in the following fashion:

    test => {TESTS => 't/*.t t/*/*.t'}

That will run all tests in F<t/>, as well as all tests in all subdirectories
that reside under F<t/>. You can nest as deeply as makes sense for your project. 
Simply add another entry in the test location string. For example, to test:

    t/foo/bar/subdir_test.t

You would use the following C<test> directive:

    test => {TESTS => 't/*.t t/*/*/*.t'}

Note that in the above example, tests in the first subdirectory will not be
run. To run all tests in the intermediary subdirectory preceding the one
the test files are in, you need to explicitly note it:

    test => {TESTS => 't/*.t t/*/*.t t/*/*/*.t'}

You don't need to specify wildcards if you only want to test within specific
subdirectories. The following example will only run tests in F<t/foo>:

    test => {TESTS => 't/foo/*.t'}

Tests are run from the top level of your distribution.  So inside a test
you would refer to ./lib to enter the lib directory, for example.


=item Changes

A log of changes you've made to this module.  The layout is free-form.
Here's an example:

    1.01 Fri Apr 11 00:21:25 PDT 2003
        - thing() does some stuff now
        - fixed the wiggy bug in withit()

    1.00 Mon Apr  7 00:57:15 PDT 2003
        - "Rain of Frogs" now supported


=item README

A short description of your module, what it does, why someone would use it
and its limitations.  CPAN automatically pulls your README file out of
the archive and makes it available to CPAN users, it is the first thing
they will read to decide if your module is right for them.


=item INSTALL

Instructions on how to install your module along with any dependencies.
Suggested information to include here:

    any extra modules required for use
    the minimum version of Perl required
    if only works on certain operating systems


=item MANIFEST.SKIP

A file full of regular expressions to exclude when using 'make
manifest' to generate the MANIFEST.  These regular expressions
are checked against each file path found in the distribution (so
you're matching against "t/foo.t" not "foo.t").

Here's a sample:

    ~$          # ignore emacs and vim backup files
    .bak$       # ignore manual backups
    \#          # ignore CVS old revision files and emacs temp files

Since # can be used for comments, # must be escaped.

MakeMaker comes with a default MANIFEST.SKIP to avoid things like
version control directories and backup files.  Specifying your own
will override this default.


=item bin/


=back

=head1 SEE ALSO

L<perlmodstyle> gives stylistic help writing a module.

L<perlnewmod> gives more information about how to write a module.

There are modules to help you through the process of writing a module:
L<ExtUtils::ModuleMaker>, L<Module::Starter>, L<Minilla::Tutorial>,
L<Dist::Milla::Tutorial>, L<Dist::Zilla::Starter>

=cut

1;
PK       ! �6�&b  &b    perl5/ExtUtils/Liblist/Kid.pmnu ��6�$        package ExtUtils::Liblist::Kid;

# XXX Splitting this out into its own .pm is a temporary solution.

# This kid package is to be used by MakeMaker.  It will not work if
# $self is not a Makemaker.

use 5.006;

# Broken out of MakeMaker from version 4.11

use strict;
use warnings;
our $VERSION = '7.50';
$VERSION =~ tr/_//d;

use ExtUtils::MakeMaker::Config;
use Cwd 'cwd';
use File::Basename;
use File::Spec;

sub ext {
    if    ( $^O eq 'VMS' )     { return &_vms_ext; }
    elsif ( $^O eq 'MSWin32' ) { return &_win32_ext; }
    else                       { return &_unix_os2_ext; }
}

sub _unix_os2_ext {
    my ( $self, $potential_libs, $verbose, $give_libs ) = @_;
    $verbose ||= 0;

    if ( $^O =~ /os2|android/ and $Config{perllibs} ) {

        # Dynamic libraries are not transitive, so we may need including
        # the libraries linked against perl.dll/libperl.so again.

        $potential_libs .= " " if $potential_libs;
        $potential_libs .= $Config{perllibs};
    }
    return ( "", "", "", "", ( $give_libs ? [] : () ) ) unless $potential_libs;
    warn "Potential libraries are '$potential_libs':\n" if $verbose;

    my ( $so ) = $Config{so};
    my ( $libs ) = defined $Config{perllibs} ? $Config{perllibs} : $Config{libs};
    my $Config_libext = $Config{lib_ext} || ".a";
    my $Config_dlext = $Config{dlext};

    # compute $extralibs, $bsloadlibs and $ldloadlibs from
    # $potential_libs
    # this is a rewrite of Andy Dougherty's extliblist in perl

    require Text::ParseWords;

    my ( @searchpath );    # from "-L/path" entries in $potential_libs
    my ( @libpath ) = Text::ParseWords::quotewords( '\s+', 0, $Config{'libpth'} || '' );
    my ( @ldloadlibs, @bsloadlibs, @extralibs, @ld_run_path, %ld_run_path_seen );
    my ( @libs,       %libs_seen );
    my ( $fullname,   @fullname );
    my ( $pwd )   = cwd();    # from Cwd.pm
    my ( $found ) = 0;

    if ( $^O eq 'darwin' or $^O eq 'next' )  {
        # 'escape' Mach-O ld -framework and -F flags, so they aren't dropped later on
        $potential_libs =~ s/(^|\s)(-(?:weak_|reexport_|lazy_)?framework)\s+(\S+)/$1-Wl,$2 -Wl,$3/g;
        $potential_libs =~ s/(^|\s)(-F)\s*(\S+)/$1-Wl,$2 -Wl,$3/g;
    }

    foreach my $thislib ( Text::ParseWords::quotewords( '\s+', 0, $potential_libs) ) {
        my ( $custom_name ) = '';

        # Handle possible linker path arguments.
        if ( $thislib =~ s/^(-[LR]|-Wl,-R|-Wl,-rpath,)// ) {    # save path flag type
            my ( $ptype ) = $1;
            unless ( -d $thislib ) {
                warn "$ptype$thislib ignored, directory does not exist\n"
                  if $verbose;
                next;
            }
            my ( $rtype ) = $ptype;
            if ( ( $ptype eq '-R' ) or ( $ptype =~ m!^-Wl,-[Rr]! ) ) {
                if ( $Config{'lddlflags'} =~ /-Wl,-[Rr]/ ) {
                    $rtype = '-Wl,-R';
                }
                elsif ( $Config{'lddlflags'} =~ /-R/ ) {
                    $rtype = '-R';
                }
            }
            unless ( File::Spec->file_name_is_absolute( $thislib ) ) {
                warn "Warning: $ptype$thislib changed to $ptype$pwd/$thislib\n";
                $thislib = $self->catdir( $pwd, $thislib );
            }
            push( @searchpath, $thislib );
            $thislib = qq{"$thislib"} if $thislib =~ / /; # protect spaces if there
            push( @extralibs,  "$ptype$thislib" );
            push( @ldloadlibs, "$rtype$thislib" );
            next;
        }

        if ( $thislib =~ m!^-Wl,! ) {
            push( @extralibs,  $thislib );
            push( @ldloadlibs, $thislib );
            next;
        }

        # Handle possible library arguments.
        if ( $thislib =~ s/^-l(:)?// ) {
            # Handle -l:foo.so, which means that the library will
            # actually be called foo.so, not libfoo.so.  This
            # is used in Android by ExtUtils::Depends to allow one XS
            # module to link to another.
            $custom_name = $1 || '';
        }
        else {
            warn "Unrecognized argument in LIBS ignored: '$thislib'\n";
            next;
        }

        my ( $found_lib ) = 0;
        foreach my $thispth ( @searchpath, @libpath ) {

            # Try to find the full name of the library.  We need this to
            # determine whether it's a dynamically-loadable library or not.
            # This tends to be subject to various os-specific quirks.
            # For gcc-2.6.2 on linux (March 1995), DLD can not load
            # .sa libraries, with the exception of libm.sa, so we
            # deliberately skip them.
            if ((@fullname =
                 $self->lsdir($thispth, "^\Qlib$thislib.$so.\E[0-9]+")) ||
                (@fullname =
                 $self->lsdir($thispth, "^\Qlib$thislib.\E[0-9]+\Q\.$so"))) {
                # Take care that libfoo.so.10 wins against libfoo.so.9.
                # Compare two libraries to find the most recent version
                # number.  E.g.  if you have libfoo.so.9.0.7 and
                # libfoo.so.10.1, first convert all digits into two
                # decimal places.  Then we'll add ".00" to the shorter
                # strings so that we're comparing strings of equal length
                # Thus we'll compare libfoo.so.09.07.00 with
                # libfoo.so.10.01.00.  Some libraries might have letters
                # in the version.  We don't know what they mean, but will
                # try to skip them gracefully -- we'll set any letter to
                # '0'.  Finally, sort in reverse so we can take the
                # first element.

                #TODO: iterate through the directory instead of sorting

                $fullname = "$thispth/" . (
                    sort {
                        my ( $ma ) = $a;
                        my ( $mb ) = $b;
                        $ma =~ tr/A-Za-z/0/s;
                        $ma =~ s/\b(\d)\b/0$1/g;
                        $mb =~ tr/A-Za-z/0/s;
                        $mb =~ s/\b(\d)\b/0$1/g;
                        while ( length( $ma ) < length( $mb ) ) { $ma .= ".00"; }
                        while ( length( $mb ) < length( $ma ) ) { $mb .= ".00"; }

                        # Comparison deliberately backwards
                        $mb cmp $ma;
                      } @fullname
                )[0];
            }
            elsif ( -f ( $fullname = "$thispth/lib$thislib.$so" )
                && ( ( $Config{'dlsrc'} ne "dl_dld.xs" ) || ( $thislib eq "m" ) ) )
            {
            }
            elsif (-f ( $fullname = "$thispth/lib${thislib}_s$Config_libext" )
                && ( $Config{'archname'} !~ /RM\d\d\d-svr4/ )
                && ( $thislib .= "_s" ) )
            {    # we must explicitly use _s version
            }
            elsif ( -f ( $fullname = "$thispth/lib$thislib$Config_libext" ) ) {
            }
            elsif ( defined( $Config_dlext )
                && -f ( $fullname = "$thispth/lib$thislib.$Config_dlext" ) )
            {
            }
            elsif ( -f ( $fullname = "$thispth/$thislib$Config_libext" ) ) {
            }
            elsif ( -f ( $fullname = "$thispth/lib$thislib.dll$Config_libext" ) ) {
            }
            elsif ( $^O eq 'cygwin' && -f ( $fullname = "$thispth/$thislib.dll" ) ) {
            }
            elsif ( -f ( $fullname = "$thispth/Slib$thislib$Config_libext" ) ) {
            }
            elsif ($^O eq 'dgux'
                && -l ( $fullname = "$thispth/lib$thislib$Config_libext" )
                && readlink( $fullname ) =~ /^elink:/s )
            {

                # Some of DG's libraries look like misconnected symbolic
                # links, but development tools can follow them.  (They
                # look like this:
                #
                #    libm.a -> elink:${SDE_PATH:-/usr}/sde/\
                #    ${TARGET_BINARY_INTERFACE:-m88kdgux}/usr/lib/libm.a
                #
                # , the compilation tools expand the environment variables.)
            }
            elsif ( $custom_name && -f ( $fullname = "$thispth/$thislib" ) ) {
            }
            else {
                warn "$thislib not found in $thispth\n" if $verbose;
                next;
            }
            warn "'-l$thislib' found at $fullname\n" if $verbose;
            push @libs, $fullname unless $libs_seen{$fullname}++;
            $found++;
            $found_lib++;

            # Now update library lists

            # what do we know about this library...
            # "Sounds like we should always assume it's a dynamic library on AIX."
            my $is_dyna = $^O eq 'aix' ? 1 : ( $fullname !~ /\Q$Config_libext\E\z/ );
            my $in_perl = ( $libs =~ /\B-l:?\Q${thislib}\E\b/s );

            # include the path to the lib once in the dynamic linker path
            # but only if it is a dynamic lib and not in Perl itself
            my ( $fullnamedir ) = dirname( $fullname );
            push @ld_run_path, $fullnamedir
              if $is_dyna
                  && !$in_perl
                  && !$ld_run_path_seen{$fullnamedir}++;

            # Do not add it into the list if it is already linked in
            # with the main perl executable.
            # We have to special-case the NeXT, because math and ndbm
            # are both in libsys_s
            unless (
                $in_perl
                || ( $Config{'osname'} eq 'next'
                    && ( $thislib eq 'm' || $thislib eq 'ndbm' ) )
              )
            {
                push( @extralibs, "-l$custom_name$thislib" );
            }

            # We might be able to load this archive file dynamically
            if (   ( $Config{'dlsrc'} =~ /dl_next/ && $Config{'osvers'} lt '4_0' )
                || ( $Config{'dlsrc'} =~ /dl_dld/ ) )
            {

                # We push -l$thislib instead of $fullname because
                # it avoids hardwiring a fixed path into the .bs file.
                # Mkbootstrap will automatically add dl_findfile() to
                # the .bs file if it sees a name in the -l format.
                # USE THIS, when dl_findfile() is fixed:
                # push(@bsloadlibs, "-l$thislib");
                # OLD USE WAS while checking results against old_extliblist
                push( @bsloadlibs, "$fullname" );
            }
            else {
                if ( $is_dyna ) {

                    # For SunOS4, do not add in this shared library if
                    # it is already linked in the main perl executable
                    push( @ldloadlibs, "-l$custom_name$thislib" )
                      unless ( $in_perl and $^O eq 'sunos' );
                }
                else {
                    push( @ldloadlibs, "-l$custom_name$thislib" );
                }
            }
            last;    # found one here so don't bother looking further
        }
        warn "Warning (mostly harmless): " . "No library found for -l$thislib\n"
          unless $found_lib > 0;
    }

    unless ( $found ) {
        return ( '', '', '', '', ( $give_libs ? \@libs : () ) );
    }
    else {
        return ( "@extralibs", "@bsloadlibs", "@ldloadlibs", join( ":", @ld_run_path ), ( $give_libs ? \@libs : () ) );
    }
}

sub _win32_ext {

    require Text::ParseWords;

    my ( $self, $potential_libs, $verbose, $give_libs ) = @_;
    $verbose ||= 0;

    # If user did not supply a list, we punt.
    # (caller should probably use the list in $Config{libs})
    return ( "", "", "", "", ( $give_libs ? [] : () ) ) unless $potential_libs;

    # TODO: make this use MM_Win32.pm's compiler detection
    my %libs_seen;
    my @extralibs;
    my $cc = $Config{cc} || '';
    my $VC = $cc =~ /\bcl\b/i;
    my $GC = $cc =~ /\bgcc\b/i;

    my $libext     = _win32_lib_extensions();
    my @searchpath = ( '' );                                    # from "-L/path" entries in $potential_libs
    my @libpath    = _win32_default_search_paths( $VC, $GC );
    my $pwd        = cwd();                                     # from Cwd.pm
    my $search     = 1;

    # compute @extralibs from $potential_libs
    my @lib_search_list = _win32_make_lib_search_list( $potential_libs, $verbose );
    for ( @lib_search_list ) {

        my $thislib = $_;

        # see if entry is a flag
        if ( /^:\w+$/ ) {
            $search = 0 if lc eq ':nosearch';
            $search = 1 if lc eq ':search';
            _debug( "Ignoring unknown flag '$thislib'\n", $verbose ) if !/^:(no)?(search|default)$/i;
            next;
        }

        # if searching is disabled, do compiler-specific translations
        unless ( $search ) {
            s/^-l(.+)$/$1.lib/ unless $GC;
            s/^-L/-libpath:/ if $VC;
            push( @extralibs, $_ );
            next;
        }

        # handle possible linker path arguments
        if ( s/^-L// and not -d ) {
            _debug( "$thislib ignored, directory does not exist\n", $verbose );
            next;
        }
        elsif ( -d ) {
            unless ( File::Spec->file_name_is_absolute( $_ ) ) {
                warn "Warning: '$thislib' changed to '-L$pwd/$_'\n";
                $_ = $self->catdir( $pwd, $_ );
            }
            push( @searchpath, $_ );
            next;
        }

        my @paths = ( @searchpath, @libpath );
        my ( $fullname, $path ) = _win32_search_file( $thislib, $libext, \@paths, $verbose, $GC );

        if ( !$fullname ) {
            warn "Warning (mostly harmless): No library found for $thislib\n";
            next;
        }

        _debug( "'$thislib' found as '$fullname'\n", $verbose );
        push( @extralibs, $fullname );
        $libs_seen{$fullname} = 1 if $path;    # why is this a special case?
    }

    my @libs = sort keys %libs_seen;

    return ( '', '', '', '', ( $give_libs ? \@libs : () ) ) unless @extralibs;

    # make sure paths with spaces are properly quoted
    @extralibs = map { qq["$_"] } @extralibs;
    @libs      = map { qq["$_"] } @libs;

    my $lib = join( ' ', @extralibs );

    # normalize back to backward slashes (to help braindead tools)
    # XXX this may break equally braindead GNU tools that don't understand
    # backslashes, either.  Seems like one can't win here.  Cursed be CP/M.
    $lib =~ s,/,\\,g;

    _debug( "Result: $lib\n", $verbose );
    wantarray ? ( $lib, '', $lib, '', ( $give_libs ? \@libs : () ) ) : $lib;
}

sub _win32_make_lib_search_list {
    my ( $potential_libs, $verbose ) = @_;

    # If Config.pm defines a set of default libs, we always
    # tack them on to the user-supplied list, unless the user
    # specified :nodefault
    my $libs = $Config{'perllibs'};
    $potential_libs = join( ' ', $potential_libs, $libs ) if $libs and $potential_libs !~ /:nodefault/i;
    _debug( "Potential libraries are '$potential_libs':\n", $verbose );

    $potential_libs =~ s,\\,/,g;    # normalize to forward slashes

    my @list = Text::ParseWords::quotewords( '\s+', 0, $potential_libs );

    return @list;
}

sub _win32_default_search_paths {
    my ( $VC, $GC ) = @_;

    my $libpth = $Config{'libpth'} || '';
    $libpth =~ s,\\,/,g;            # normalize to forward slashes

    my @libpath = Text::ParseWords::quotewords( '\s+', 0, $libpth );
    push @libpath, "$Config{installarchlib}/CORE";    # add "$Config{installarchlib}/CORE" to default search path

    push @libpath, split /;/, $ENV{LIB}          if $VC and $ENV{LIB};
    push @libpath, split /;/, $ENV{LIBRARY_PATH} if $GC and $ENV{LIBRARY_PATH};

    return @libpath;
}

sub _win32_search_file {
    my ( $thislib, $libext, $paths, $verbose, $GC ) = @_;

    my @file_list = _win32_build_file_list( $thislib, $GC, $libext );

    for my $lib_file ( @file_list ) {
        for my $path ( @{$paths} ) {
            my $fullname = $lib_file;
            $fullname = "$path\\$fullname" if $path;

            return ( $fullname, $path ) if -f $fullname;

            _debug( "'$thislib' not found as '$fullname'\n", $verbose );
        }
    }

    return;
}

sub _win32_build_file_list {
    my ( $lib, $GC, $extensions ) = @_;

    my @pre_fixed = _win32_build_prefixed_list( $lib, $GC );
    return map _win32_attach_extensions( $_, $extensions ), @pre_fixed;
}

sub _win32_build_prefixed_list {
    my ( $lib, $GC ) = @_;

    return $lib if $lib !~ s/^-l//;
    return $lib if $lib =~ /^lib/ and !$GC;

    ( my $no_prefix = $lib ) =~ s/^lib//i;
    $lib = "lib$lib" if $no_prefix eq $lib;

    return ( $lib, $no_prefix ) if $GC;
    return ( $no_prefix, $lib );
}

sub _win32_attach_extensions {
    my ( $lib, $extensions ) = @_;
    return map _win32_try_attach_extension( $lib, $_ ), @{$extensions};
}

sub _win32_try_attach_extension {
    my ( $lib, $extension ) = @_;

    return $lib if $lib =~ /\Q$extension\E$/i;
    return "$lib$extension";
}

sub _win32_lib_extensions {
    my @extensions;
    push @extensions, $Config{'lib_ext'} if $Config{'lib_ext'};
    push @extensions, '.dll.a' if grep { m!^\.a$! } @extensions;
    push @extensions, '.lib' unless grep { m!^\.lib$! } @extensions;
    return \@extensions;
}

sub _debug {
    my ( $message, $verbose ) = @_;
    return if !$verbose;
    warn $message;
    return;
}

sub _vms_ext {
    my ( $self, $potential_libs, $verbose, $give_libs ) = @_;
    $verbose ||= 0;

    my ( @crtls, $crtlstr );
    @crtls = ( ( $Config{'ldflags'} =~ m-/Debug-i ? $Config{'dbgprefix'} : '' ) . 'PerlShr/Share' );
    push( @crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'} );
    push( @crtls, grep { not /\(/ } split /\s+/, $Config{'libc'} );

    # In general, we pass through the basic libraries from %Config unchanged.
    # The one exception is that if we're building in the Perl source tree, and
    # a library spec could be resolved via a logical name, we go to some trouble
    # to insure that the copy in the local tree is used, rather than one to
    # which a system-wide logical may point.
    if ( $self->{PERL_SRC} ) {
        my ( $locspec, $type );
        foreach my $lib ( @crtls ) {
            if ( ( $locspec, $type ) = $lib =~ m{^([\w\$-]+)(/\w+)?} and $locspec =~ /perl/i ) {
                if    ( lc $type eq '/share' )   { $locspec .= $Config{'exe_ext'}; }
                elsif ( lc $type eq '/library' ) { $locspec .= $Config{'lib_ext'}; }
                else                             { $locspec .= $Config{'obj_ext'}; }
                $locspec = $self->catfile( $self->{PERL_SRC}, $locspec );
                $lib = "$locspec$type" if -e $locspec;
            }
        }
    }
    $crtlstr = @crtls ? join( ' ', @crtls ) : '';

    unless ( $potential_libs ) {
        warn "Result:\n\tEXTRALIBS: \n\tLDLOADLIBS: $crtlstr\n" if $verbose;
        return ( '', '', $crtlstr, '', ( $give_libs ? [] : () ) );
    }

    my ( %found, @fndlibs, $ldlib );
    my $cwd = cwd();
    my ( $so, $lib_ext, $obj_ext ) = @Config{ 'so', 'lib_ext', 'obj_ext' };

    # List of common Unix library names and their VMS equivalents
    # (VMS equivalent of '' indicates that the library is automatically
    # searched by the linker, and should be skipped here.)
    my ( @flibs, %libs_seen );
    my %libmap = (
        'm'      => '',
        'f77'    => '',
        'F77'    => '',
        'V77'    => '',
        'c'      => '',
        'malloc' => '',
        'crypt'  => '',
        'resolv' => '',
        'c_s'    => '',
        'socket' => '',
        'X11'    => 'DECW$XLIBSHR',
        'Xt'     => 'DECW$XTSHR',
        'Xm'     => 'DECW$XMLIBSHR',
        'Xmu'    => 'DECW$XMULIBSHR'
    );

    warn "Potential libraries are '$potential_libs'\n" if $verbose;

    # First, sort out directories and library names in the input
    my ( @dirs, @libs );
    foreach my $lib ( split ' ', $potential_libs ) {
        push( @dirs, $1 ),   next if $lib =~ /^-L(.*)/;
        push( @dirs, $lib ), next if $lib =~ /[:>\]]$/;
        push( @dirs, $lib ), next if -d $lib;
        push( @libs, $1 ),   next if $lib =~ /^-l(.*)/;
        push( @libs, $lib );
    }
    push( @dirs, split( ' ', $Config{'libpth'} ) );

    # Now make sure we've got VMS-syntax absolute directory specs
    # (We don't, however, check whether someone's hidden a relative
    # path in a logical name.)
    foreach my $dir ( @dirs ) {
        unless ( -d $dir ) {
            warn "Skipping nonexistent Directory $dir\n" if $verbose > 1;
            $dir = '';
            next;
        }
        warn "Resolving directory $dir\n" if $verbose;
        if ( File::Spec->file_name_is_absolute( $dir ) ) {
            $dir = VMS::Filespec::vmspath( $dir );
        }
        else {
            $dir = $self->catdir( $cwd, $dir );
        }
    }
    @dirs = grep { length( $_ ) } @dirs;
    unshift( @dirs, '' );    # Check each $lib without additions first

  LIB: foreach my $lib ( @libs ) {
        if ( exists $libmap{$lib} ) {
            next unless length $libmap{$lib};
            $lib = $libmap{$lib};
        }

        my ( @variants, $cand );
        my ( $ctype ) = '';

        # If we don't have a file type, consider it a possibly abbreviated name and
        # check for common variants.  We try these first to grab libraries before
        # a like-named executable image (e.g. -lperl resolves to perlshr.exe
        # before perl.exe).
        if ( $lib !~ /\.[^:>\]]*$/ ) {
            push( @variants, "${lib}shr", "${lib}rtl", "${lib}lib" );
            push( @variants, "lib$lib" ) if $lib !~ /[:>\]]/;
        }
        push( @variants, $lib );
        warn "Looking for $lib\n" if $verbose;
        foreach my $variant ( @variants ) {
            my ( $fullname, $name );

            foreach my $dir ( @dirs ) {
                my ( $type );

                $name = "$dir$variant";
                warn "\tChecking $name\n" if $verbose > 2;
                $fullname = VMS::Filespec::rmsexpand( $name );
                if ( defined $fullname and -f $fullname ) {

                    # It's got its own suffix, so we'll have to figure out the type
                    if    ( $fullname =~ /(?:$so|exe)$/i )      { $type = 'SHR'; }
                    elsif ( $fullname =~ /(?:$lib_ext|olb)$/i ) { $type = 'OLB'; }
                    elsif ( $fullname =~ /(?:$obj_ext|obj)$/i ) {
                        warn "Warning (mostly harmless): " . "Plain object file $fullname found in library list\n";
                        $type = 'OBJ';
                    }
                    else {
                        warn "Warning (mostly harmless): " . "Unknown library type for $fullname; assuming shared\n";
                        $type = 'SHR';
                    }
                }
                elsif (-f ( $fullname = VMS::Filespec::rmsexpand( $name, $so ) )
                    or -f ( $fullname = VMS::Filespec::rmsexpand( $name, '.exe' ) ) )
                {
                    $type = 'SHR';
                    $name = $fullname unless $fullname =~ /exe;?\d*$/i;
                }
                elsif (
                    not length( $ctype ) and    # If we've got a lib already,
                                                # don't bother
                    ( -f ( $fullname = VMS::Filespec::rmsexpand( $name, $lib_ext ) ) or -f ( $fullname = VMS::Filespec::rmsexpand( $name, '.olb' ) ) )
                  )
                {
                    $type = 'OLB';
                    $name = $fullname unless $fullname =~ /olb;?\d*$/i;
                }
                elsif (
                    not length( $ctype ) and    # If we've got a lib already,
                                                # don't bother
                    ( -f ( $fullname = VMS::Filespec::rmsexpand( $name, $obj_ext ) ) or -f ( $fullname = VMS::Filespec::rmsexpand( $name, '.obj' ) ) )
                  )
                {
                    warn "Warning (mostly harmless): " . "Plain object file $fullname found in library list\n";
                    $type = 'OBJ';
                    $name = $fullname unless $fullname =~ /obj;?\d*$/i;
                }
                if ( defined $type ) {
                    $ctype = $type;
                    $cand  = $name;
                    last if $ctype eq 'SHR';
                }
            }
            if ( $ctype ) {

                push @{ $found{$ctype} }, $cand;
                warn "\tFound as $cand (really $fullname), type $ctype\n"
                  if $verbose > 1;
                push @flibs, $name unless $libs_seen{$fullname}++;
                next LIB;
            }
        }
        warn "Warning (mostly harmless): " . "No library found for $lib\n";
    }

    push @fndlibs, @{ $found{OBJ} } if exists $found{OBJ};
    push @fndlibs, map { "$_/Library" } @{ $found{OLB} } if exists $found{OLB};
    push @fndlibs, map { "$_/Share" } @{ $found{SHR} }   if exists $found{SHR};
    my $lib = join( ' ', @fndlibs );

    $ldlib = $crtlstr ? "$lib $crtlstr" : $lib;
    $ldlib =~ s/^\s+|\s+$//g;
    warn "Result:\n\tEXTRALIBS: $lib\n\tLDLOADLIBS: $ldlib\n" if $verbose;
    wantarray ? ( $lib, '', $ldlib, '', ( $give_libs ? \@flibs : () ) ) : $lib;
}

1;
PK       ! �:���  ��    perl5/ExtUtils/Install.pmnu ��6�$        package ExtUtils::Install;
use strict;

use vars qw(@ISA @EXPORT $VERSION $MUST_REBOOT %Config);

use AutoSplit;
use Carp ();
use Config qw(%Config);
use Cwd qw(cwd);
use Exporter;
use ExtUtils::Packlist;
use File::Basename qw(dirname);
use File::Compare qw(compare);
use File::Copy;
use File::Find qw(find);
use File::Path;
use File::Spec;


@ISA = ('Exporter');
@EXPORT = ('install','uninstall','pm_to_blib', 'install_default');

=pod

=head1 NAME

ExtUtils::Install - install files from here to there

=head1 SYNOPSIS

  use ExtUtils::Install;

  install({ 'blib/lib' => 'some/install/dir' } );

  uninstall($packlist);

  pm_to_blib({ 'lib/Foo/Bar.pm' => 'blib/lib/Foo/Bar.pm' });

=head1 VERSION

2.06

=cut

$VERSION = '2.06';  # <-- do not forget to update the POD section just above this line!
$VERSION = eval $VERSION;

=pod

=head1 DESCRIPTION

Handles the installing and uninstalling of perl modules, scripts, man
pages, etc...

Both install() and uninstall() are specific to the way
ExtUtils::MakeMaker handles the installation and deinstallation of
perl modules. They are not designed as general purpose tools.

On some operating systems such as Win32 installation may not be possible
until after a reboot has occurred. This can have varying consequences:
removing an old DLL does not impact programs using the new one, but if
a new DLL cannot be installed properly until reboot then anything
depending on it must wait. The package variable

  $ExtUtils::Install::MUST_REBOOT

is used to store this status.

If this variable is true then such an operation has occurred and
anything depending on this module cannot proceed until a reboot
has occurred.

If this value is defined but false then such an operation has
ocurred, but should not impact later operations.

=over

=begin _private

=item _chmod($$;$)

Wrapper to chmod() for debugging and error trapping.

=item _warnonce(@)

Warns about something only once.

=item _choke(@)

Dies with a special message.

=back

=end _private

=cut

my $Is_VMS     = $^O eq 'VMS';
my $Is_MacPerl = $^O eq 'MacOS';
my $Is_Win32   = $^O eq 'MSWin32';
my $Is_cygwin  = $^O eq 'cygwin';
my $CanMoveAtBoot = ($Is_Win32 || $Is_cygwin);


my $Inc_uninstall_warn_handler;

# install relative to here

my $INSTALL_ROOT = $ENV{PERL_INSTALL_ROOT};
my $INSTALL_QUIET = $ENV{PERL_INSTALL_QUIET};

my $Curdir = File::Spec->curdir;
my $Updir  = File::Spec->updir;

sub _estr(@) {
    return join "\n",'!' x 72,@_,'!' x 72,'';
}

{my %warned;
sub _warnonce(@) {
    my $first=shift;
    my $msg=_estr "WARNING: $first",@_;
    warn $msg unless $warned{$msg}++;
}}

sub _choke(@) {
    my $first=shift;
    my $msg=_estr "ERROR: $first",@_;
    Carp::croak($msg);
}


sub _chmod($$;$) {
    my ( $mode, $item, $verbose )=@_;
    $verbose ||= 0;
    if (chmod $mode, $item) {
        printf "chmod(0%o, %s)\n",$mode, $item if $verbose > 1;
    } else {
        my $err="$!";
        _warnonce sprintf "WARNING: Failed chmod(0%o, %s): %s\n",
                  $mode, $item, $err
            if -e $item;
    }
}

=begin _private

=over

=item _move_file_at_boot( $file, $target, $moan  )

OS-Specific, Win32/Cygwin

Schedules a file to be moved/renamed/deleted at next boot.
$file should be a filespec of an existing file
$target should be a ref to an array if the file is to be deleted
otherwise it should be a filespec for a rename. If the file is existing
it will be replaced.

Sets $MUST_REBOOT to 0 to indicate a deletion operation has occurred
and sets it to 1 to indicate that a move operation has been requested.

returns 1 on success, on failure if $moan is false errors are fatal.
If $moan is true then returns 0 on error and warns instead of dies.

=end _private

=cut

{
    my $Has_Win32API_File;
    sub _move_file_at_boot { #XXX OS-SPECIFIC
        my ( $file, $target, $moan  )= @_;
        Carp::confess("Panic: Can't _move_file_at_boot on this platform!")
             unless $CanMoveAtBoot;

        my $descr= ref $target
                    ? "'$file' for deletion"
                    : "'$file' for installation as '$target'";

        # *note* CanMoveAtBoot is only incidentally the same condition as below
        # this needs not hold true in the future.
        $Has_Win32API_File = ($Is_Win32 || $Is_cygwin)
            ? (eval {require Win32API::File; 1} || 0)
            : 0 unless defined $Has_Win32API_File;
        if ( ! $Has_Win32API_File ) {

            my @msg=(
                "Cannot schedule $descr at reboot.",
                "Try installing Win32API::File to allow operations on locked files",
                "to be scheduled during reboot. Or try to perform the operation by",
                "hand yourself. (You may need to close other perl processes first)"
            );
            if ( $moan ) { _warnonce(@msg) } else { _choke(@msg) }
            return 0;
        }
        my $opts= Win32API::File::MOVEFILE_DELAY_UNTIL_REBOOT();
        $opts= $opts | Win32API::File::MOVEFILE_REPLACE_EXISTING()
            unless ref $target;

        _chmod( 0666, $file );
        _chmod( 0666, $target ) unless ref $target;

        if (Win32API::File::MoveFileEx( $file, $target, $opts )) {
            $MUST_REBOOT ||= ref $target ? 0 : 1;
            return 1;
        } else {
            my @msg=(
                "MoveFileEx $descr at reboot failed: $^E",
                "You may try to perform the operation by hand yourself. ",
                "(You may need to close other perl processes first).",
            );
            if ( $moan ) { _warnonce(@msg) } else { _choke(@msg) }
        }
        return 0;
    }
}


=begin _private


=item _unlink_or_rename( $file, $tryhard, $installing )

OS-Specific, Win32/Cygwin

Tries to get a file out of the way by unlinking it or renaming it. On
some OS'es (Win32 based) DLL files can end up locked such that they can
be renamed but not deleted. Likewise sometimes a file can be locked such
that it cant even be renamed or changed except at reboot. To handle
these cases this routine finds a tempfile name that it can either rename
the file out of the way or use as a proxy for the install so that the
rename can happen later (at reboot).

  $file : the file to remove.
  $tryhard : should advanced tricks be used for deletion
  $installing : we are not merely deleting but we want to overwrite

When $tryhard is not true if the unlink fails its fatal. When $tryhard
is true then the file is attempted to be renamed. The renamed file is
then scheduled for deletion. If the rename fails then $installing
governs what happens. If it is false the failure is fatal. If it is true
then an attempt is made to schedule installation at boot using a
temporary file to hold the new file. If this fails then a fatal error is
thrown, if it succeeds it returns the temporary file name (which will be
a derivative of the original in the same directory) so that the caller can
use it to install under. In all other cases of success returns $file.
On failure throws a fatal error.

=end _private

=cut


sub _unlink_or_rename { #XXX OS-SPECIFIC
    my ( $file, $tryhard, $installing )= @_;

    # this chmod was originally unconditional. However, its not needed on
    # POSIXy systems since permission to unlink a file is specified by the
    # directory rather than the file; and in fact it screwed up hard- and
    # symlinked files. Keep it for other platforms in case its still
    # needed there.
    if ($^O =~ /^(dos|os2|MSWin32|VMS)$/) {
        _chmod( 0666, $file );
    }
    my $unlink_count = 0;
    while (unlink $file) { $unlink_count++; }
    return $file if $unlink_count > 0;
    my $error="$!";

    _choke("Cannot unlink '$file': $!")
          unless $CanMoveAtBoot && $tryhard;

    my $tmp= "AAA";
    ++$tmp while -e "$file.$tmp";
    $tmp= "$file.$tmp";

    warn "WARNING: Unable to unlink '$file': $error\n",
         "Going to try to rename it to '$tmp'.\n";

    if ( rename $file, $tmp ) {
        warn "Rename successful. Scheduling '$tmp'\nfor deletion at reboot.\n";
        # when $installing we can set $moan to true.
        # IOW, if we cant delete the renamed file at reboot its
        # not the end of the world. The other cases are more serious
        # and need to be fatal.
        _move_file_at_boot( $tmp, [], $installing );
        return $file;
    } elsif ( $installing ) {
        _warnonce("Rename failed: $!. Scheduling '$tmp'\nfor".
             " installation as '$file' at reboot.\n");
        _move_file_at_boot( $tmp, $file );
        return $tmp;
    } else {
        _choke("Rename failed:$!", "Cannot proceed.");
    }

}


=pod

=back

=head2 Functions

=begin _private

=over

=item _get_install_skip

Handles loading the INSTALL.SKIP file. Returns an array of patterns to use.

=cut


sub _get_install_skip {
    my ( $skip, $verbose )= @_;
    if ($ENV{EU_INSTALL_IGNORE_SKIP}) {
        print "EU_INSTALL_IGNORE_SKIP is set, ignore skipfile settings\n"
            if $verbose>2;
        return [];
    }
    if ( ! defined $skip ) {
        print "Looking for install skip list\n"
            if $verbose>2;
        for my $file ( 'INSTALL.SKIP', $ENV{EU_INSTALL_SITE_SKIPFILE} ) {
            next unless $file;
            print "\tChecking for $file\n"
                if $verbose>2;
            if (-e $file) {
                $skip= $file;
                last;
            }
        }
    }
    if ($skip && !ref $skip) {
        print "Reading skip patterns from '$skip'.\n"
            if $verbose;
        if (open my $fh,$skip ) {
            my @patterns;
            while (<$fh>) {
                chomp;
                next if /^\s*(?:#|$)/;
                print "\tSkip pattern: $_\n" if $verbose>3;
                push @patterns, $_;
            }
            $skip= \@patterns;
        } else {
            warn "Can't read skip file:'$skip':$!\n";
            $skip=[];
        }
    } elsif ( UNIVERSAL::isa($skip,'ARRAY') ) {
        print "Using array for skip list\n"
            if $verbose>2;
    } elsif ($verbose) {
        print "No skip list found.\n"
            if $verbose>1;
        $skip= [];
    }
    warn "Got @{[0+@$skip]} skip patterns.\n"
        if $verbose>3;
    return $skip
}

=pod

=item _have_write_access

Abstract a -w check that tries to use POSIX::access() if possible.

=cut

{
    my  $has_posix;
    sub _have_write_access {
        my $dir=shift;
        unless (defined $has_posix) {
            $has_posix= (!$Is_cygwin && !$Is_Win32
             && eval 'local $^W; require POSIX; 1') || 0;
        }
        if ($has_posix) {
            return POSIX::access($dir, POSIX::W_OK());
        } else {
            return -w $dir;
        }
    }
}

=pod

=item _can_write_dir(C<$dir>)

Checks whether a given directory is writable, taking account
the possibility that the directory might not exist and would have to
be created first.

Returns a list, containing: C<($writable, $determined_by, @create)>

C<$writable> says whether the directory is (hypothetically) writable

C<$determined_by> is the directory the status was determined from. It will be
either the C<$dir>, or one of its parents.

C<@create> is a list of directories that would probably have to be created
to make the requested directory. It may not actually be correct on
relative paths with C<..> in them. But for our purposes it should work ok

=cut


sub _can_write_dir {
    my $dir=shift;
    return
        unless defined $dir and length $dir;

    my ($vol, $dirs, $file) = File::Spec->splitpath($dir,1);
    my @dirs = File::Spec->splitdir($dirs);
    unshift @dirs, File::Spec->curdir
        unless File::Spec->file_name_is_absolute($dir);

    my $path='';
    my @make;
    while (@dirs) {
        if ($Is_VMS) {
            $dir = File::Spec->catdir($vol,@dirs);
        }
        else {
            $dir = File::Spec->catdir(@dirs);
            $dir = File::Spec->catpath($vol,$dir,'')
                    if defined $vol and length $vol;
        }
        next if ( $dir eq $path );
        if ( ! -e $dir ) {
            unshift @make,$dir;
            next;
        }
        if ( _have_write_access($dir) ) {
            return 1,$dir,@make
        } else {
            return 0,$dir,@make
        }
    } continue {
        pop @dirs;
    }
    return 0;
}

=pod

=item _mkpath($dir,$show,$mode,$verbose,$dry_run)

Wrapper around File::Path::mkpath() to handle errors.

If $verbose is true and >1 then additional diagnostics will be produced, also
this will force $show to true.

If $dry_run is true then the directory will not be created but a check will be
made to see whether it would be possible to write to the directory, or that
it would be possible to create the directory.

If $dry_run is not true dies if the directory can not be created or is not
writable.

=cut

sub _mkpath {
    my ($dir,$show,$mode,$verbose,$dry_run)=@_;
    if ( $verbose && $verbose > 1 && ! -d $dir) {
        $show= 1;
        printf "mkpath(%s,%d,%#o)\n", $dir, $show, $mode;
    }
    if (!$dry_run) {
        if ( ! eval { File::Path::mkpath($dir,$show,$mode); 1 } ) {
            _choke("Can't create '$dir'","$@");
        }

    }
    my ($can,$root,@make)=_can_write_dir($dir);
    if (!$can) {
        my @msg=(
            "Can't create '$dir'",
            $root ? "Do not have write permissions on '$root'"
                  : "Unknown Error"
        );
        if ($dry_run) {
            _warnonce @msg;
        } else {
            _choke @msg;
        }
    } elsif ($show and $dry_run) {
        print "$_\n" for @make;
    }

}

=pod

=item _copy($from,$to,$verbose,$dry_run)

Wrapper around File::Copy::copy to handle errors.

If $verbose is true and >1 then additional diagnostics will be emitted.

If $dry_run is true then the copy will not actually occur.

Dies if the copy fails.

=cut


sub _copy {
    my ( $from, $to, $verbose, $dry_run)=@_;
    if ($verbose && $verbose>1) {
        printf "copy(%s,%s)\n", $from, $to;
    }
    if (!$dry_run) {
        File::Copy::copy($from,$to)
            or Carp::croak( _estr "ERROR: Cannot copy '$from' to '$to': $!" );
    }
}

=pod

=item _chdir($from)

Wrapper around chdir to catch errors.

If not called in void context returns the cwd from before the chdir.

dies on error.

=cut

sub _chdir {
    my ($dir)= @_;
    my $ret;
    if (defined wantarray) {
        $ret= cwd;
    }
    chdir $dir
        or _choke("Couldn't chdir to '$dir': $!");
    return $ret;
}

=pod

=back

=end _private

=over

=item B<install>

    # deprecated forms
    install(\%from_to);
    install(\%from_to, $verbose, $dry_run, $uninstall_shadows,
                $skip, $always_copy, \%result);

    # recommended form as of 1.47
    install([
        from_to => \%from_to,
        verbose => 1,
        dry_run => 0,
        uninstall_shadows => 1,
        skip => undef,
        always_copy => 1,
        result => \%install_results,
    ]);


Copies each directory tree of %from_to to its corresponding value
preserving timestamps and permissions.

There are two keys with a special meaning in the hash: "read" and
"write".  These contain packlist files.  After the copying is done,
install() will write the list of target files to $from_to{write}. If
$from_to{read} is given the contents of this file will be merged into
the written file. The read and the written file may be identical, but
on AFS it is quite likely that people are installing to a different
directory than the one where the files later appear.

If $verbose is true, will print out each file removed.  Default is
false.  This is "make install VERBINST=1". $verbose values going
up to 5 show increasingly more diagnostics output.

If $dry_run is true it will only print what it was going to do
without actually doing it.  Default is false.

If $uninstall_shadows is true any differing versions throughout @INC
will be uninstalled.  This is "make install UNINST=1"

As of 1.37_02 install() supports the use of a list of patterns to filter out
files that shouldn't be installed. If $skip is omitted or undefined then
install will try to read the list from INSTALL.SKIP in the CWD. This file is
a list of regular expressions and is just like the MANIFEST.SKIP file used
by L<ExtUtils::Manifest>.

A default site INSTALL.SKIP may be provided by setting then environment
variable EU_INSTALL_SITE_SKIPFILE, this will only be used when there isn't a
distribution specific INSTALL.SKIP. If the environment variable
EU_INSTALL_IGNORE_SKIP is true then no install file filtering will be
performed.

If $skip is undefined then the skip file will be autodetected and used if it
is found. If $skip is a reference to an array then it is assumed the array
contains the list of patterns, if $skip is a true non reference it is
assumed to be the filename holding the list of patterns, any other value of
$skip is taken to mean that no install filtering should occur.

B<Changes As of Version 1.47>

As of version 1.47 the following additions were made to the install interface.
Note that the new argument style and use of the %result hash is recommended.

The $always_copy parameter which when true causes files to be updated
regardless as to whether they have changed, if it is defined but false then
copies are made only if the files have changed, if it is undefined then the
value of the environment variable EU_INSTALL_ALWAYS_COPY is used as default.

The %result hash will be populated with the various keys/subhashes reflecting
the install. Currently these keys and their structure are:

    install             => { $target    => $source },
    install_fail        => { $target    => $source },
    install_unchanged   => { $target    => $source },

    install_filtered    => { $source    => $pattern },

    uninstall           => { $uninstalled => $source },
    uninstall_fail      => { $uninstalled => $source },

where C<$source> is the filespec of the file being installed. C<$target> is where
it is being installed to, and C<$uninstalled> is any shadow file that is in C<@INC>
or C<$ENV{PERL5LIB}> or other standard locations, and C<$pattern> is the pattern that
caused a source file to be skipped. In future more keys will be added, such as to
show created directories, however this requires changes in other modules and must
therefore wait.

These keys will be populated before any exceptions are thrown should there be an
error.

Note that all updates of the %result are additive, the hash will not be
cleared before use, thus allowing status results of many installs to be easily
aggregated.

B<NEW ARGUMENT STYLE>

If there is only one argument and it is a reference to an array then
the array is assumed to contain a list of key-value pairs specifying
the options. In this case the option "from_to" is mandatory. This style
means that you do not have to supply a cryptic list of arguments and can
use a self documenting argument list that is easier to understand.

This is now the recommended interface to install().

B<RETURN>

If all actions were successful install will return a hashref of the results
as described above for the $result parameter. If any action is a failure
then install will die, therefore it is recommended to pass in the $result
parameter instead of using the return value. If the result parameter is
provided then the returned hashref will be the passed in hashref.

=cut

sub install { #XXX OS-SPECIFIC
    my($from_to,$verbose,$dry_run,$uninstall_shadows,$skip,$always_copy,$result) = @_;
    if (@_==1 and eval { 1+@$from_to }) {
        my %opts        = @$from_to;
        $from_to        = $opts{from_to}
                            or Carp::confess("from_to is a mandatory parameter");
        $verbose        = $opts{verbose};
        $dry_run        = $opts{dry_run};
        $uninstall_shadows  = $opts{uninstall_shadows};
        $skip           = $opts{skip};
        $always_copy    = $opts{always_copy};
        $result         = $opts{result};
    }

    $result ||= {};
    $verbose ||= 0;
    $dry_run  ||= 0;

    $skip= _get_install_skip($skip,$verbose);
    $always_copy =  $ENV{EU_INSTALL_ALWAYS_COPY}
                 || $ENV{EU_ALWAYS_COPY}
                 || 0
        unless defined $always_copy;

    my(%from_to) = %$from_to;
    my(%pack, $dir, %warned);
    my($packlist) = ExtUtils::Packlist->new();

    local(*DIR);
    for (qw/read write/) {
        $pack{$_}=$from_to{$_};
        delete $from_to{$_};
    }
    my $tmpfile = install_rooted_file($pack{"read"});
    $packlist->read($tmpfile) if (-f $tmpfile);
    my $cwd = cwd();
    my @found_files;
    my %check_dirs;

    MOD_INSTALL: foreach my $source (sort keys %from_to) {
        #copy the tree to the target directory without altering
        #timestamp and permission and remember for the .packlist
        #file. The packlist file contains the absolute paths of the
        #install locations. AFS users may call this a bug. We'll have
        #to reconsider how to add the means to satisfy AFS users also.

        #October 1997: we want to install .pm files into archlib if
        #there are any files in arch. So we depend on having ./blib/arch
        #hardcoded here.

        my $targetroot = install_rooted_dir($from_to{$source});

        my $blib_lib  = File::Spec->catdir('blib', 'lib');
        my $blib_arch = File::Spec->catdir('blib', 'arch');
        if ($source eq $blib_lib and
            exists $from_to{$blib_arch} and
            directory_not_empty($blib_arch)
        ){
            $targetroot = install_rooted_dir($from_to{$blib_arch});
            print "Files found in $blib_arch: installing files in $blib_lib into architecture dependent library tree\n";
        }

        next unless -d $source;
        _chdir($source);
        # 5.5.3's File::Find missing no_chdir option
        # XXX OS-SPECIFIC
        # File::Find seems to always be Unixy except on MacPerl :(
        my $current_directory= $Is_MacPerl ? $Curdir : '.';
        find(sub {
            my ($mode,$size,$atime,$mtime) = (stat)[2,7,8,9];

            return if !-f _;
            my $origfile = $_;

            return if $origfile eq ".exists";
            my $targetdir  = File::Spec->catdir($targetroot, $File::Find::dir);
            my $targetfile = File::Spec->catfile($targetdir, $origfile);
            my $sourcedir  = File::Spec->catdir($source, $File::Find::dir);
            my $sourcefile = File::Spec->catfile($sourcedir, $origfile);

            for my $pat (@$skip) {
                if ( $sourcefile=~/$pat/ ) {
                    print "Skipping $targetfile (filtered)\n"
                        if $verbose>1;
                    $result->{install_filtered}{$sourcefile} = $pat;
                    return;
                }
            }
            # we have to do this for back compat with old File::Finds
            # and because the target is relative
            my $save_cwd = _chdir($cwd);
            my $diff = 0;
            # XXX: I wonder how useful this logic is actually -- demerphq
            if ( $always_copy or !-f $targetfile or -s $targetfile != $size) {
                $diff++;
            } else {
                # we might not need to copy this file
                $diff = compare($sourcefile, $targetfile);
            }
            $check_dirs{$targetdir}++
                unless -w $targetfile;

            push @found_files,
                [ $diff, $File::Find::dir, $origfile,
                  $mode, $size, $atime, $mtime,
                  $targetdir, $targetfile, $sourcedir, $sourcefile,

                ];
            #restore the original directory we were in when File::Find
            #called us so that it doesn't get horribly confused.
            _chdir($save_cwd);
        }, $current_directory );
        _chdir($cwd);
    }
    foreach my $targetdir (sort keys %check_dirs) {
        _mkpath( $targetdir, 0, 0755, $verbose, $dry_run );
    }
    foreach my $found (@found_files) {
        my ($diff, $ffd, $origfile, $mode, $size, $atime, $mtime,
            $targetdir, $targetfile, $sourcedir, $sourcefile)= @$found;

        my $realtarget= $targetfile;
        if ($diff) {
            eval {
                if (-f $targetfile) {
                    print "_unlink_or_rename($targetfile)\n" if $verbose>1;
                    $targetfile= _unlink_or_rename( $targetfile, 'tryhard', 'install' )
                        unless $dry_run;
                } elsif ( ! -d $targetdir ) {
                    _mkpath( $targetdir, 0, 0755, $verbose, $dry_run );
                }
                print "Installing $targetfile\n";

                _copy( $sourcefile, $targetfile, $verbose, $dry_run, );


                #XXX OS-SPECIFIC
                print "utime($atime,$mtime,$targetfile)\n" if $verbose>1;
                utime($atime,$mtime + $Is_VMS,$targetfile) unless $dry_run>1;


                $mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
                $mode = $mode | 0222
                    if $realtarget ne $targetfile;
                _chmod( $mode, $targetfile, $verbose );
                $result->{install}{$targetfile} = $sourcefile;
                1
            } or do {
                $result->{install_fail}{$targetfile} = $sourcefile;
                die $@;
            };
        } else {
            $result->{install_unchanged}{$targetfile} = $sourcefile;
            print "Skipping $targetfile (unchanged)\n" if $verbose;
        }

        if ( $uninstall_shadows ) {
            inc_uninstall($sourcefile,$ffd, $verbose,
                          $dry_run,
                          $realtarget ne $targetfile ? $realtarget : "",
                          $result);
        }

        # Record the full pathname.
        $packlist->{$targetfile}++;
    }

    if ($pack{'write'}) {
        $dir = install_rooted_dir(dirname($pack{'write'}));
        _mkpath( $dir, 0, 0755, $verbose, $dry_run );
        print "Writing $pack{'write'}\n" if $verbose;
        $packlist->write(install_rooted_file($pack{'write'})) unless $dry_run;
    }

    _do_cleanup($verbose);
    return $result;
}

=begin _private

=item _do_cleanup

Standardize finish event for after another instruction has occurred.
Handles converting $MUST_REBOOT to a die for instance.

=end _private

=cut

sub _do_cleanup {
    my ($verbose) = @_;
    if ($MUST_REBOOT) {
        die _estr "Operation not completed! ",
            "You must reboot to complete the installation.",
            "Sorry.";
    } elsif (defined $MUST_REBOOT & $verbose) {
        warn _estr "Installation will be completed at the next reboot.\n",
             "However it is not necessary to reboot immediately.\n";
    }
}

=begin _undocumented

=item install_rooted_file( $file )

Returns $file, or catfile($INSTALL_ROOT,$file) if $INSTALL_ROOT
is defined.

=item install_rooted_dir( $dir )

Returns $dir, or catdir($INSTALL_ROOT,$dir) if $INSTALL_ROOT
is defined.

=end _undocumented

=cut


sub install_rooted_file {
    if (defined $INSTALL_ROOT) {
        File::Spec->catfile($INSTALL_ROOT, $_[0]);
    } else {
        $_[0];
    }
}


sub install_rooted_dir {
    if (defined $INSTALL_ROOT) {
        File::Spec->catdir($INSTALL_ROOT, $_[0]);
    } else {
        $_[0];
    }
}

=begin _undocumented

=item forceunlink( $file, $tryhard )

Tries to delete a file. If $tryhard is true then we will use whatever
devious tricks we can to delete the file. Currently this only applies to
Win32 in that it will try to use Win32API::File to schedule a delete at
reboot. A wrapper for _unlink_or_rename().

=end _undocumented

=cut


sub forceunlink {
    my ( $file, $tryhard )= @_; #XXX OS-SPECIFIC
    _unlink_or_rename( $file, $tryhard, not("installing") );
}

=begin _undocumented

=item directory_not_empty( $dir )

Returns 1 if there is an .exists file somewhere in a directory tree.
Returns 0 if there is not.

=end _undocumented

=cut

sub directory_not_empty ($) {
  my($dir) = @_;
  my $files = 0;
  find(sub {
           return if $_ eq ".exists";
           if (-f) {
             $File::Find::prune++;
             $files = 1;
           }
       }, $dir);
  return $files;
}

=pod

=item B<install_default> I<DISCOURAGED>

    install_default();
    install_default($fullext);

Calls install() with arguments to copy a module from blib/ to the
default site installation location.

$fullext is the name of the module converted to a directory
(ie. Foo::Bar would be Foo/Bar).  If $fullext is not specified, it
will attempt to read it from @ARGV.

This is primarily useful for install scripts.

B<NOTE> This function is not really useful because of the hard-coded
install location with no way to control site vs core vs vendor
directories and the strange way in which the module name is given.
Consider its use discouraged.

=cut

sub install_default {
  @_ < 2 or Carp::croak("install_default should be called with 0 or 1 argument");
  my $FULLEXT = @_ ? shift : $ARGV[0];
  defined $FULLEXT or die "Do not know to where to write install log";
  my $INST_LIB = File::Spec->catdir($Curdir,"blib","lib");
  my $INST_ARCHLIB = File::Spec->catdir($Curdir,"blib","arch");
  my $INST_BIN = File::Spec->catdir($Curdir,'blib','bin');
  my $INST_SCRIPT = File::Spec->catdir($Curdir,'blib','script');
  my $INST_MAN1DIR = File::Spec->catdir($Curdir,'blib','man1');
  my $INST_MAN3DIR = File::Spec->catdir($Curdir,'blib','man3');

  my @INST_HTML;
  if($Config{installhtmldir}) {
      my $INST_HTMLDIR = File::Spec->catdir($Curdir,'blib','html');
      @INST_HTML = ($INST_HTMLDIR => $Config{installhtmldir});
  }

  install({
           read => "$Config{sitearchexp}/auto/$FULLEXT/.packlist",
           write => "$Config{installsitearch}/auto/$FULLEXT/.packlist",
           $INST_LIB => (directory_not_empty($INST_ARCHLIB)) ?
                         $Config{installsitearch} :
                         $Config{installsitelib},
           $INST_ARCHLIB => $Config{installsitearch},
           $INST_BIN => $Config{installbin} ,
           $INST_SCRIPT => $Config{installscript},
           $INST_MAN1DIR => $Config{installman1dir},
           $INST_MAN3DIR => $Config{installman3dir},
       @INST_HTML,
          },1,0,0);
}


=item B<uninstall>

    uninstall($packlist_file);
    uninstall($packlist_file, $verbose, $dont_execute);

Removes the files listed in a $packlist_file.

If $verbose is true, will print out each file removed.  Default is
false.

If $dont_execute is true it will only print what it was going to do
without actually doing it.  Default is false.

=cut

sub uninstall {
    my($fil,$verbose,$dry_run) = @_;
    $verbose ||= 0;
    $dry_run  ||= 0;

    die _estr "ERROR: no packlist file found: '$fil'"
        unless -f $fil;
    # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
    # require $my_req; # Hairy, but for the first
    my ($packlist) = ExtUtils::Packlist->new($fil);
    foreach (sort(keys(%$packlist))) {
        chomp;
        print "unlink $_\n" if $verbose;
        forceunlink($_,'tryhard') unless $dry_run;
    }
    print "unlink $fil\n" if $verbose;
    forceunlink($fil, 'tryhard') unless $dry_run;
    _do_cleanup($verbose);
}

=begin _undocumented

=item inc_uninstall($filepath,$libdir,$verbose,$dry_run,$ignore,$results)

Remove shadowed files. If $ignore is true then it is assumed to hold
a filename to ignore. This is used to prevent spurious warnings from
occurring when doing an install at reboot.

We now only die when failing to remove a file that has precedence over
our own, when our install has precedence we only warn.

$results is assumed to contain a hashref which will have the keys
'uninstall' and 'uninstall_fail' populated with  keys for the files
removed and values of the source files they would shadow.

=end _undocumented

=cut

sub inc_uninstall {
    my($filepath,$libdir,$verbose,$dry_run,$ignore,$results) = @_;
    my($dir);
    $ignore||="";
    my $file = (File::Spec->splitpath($filepath))[2];
    my %seen_dir = ();

    my @PERL_ENV_LIB = split $Config{path_sep}, defined $ENV{'PERL5LIB'}
      ? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'} || '';

    my @dirs=( @PERL_ENV_LIB,
               @INC,
               @Config{qw(archlibexp
                          privlibexp
                          sitearchexp
                          sitelibexp)});

    #warn join "\n","---",@dirs,"---";
    my $seen_ours;
    foreach $dir ( @dirs ) {
        my $canonpath = $Is_VMS ? $dir : File::Spec->canonpath($dir);
        next if $canonpath eq $Curdir;
        next if $seen_dir{$canonpath}++;
        my $targetfile = File::Spec->catfile($canonpath,$libdir,$file);
        next unless -f $targetfile;

        # The reason why we compare file's contents is, that we cannot
        # know, which is the file we just installed (AFS). So we leave
        # an identical file in place
        my $diff = 0;
        if ( -f $targetfile && -s _ == -s $filepath) {
            # We have a good chance, we can skip this one
            $diff = compare($filepath,$targetfile);
        } else {
            $diff++;
        }
        print "#$file and $targetfile differ\n" if $diff && $verbose > 1;

        if (!$diff or $targetfile eq $ignore) {
            $seen_ours = 1;
            next;
        }
        if ($dry_run) {
            $results->{uninstall}{$targetfile} = $filepath;
            if ($verbose) {
                $Inc_uninstall_warn_handler ||= ExtUtils::Install::Warn->new();
                $libdir =~ s|^\./||s ; # That's just cosmetics, no need to port. It looks prettier.
                $Inc_uninstall_warn_handler->add(
                                     File::Spec->catfile($libdir, $file),
                                     $targetfile
                                    );
            }
            # if not verbose, we just say nothing
        } else {
            print "Unlinking $targetfile (shadowing?)\n" if $verbose;
            eval {
                die "Fake die for testing"
                    if $ExtUtils::Install::Testing and
                       ucase(File::Spec->canonpath($ExtUtils::Install::Testing)) eq ucase($targetfile);
                forceunlink($targetfile,'tryhard');
                $results->{uninstall}{$targetfile} = $filepath;
                1;
            } or do {
                $results->{fail_uninstall}{$targetfile} = $filepath;
                if ($seen_ours) {
                    warn "Failed to remove probably harmless shadow file '$targetfile'\n";
                } else {
                    die "$@\n";
                }
            };
        }
    }
}

=begin _undocumented

=item run_filter($cmd,$src,$dest)

Filter $src using $cmd into $dest.

=end _undocumented

=cut

sub run_filter {
    my ($cmd, $src, $dest) = @_;
    local(*CMD, *SRC);
    open(CMD, "|$cmd >$dest") || die "Cannot fork: $!";
    open(SRC, $src)           || die "Cannot open $src: $!";
    my $buf;
    my $sz = 1024;
    while (my $len = sysread(SRC, $buf, $sz)) {
        syswrite(CMD, $buf, $len);
    }
    close SRC;
    close CMD or die "Filter command '$cmd' failed for $src";
}

=pod

=item B<pm_to_blib>

    pm_to_blib(\%from_to);
    pm_to_blib(\%from_to, $autosplit_dir);
    pm_to_blib(\%from_to, $autosplit_dir, $filter_cmd);

Copies each key of %from_to to its corresponding value efficiently.
If an $autosplit_dir is provided, all .pm files will be autosplit into it.
Any destination directories are created.

$filter_cmd is an optional shell command to run each .pm file through
prior to splitting and copying.  Input is the contents of the module,
output the new module contents.

You can have an environment variable PERL_INSTALL_ROOT set which will
be prepended as a directory to each installed file (and directory).

By default verbose output is generated, setting the PERL_INSTALL_QUIET
environment variable will silence this output.

=cut

sub pm_to_blib {
    my($fromto,$autodir,$pm_filter) = @_;

    _mkpath($autodir,0,0755) if defined $autodir;
    while(my($from, $to) = each %$fromto) {
        if( -f $to && -s $from == -s $to && -M $to < -M $from ) {
            print "Skip $to (unchanged)\n" unless $INSTALL_QUIET;
            next;
        }

        # When a pm_filter is defined, we need to pre-process the source first
        # to determine whether it has changed or not.  Therefore, only perform
        # the comparison check when there's no filter to be ran.
        #    -- RAM, 03/01/2001

        my $need_filtering = defined $pm_filter && length $pm_filter &&
                             $from =~ /\.pm$/;

        if (!$need_filtering && 0 == compare($from,$to)) {
            print "Skip $to (unchanged)\n" unless $INSTALL_QUIET;
            next;
        }
        if (-f $to){
            # we wont try hard here. its too likely to mess things up.
            forceunlink($to);
        } else {
            _mkpath(dirname($to),0,0755);
        }
        if ($need_filtering) {
            run_filter($pm_filter, $from, $to);
            print "$pm_filter <$from >$to\n";
        } else {
            _copy( $from, $to );
            print "cp $from $to\n" unless $INSTALL_QUIET;
        }
        my($mode,$atime,$mtime) = (stat $from)[2,8,9];
        utime($atime,$mtime+$Is_VMS,$to);
        _chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$to);
        next unless $from =~ /\.pm$/;
        _autosplit($to,$autodir) if defined $autodir;
    }
}


=begin _private

=item _autosplit

From 1.0307 back, AutoSplit will sometimes leave an open filehandle to
the file being split.  This causes problems on systems with mandatory
locking (ie. Windows).  So we wrap it and close the filehandle.

=end _private

=cut

sub _autosplit { #XXX OS-SPECIFIC
    my $retval = autosplit(@_);
    close *AutoSplit::IN if defined *AutoSplit::IN{IO};

    return $retval;
}


package ExtUtils::Install::Warn;

sub new { bless {}, shift }

sub add {
    my($self,$file,$targetfile) = @_;
    push @{$self->{$file}}, $targetfile;
}

sub DESTROY {
    unless(defined $INSTALL_ROOT) {
        my $self = shift;
        my($file,$i,$plural);
        foreach $file (sort keys %$self) {
            $plural = @{$self->{$file}} > 1 ? "s" : "";
            print "## Differing version$plural of $file found. You might like to\n";
            for (0..$#{$self->{$file}}) {
                print "rm ", $self->{$file}[$_], "\n";
                $i++;
            }
        }
        $plural = $i>1 ? "all those files" : "this file";
        my $inst = (_invokant() eq 'ExtUtils::MakeMaker')
                 ? ( $Config::Config{make} || 'make' ).' install'
                     . ( $Is_VMS ? '/MACRO="UNINST"=1' : ' UNINST=1' )
                 : './Build install uninst=1';
        print "## Running '$inst' will unlink $plural for you.\n";
    }
}

=begin _private

=item _invokant

Does a heuristic on the stack to see who called us for more intelligent
error messages. Currently assumes we will be called only by Module::Build
or by ExtUtils::MakeMaker.

=end _private

=cut

sub _invokant {
    my @stack;
    my $frame = 0;
    while (my $file = (caller($frame++))[1]) {
        push @stack, (File::Spec->splitpath($file))[2];
    }

    my $builder;
    my $top = pop @stack;
    if ($top =~ /^Build/i || exists($INC{'Module/Build.pm'})) {
        $builder = 'Module::Build';
    } else {
        $builder = 'ExtUtils::MakeMaker';
    }
    return $builder;
}

=pod

=back

=head1 ENVIRONMENT

=over 4

=item B<PERL_INSTALL_ROOT>

Will be prepended to each install path.

=item B<EU_INSTALL_IGNORE_SKIP>

Will prevent the automatic use of INSTALL.SKIP as the install skip file.

=item B<EU_INSTALL_SITE_SKIPFILE>

If there is no INSTALL.SKIP file in the make directory then this value
can be used to provide a default.

=item B<EU_INSTALL_ALWAYS_COPY>

If this environment variable is true then normal install processes will
always overwrite older identical files during the install process.

Note that the alias EU_ALWAYS_COPY will be supported if EU_INSTALL_ALWAYS_COPY
is not defined until at least the 1.50 release. Please ensure you use the
correct EU_INSTALL_ALWAYS_COPY.

=back

=head1 AUTHOR

Original author lost in the mists of time.  Probably the same as Makemaker.

Production release currently maintained by demerphq C<yves at cpan.org>,
extensive changes by Michael G. Schwern.

Send bug reports via http://rt.cpan.org/.  Please send your
generated Makefile along with your report.

=head1 LICENSE

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

See L<http://www.perl.com/perl/misc/Artistic.html>


=cut

1;
PK       ! p^�  �    perl5/ExtUtils/MM_Darwin.pmnu ��6�$        package ExtUtils::MM_Darwin;

use strict;
use warnings;

BEGIN {
    require ExtUtils::MM_Unix;
    our @ISA = qw( ExtUtils::MM_Unix );
}

our $VERSION = '7.50';
$VERSION =~ tr/_//d;


=head1 NAME

ExtUtils::MM_Darwin - special behaviors for OS X

=head1 SYNOPSIS

    For internal MakeMaker use only

=head1 DESCRIPTION

See L<ExtUtils::MM_Unix> or L<ExtUtils::MM_Any> for documentation on the
methods overridden here.

=head2 Overridden Methods

=head3 init_dist

Turn off Apple tar's tendency to copy resource forks as "._foo" files.

=cut

sub init_dist {
    my $self = shift;

    # Thank you, Apple, for breaking tar and then breaking the work around.
    # 10.4 wants COPY_EXTENDED_ATTRIBUTES_DISABLE while 10.5 wants
    # COPYFILE_DISABLE.  I'm not going to push my luck and instead just
    # set both.
    $self->{TAR} ||=
        'COPY_EXTENDED_ATTRIBUTES_DISABLE=1 COPYFILE_DISABLE=1 tar';

    $self->SUPER::init_dist(@_);
}

=head3 cflags

Over-ride Apple's automatic setting of -Werror

=cut

sub cflags {
    my $self = shift;

    $self->{CCFLAGS} .= ($self->{CCFLAGS} ? ' ' : '').'-Wno-error=implicit-function-declaration';

    $self->SUPER::cflags(@_);
}

1;
PK       ! �rWh  h    perl5/ExtUtils/MM_NW5.pmnu ��6�$        package ExtUtils::MM_NW5;

=head1 NAME

ExtUtils::MM_NW5 - methods to override UN*X behaviour in ExtUtils::MakeMaker

=head1 SYNOPSIS

 use ExtUtils::MM_NW5; # Done internally by ExtUtils::MakeMaker if needed

=head1 DESCRIPTION

See L<ExtUtils::MM_Unix> for a documentation of the methods provided
there. This package overrides the implementation of these methods, not
the semantics.

=over

=cut

use strict;
use warnings;
use ExtUtils::MakeMaker::Config;
use File::Basename;

our $VERSION = '7.50';
$VERSION =~ tr/_//d;

require ExtUtils::MM_Win32;
our @ISA = qw(ExtUtils::MM_Win32);

use ExtUtils::MakeMaker qw(&neatvalue &_sprintf562);

$ENV{EMXSHELL} = 'sh'; # to run `commands`

my $BORLAND  = $Config{'cc'} =~ /\bbcc/i;
my $GCC      = $Config{'cc'} =~ /\bgcc/i;


=item os_flavor

We're Netware in addition to being Windows.

=cut

sub os_flavor {
    my $self = shift;
    return ($self->SUPER::os_flavor, 'Netware');
}

=item init_platform

Add Netware macros.

LIBPTH, BASE_IMPORT, NLM_VERSION, MPKTOOL, TOOLPATH, BOOT_SYMBOL,
NLM_SHORT_NAME, INCLUDE, PATH, MM_NW5_REVISION


=item platform_constants

Add Netware macros initialized above to the Makefile.

=cut

sub init_platform {
    my($self) = shift;

    # To get Win32's setup.
    $self->SUPER::init_platform;

    # incpath is copied to makefile var INCLUDE in constants sub, here just
    # make it empty
    my $libpth = $Config{'libpth'};
    $libpth =~ s( )(;);
    $self->{'LIBPTH'} = $libpth;

    $self->{'BASE_IMPORT'} = $Config{'base_import'};

    # Additional import file specified from Makefile.pl
    if($self->{'base_import'}) {
        $self->{'BASE_IMPORT'} .= ', ' . $self->{'base_import'};
    }

    $self->{'NLM_VERSION'} = $Config{'nlm_version'};
    $self->{'MPKTOOL'}	= $Config{'mpktool'};
    $self->{'TOOLPATH'}	= $Config{'toolpath'};

    (my $boot = $self->{'NAME'}) =~ s/:/_/g;
    $self->{'BOOT_SYMBOL'}=$boot;

    # If the final binary name is greater than 8 chars,
    # truncate it here.
    if(length($self->{'BASEEXT'}) > 8) {
        $self->{'NLM_SHORT_NAME'} = substr($self->{'BASEEXT'},0,8);
    }

    # Get the include path and replace the spaces with ;
    # Copy this to makefile as INCLUDE = d:\...;d:\;
    ($self->{INCLUDE} = $Config{'incpath'}) =~ s/([ ]*)-I/;/g;

    # Set the path to CodeWarrior binaries which might not have been set in
    # any other place
    $self->{PATH} = '$(PATH);$(TOOLPATH)';

    $self->{MM_NW5_VERSION} = $VERSION;
}

sub platform_constants {
    my($self) = shift;
    my $make_frag = '';

    # Setup Win32's constants.
    $make_frag .= $self->SUPER::platform_constants;

    foreach my $macro (qw(LIBPTH BASE_IMPORT NLM_VERSION MPKTOOL
                          TOOLPATH BOOT_SYMBOL NLM_SHORT_NAME INCLUDE PATH
                          MM_NW5_VERSION
                      ))
    {
        next unless defined $self->{$macro};
        $make_frag .= "$macro = $self->{$macro}\n";
    }

    return $make_frag;
}

=item static_lib_pure_cmd

Defines how to run the archive utility

=cut

sub static_lib_pure_cmd {
    my ($self, $src) = @_;
    $src =~ s/(\$\(\w+)(\))/$1:^"+"$2/g if $BORLAND;
    sprintf qq{\t\$(AR) %s\n}, ($BORLAND ? '$@ ' . $src
                          : ($GCC ? '-ru $@ ' . $src
                                  : '-type library -o $@ ' . $src));
}

=item xs_static_lib_is_xs

=cut

sub xs_static_lib_is_xs {
    return 1;
}

=item dynamic_lib

Override of utility methods for OS-specific work.

=cut

sub xs_make_dynamic_lib {
    my ($self, $attribs, $from, $to, $todir, $ldfrom, $exportlist) = @_;
    my @m;
    # Taking care of long names like FileHandle, ByteLoader, SDBM_File etc
    if ($to =~ /^\$/) {
        if ($self->{NLM_SHORT_NAME}) {
            # deal with shortnames
            my $newto = q{$(INST_AUTODIR)\\$(NLM_SHORT_NAME).$(DLEXT)};
            push @m, "$to: $newto\n\n";
            $to = $newto;
        }
    } else {
        my ($v, $d, $f) = File::Spec->splitpath($to);
        # relies on $f having a literal "." in it, unlike for $(OBJ_EXT)
        if ($f =~ /[^\.]{9}\./) {
            # 9+ chars before '.', need to shorten
            $f = substr $f, 0, 8;
        }
        my $newto = File::Spec->catpath($v, $d, $f);
        push @m, "$to: $newto\n\n";
        $to = $newto;
    }
    # bits below should be in dlsyms, not here
    #                                   1    2      3       4
    push @m, _sprintf562 <<'MAKE_FRAG', $to, $from, $todir, $exportlist;
# Create xdc data for an MT safe NLM in case of mpk build
%1$s: %2$s $(MYEXTLIB) $(BOOTSTRAP) %3$s$(DFSEP).exists
	$(NOECHO) $(ECHO) Export boot_$(BOOT_SYMBOL) > %4$s
	$(NOECHO) $(ECHO) $(BASE_IMPORT) >> %4$s
	$(NOECHO) $(ECHO) Import @$(PERL_INC)\perl.imp >> %4$s
MAKE_FRAG
    if ( $self->{CCFLAGS} =~ m/ -DMPK_ON /) {
        (my $xdc = $exportlist) =~ s#def\z#xdc#;
        $xdc = '$(BASEEXT).xdc';
        push @m, sprintf <<'MAKE_FRAG', $xdc, $exportlist;
	$(MPKTOOL) $(XDCFLAGS) %s
	$(NOECHO) $(ECHO) xdcdata $(BASEEXT).xdc >> %s
MAKE_FRAG
    }
    # Reconstruct the X.Y.Z version.
    my $version = join '.', map { sprintf "%d", $_ }
                              "$]" =~ /(\d)\.(\d{3})(\d{2})/;
    push @m, sprintf <<'EOF', $from, $version, $to, $exportlist;
	$(LD) $(LDFLAGS) %s -desc "Perl %s Extension ($(BASEEXT))  XS_VERSION: $(XS_VERSION)" -nlmversion $(NLM_VERSION) -o %s $(MYEXTLIB) $(PERL_INC)\Main.lib -commandfile %s
	$(CHMOD) 755 $@
EOF
    join '', @m;
}

1;
__END__

=back

=cut
PK       ! ����:  �:    perl5/ExtUtils/MM_Win32.pmnu ��6�$        package ExtUtils::MM_Win32;

use strict;
use warnings;

=head1 NAME

ExtUtils::MM_Win32 - methods to override UN*X behaviour in ExtUtils::MakeMaker

=head1 SYNOPSIS

 use ExtUtils::MM_Win32; # Done internally by ExtUtils::MakeMaker if needed

=head1 DESCRIPTION

See L<ExtUtils::MM_Unix> for a documentation of the methods provided
there. This package overrides the implementation of these methods, not
the semantics.

=cut

use ExtUtils::MakeMaker::Config;
use File::Basename;
use File::Spec;
use ExtUtils::MakeMaker qw(neatvalue _sprintf562);

require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );
our $VERSION = '7.50';
$VERSION =~ tr/_//d;

$ENV{EMXSHELL} = 'sh'; # to run `commands`

my ( $BORLAND, $GCC, $MSVC ) = _identify_compiler_environment( \%Config );

sub _identify_compiler_environment {
	my ( $config ) = @_;

	my $BORLAND = $config->{cc} =~ /\bbcc/i ? 1 : 0;
	my $GCC     = $config->{cc} =~ /\bgcc\b/i ? 1 : 0;
	my $MSVC    = $config->{cc} =~ /\b(?:cl|icl)/i ? 1 : 0; # MSVC can come as clarm.exe, icl=Intel C

	return ( $BORLAND, $GCC, $MSVC );
}


=head2 Overridden methods

=over 4

=item B<dlsyms>

=cut

sub dlsyms {
    my($self,%attribs) = @_;
    return '' if $self->{SKIPHASH}{'dynamic'};
    $self->xs_dlsyms_iterator(\%attribs);
}

=item xs_dlsyms_ext

On Win32, is C<.def>.

=cut

sub xs_dlsyms_ext {
    '.def';
}

=item replace_manpage_separator

Changes the path separator with .

=cut

sub replace_manpage_separator {
    my($self,$man) = @_;
    $man =~ s,[/\\]+,.,g;
    $man;
}


=item B<maybe_command>

Since Windows has nothing as simple as an executable bit, we check the
file extension.

The PATHEXT env variable will be used to get a list of extensions that
might indicate a command, otherwise .com, .exe, .bat and .cmd will be
used by default.

=cut

sub maybe_command {
    my($self,$file) = @_;
    my @e = exists($ENV{'PATHEXT'})
          ? split(/;/, $ENV{PATHEXT})
	  : qw(.com .exe .bat .cmd);
    my $e = '';
    for (@e) { $e .= "\Q$_\E|" }
    chop $e;
    # see if file ends in one of the known extensions
    if ($file =~ /($e)$/i) {
	return $file if -e $file;
    }
    else {
	for (@e) {
	    return "$file$_" if -e "$file$_";
	}
    }
    return;
}


=item B<init_DIRFILESEP>

Using \ for Windows, except for "gmake" where it is /.

=cut

sub init_DIRFILESEP {
    my($self) = shift;

    # The ^ makes sure its not interpreted as an escape in nmake
    $self->{DIRFILESEP} = $self->is_make_type('nmake') ? '^\\' :
                          $self->is_make_type('dmake') ? '\\\\' :
                          $self->is_make_type('gmake') ? '/'
                                                       : '\\';
}

=item init_tools

Override some of the slower, portable commands with Windows specific ones.

=cut

sub init_tools {
    my ($self) = @_;

    $self->{NOOP}     ||= 'rem';
    $self->{DEV_NULL} ||= '> NUL';

    $self->{FIXIN}    ||= $self->{PERL_CORE} ?
      "\$(PERLRUN) -I$self->{PERL_SRC}\\cpan\\ExtUtils-PL2Bat\\lib $self->{PERL_SRC}\\win32\\bin\\pl2bat.pl" :
      'pl2bat.bat';

    $self->SUPER::init_tools;

    # Setting SHELL from $Config{sh} can break dmake.  Its ok without it.
    delete $self->{SHELL};

    return;
}


=item init_others

Override the default link and compile tools.

LDLOADLIBS's default is changed to $Config{libs}.

Adjustments are made for Borland's quirks needing -L to come first.

=cut

sub init_others {
    my $self = shift;

    $self->{LD}     ||= 'link';
    $self->{AR}     ||= 'lib';

    $self->SUPER::init_others;

    $self->{LDLOADLIBS} ||= $Config{libs};
    # -Lfoo must come first for Borland, so we put it in LDDLFLAGS
    if ($BORLAND) {
        my $libs = $self->{LDLOADLIBS};
        my $libpath = '';
        while ($libs =~ s/(?:^|\s)(("?)-L.+?\2)(?:\s|$)/ /) {
            $libpath .= ' ' if length $libpath;
            $libpath .= $1;
        }
        $self->{LDLOADLIBS} = $libs;
        $self->{LDDLFLAGS} ||= $Config{lddlflags};
        $self->{LDDLFLAGS} .= " $libpath";
    }

    return;
}


=item init_platform

Add MM_Win32_VERSION.

=item platform_constants

=cut

sub init_platform {
    my($self) = shift;

    $self->{MM_Win32_VERSION} = $VERSION;

    return;
}

sub platform_constants {
    my($self) = shift;
    my $make_frag = '';

    foreach my $macro (qw(MM_Win32_VERSION))
    {
        next unless defined $self->{$macro};
        $make_frag .= "$macro = $self->{$macro}\n";
    }

    return $make_frag;
}

=item specify_shell

Set SHELL to $ENV{COMSPEC} only if make is type 'gmake'.

=cut

sub specify_shell {
    my $self = shift;
    return '' unless $self->is_make_type('gmake');
    "\nSHELL = $ENV{COMSPEC}\n";
}

=item constants

Add MAXLINELENGTH for dmake before all the constants are output.

=cut

sub constants {
    my $self = shift;

    my $make_text = $self->SUPER::constants;
    return $make_text unless $self->is_make_type('dmake');

    # dmake won't read any single "line" (even those with escaped newlines)
    # larger than a certain size which can be as small as 8k.  PM_TO_BLIB
    # on large modules like DateTime::TimeZone can create lines over 32k.
    # So we'll crank it up to a <ironic>WHOPPING</ironic> 64k.
    #
    # This has to come here before all the constants and not in
    # platform_constants which is after constants.
    my $size = $self->{MAXLINELENGTH} || 800000;
    my $prefix = qq{
# Get dmake to read long commands like PM_TO_BLIB
MAXLINELENGTH = $size

};

    return $prefix . $make_text;
}


=item special_targets

Add .USESHELL target for dmake.

=cut

sub special_targets {
    my($self) = @_;

    my $make_frag = $self->SUPER::special_targets;

    $make_frag .= <<'MAKE_FRAG' if $self->is_make_type('dmake');
.USESHELL :
MAKE_FRAG

    return $make_frag;
}

=item static_lib_pure_cmd

Defines how to run the archive utility

=cut

sub static_lib_pure_cmd {
    my ($self, $from) = @_;
    $from =~ s/(\$\(\w+)(\))/$1:^"+"$2/g if $BORLAND;
    sprintf qq{\t\$(AR) %s\n}, ($BORLAND ? '$@ ' . $from
                          : ($GCC ? '-ru $@ ' . $from
                                  : '-out:$@ ' . $from));
}

=item dynamic_lib

Methods are overridden here: not dynamic_lib itself, but the utility
ones that do the OS-specific work.

=cut

sub xs_make_dynamic_lib {
    my ($self, $attribs, $from, $to, $todir, $ldfrom, $exportlist) = @_;
    my @m = sprintf '%s : %s $(MYEXTLIB) %s$(DFSEP).exists %s $(PERL_ARCHIVEDEP) $(INST_DYNAMIC_DEP)'."\n", $to, $from, $todir, $exportlist;
    if ($GCC) {
      # per https://rt.cpan.org/Ticket/Display.html?id=78395 no longer
      # uses dlltool - relies on post 2002 MinGW
      #                             1            2
      push @m, _sprintf562 <<'EOF', $exportlist, $ldfrom;
	$(LD) %1$s -o $@ $(LDDLFLAGS) %2$s $(OTHERLDFLAGS) $(MYEXTLIB) "$(PERL_ARCHIVE)" $(LDLOADLIBS) -Wl,--enable-auto-image-base
EOF
    } elsif ($BORLAND) {
      my $ldargs = $self->is_make_type('dmake')
          ? q{"$(PERL_ARCHIVE:s,/,\,)" $(LDLOADLIBS:s,/,\,) $(MYEXTLIB:s,/,\,),}
          : q{"$(subst /,\,$(PERL_ARCHIVE))" $(subst /,\,$(LDLOADLIBS)) $(subst /,\,$(MYEXTLIB)),};
      my $subbed;
      if ($exportlist eq '$(EXPORT_LIST)') {
          $subbed = $self->is_make_type('dmake')
              ? q{$(EXPORT_LIST:s,/,\,)}
              : q{$(subst /,\,$(EXPORT_LIST))};
      } else {
            # in XSMULTI, exportlist is per-XS, so have to sub in perl not make
          ($subbed = $exportlist) =~ s#/#\\#g;
      }
      push @m, sprintf <<'EOF', $ldfrom, $ldargs . $subbed;
        $(LD) $(LDDLFLAGS) $(OTHERLDFLAGS) %s,$@,,%s,$(RESFILES)
EOF
    } else {	# VC
      push @m, sprintf <<'EOF', $ldfrom, $exportlist;
	$(LD) -out:$@ $(LDDLFLAGS) %s $(OTHERLDFLAGS) $(MYEXTLIB) "$(PERL_ARCHIVE)" $(LDLOADLIBS) -def:%s
EOF
      # Embed the manifest file if it exists
      push(@m, q{	if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;2
	if exist $@.manifest del $@.manifest});
    }
    push @m, "\n\t\$(CHMOD) \$(PERM_RWX) \$\@\n";

    join '', @m;
}

sub xs_dynamic_lib_macros {
    my ($self, $attribs) = @_;
    my $otherldflags = $attribs->{OTHERLDFLAGS} || ($BORLAND ? 'c0d32.obj': '');
    my $inst_dynamic_dep = $attribs->{INST_DYNAMIC_DEP} || "";
    sprintf <<'EOF', $otherldflags, $inst_dynamic_dep;
# This section creates the dynamically loadable objects from relevant
# objects and possibly $(MYEXTLIB).
OTHERLDFLAGS = %s
INST_DYNAMIC_DEP = %s
EOF
}

=item extra_clean_files

Clean out some extra dll.{base,exp} files which might be generated by
gcc.  Otherwise, take out all *.pdb files.

=cut

sub extra_clean_files {
    my $self = shift;

    return $GCC ? (qw(dll.base dll.exp)) : ('*.pdb');
}

=item init_linker

=cut

sub init_linker {
    my $self = shift;

    $self->{PERL_ARCHIVE}       = "\$(PERL_INC)\\$Config{libperl}";
    $self->{PERL_ARCHIVEDEP}    = "\$(PERL_INCDEP)\\$Config{libperl}";
    $self->{PERL_ARCHIVE_AFTER} = '';
    $self->{EXPORT_LIST}        = '$(BASEEXT).def';
}


=item perl_script

Checks for the perl program under several common perl extensions.

=cut

sub perl_script {
    my($self,$file) = @_;
    return $file if -r $file && -f _;
    return "$file.pl"  if -r "$file.pl" && -f _;
    return "$file.plx" if -r "$file.plx" && -f _;
    return "$file.bat" if -r "$file.bat" && -f _;
    return;
}

sub can_dep_space {
    my ($self) = @_;
    return 0 unless $self->can_load_xs;
    require Win32;
    require File::Spec;
    my ($vol, $dir) = File::Spec->splitpath($INC{'ExtUtils/MakeMaker.pm'});
    # can_dep_space via GetShortPathName, if short paths are supported
    my $canary = Win32::GetShortPathName(File::Spec->catpath($vol, $dir, 'MakeMaker.pm'));
    (undef, undef, my $file) = File::Spec->splitpath($canary);
    return (length $file > 11) ? 0 : 1;
}

=item quote_dep

=cut

sub quote_dep {
    my ($self, $arg) = @_;
    if ($arg =~ / / and not $self->is_make_type('gmake')) {
        require Win32;
        $arg = Win32::GetShortPathName($arg);
        die <<EOF if not defined $arg or $arg =~ / /;
Tried to use make dependency with space for non-GNU make:
  '$arg'
Fallback to short pathname failed.
EOF
        return $arg;
    }
    return $self->SUPER::quote_dep($arg);
}


=item xs_obj_opt

Override to fixup -o flags for MSVC.

=cut

sub xs_obj_opt {
    my ($self, $output_file) = @_;
    ($MSVC ? "/Fo" : "-o ") . $output_file;
}


=item pasthru

All we send is -nologo to nmake to prevent it from printing its damned
banner.

=cut

sub pasthru {
    my($self) = shift;
    my $old = $self->SUPER::pasthru;
    return $old unless $self->is_make_type('nmake');
    $old =~ s/(PASTHRU\s*=\s*)/$1 -nologo /;
    $old;
}


=item arch_check (override)

Normalize all arguments for consistency of comparison.

=cut

sub arch_check {
    my $self = shift;

    # Win32 is an XS module, minperl won't have it.
    # arch_check() is not critical, so just fake it.
    return 1 unless $self->can_load_xs;
    return $self->SUPER::arch_check( map { $self->_normalize_path_name($_) } @_);
}

sub _normalize_path_name {
    my $self = shift;
    my $file = shift;

    require Win32;
    my $short = Win32::GetShortPathName($file);
    return defined $short ? lc $short : lc $file;
}


=item oneliner

These are based on what command.com does on Win98.  They may be wrong
for other Windows shells, I don't know.

=cut

sub oneliner {
    my($self, $cmd, $switches) = @_;
    $switches = [] unless defined $switches;

    # Strip leading and trailing newlines
    $cmd =~ s{^\n+}{};
    $cmd =~ s{\n+$}{};

    $cmd = $self->quote_literal($cmd);
    $cmd = $self->escape_newlines($cmd);

    $switches = join ' ', @$switches;

    return qq{\$(ABSPERLRUN) $switches -e $cmd --};
}


sub quote_literal {
    my($self, $text, $opts) = @_;
    $opts->{allow_variables} = 1 unless defined $opts->{allow_variables};

    # See: http://www.autohotkey.net/~deleyd/parameters/parameters.htm#CPP

    # Apply the Microsoft C/C++ parsing rules
    $text =~ s{\\\\"}{\\\\\\\\\\"}g;  # \\" -> \\\\\"
    $text =~ s{(?<!\\)\\"}{\\\\\\"}g; # \"  -> \\\"
    $text =~ s{(?<!\\)"}{\\"}g;       # "   -> \"
    $text = qq{"$text"} if $text =~ /[ \t#]/; # hash because gmake 4.2.1

    # Apply the Command Prompt parsing rules (cmd.exe)
    my @text = split /("[^"]*")/, $text;
    # We should also escape parentheses, but it breaks one-liners containing
    # $(MACRO)s in makefiles.
    s{([<>|&^@!])}{^$1}g foreach grep { !/^"[^"]*"$/ } @text;
    $text = join('', @text);

    # dmake expands {{ to { and }} to }.
    if( $self->is_make_type('dmake') ) {
        $text =~ s/{/{{/g;
        $text =~ s/}/}}/g;
    }

    $text = $opts->{allow_variables}
      ? $self->escape_dollarsigns($text) : $self->escape_all_dollarsigns($text);

    return $text;
}


sub escape_newlines {
    my($self, $text) = @_;

    # Escape newlines
    $text =~ s{\n}{\\\n}g;

    return $text;
}


=item cd

dmake can handle Unix style cd'ing but nmake (at least 1.5) cannot.  It
wants:

    cd dir1\dir2
    command
    another_command
    cd ..\..

=cut

sub cd {
    my($self, $dir, @cmds) = @_;

    return $self->SUPER::cd($dir, @cmds) unless $self->is_make_type('nmake');

    my $cmd = join "\n\t", map "$_", @cmds;

    my $updirs = $self->catdir(map { $self->updir } $self->splitdir($dir));

    # No leading tab and no trailing newline makes for easier embedding.
    my $make_frag = sprintf <<'MAKE_FRAG', $dir, $cmd, $updirs;
cd %s
	%s
	cd %s
MAKE_FRAG

    chomp $make_frag;

    return $make_frag;
}


=item max_exec_len

nmake 1.50 limits command length to 2048 characters.

=cut

sub max_exec_len {
    my $self = shift;

    return $self->{_MAX_EXEC_LEN} ||= 2 * 1024;
}


=item os_flavor

Windows is Win32.

=cut

sub os_flavor {
    return('Win32');
}

=item dbgoutflag

Returns a CC flag that tells the CC to emit a separate debugging symbol file
when compiling an object file.

=cut

sub dbgoutflag {
    $MSVC ? '-Fd$(*).pdb' : '';
}

=item cflags

Defines the PERLDLL symbol if we are configured for static building since all
code destined for the perl5xx.dll must be compiled with the PERLDLL symbol
defined.

=cut

sub cflags {
    my($self,$libperl)=@_;
    return $self->{CFLAGS} if $self->{CFLAGS};
    return '' unless $self->needs_linking();

    my $base = $self->SUPER::cflags($libperl);
    foreach (split /\n/, $base) {
        /^(\S*)\s*=\s*(\S*)$/ and $self->{$1} = $2;
    };
    $self->{CCFLAGS} .= " -DPERLDLL" if ($self->{LINKTYPE} eq 'static');

    return $self->{CFLAGS} = qq{
CCFLAGS = $self->{CCFLAGS}
OPTIMIZE = $self->{OPTIMIZE}
PERLTYPE = $self->{PERLTYPE}
};

}

=item make_type

Returns a suitable string describing the type of makefile being written.

=cut

sub make_type {
    my ($self) = @_;
    my $make = $self->make;
    $make = +( File::Spec->splitpath( $make ) )[-1];
    $make =~ s!\.exe$!!i;
    if ( $make =~ m![^A-Z0-9]!i ) {
      ($make) = grep { m!make!i } split m![^A-Z0-9]!i, $make;
    }
    return "$make-style";
}

1;
__END__

=back
PK       ! ���    perl5/ExtUtils/ParseXS.pmnu ��6�$        package ExtUtils::ParseXS;
use strict;

use 5.006001;
use Cwd;
use Config;
use Exporter 'import';
use File::Basename;
use File::Spec;
use Symbol;

our $VERSION;
BEGIN {
  $VERSION = '3.35';
}
use ExtUtils::ParseXS::Constants $VERSION;
use ExtUtils::ParseXS::CountLines $VERSION;
use ExtUtils::ParseXS::Utilities $VERSION;
use ExtUtils::ParseXS::Eval $VERSION;
$VERSION = eval $VERSION if $VERSION =~ /_/;

use ExtUtils::ParseXS::Utilities qw(
  standard_typemap_locations
  trim_whitespace
  C_string
  valid_proto_string
  process_typemaps
  map_type
  standard_XS_defs
  assign_func_args
  analyze_preprocessor_statements
  set_cond
  Warn
  current_line_number
  blurt
  death
  check_conditional_preprocessor_statements
  escape_file_for_line_directive
  report_typemap_failure
);

our @EXPORT_OK = qw(
  process_file
  report_error_count
);

##############################
# A number of "constants"

our ($C_group_rex, $C_arg);
# Group in C (no support for comments or literals)
$C_group_rex = qr/ [({\[]
             (?: (?> [^()\[\]{}]+ ) | (??{ $C_group_rex }) )*
             [)}\]] /x;
# Chunk in C without comma at toplevel (no comments):
$C_arg = qr/ (?: (?> [^()\[\]{},"']+ )
       |   (??{ $C_group_rex })
       |   " (?: (?> [^\\"]+ )
         |   \\.
         )* "        # String literal
              |   ' (?: (?> [^\\']+ ) | \\. )* ' # Char literal
       )* /xs;

# "impossible" keyword (multiple newline)
my $END = "!End!\n\n";
# Match an XS Keyword
my $BLOCK_regexp = '\s*(' . $ExtUtils::ParseXS::Constants::XSKeywordsAlternation . "|$END)\\s*:";


sub new {
  return bless {} => shift;
}

our $Singleton = __PACKAGE__->new;

sub process_file {
  my $self;
  # Allow for $package->process_file(%hash), $obj->process_file, and process_file()
  if (@_ % 2) {
    my $invocant = shift;
    $self = ref($invocant) ? $invocant : $invocant->new;
  }
  else {
    $self = $Singleton;
  }

  my %options = @_;
  $self->{ProtoUsed} = exists $options{prototypes};

  # Set defaults.
  my %args = (
    argtypes        => 1,
    csuffix         => '.c',
    except          => 0,
    hiertype        => 0,
    inout           => 1,
    linenumbers     => 1,
    optimize        => 1,
    output          => \*STDOUT,
    prototypes      => 0,
    typemap         => [],
    versioncheck    => 1,
    FH              => Symbol::gensym(),
    %options,
  );
  $args{except} = $args{except} ? ' TRY' : '';

  # Global Constants

  my ($Is_VMS, $SymSet);
  if ($^O eq 'VMS') {
    $Is_VMS = 1;
    # Establish set of global symbols with max length 28, since xsubpp
    # will later add the 'XS_' prefix.
    require ExtUtils::XSSymSet;
    $SymSet = ExtUtils::XSSymSet->new(28);
  }
  @{ $self->{XSStack} } = ({type => 'none'});
  $self->{InitFileCode} = [ @ExtUtils::ParseXS::Constants::InitFileCode ];
  $self->{Overload}     = 0; # bool
  $self->{errors}       = 0; # count
  $self->{Fallback}     = '&PL_sv_undef';

  # Most of the 1500 lines below uses these globals.  We'll have to
  # clean this up sometime, probably.  For now, we just pull them out
  # of %args.  -Ken

  $self->{RetainCplusplusHierarchicalTypes} = $args{hiertype};
  $self->{WantPrototypes} = $args{prototypes};
  $self->{WantVersionChk} = $args{versioncheck};
  $self->{WantLineNumbers} = $args{linenumbers};
  $self->{IncludedFiles} = {};

  die "Missing required parameter 'filename'" unless $args{filename};
  $self->{filepathname} = $args{filename};
  ($self->{dir}, $self->{filename}) =
    (dirname($args{filename}), basename($args{filename}));
  $self->{filepathname} =~ s/\\/\\\\/g;
  $self->{IncludedFiles}->{$args{filename}}++;

  # Open the output file if given as a string.  If they provide some
  # other kind of reference, trust them that we can print to it.
  if (not ref $args{output}) {
    open my($fh), "> $args{output}" or die "Can't create $args{output}: $!";
    $args{outfile} = $args{output};
    $args{output} = $fh;
  }

  # Really, we shouldn't have to chdir() or select() in the first
  # place.  For now, just save and restore.
  my $orig_cwd = cwd();
  my $orig_fh = select();

  chdir($self->{dir});
  my $pwd = cwd();
  my $csuffix = $args{csuffix};

  if ($self->{WantLineNumbers}) {
    my $cfile;
    if ( $args{outfile} ) {
      $cfile = $args{outfile};
    }
    else {
      $cfile = $args{filename};
      $cfile =~ s/\.xs$/$csuffix/i or $cfile .= $csuffix;
    }
    tie(*PSEUDO_STDOUT, 'ExtUtils::ParseXS::CountLines', $cfile, $args{output});
    select PSEUDO_STDOUT;
  }
  else {
    select $args{output};
  }

  $self->{typemap} = process_typemaps( $args{typemap}, $pwd );

  # Move more settings from parameters to object
  foreach my $datum ( qw| argtypes except inout optimize | ) {
    $self->{$datum} = $args{$datum};
  }
  $self->{strip_c_func_prefix} = $args{s};

  # Identify the version of xsubpp used
  print <<EOM;
/*
 * This file was generated automatically by ExtUtils::ParseXS version $VERSION from the
 * contents of $self->{filename}. Do not edit this file, edit $self->{filename} instead.
 *
 *    ANY CHANGES MADE HERE WILL BE LOST!
 *
 */

EOM


  print("#line 1 \"" . escape_file_for_line_directive($self->{filepathname}) . "\"\n")
    if $self->{WantLineNumbers};

  # Open the input file (using $self->{filename} which
  # is a basename'd $args{filename} due to chdir above)
  open($self->{FH}, '<', $self->{filename}) or die "cannot open $self->{filename}: $!\n";

  FIRSTMODULE:
  while (readline($self->{FH})) {
    if (/^=/) {
      my $podstartline = $.;
      do {
        if (/^=cut\s*$/) {
          # We can't just write out a /* */ comment, as our embedded
          # POD might itself be in a comment. We can't put a /**/
          # comment inside #if 0, as the C standard says that the source
          # file is decomposed into preprocessing characters in the stage
          # before preprocessing commands are executed.
          # I don't want to leave the text as barewords, because the spec
          # isn't clear whether macros are expanded before or after
          # preprocessing commands are executed, and someone pathological
          # may just have defined one of the 3 words as a macro that does
          # something strange. Multiline strings are illegal in C, so
          # the "" we write must be a string literal. And they aren't
          # concatenated until 2 steps later, so we are safe.
          #     - Nicholas Clark
          print("#if 0\n  \"Skipped embedded POD.\"\n#endif\n");
          printf("#line %d \"%s\"\n", $. + 1, escape_file_for_line_directive($self->{filepathname}))
            if $self->{WantLineNumbers};
          next FIRSTMODULE;
        }

      } while (readline($self->{FH}));
      # At this point $. is at end of file so die won't state the start
      # of the problem, and as we haven't yet read any lines &death won't
      # show the correct line in the message either.
      die ("Error: Unterminated pod in $self->{filename}, line $podstartline\n")
        unless $self->{lastline};
    }
    last if ($self->{Package}, $self->{Prefix}) =
      /^MODULE\s*=\s*[\w:]+(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;

    print $_;
  }
  unless (defined $_) {
    warn "Didn't find a 'MODULE ... PACKAGE ... PREFIX' line\n";
    exit 0; # Not a fatal error for the caller process
  }

  print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $self->{WantLineNumbers};

  standard_XS_defs();

  print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $self->{WantLineNumbers};

  $self->{lastline}    = $_;
  $self->{lastline_no} = $.;

  my $BootCode_ref = [];
  my $XSS_work_idx = 0;
  my $cpp_next_tmp = 'XSubPPtmpAAAA';
 PARAGRAPH:
  while ($self->fetch_para()) {
    my $outlist_ref  = [];
    # Print initial preprocessor statements and blank lines
    while (@{ $self->{line} } && $self->{line}->[0] !~ /^[^\#]/) {
      my $ln = shift(@{ $self->{line} });
      print $ln, "\n";
      next unless $ln =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/;
      my $statement = $+;
      ( $self, $XSS_work_idx, $BootCode_ref ) =
        analyze_preprocessor_statements(
          $self, $statement, $XSS_work_idx, $BootCode_ref
        );
    }

    next PARAGRAPH unless @{ $self->{line} };

    if ($XSS_work_idx && !$self->{XSStack}->[$XSS_work_idx]{varname}) {
      # We are inside an #if, but have not yet #defined its xsubpp variable.
      print "#define $cpp_next_tmp 1\n\n";
      push(@{ $self->{InitFileCode} }, "#if $cpp_next_tmp\n");
      push(@{ $BootCode_ref },     "#if $cpp_next_tmp");
      $self->{XSStack}->[$XSS_work_idx]{varname} = $cpp_next_tmp++;
    }

    $self->death(
      "Code is not inside a function"
        ." (maybe last function was ended by a blank line "
        ." followed by a statement on column one?)")
      if $self->{line}->[0] =~ /^\s/;

    # initialize info arrays
    foreach my $member (qw(args_match var_types defaults arg_list
                           argtype_seen in_out lengthof))
    {
      $self->{$member} = {};
    }
    $self->{proto_arg} = [];
    $self->{processing_arg_with_types} = 0; # bool
    $self->{proto_in_this_xsub}        = 0; # counter & bool
    $self->{scope_in_this_xsub}        = 0; # counter & bool
    $self->{interface}                 = 0; # bool
    $self->{interface_macro}           = 'XSINTERFACE_FUNC';
    $self->{interface_macro_set}       = 'XSINTERFACE_FUNC_SET';
    $self->{ProtoThisXSUB}             = $self->{WantPrototypes}; # states 0 (none), 1 (yes), 2 (empty prototype)
    $self->{ScopeThisXSUB}             = 0; # bool

    my $xsreturn = 0;

    $_ = shift(@{ $self->{line} });
    while (my $kwd = $self->check_keyword("REQUIRE|PROTOTYPES|EXPORT_XSUB_SYMBOLS|FALLBACK|VERSIONCHECK|INCLUDE(?:_COMMAND)?|SCOPE")) {
      my $method = $kwd . "_handler";
      $self->$method($_);
      next PARAGRAPH unless @{ $self->{line} };
      $_ = shift(@{ $self->{line} });
    }

    if ($self->check_keyword("BOOT")) {
      check_conditional_preprocessor_statements($self);
      push (@{ $BootCode_ref }, "#line $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} }] \""
                                . escape_file_for_line_directive($self->{filepathname}) . "\"")
        if $self->{WantLineNumbers} && $self->{line}->[0] !~ /^\s*#\s*line\b/;
      push (@{ $BootCode_ref }, @{ $self->{line} }, "");
      next PARAGRAPH;
    }

    # extract return type, function name and arguments
    ($self->{ret_type}) = ExtUtils::Typemaps::tidy_type($_);
    my $RETVAL_no_return = 1 if $self->{ret_type} =~ s/^NO_OUTPUT\s+//;

    # Allow one-line ANSI-like declaration
    unshift @{ $self->{line} }, $2
      if $self->{argtypes}
        and $self->{ret_type} =~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s;

    # a function definition needs at least 2 lines
    $self->blurt("Error: Function definition too short '$self->{ret_type}'"), next PARAGRAPH
      unless @{ $self->{line} };

    my $externC = 1 if $self->{ret_type} =~ s/^extern "C"\s+//;
    my $static  = 1 if $self->{ret_type} =~ s/^static\s+//;

    my $func_header = shift(@{ $self->{line} });
    $self->blurt("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
      unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*(;\s*)?$/s;

    my ($class, $orig_args);
    ($class, $self->{func_name}, $orig_args) =  ($1, $2, $3);
    $class = "$4 $class" if $4;
    ($self->{pname} = $self->{func_name}) =~ s/^($self->{Prefix})?/$self->{Packprefix}/;
    my $clean_func_name;
    ($clean_func_name = $self->{func_name}) =~ s/^$self->{Prefix}//;
    $self->{Full_func_name} = "$self->{Packid}_$clean_func_name";
    if ($Is_VMS) {
      $self->{Full_func_name} = $SymSet->addsym( $self->{Full_func_name} );
    }

    # Check for duplicate function definition
    for my $tmp (@{ $self->{XSStack} }) {
      next unless defined $tmp->{functions}{ $self->{Full_func_name} };
      Warn( $self, "Warning: duplicate function definition '$clean_func_name' detected");
      last;
    }
    $self->{XSStack}->[$XSS_work_idx]{functions}{ $self->{Full_func_name} }++;
    delete $self->{XsubAliases};
    delete $self->{XsubAliasValues};
    %{ $self->{Interfaces} }      = ();
    @{ $self->{Attributes} }      = ();
    $self->{DoSetMagic} = 1;

    $orig_args =~ s/\\\s*/ /g;    # process line continuations
    my @args;

    my (@fake_INPUT_pre);    # For length(s) generated variables
    my (@fake_INPUT);
    my $only_C_inlist_ref = {};        # Not in the signature of Perl function
    if ($self->{argtypes} and $orig_args =~ /\S/) {
      my $args = "$orig_args ,";
      use re 'eval';
      if ($args =~ /^( (??{ $C_arg }) , )* $ /x) {
        @args = ($args =~ /\G ( (??{ $C_arg }) ) , /xg);
        no re 'eval';
        for ( @args ) {
          s/^\s+//;
          s/\s+$//;
          my ($arg, $default) = ($_ =~ m/ ( [^=]* ) ( (?: = .* )? ) /x);
          my ($pre, $len_name) = ($arg =~ /(.*?) \s*
                             \b ( \w+ | length\( \s*\w+\s* \) )
                             \s* $ /x);
          next unless defined($pre) && length($pre);
          my $out_type = '';
          my $inout_var;
          if ($self->{inout} and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//) {
            my $type = $1;
            $out_type = $type if $type ne 'IN';
            $arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//;
            $pre =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//;
          }
          my $islength;
          if ($len_name =~ /^length\( \s* (\w+) \s* \)\z/x) {
            $len_name = "XSauto_length_of_$1";
            $islength = 1;
            die "Default value on length() argument: '$_'"
              if length $default;
          }
          if (length $pre or $islength) { # Has a type
            if ($islength) {
              push @fake_INPUT_pre, $arg;
            }
            else {
              push @fake_INPUT, $arg;
            }
            # warn "pushing '$arg'\n";
            $self->{argtype_seen}->{$len_name}++;
            $_ = "$len_name$default"; # Assigns to @args
          }
          $only_C_inlist_ref->{$_} = 1 if $out_type eq "OUTLIST" or $islength;
          push @{ $outlist_ref }, $len_name if $out_type =~ /OUTLIST$/;
          $self->{in_out}->{$len_name} = $out_type if $out_type;
        }
      }
      else {
        no re 'eval';
        @args = split(/\s*,\s*/, $orig_args);
        Warn( $self, "Warning: cannot parse argument list '$orig_args', fallback to split");
      }
    }
    else {
      @args = split(/\s*,\s*/, $orig_args);
      for (@args) {
        if ($self->{inout} and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\b\s*//) {
          my $out_type = $1;
          next if $out_type eq 'IN';
          $only_C_inlist_ref->{$_} = 1 if $out_type eq "OUTLIST";
          if ($out_type =~ /OUTLIST$/) {
              push @{ $outlist_ref }, undef;
          }
          $self->{in_out}->{$_} = $out_type;
        }
      }
    }
    if (defined($class)) {
      my $arg0 = ((defined($static) or $self->{func_name} eq 'new')
          ? "CLASS" : "THIS");
      unshift(@args, $arg0);
    }
    my $extra_args = 0;
    my @args_num = ();
    my $num_args = 0;
    my $report_args = '';
    my $ellipsis;
    foreach my $i (0 .. $#args) {
      if ($args[$i] =~ s/\.\.\.//) {
        $ellipsis = 1;
        if ($args[$i] eq '' && $i == $#args) {
          $report_args .= ", ...";
          pop(@args);
          last;
        }
      }
      if ($only_C_inlist_ref->{$args[$i]}) {
        push @args_num, undef;
      }
      else {
        push @args_num, ++$num_args;
          $report_args .= ", $args[$i]";
      }
      if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) {
        $extra_args++;
        $args[$i] = $1;
        $self->{defaults}->{$args[$i]} = $2;
        $self->{defaults}->{$args[$i]} =~ s/"/\\"/g;
      }
      $self->{proto_arg}->[$i+1] = '$';
    }
    my $min_args = $num_args - $extra_args;
    $report_args =~ s/"/\\"/g;
    $report_args =~ s/^,\s+//;
    $self->{func_args} = assign_func_args($self, \@args, $class);
    @{ $self->{args_match} }{@args} = @args_num;

    my $PPCODE = grep(/^\s*PPCODE\s*:/, @{ $self->{line} });
    my $CODE = grep(/^\s*CODE\s*:/, @{ $self->{line} });
    # Detect CODE: blocks which use ST(n)= or XST_m*(n,v)
    # to set explicit return values.
    my $EXPLICIT_RETURN = ($CODE &&
            ("@{ $self->{line} }" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x ));

    $self->{ALIAS}  = grep(/^\s*ALIAS\s*:/,  @{ $self->{line} });

    my $INTERFACE  = grep(/^\s*INTERFACE\s*:/,  @{ $self->{line} });

    $xsreturn = 1 if $EXPLICIT_RETURN;

    $externC = $externC ? qq[extern "C"] : "";

    # print function header
    print Q(<<"EOF");
#$externC
#XS_EUPXS(XS_$self->{Full_func_name}); /* prototype to pass -Wmissing-prototypes */
#XS_EUPXS(XS_$self->{Full_func_name})
#[[
#    dVAR; dXSARGS;
EOF
    print Q(<<"EOF") if $self->{ALIAS};
#    dXSI32;
EOF
    print Q(<<"EOF") if $INTERFACE;
#    dXSFUNCTION($self->{ret_type});
EOF

    $self->{cond} = set_cond($ellipsis, $min_args, $num_args);

    print Q(<<"EOF") if $self->{except};
#    char errbuf[1024];
#    *errbuf = '\\0';
EOF

    if($self->{cond}) {
      print Q(<<"EOF");
#    if ($self->{cond})
#       croak_xs_usage(cv,  "$report_args");
EOF
    }
    else {
    # cv likely to be unused
    print Q(<<"EOF");
#    PERL_UNUSED_VAR(cv); /* -W */
EOF
    }

    #gcc -Wall: if an xsub has PPCODE is used
    #it is possible none of ST, XSRETURN or XSprePUSH macros are used
    #hence 'ax' (setup by dXSARGS) is unused
    #XXX: could breakup the dXSARGS; into dSP;dMARK;dITEMS
    #but such a move could break third-party extensions
    print Q(<<"EOF") if $PPCODE;
#    PERL_UNUSED_VAR(ax); /* -Wall */
EOF

    print Q(<<"EOF") if $PPCODE;
#    SP -= items;
EOF

    # Now do a block of some sort.

    $self->{condnum} = 0;
    $self->{cond} = '';            # last CASE: conditional
    push(@{ $self->{line} }, "$END:");
    push(@{ $self->{line_no} }, $self->{line_no}->[-1]);
    $_ = '';
    check_conditional_preprocessor_statements();
    while (@{ $self->{line} }) {

      $self->CASE_handler($_) if $self->check_keyword("CASE");
      print Q(<<"EOF");
#   $self->{except} [[
EOF

      # do initialization of input variables
      $self->{thisdone} = 0;
      $self->{retvaldone} = 0;
      $self->{deferred} = "";
      %{ $self->{arg_list} } = ();
      $self->{gotRETVAL} = 0;
      $self->INPUT_handler($_);
      $self->process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD");

      print Q(<<"EOF") if $self->{ScopeThisXSUB};
#   ENTER;
#   [[
EOF

      if (!$self->{thisdone} && defined($class)) {
        if (defined($static) or $self->{func_name} eq 'new') {
          print "\tchar *";
          $self->{var_types}->{"CLASS"} = "char *";
          $self->generate_init( {
            type          => "char *",
            num           => 1,
            var           => "CLASS",
            printed_name  => undef,
          } );
        }
        else {
          print "\t" . map_type($self, "$class *");
          $self->{var_types}->{"THIS"} = "$class *";
          $self->generate_init( {
            type          => "$class *",
            num           => 1,
            var           => "THIS",
            printed_name  => undef,
          } );
        }
      }

      # These are set if OUTPUT is found and/or CODE using RETVAL
      $self->{have_OUTPUT} = $self->{have_CODE_with_RETVAL} = 0;

      my ($wantRETVAL);
      # do code
      if (/^\s*NOT_IMPLEMENTED_YET/) {
        print "\n\tPerl_croak(aTHX_ \"$self->{pname}: not implemented yet\");\n";
        $_ = '';
      }
      else {
        if ($self->{ret_type} ne "void") {
          print "\t" . map_type($self, $self->{ret_type}, 'RETVAL') . ";\n"
            if !$self->{retvaldone};
          $self->{args_match}->{"RETVAL"} = 0;
          $self->{var_types}->{"RETVAL"} = $self->{ret_type};
          my $outputmap = $self->{typemap}->get_outputmap( ctype => $self->{ret_type} );
          print "\tdXSTARG;\n"
            if $self->{optimize} and $outputmap and $outputmap->targetable;
        }

        if (@fake_INPUT or @fake_INPUT_pre) {
          unshift @{ $self->{line} }, @fake_INPUT_pre, @fake_INPUT, $_;
          $_ = "";
          $self->{processing_arg_with_types} = 1;
          $self->INPUT_handler($_);
        }
        print $self->{deferred};

        $self->process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD");

        if ($self->check_keyword("PPCODE")) {
          $self->print_section();
          $self->death("PPCODE must be last thing") if @{ $self->{line} };
          print "\tLEAVE;\n" if $self->{ScopeThisXSUB};
          print "\tPUTBACK;\n\treturn;\n";
        }
        elsif ($self->check_keyword("CODE")) {
          my $consumed_code = $self->print_section();
          if ($consumed_code =~ /\bRETVAL\b/) {
            $self->{have_CODE_with_RETVAL} = 1;
          }
        }
        elsif (defined($class) and $self->{func_name} eq "DESTROY") {
          print "\n\t";
          print "delete THIS;\n";
        }
        else {
          print "\n\t";
          if ($self->{ret_type} ne "void") {
            print "RETVAL = ";
            $wantRETVAL = 1;
          }
          if (defined($static)) {
            if ($self->{func_name} eq 'new') {
              $self->{func_name} = "$class";
            }
            else {
              print "${class}::";
            }
          }
          elsif (defined($class)) {
            if ($self->{func_name} eq 'new') {
              $self->{func_name} .= " $class";
            }
            else {
              print "THIS->";
            }
          }
          my $strip = $self->{strip_c_func_prefix};
          $self->{func_name} =~ s/^\Q$strip//
            if defined $strip;
          $self->{func_name} = 'XSFUNCTION' if $self->{interface};
          print "$self->{func_name}($self->{func_args});\n";
        }
      }

      # do output variables
      $self->{gotRETVAL} = 0;        # 1 if RETVAL seen in OUTPUT section;
      undef $self->{RETVAL_code} ;    # code to set RETVAL (from OUTPUT section);
      # $wantRETVAL set if 'RETVAL =' autogenerated
      ($wantRETVAL, $self->{ret_type}) = (0, 'void') if $RETVAL_no_return;
      undef %{ $self->{outargs} };

      $self->process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");

      # A CODE section with RETVAL, but no OUTPUT? FAIL!
      if ($self->{have_CODE_with_RETVAL} and not $self->{have_OUTPUT} and $self->{ret_type} ne 'void') {
        $self->Warn("Warning: Found a 'CODE' section which seems to be using 'RETVAL' but no 'OUTPUT' section.");
      }

      $self->generate_output( {
        type        => $self->{var_types}->{$_},
        num         => $self->{args_match}->{$_},
        var         => $_,
        do_setmagic => $self->{DoSetMagic},
        do_push     => undef,
      } ) for grep $self->{in_out}->{$_} =~ /OUT$/, sort keys %{ $self->{in_out} };

      my $prepush_done;
      # all OUTPUT done, so now push the return value on the stack
      if ($self->{gotRETVAL} && $self->{RETVAL_code}) {
        print "\t$self->{RETVAL_code}\n";
      }
      elsif ($self->{gotRETVAL} || $wantRETVAL) {
        my $outputmap = $self->{typemap}->get_outputmap( ctype => $self->{ret_type} );
        my $trgt = $self->{optimize} && $outputmap && $outputmap->targetable;
        my $var = 'RETVAL';
        my $type = $self->{ret_type};

        if ($trgt) {
          my $what = $self->eval_output_typemap_code(
            qq("$trgt->{what}"),
            {var => $var, type => $self->{ret_type}}
          );
          if (not $trgt->{with_size} and $trgt->{type} eq 'p') { # sv_setpv
            # PUSHp corresponds to sv_setpvn.  Treat sv_setpv directly
            print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n";
            $prepush_done = 1;
          }
          else {
            my $tsize = $trgt->{what_size};
            $tsize = '' unless defined $tsize;
            $tsize = $self->eval_output_typemap_code(
              qq("$tsize"),
              {var => $var, type => $self->{ret_type}}
            );
            print "\tXSprePUSH; PUSH$trgt->{type}($what$tsize);\n";
            $prepush_done = 1;
          }
        }
        else {
          # RETVAL almost never needs SvSETMAGIC()
          $self->generate_output( {
            type        => $self->{ret_type},
            num         => 0,
            var         => 'RETVAL',
            do_setmagic => 0,
            do_push     => undef,
          } );
        }
      }

      $xsreturn = 1 if $self->{ret_type} ne "void";
      my $num = $xsreturn;
      my $c = @{ $outlist_ref };
      print "\tXSprePUSH;" if $c and not $prepush_done;
      print "\tEXTEND(SP,$c);\n" if $c;
      $xsreturn += $c;
      $self->generate_output( {
        type        => $self->{var_types}->{$_},
        num         => $num++,
        var         => $_,
        do_setmagic => 0,
        do_push     => 1,
      } ) for @{ $outlist_ref };

      # do cleanup
      $self->process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");

      print Q(<<"EOF") if $self->{ScopeThisXSUB};
#   ]]
EOF
      print Q(<<"EOF") if $self->{ScopeThisXSUB} and not $PPCODE;
#   LEAVE;
EOF

      # print function trailer
      print Q(<<"EOF");
#    ]]
EOF
      print Q(<<"EOF") if $self->{except};
#    BEGHANDLERS
#    CATCHALL
#    sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
#    ENDHANDLERS
EOF
      if ($self->check_keyword("CASE")) {
        $self->blurt("Error: No 'CASE:' at top of function")
          unless $self->{condnum};
        $_ = "CASE: $_";    # Restore CASE: label
        next;
      }
      last if $_ eq "$END:";
      $self->death(/^$BLOCK_regexp/o ? "Misplaced '$1:'" : "Junk at end of function ($_)");
    }

    print Q(<<"EOF") if $self->{except};
#    if (errbuf[0])
#    Perl_croak(aTHX_ errbuf);
EOF

    if ($xsreturn) {
      print Q(<<"EOF") unless $PPCODE;
#    XSRETURN($xsreturn);
EOF
    }
    else {
      print Q(<<"EOF") unless $PPCODE;
#    XSRETURN_EMPTY;
EOF
    }

    print Q(<<"EOF");
#]]
#
EOF

    $self->{proto} = "";
    unless($self->{ProtoThisXSUB}) {
      $self->{newXS} = "newXS_deffile";
      $self->{file} = "";
    }
    else {
    # Build the prototype string for the xsub
      $self->{newXS} = "newXSproto_portable";
      $self->{file} = ", file";

      if ($self->{ProtoThisXSUB} eq 2) {
        # User has specified empty prototype
      }
      elsif ($self->{ProtoThisXSUB} eq 1) {
        my $s = ';';
        if ($min_args < $num_args)  {
          $s = '';
          $self->{proto_arg}->[$min_args] .= ";";
        }
        push @{ $self->{proto_arg} }, "$s\@"
          if $ellipsis;

        $self->{proto} = join ("", grep defined, @{ $self->{proto_arg} } );
      }
      else {
        # User has specified a prototype
        $self->{proto} = $self->{ProtoThisXSUB};
      }
      $self->{proto} = qq{, "$self->{proto}"};
    }

    if ($self->{XsubAliases} and keys %{ $self->{XsubAliases} }) {
      $self->{XsubAliases}->{ $self->{pname} } = 0
        unless defined $self->{XsubAliases}->{ $self->{pname} };
      foreach my $xname (sort keys %{ $self->{XsubAliases} }) {
        my $value = $self->{XsubAliases}{$xname};
        push(@{ $self->{InitFileCode} }, Q(<<"EOF"));
#        cv = $self->{newXS}(\"$xname\", XS_$self->{Full_func_name}$self->{file}$self->{proto});
#        XSANY.any_i32 = $value;
EOF
      }
    }
    elsif (@{ $self->{Attributes} }) {
      push(@{ $self->{InitFileCode} }, Q(<<"EOF"));
#        cv = $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto});
#        apply_attrs_string("$self->{Package}", cv, "@{ $self->{Attributes} }", 0);
EOF
    }
    elsif ($self->{interface}) {
      foreach my $yname (sort keys %{ $self->{Interfaces} }) {
        my $value = $self->{Interfaces}{$yname};
        $yname = "$self->{Package}\::$yname" unless $yname =~ /::/;
        push(@{ $self->{InitFileCode} }, Q(<<"EOF"));
#        cv = $self->{newXS}(\"$yname\", XS_$self->{Full_func_name}$self->{file}$self->{proto});
#        $self->{interface_macro_set}(cv,$value);
EOF
      }
    }
    elsif($self->{newXS} eq 'newXS_deffile'){ # work around P5NCI's empty newXS macro
      push(@{ $self->{InitFileCode} },
       "        $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n");
    }
    else {
      push(@{ $self->{InitFileCode} },
       "        (void)$self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n");
    }
  } # END 'PARAGRAPH' 'while' loop

  if ($self->{Overload}) { # make it findable with fetchmethod
    print Q(<<"EOF");
#XS_EUPXS(XS_$self->{Packid}_nil); /* prototype to pass -Wmissing-prototypes */
#XS_EUPXS(XS_$self->{Packid}_nil)
#{
#   dXSARGS;
#   XSRETURN_EMPTY;
#}
#
EOF
    unshift(@{ $self->{InitFileCode} }, <<"MAKE_FETCHMETHOD_WORK");
    /* Making a sub named "$self->{Package}::()" allows the package */
    /* to be findable via fetchmethod(), and causes */
    /* overload::Overloaded("$self->{Package}") to return true. */
    (void)$self->{newXS}("$self->{Package}::()", XS_$self->{Packid}_nil$self->{file}$self->{proto});
MAKE_FETCHMETHOD_WORK
  }

  # print initialization routine

  print Q(<<"EOF");
##ifdef __cplusplus
#extern "C"
##endif
EOF

  print Q(<<"EOF");
#XS_EXTERNAL(boot_$self->{Module_cname}); /* prototype to pass -Wmissing-prototypes */
#XS_EXTERNAL(boot_$self->{Module_cname})
#[[
##if PERL_VERSION_LE(5, 21, 5)
#    dVAR; dXSARGS;
##else
#    dVAR; ${\($self->{WantVersionChk} ?
     'dXSBOOTARGSXSAPIVERCHK;' : 'dXSBOOTARGSAPIVERCHK;')}
##endif
EOF

  #Under 5.8.x and lower, newXS is declared in proto.h as expecting a non-const
  #file name argument. If the wrong qualifier is used, it causes breakage with
  #C++ compilers and warnings with recent gcc.
  #-Wall: if there is no $self->{Full_func_name} there are no xsubs in this .xs
  #so 'file' is unused
  print Q(<<"EOF") if $self->{Full_func_name};
##if (PERL_REVISION == 5 && PERL_VERSION < 9)
#    char* file = __FILE__;
##else
#    const char* file = __FILE__;
##endif
#
#    PERL_UNUSED_VAR(file);
EOF

  print Q("#\n");

  print Q(<<"EOF");
#    PERL_UNUSED_VAR(cv); /* -W */
#    PERL_UNUSED_VAR(items); /* -W */
EOF

  if( $self->{WantVersionChk}){
    print Q(<<"EOF") ;
##if PERL_VERSION_LE(5, 21, 5)
#    XS_VERSION_BOOTCHECK;
##  ifdef XS_APIVERSION_BOOTCHECK
#    XS_APIVERSION_BOOTCHECK;
##  endif
##endif

EOF
  } else {
    print Q(<<"EOF") ;
##if PERL_VERSION_LE(5, 21, 5) && defined(XS_APIVERSION_BOOTCHECK)
#  XS_APIVERSION_BOOTCHECK;
##endif

EOF
  }

  print Q(<<"EOF") if defined $self->{XsubAliases} or defined $self->{interfaces};
#    {
#        CV * cv;
#
EOF

  print Q(<<"EOF") if ($self->{Overload});
#    /* register the overloading (type 'A') magic */
##if (PERL_REVISION == 5 && PERL_VERSION < 9)
#    PL_amagic_generation++;
##endif
#    /* The magic for overload gets a GV* via gv_fetchmeth as */
#    /* mentioned above, and looks in the SV* slot of it for */
#    /* the "fallback" status. */
#    sv_setsv(
#        get_sv( "$self->{Package}::()", TRUE ),
#        $self->{Fallback}
#    );
EOF

  print @{ $self->{InitFileCode} };

  print Q(<<"EOF") if defined $self->{XsubAliases} or defined $self->{interfaces};
#    }
EOF

  if (@{ $BootCode_ref }) {
    print "\n    /* Initialisation Section */\n\n";
    @{ $self->{line} } = @{ $BootCode_ref };
    $self->print_section();
    print "\n    /* End of Initialisation Section */\n\n";
  }

  print Q(<<'EOF');
##if PERL_VERSION_LE(5, 21, 5)
##  if PERL_VERSION_GE(5, 9, 0)
#    if (PL_unitcheckav)
#        call_list(PL_scopestack_ix, PL_unitcheckav);
##  endif
#    XSRETURN_YES;
##else
#    Perl_xs_boot_epilog(aTHX_ ax);
##endif
#]]
#
EOF

  warn("Please specify prototyping behavior for $self->{filename} (see perlxs manual)\n")
    unless $self->{ProtoUsed};

  chdir($orig_cwd);
  select($orig_fh);
  untie *PSEUDO_STDOUT if tied *PSEUDO_STDOUT;
  close $self->{FH};

  return 1;
}

sub report_error_count {
  if (@_) {
    return $_[0]->{errors}||0;
  }
  else {
    return $Singleton->{errors}||0;
  }
}

# Input:  ($self, $_, @{ $self->{line} }) == unparsed input.
# Output: ($_, @{ $self->{line} }) == (rest of line, following lines).
# Return: the matched keyword if found, otherwise 0
sub check_keyword {
  my $self = shift;
  $_ = shift(@{ $self->{line} }) while !/\S/ && @{ $self->{line} };
  s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
}

sub print_section {
  my $self = shift;

  # the "do" is required for right semantics
  do { $_ = shift(@{ $self->{line} }) } while !/\S/ && @{ $self->{line} };

  my $consumed_code = '';

  print("#line ", $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} } -1], " \"",
        escape_file_for_line_directive($self->{filepathname}), "\"\n")
    if $self->{WantLineNumbers} && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/;
  for (;  defined($_) && !/^$BLOCK_regexp/o;  $_ = shift(@{ $self->{line} })) {
    print "$_\n";
    $consumed_code .= "$_\n";
  }
  print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $self->{WantLineNumbers};

  return $consumed_code;
}

sub merge_section {
  my $self = shift;
  my $in = '';

  while (!/\S/ && @{ $self->{line} }) {
    $_ = shift(@{ $self->{line} });
  }

  for (;  defined($_) && !/^$BLOCK_regexp/o;  $_ = shift(@{ $self->{line} })) {
    $in .= "$_\n";
  }
  chomp $in;
  return $in;
}

sub process_keyword {
  my($self, $pattern) = @_;

  while (my $kwd = $self->check_keyword($pattern)) {
    my $method = $kwd . "_handler";
    $self->$method($_);
  }
}

sub CASE_handler {
  my $self = shift;
  $_ = shift;
  $self->blurt("Error: 'CASE:' after unconditional 'CASE:'")
    if $self->{condnum} && $self->{cond} eq '';
  $self->{cond} = $_;
  trim_whitespace($self->{cond});
  print "   ", ($self->{condnum}++ ? " else" : ""), ($self->{cond} ? " if ($self->{cond})\n" : "\n");
  $_ = '';
}

sub INPUT_handler {
  my $self = shift;
  $_ = shift;
  for (;  !/^$BLOCK_regexp/o;  $_ = shift(@{ $self->{line} })) {
    last if /^\s*NOT_IMPLEMENTED_YET/;
    next unless /\S/;        # skip blank lines

    trim_whitespace($_);
    my $ln = $_;

    # remove trailing semicolon if no initialisation
    s/\s*;$//g unless /[=;+].*\S/;

    # Process the length(foo) declarations
    if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) {
      print "\tSTRLEN\tSTRLEN_length_of_$2;\n";
      $self->{lengthof}->{$2} = undef;
      $self->{deferred} .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;\n";
    }

    # check for optional initialisation code
    my $var_init = '';
    $var_init = $1 if s/\s*([=;+].*)$//s;
    $var_init =~ s/"/\\"/g;
    # *sigh* It's valid to supply explicit input typemaps in the argument list...
    my $is_overridden_typemap = $var_init =~ /ST\s*\(|\$arg\b/;

    s/\s+/ /g;
    my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s
      or $self->blurt("Error: invalid argument declaration '$ln'"), next;

    # Check for duplicate definitions
    $self->blurt("Error: duplicate definition of argument '$var_name' ignored"), next
      if $self->{arg_list}->{$var_name}++
        or defined $self->{argtype_seen}->{$var_name} and not $self->{processing_arg_with_types};

    $self->{thisdone} |= $var_name eq "THIS";
    $self->{retvaldone} |= $var_name eq "RETVAL";
    $self->{var_types}->{$var_name} = $var_type;
    # XXXX This check is a safeguard against the unfinished conversion of
    # generate_init().  When generate_init() is fixed,
    # one can use 2-args map_type() unconditionally.
    my $printed_name;
    if ($var_type =~ / \( \s* \* \s* \) /x) {
      # Function pointers are not yet supported with output_init()!
      print "\t" . map_type($self, $var_type, $var_name);
      $printed_name = 1;
    }
    else {
      print "\t" . map_type($self, $var_type, undef);
      $printed_name = 0;
    }
    $self->{var_num} = $self->{args_match}->{$var_name};

    if ($self->{var_num}) {
      my $typemap = $self->{typemap}->get_typemap(ctype => $var_type);
      $self->report_typemap_failure($self->{typemap}, $var_type, "death")
        if not $typemap and not $is_overridden_typemap;
      $self->{proto_arg}->[$self->{var_num}] = ($typemap && $typemap->proto) || "\$";
    }
    $self->{func_args} =~ s/\b($var_name)\b/&$1/ if $var_addr;
    if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/
      or $self->{in_out}->{$var_name} and $self->{in_out}->{$var_name} =~ /^OUT/
      and $var_init !~ /\S/) {
      if ($printed_name) {
        print ";\n";
      }
      else {
        print "\t$var_name;\n";
      }
    }
    elsif ($var_init =~ /\S/) {
      $self->output_init( {
        type          => $var_type,
        num           => $self->{var_num},
        var           => $var_name,
        init          => $var_init,
        printed_name  => $printed_name,
      } );
    }
    elsif ($self->{var_num}) {
      $self->generate_init( {
        type          => $var_type,
        num           => $self->{var_num},
        var           => $var_name,
        printed_name  => $printed_name,
      } );
    }
    else {
      print ";\n";
    }
  }
}

sub OUTPUT_handler {
  my $self = shift;
  $self->{have_OUTPUT} = 1;

  $_ = shift;
  for (;  !/^$BLOCK_regexp/o;  $_ = shift(@{ $self->{line} })) {
    next unless /\S/;
    if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) {
      $self->{DoSetMagic} = ($1 eq "ENABLE" ? 1 : 0);
      next;
    }
    my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s;
    $self->blurt("Error: duplicate OUTPUT argument '$outarg' ignored"), next
      if $self->{outargs}->{$outarg}++;
    if (!$self->{gotRETVAL} and $outarg eq 'RETVAL') {
      # deal with RETVAL last
      $self->{RETVAL_code} = $outcode;
      $self->{gotRETVAL} = 1;
      next;
    }
    $self->blurt("Error: OUTPUT $outarg not an argument"), next
      unless defined($self->{args_match}->{$outarg});
    $self->blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
      unless defined $self->{var_types}->{$outarg};
    $self->{var_num} = $self->{args_match}->{$outarg};
    if ($outcode) {
      print "\t$outcode\n";
      print "\tSvSETMAGIC(ST(" , $self->{var_num} - 1 , "));\n" if $self->{DoSetMagic};
    }
    else {
      $self->generate_output( {
        type        => $self->{var_types}->{$outarg},
        num         => $self->{var_num},
        var         => $outarg,
        do_setmagic => $self->{DoSetMagic},
        do_push     => undef,
      } );
    }
    delete $self->{in_out}->{$outarg}     # No need to auto-OUTPUT
      if exists $self->{in_out}->{$outarg} and $self->{in_out}->{$outarg} =~ /OUT$/;
  }
}

sub C_ARGS_handler {
  my $self = shift;
  $_ = shift;
  my $in = $self->merge_section();

  trim_whitespace($in);
  $self->{func_args} = $in;
}

sub INTERFACE_MACRO_handler {
  my $self = shift;
  $_ = shift;
  my $in = $self->merge_section();

  trim_whitespace($in);
  if ($in =~ /\s/) {        # two
    ($self->{interface_macro}, $self->{interface_macro_set}) = split ' ', $in;
  }
  else {
    $self->{interface_macro} = $in;
    $self->{interface_macro_set} = 'UNKNOWN_CVT'; # catch later
  }
  $self->{interface} = 1;        # local
  $self->{interfaces} = 1;        # global
}

sub INTERFACE_handler {
  my $self = shift;
  $_ = shift;
  my $in = $self->merge_section();

  trim_whitespace($in);

  foreach (split /[\s,]+/, $in) {
    my $iface_name = $_;
    $iface_name =~ s/^$self->{Prefix}//;
    $self->{Interfaces}->{$iface_name} = $_;
  }
  print Q(<<"EOF");
#    XSFUNCTION = $self->{interface_macro}($self->{ret_type},cv,XSANY.any_dptr);
EOF
  $self->{interface} = 1;        # local
  $self->{interfaces} = 1;        # global
}

sub CLEANUP_handler {
  my $self = shift;
  $self->print_section();
}

sub PREINIT_handler {
  my $self = shift;
  $self->print_section();
}

sub POSTCALL_handler {
  my $self = shift;
  $self->print_section();
}

sub INIT_handler {
  my $self = shift;
  $self->print_section();
}

sub get_aliases {
  my $self = shift;
  my ($line) = @_;
  my ($orig) = $line;

  # Parse alias definitions
  # format is
  #    alias = value alias = value ...

  while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
    my ($alias, $value) = ($1, $2);
    my $orig_alias = $alias;

    # check for optional package definition in the alias
    $alias = $self->{Packprefix} . $alias if $alias !~ /::/;

    # check for duplicate alias name & duplicate value
    Warn( $self, "Warning: Ignoring duplicate alias '$orig_alias'")
      if defined $self->{XsubAliases}->{$alias};

    Warn( $self, "Warning: Aliases '$orig_alias' and '$self->{XsubAliasValues}->{$value}' have identical values")
      if $self->{XsubAliasValues}->{$value};

    $self->{XsubAliases}->{$alias} = $value;
    $self->{XsubAliasValues}->{$value} = $orig_alias;
  }

  blurt( $self, "Error: Cannot parse ALIAS definitions from '$orig'")
    if $line;
}

sub ATTRS_handler {
  my $self = shift;
  $_ = shift;

  for (;  !/^$BLOCK_regexp/o;  $_ = shift(@{ $self->{line} })) {
    next unless /\S/;
    trim_whitespace($_);
    push @{ $self->{Attributes} }, $_;
  }
}

sub ALIAS_handler {
  my $self = shift;
  $_ = shift;

  for (;  !/^$BLOCK_regexp/o;  $_ = shift(@{ $self->{line} })) {
    next unless /\S/;
    trim_whitespace($_);
    $self->get_aliases($_) if $_;
  }
}

sub OVERLOAD_handler {
  my $self = shift;
  $_ = shift;

  for (;  !/^$BLOCK_regexp/o;  $_ = shift(@{ $self->{line} })) {
    next unless /\S/;
    trim_whitespace($_);
    while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) {
      $self->{Overload} = 1 unless $self->{Overload};
      my $overload = "$self->{Package}\::(".$1;
      push(@{ $self->{InitFileCode} },
       "        (void)$self->{newXS}(\"$overload\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n");
    }
  }
}

sub FALLBACK_handler {
  my ($self, $setting) = @_;

  # the rest of the current line should contain either TRUE,
  # FALSE or UNDEF

  trim_whitespace($setting);
  $setting = uc($setting);

  my %map = (
    TRUE => "&PL_sv_yes", 1 => "&PL_sv_yes",
    FALSE => "&PL_sv_no", 0 => "&PL_sv_no",
    UNDEF => "&PL_sv_undef",
  );

  # check for valid FALLBACK value
  $self->death("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{$setting};

  $self->{Fallback} = $map{$setting};
}


sub REQUIRE_handler {
  # the rest of the current line should contain a version number
  my ($self, $ver) = @_;

  trim_whitespace($ver);

  $self->death("Error: REQUIRE expects a version number")
    unless $ver;

  # check that the version number is of the form n.n
  $self->death("Error: REQUIRE: expected a number, got '$ver'")
    unless $ver =~ /^\d+(\.\d*)?/;

  $self->death("Error: xsubpp $ver (or better) required--this is only $VERSION.")
    unless $VERSION >= $ver;
}

sub VERSIONCHECK_handler {
  # the rest of the current line should contain either ENABLE or
  # DISABLE
  my ($self, $setting) = @_;

  trim_whitespace($setting);

  # check for ENABLE/DISABLE
  $self->death("Error: VERSIONCHECK: ENABLE/DISABLE")
    unless $setting =~ /^(ENABLE|DISABLE)/i;

  $self->{WantVersionChk} = 1 if $1 eq 'ENABLE';
  $self->{WantVersionChk} = 0 if $1 eq 'DISABLE';

}

sub PROTOTYPE_handler {
  my $self = shift;
  $_ = shift;

  my $specified;

  $self->death("Error: Only 1 PROTOTYPE definition allowed per xsub")
    if $self->{proto_in_this_xsub}++;

  for (;  !/^$BLOCK_regexp/o;  $_ = shift(@{ $self->{line} })) {
    next unless /\S/;
    $specified = 1;
    trim_whitespace($_);
    if ($_ eq 'DISABLE') {
      $self->{ProtoThisXSUB} = 0;
    }
    elsif ($_ eq 'ENABLE') {
      $self->{ProtoThisXSUB} = 1;
    }
    else {
      # remove any whitespace
      s/\s+//g;
      $self->death("Error: Invalid prototype '$_'")
        unless valid_proto_string($_);
      $self->{ProtoThisXSUB} = C_string($_);
    }
  }

  # If no prototype specified, then assume empty prototype ""
  $self->{ProtoThisXSUB} = 2 unless $specified;

  $self->{ProtoUsed} = 1;
}

sub SCOPE_handler {
  # Rest of line should be either ENABLE or DISABLE
  my ($self, $setting) = @_;

  $self->death("Error: Only 1 SCOPE declaration allowed per xsub")
    if $self->{scope_in_this_xsub}++;

  trim_whitespace($setting);
  $self->death("Error: SCOPE: ENABLE/DISABLE")
      unless $setting =~ /^(ENABLE|DISABLE)\b/i;
  $self->{ScopeThisXSUB} = ( uc($1) eq 'ENABLE' );
}

sub PROTOTYPES_handler {
  # the rest of the current line should contain either ENABLE or
  # DISABLE
  my ($self, $setting) = @_;

  trim_whitespace($setting);

  # check for ENABLE/DISABLE
  $self->death("Error: PROTOTYPES: ENABLE/DISABLE")
    unless $setting =~ /^(ENABLE|DISABLE)/i;

  $self->{WantPrototypes} = 1 if $1 eq 'ENABLE';
  $self->{WantPrototypes} = 0 if $1 eq 'DISABLE';
  $self->{ProtoUsed} = 1;
}

sub EXPORT_XSUB_SYMBOLS_handler {
  # the rest of the current line should contain either ENABLE or
  # DISABLE
  my ($self, $setting) = @_;

  trim_whitespace($setting);

  # check for ENABLE/DISABLE
  $self->death("Error: EXPORT_XSUB_SYMBOLS: ENABLE/DISABLE")
    unless $setting =~ /^(ENABLE|DISABLE)/i;

  my $xs_impl = $1 eq 'ENABLE' ? 'XS_EXTERNAL' : 'XS_INTERNAL';

  print Q(<<"EOF");
##undef XS_EUPXS
##if defined(PERL_EUPXS_ALWAYS_EXPORT)
##  define XS_EUPXS(name) XS_EXTERNAL(name)
##elif defined(PERL_EUPXS_NEVER_EXPORT)
##  define XS_EUPXS(name) XS_INTERNAL(name)
##else
##  define XS_EUPXS(name) $xs_impl(name)
##endif
EOF
}


sub PushXSStack {
  my $self = shift;
  my %args = @_;
  # Save the current file context.
  push(@{ $self->{XSStack} }, {
          type            => 'file',
          LastLine        => $self->{lastline},
          LastLineNo      => $self->{lastline_no},
          Line            => $self->{line},
          LineNo          => $self->{line_no},
          Filename        => $self->{filename},
          Filepathname    => $self->{filepathname},
          Handle          => $self->{FH},
          IsPipe          => scalar($self->{filename} =~ /\|\s*$/),
          %args,
         });

}

sub INCLUDE_handler {
  my $self = shift;
  $_ = shift;
  # the rest of the current line should contain a valid filename

  trim_whitespace($_);

  $self->death("INCLUDE: filename missing")
    unless $_;

  $self->death("INCLUDE: output pipe is illegal")
    if /^\s*\|/;

  # simple minded recursion detector
  $self->death("INCLUDE loop detected")
    if $self->{IncludedFiles}->{$_};

  ++$self->{IncludedFiles}->{$_} unless /\|\s*$/;

  if (/\|\s*$/ && /^\s*perl\s/) {
    Warn( $self, "The INCLUDE directive with a command is discouraged." .
          " Use INCLUDE_COMMAND instead! In particular using 'perl'" .
          " in an 'INCLUDE: ... |' directive is not guaranteed to pick" .
          " up the correct perl. The INCLUDE_COMMAND directive allows" .
          " the use of \$^X as the currently running perl, see" .
          " 'perldoc perlxs' for details.");
  }

  $self->PushXSStack();

  $self->{FH} = Symbol::gensym();

  # open the new file
  open($self->{FH}, $_) or $self->death("Cannot open '$_': $!");

  print Q(<<"EOF");
#
#/* INCLUDE:  Including '$_' from '$self->{filename}' */
#
EOF

  $self->{filename} = $_;
  $self->{filepathname} = ( $^O =~ /^mswin/i )
                          ? qq($self->{dir}/$self->{filename}) # See CPAN RT #61908: gcc doesn't like backslashes on win32?
                          : File::Spec->catfile($self->{dir}, $self->{filename});

  # Prime the pump by reading the first
  # non-blank line

  # skip leading blank lines
  while (readline($self->{FH})) {
    last unless /^\s*$/;
  }

  $self->{lastline} = $_;
  $self->{lastline_no} = $.;
}

sub QuoteArgs {
  my $cmd = shift;
  my @args = split /\s+/, $cmd;
  $cmd = shift @args;
  for (@args) {
    $_ = q(").$_.q(") if !/^\"/ && length($_) > 0;
  }
  return join (' ', ($cmd, @args));
}

# code copied from CPAN::HandleConfig::safe_quote
#  - that has doc saying leave if start/finish with same quote, but no code
# given text, will conditionally quote it to protect from shell
{
  my ($quote, $use_quote) = $^O eq 'MSWin32'
      ? (q{"}, q{"})
      : (q{"'}, q{'});
  sub _safe_quote {
      my ($self, $command) = @_;
      # Set up quote/default quote
      if (defined($command)
          and $command =~ /\s/
          and $command !~ /[$quote]/) {
          return qq{$use_quote$command$use_quote}
      }
      return $command;
  }
}

sub INCLUDE_COMMAND_handler {
  my $self = shift;
  $_ = shift;
  # the rest of the current line should contain a valid command

  trim_whitespace($_);

  $_ = QuoteArgs($_) if $^O eq 'VMS';

  $self->death("INCLUDE_COMMAND: command missing")
    unless $_;

  $self->death("INCLUDE_COMMAND: pipes are illegal")
    if /^\s*\|/ or /\|\s*$/;

  $self->PushXSStack( IsPipe => 1 );

  $self->{FH} = Symbol::gensym();

  # If $^X is used in INCLUDE_COMMAND, we know it's supposed to be
  # the same perl interpreter as we're currently running
  my $X = $self->_safe_quote($^X); # quotes if has spaces
  s/^\s*\$\^X/$X/;

  # open the new file
  open ($self->{FH}, "-|", $_)
    or $self->death( $self, "Cannot run command '$_' to include its output: $!");

  print Q(<<"EOF");
#
#/* INCLUDE_COMMAND:  Including output of '$_' from '$self->{filename}' */
#
EOF

  $self->{filename} = $_;
  $self->{filepathname} = $self->{filename};
  #$self->{filepathname} =~ s/\"/\\"/g; # Fails? See CPAN RT #53938: MinGW Broken after 2.21
  $self->{filepathname} =~ s/\\/\\\\/g; # Works according to reporter of #53938

  # Prime the pump by reading the first
  # non-blank line

  # skip leading blank lines
  while (readline($self->{FH})) {
    last unless /^\s*$/;
  }

  $self->{lastline} = $_;
  $self->{lastline_no} = $.;
}

sub PopFile {
  my $self = shift;

  return 0 unless $self->{XSStack}->[-1]{type} eq 'file';

  my $data     = pop @{ $self->{XSStack} };
  my $ThisFile = $self->{filename};
  my $isPipe   = $data->{IsPipe};

  --$self->{IncludedFiles}->{$self->{filename}}
    unless $isPipe;

  close $self->{FH};

  $self->{FH}         = $data->{Handle};
  # $filename is the leafname, which for some reason is used for diagnostic
  # messages, whereas $filepathname is the full pathname, and is used for
  # #line directives.
  $self->{filename}   = $data->{Filename};
  $self->{filepathname} = $data->{Filepathname};
  $self->{lastline}   = $data->{LastLine};
  $self->{lastline_no} = $data->{LastLineNo};
  @{ $self->{line} }       = @{ $data->{Line} };
  @{ $self->{line_no} }    = @{ $data->{LineNo} };

  if ($isPipe and $? ) {
    --$self->{lastline_no};
    print STDERR "Error reading from pipe '$ThisFile': $! in $self->{filename}, line $self->{lastline_no}\n" ;
    exit 1;
  }

  print Q(<<"EOF");
#
#/* INCLUDE: Returning to '$self->{filename}' from '$ThisFile' */
#
EOF

  return 1;
}

sub Q {
  my($text) = @_;
  $text =~ s/^#//gm;
  $text =~ s/\[\[/{/g;
  $text =~ s/\]\]/}/g;
  $text;
}

# Process "MODULE = Foo ..." lines and update global state accordingly
sub _process_module_xs_line {
  my ($self, $module, $pkg, $prefix) = @_;

  ($self->{Module_cname} = $module) =~ s/\W/_/g;

  $self->{Package} = defined($pkg) ? $pkg : '';
  $self->{Prefix}  = quotemeta( defined($prefix) ? $prefix : '' );

  ($self->{Packid} = $self->{Package}) =~ tr/:/_/;

  $self->{Packprefix} = $self->{Package};
  $self->{Packprefix} .= "::" if $self->{Packprefix} ne "";

  $self->{lastline} = "";
}

# Skip any embedded POD sections
sub _maybe_skip_pod {
  my ($self) = @_;

  while ($self->{lastline} =~ /^=/) {
    while ($self->{lastline} = readline($self->{FH})) {
      last if ($self->{lastline} =~ /^=cut\s*$/);
    }
    $self->death("Error: Unterminated pod") unless defined $self->{lastline};
    $self->{lastline} = readline($self->{FH});
    chomp $self->{lastline};
    $self->{lastline} =~ s/^\s+$//;
  }
}

# This chunk of code strips out (and parses) embedded TYPEMAP blocks
# which support a HEREdoc-alike block syntax.
sub _maybe_parse_typemap_block {
  my ($self) = @_;

  # This is special cased from the usual paragraph-handler logic
  # due to the HEREdoc-ish syntax.
  if ($self->{lastline} =~ /^TYPEMAP\s*:\s*<<\s*(?:(["'])(.+?)\1|([^\s'"]+?))\s*;?\s*$/)
  {
    my $end_marker = quotemeta(defined($1) ? $2 : $3);

    # Scan until we find $end_marker alone on a line.
    my @tmaplines;
    while (1) {
      $self->{lastline} = readline($self->{FH});
      $self->death("Error: Unterminated TYPEMAP section") if not defined $self->{lastline};
      last if $self->{lastline} =~ /^$end_marker\s*$/;
      push @tmaplines, $self->{lastline};
    }

    my $tmap = ExtUtils::Typemaps->new(
      string        => join("", @tmaplines),
      lineno_offset => 1 + ($self->current_line_number() || 0),
      fake_filename => $self->{filename},
    );
    $self->{typemap}->merge(typemap => $tmap, replace => 1);

    $self->{lastline} = "";
  }
}

# Read next xsub into @{ $self->{line} } from ($lastline, readline($self->{FH})).
sub fetch_para {
  my $self = shift;

  # parse paragraph
  $self->death("Error: Unterminated '#if/#ifdef/#ifndef'")
    if !defined $self->{lastline} && $self->{XSStack}->[-1]{type} eq 'if';
  @{ $self->{line} } = ();
  @{ $self->{line_no} } = ();
  return $self->PopFile() if not defined $self->{lastline}; # EOF

  if ($self->{lastline} =~
      /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/)
  {
    $self->_process_module_xs_line($1, $2, $3);
  }

  for (;;) {
    $self->_maybe_skip_pod;

    $self->_maybe_parse_typemap_block;

    if ($self->{lastline} !~ /^\s*#/ # not a CPP directive
        # CPP directives:
        #    ANSI:    if ifdef ifndef elif else endif define undef
        #        line error pragma
        #    gcc:    warning include_next
        #   obj-c:    import
        #   others:    ident (gcc notes that some cpps have this one)
        || $self->{lastline} =~ /^\#[ \t]*
                                  (?:
                                        (?:if|ifn?def|elif|else|endif|
                                           define|undef|pragma|error|
                                           warning|line\s+\d+|ident)
                                        \b
                                      | (?:include(?:_next)?|import)
                                        \s* ["<] .* [>"]
                                 )
                                /x
    )
    {
      last if $self->{lastline} =~ /^\S/ && @{ $self->{line} } && $self->{line}->[-1] eq "";
      push(@{ $self->{line} }, $self->{lastline});
      push(@{ $self->{line_no} }, $self->{lastline_no});
    }

    # Read next line and continuation lines
    last unless defined($self->{lastline} = readline($self->{FH}));
    $self->{lastline_no} = $.;
    my $tmp_line;
    $self->{lastline} .= $tmp_line
      while ($self->{lastline} =~ /\\$/ && defined($tmp_line = readline($self->{FH})));

    chomp $self->{lastline};
    $self->{lastline} =~ s/^\s+$//;
  }

  # Nuke trailing "line" entries until there's one that's not empty
  pop(@{ $self->{line} }), pop(@{ $self->{line_no} })
    while @{ $self->{line} } && $self->{line}->[-1] eq "";

  return 1;
}

sub output_init {
  my $self = shift;
  my $argsref = shift;

  my ($type, $num, $var, $init, $printed_name)
    = @{$argsref}{qw(type num var init printed_name)};

  # local assign for efficiently passing in to eval_input_typemap_code
  local $argsref->{arg} = $num
                          ? "ST(" . ($num-1) . ")"
                          : "/* not a parameter */";

  if ( $init =~ /^=/ ) {
    if ($printed_name) {
      $self->eval_input_typemap_code(qq/print " $init\\n"/, $argsref);
    }
    else {
      $self->eval_input_typemap_code(qq/print "\\t$var $init\\n"/, $argsref);
    }
  }
  else {
    if (  $init =~ s/^\+//  &&  $num  ) {
      $self->generate_init( {
        type          => $type,
        num           => $num,
        var           => $var,
        printed_name  => $printed_name,
      } );
    }
    elsif ($printed_name) {
      print ";\n";
      $init =~ s/^;//;
    }
    else {
      $self->eval_input_typemap_code(qq/print "\\t$var;\\n"/, $argsref);
      $init =~ s/^;//;
    }
    $self->{deferred}
      .= $self->eval_input_typemap_code(qq/"\\n\\t$init\\n"/, $argsref);
  }
}

sub generate_init {
  my $self = shift;
  my $argsref = shift;

  my ($type, $num, $var, $printed_name)
    = @{$argsref}{qw(type num var printed_name)};

  my $argoff = $num - 1;
  my $arg = "ST($argoff)";

  my $typemaps = $self->{typemap};

  $type = ExtUtils::Typemaps::tidy_type($type);
  if (not $typemaps->get_typemap(ctype => $type)) {
    $self->report_typemap_failure($typemaps, $type);
    return;
  }

  (my $ntype = $type) =~ s/\s*\*/Ptr/g;
  (my $subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;

  my $typem = $typemaps->get_typemap(ctype => $type);
  my $xstype = $typem->xstype;
  #this is an optimization from perl 5.0 alpha 6, class check is skipped
  #T_REF_IV_REF is missing since it has no untyped analog at the moment
  $xstype =~ s/OBJ$/REF/ || $xstype =~ s/^T_REF_IV_PTR$/T_PTRREF/
    if $self->{func_name} =~ /DESTROY$/;
  if ($xstype eq 'T_PV' and exists $self->{lengthof}->{$var}) {
    print "\t$var" unless $printed_name;
    print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n";
    die "default value not supported with length(NAME) supplied"
      if defined $self->{defaults}->{$var};
    return;
  }
  $type =~ tr/:/_/ unless $self->{RetainCplusplusHierarchicalTypes};

  my $inputmap = $typemaps->get_inputmap(xstype => $xstype);
  if (not defined $inputmap) {
    $self->blurt("Error: No INPUT definition for type '$type', typekind '" . $type->xstype . "' found");
    return;
  }

  my $expr = $inputmap->cleaned_code;
  # Note: This gruesome bit either needs heavy rethinking or documentation. I vote for the former. --Steffen
  if ($expr =~ /DO_ARRAY_ELEM/) {
    my $subtypemap  = $typemaps->get_typemap(ctype => $subtype);
    if (not $subtypemap) {
      $self->report_typemap_failure($typemaps, $subtype);
      return;
    }

    my $subinputmap = $typemaps->get_inputmap(xstype => $subtypemap->xstype);
    if (not $subinputmap) {
      $self->blurt("Error: No INPUT definition for type '$subtype', typekind '" . $subtypemap->xstype . "' found");
      return;
    }

    my $subexpr = $subinputmap->cleaned_code;
    $subexpr =~ s/\$type/\$subtype/g;
    $subexpr =~ s/ntype/subtype/g;
    $subexpr =~ s/\$arg/ST(ix_$var)/g;
    $subexpr =~ s/\n\t/\n\t\t/g;
    $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g;
    $subexpr =~ s/\$var/${var}\[ix_$var - $argoff]/;
    $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
  }
  if ($expr =~ m#/\*.*scope.*\*/#i) {  # "scope" in C comments
    $self->{ScopeThisXSUB} = 1;
  }

  my $eval_vars = {
    var           => $var,
    printed_name  => $printed_name,
    type          => $type,
    ntype         => $ntype,
    subtype       => $subtype,
    num           => $num,
    arg           => $arg,
    argoff        => $argoff,
  };

  if (defined($self->{defaults}->{$var})) {
    $expr =~ s/(\t+)/$1    /g;
    $expr =~ s/        /\t/g;
    if ($printed_name) {
      print ";\n";
    }
    else {
      $self->eval_input_typemap_code(qq/print "\\t$var;\\n"/, $eval_vars);
    }
    if ($self->{defaults}->{$var} eq 'NO_INIT') {
      $self->{deferred} .= $self->eval_input_typemap_code(
        qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/,
        $eval_vars
      );
    }
    else {
      $self->{deferred} .= $self->eval_input_typemap_code(
        qq/"\\n\\tif (items < $num)\\n\\t    $var = $self->{defaults}->{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/,
        $eval_vars
      );
    }
  }
  elsif ($self->{ScopeThisXSUB} or $expr !~ /^\s*\$var =/) {
    if ($printed_name) {
      print ";\n";
    }
    else {
      $self->eval_input_typemap_code(qq/print "\\t$var;\\n"/, $eval_vars);
    }
    $self->{deferred}
      .= $self->eval_input_typemap_code(qq/"\\n$expr;\\n"/, $eval_vars);
  }
  else {
    die "panic: do not know how to handle this branch for function pointers"
      if $printed_name;
    $self->eval_input_typemap_code(qq/print "$expr;\\n"/, $eval_vars);
  }
}

sub generate_output {
  my $self = shift;
  my $argsref = shift;
  my ($type, $num, $var, $do_setmagic, $do_push)
    = @{$argsref}{qw(type num var do_setmagic do_push)};

  my $arg = "ST(" . ($num - ($num != 0)) . ")";

  my $typemaps = $self->{typemap};

  $type = ExtUtils::Typemaps::tidy_type($type);
  local $argsref->{type} = $type;

  if ($type =~ /^array\(([^,]*),(.*)\)/) {
    print "\t$arg = sv_newmortal();\n";
    print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n";
    print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
  }
  else {
    my $typemap = $typemaps->get_typemap(ctype => $type);
    if (not $typemap) {
      $self->report_typemap_failure($typemaps, $type);
      return;
    }

    my $outputmap = $typemaps->get_outputmap(xstype => $typemap->xstype);
    if (not $outputmap) {
      $self->blurt("Error: No OUTPUT definition for type '$type', typekind '" . $typemap->xstype . "' found");
      return;
    }

    (my $ntype = $type) =~ s/\s*\*/Ptr/g;
    $ntype =~ s/\(\)//g;
    (my $subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;

    my $eval_vars = {%$argsref, subtype => $subtype, ntype => $ntype, arg => $arg};
    my $expr = $outputmap->cleaned_code;
    if ($expr =~ /DO_ARRAY_ELEM/) {
      my $subtypemap = $typemaps->get_typemap(ctype => $subtype);
      if (not $subtypemap) {
        $self->report_typemap_failure($typemaps, $subtype);
        return;
      }

      my $suboutputmap = $typemaps->get_outputmap(xstype => $subtypemap->xstype);
      if (not $suboutputmap) {
        $self->blurt("Error: No OUTPUT definition for type '$subtype', typekind '" . $subtypemap->xstype . "' found");
        return;
      }

      my $subexpr = $suboutputmap->cleaned_code;
      $subexpr =~ s/ntype/subtype/g;
      $subexpr =~ s/\$arg/ST(ix_$var)/g;
      $subexpr =~ s/\$var/${var}\[ix_$var]/g;
      $subexpr =~ s/\n\t/\n\t\t/g;
      $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
      $self->eval_output_typemap_code("print qq\a$expr\a", $eval_vars);
      print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic;
    }
    elsif ($var eq 'RETVAL') {
      my $orig_arg = $arg;
      my $indent;
      my $use_RETVALSV = 1;
      my $do_mortal = 0;
      my $do_copy_tmp = 1;
      my $pre_expr;
      local $eval_vars->{arg} = $arg = 'RETVALSV';
      my $evalexpr = $self->eval_output_typemap_code("qq\a$expr\a", $eval_vars);

      if ($expr =~ /^\t\Q$arg\E = new/) {
        # We expect that $arg has refcnt 1, so we need to
        # mortalize it.
        $do_mortal = 1;
      }
      # If RETVAL is immortal, don't mortalize it. This code is not perfect:
      # It won't detect a func or expression that only returns immortals, for
      # example, this RE must be tried before next elsif.
      elsif ($evalexpr =~ /^\t\Q$arg\E\s*=\s*(boolSV\(|(&PL_sv_yes|&PL_sv_no|&PL_sv_undef)\s*;)/) {
        $do_copy_tmp = 0; #$arg will be a ST(X), no SV* RETVAL, no RETVALSV
        $use_RETVALSV = 0;
      }
      elsif ($evalexpr =~ /^\s*\Q$arg\E\s*=/) {
        # We expect that $arg has refcnt >=1, so we need
        # to mortalize it!
        $use_RETVALSV = 0 if $ntype eq "SVPtr";#reuse SV* RETVAL vs open new block
        $do_mortal = 1;
      }
      else {
        # Just hope that the entry would safely write it
        # over an already mortalized value. By
        # coincidence, something like $arg = &PL_sv_undef
        # works too, but should be caught above.
        $pre_expr = "RETVALSV = sv_newmortal();\n";
        # new mortals don't have set magic
        $do_setmagic = 0;
      }
      if($use_RETVALSV) {
        print "\t{\n\t    SV * RETVALSV;\n";
        $indent = "\t    ";
      } else {
        $indent = "\t";
      }
      print $indent.$pre_expr if $pre_expr;

      if($use_RETVALSV) {
        #take control of 1 layer of indent, may or may not indent more
        $evalexpr =~ s/^(\t|        )/$indent/gm;
        #"\t    \t" doesn't draw right in some IDEs
        #break down all \t into spaces
        $evalexpr =~ s/\t/        /g;
        #rebuild back into \t'es, \t==8 spaces, indent==4 spaces
        $evalexpr =~ s/        /\t/g;
      }
      else {
        if($do_mortal || $do_setmagic) {
        #typemap entry evaled with RETVALSV, if we aren't using RETVALSV replace
          $evalexpr =~ s/RETVALSV/RETVAL/g; #all uses with RETVAL for prettier code
        }
        else { #if no extra boilerplate (no mortal, no set magic) is needed
            #after $evalexport, get rid of RETVALSV's visual cluter and change
          $evalexpr =~ s/RETVALSV/$orig_arg/g;#the lvalue to ST(X)
        }
      }
      #stop "	RETVAL = RETVAL;" for SVPtr type
      print $evalexpr if $evalexpr !~ /^\s*RETVAL = RETVAL;$/;
      print $indent.'RETVAL'.($use_RETVALSV ? 'SV':'')
            .' = sv_2mortal(RETVAL'.($use_RETVALSV ? 'SV':'').");\n" if $do_mortal;
      print $indent.'SvSETMAGIC(RETVAL'.($use_RETVALSV ? 'SV':'').");\n" if $do_setmagic;
      #dont do "RETVALSV = boolSV(RETVAL); ST(0) = RETVALSV;", it is visual clutter
      print $indent."$orig_arg = RETVAL".($use_RETVALSV ? 'SV':'').";\n"
        if $do_mortal || $do_setmagic || $do_copy_tmp;
      print "\t}\n" if $use_RETVALSV;
    }
    elsif ($do_push) {
      print "\tPUSHs(sv_newmortal());\n";
      local $eval_vars->{arg} = "ST($num)";
      $self->eval_output_typemap_code("print qq\a$expr\a", $eval_vars);
      print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
    }
    elsif ($arg =~ /^ST\(\d+\)$/) {
      $self->eval_output_typemap_code("print qq\a$expr\a", $eval_vars);
      print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
    }
  }
}


# Just delegates to a clean package.
# Shim to evaluate Perl code in the right variable context
# for typemap code (having things such as $ALIAS set up).
sub eval_output_typemap_code {
  my ($self, $code, $other) = @_;
  return ExtUtils::ParseXS::Eval::eval_output_typemap_code($self, $code, $other);
}

sub eval_input_typemap_code {
  my ($self, $code, $other) = @_;
  return ExtUtils::ParseXS::Eval::eval_input_typemap_code($self, $code, $other);
}

1;

# vim: ts=2 sw=2 et:
PK       ! ����  �    perl5/ExtUtils/MY.pmnu ��6�$        package ExtUtils::MY;

use strict;
require ExtUtils::MM;

our $VERSION = '7.50';
$VERSION =~ tr/_//d;
our @ISA = qw(ExtUtils::MM);

{
    package MY;
    our @ISA = qw(ExtUtils::MY);
}

sub DESTROY {}


=head1 NAME

ExtUtils::MY - ExtUtils::MakeMaker subclass for customization

=head1 SYNOPSIS

  # in your Makefile.PL
  sub MY::whatever {
      ...
  }

=head1 DESCRIPTION

B<FOR INTERNAL USE ONLY>

ExtUtils::MY is a subclass of L<ExtUtils::MM>.  Its provided in your
Makefile.PL for you to add and override MakeMaker functionality.

It also provides a convenient alias via the MY class.

ExtUtils::MY might turn out to be a temporary solution, but MY won't
go away.

=cut
PK       ! yE�V%%  %%    perl5/ExtUtils/Liblist.pmnu ��6�$        package ExtUtils::Liblist;

use strict;
use warnings;

our $VERSION = '7.50';
$VERSION =~ tr/_//d;

use File::Spec;
require ExtUtils::Liblist::Kid;
our @ISA = qw(ExtUtils::Liblist::Kid File::Spec);

# Backwards compatibility with old interface.
sub ext {
    goto &ExtUtils::Liblist::Kid::ext;
}

sub lsdir {
  shift;
  my $rex = qr/$_[1]/;
  opendir my $dir_fh, $_[0];
  my @out = grep /$rex/, readdir $dir_fh;
  closedir $dir_fh;
  return @out;
}

__END__

=head1 NAME

ExtUtils::Liblist - determine libraries to use and how to use them

=head1 SYNOPSIS

  require ExtUtils::Liblist;

  $MM->ext($potential_libs, $verbose, $need_names);

  # Usually you can get away with:
  ExtUtils::Liblist->ext($potential_libs, $verbose, $need_names)

=head1 DESCRIPTION

This utility takes a list of libraries in the form C<-llib1 -llib2
-llib3> and returns lines suitable for inclusion in an extension
Makefile.  Extra library paths may be included with the form
C<-L/another/path> this will affect the searches for all subsequent
libraries.

It returns an array of four or five scalar values: EXTRALIBS,
BSLOADLIBS, LDLOADLIBS, LD_RUN_PATH, and, optionally, a reference to
the array of the filenames of actual libraries.  Some of these don't
mean anything unless on Unix.  See the details about those platform
specifics below.  The list of the filenames is returned only if
$need_names argument is true.

Dependent libraries can be linked in one of three ways:

=over 2

=item * For static extensions

by the ld command when the perl binary is linked with the extension
library. See EXTRALIBS below.

=item * For dynamic extensions at build/link time

by the ld command when the shared object is built/linked. See
LDLOADLIBS below.

=item * For dynamic extensions at load time

by the DynaLoader when the shared object is loaded. See BSLOADLIBS
below.

=back

=head2 EXTRALIBS

List of libraries that need to be linked with when linking a perl
binary which includes this extension. Only those libraries that
actually exist are included.  These are written to a file and used
when linking perl.

=head2 LDLOADLIBS and LD_RUN_PATH

List of those libraries which can or must be linked into the shared
library when created using ld. These may be static or dynamic
libraries.  LD_RUN_PATH is a colon separated list of the directories
in LDLOADLIBS. It is passed as an environment variable to the process
that links the shared library.

=head2 BSLOADLIBS

List of those libraries that are needed but can be linked in
dynamically at run time on this platform.  SunOS/Solaris does not need
this because ld records the information (from LDLOADLIBS) into the
object file.  This list is used to create a .bs (bootstrap) file.

=head1 PORTABILITY

This module deals with a lot of system dependencies and has quite a
few architecture specific C<if>s in the code.

=head2 VMS implementation

The version of ext() which is executed under VMS differs from the
Unix-OS/2 version in several respects:

=over 2

=item *

Input library and path specifications are accepted with or without the
C<-l> and C<-L> prefixes used by Unix linkers.  If neither prefix is
present, a token is considered a directory to search if it is in fact
a directory, and a library to search for otherwise.  Authors who wish
their extensions to be portable to Unix or OS/2 should use the Unix
prefixes, since the Unix-OS/2 version of ext() requires them.

=item *

Wherever possible, shareable images are preferred to object libraries,
and object libraries to plain object files.  In accordance with VMS
naming conventions, ext() looks for files named I<lib>shr and I<lib>rtl;
it also looks for I<lib>lib and libI<lib> to accommodate Unix conventions
used in some ported software.

=item *

For each library that is found, an appropriate directive for a linker options
file is generated.  The return values are space-separated strings of
these directives, rather than elements used on the linker command line.

=item *

LDLOADLIBS contains both the libraries found based on C<$potential_libs> and
the CRTLs, if any, specified in Config.pm.  EXTRALIBS contains just those
libraries found based on C<$potential_libs>.  BSLOADLIBS and LD_RUN_PATH
are always empty.

=back

In addition, an attempt is made to recognize several common Unix library
names, and filter them out or convert them to their VMS equivalents, as
appropriate.

In general, the VMS version of ext() should properly handle input from
extensions originally designed for a Unix or VMS environment.  If you
encounter problems, or discover cases where the search could be improved,
please let us know.

=head2 Win32 implementation

The version of ext() which is executed under Win32 differs from the
Unix-OS/2 version in several respects:

=over 2

=item *

If C<$potential_libs> is empty, the return value will be empty.
Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm)
will be appended to the list of C<$potential_libs>.  The libraries
will be searched for in the directories specified in C<$potential_libs>,
C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>.
For each library that is found,  a space-separated list of fully qualified
library pathnames is generated.

=item *

Input library and path specifications are accepted with or without the
C<-l> and C<-L> prefixes used by Unix linkers.

An entry of the form C<-La:\foo> specifies the C<a:\foo> directory to look
for the libraries that follow.

An entry of the form C<-lfoo> specifies the library C<foo>, which may be
spelled differently depending on what kind of compiler you are using.  If
you are using GCC, it gets translated to C<libfoo.a>, but for other win32
compilers, it becomes C<foo.lib>.  If no files are found by those translated
names, one more attempt is made to find them using either C<foo.a> or
C<libfoo.lib>, depending on whether GCC or some other win32 compiler is
being used, respectively.

If neither the C<-L> or C<-l> prefix is present in an entry, the entry is
considered a directory to search if it is in fact a directory, and a
library to search for otherwise.  The C<$Config{lib_ext}> suffix will
be appended to any entries that are not directories and don't already have
the suffix.

Note that the C<-L> and C<-l> prefixes are B<not required>, but authors
who wish their extensions to be portable to Unix or OS/2 should use the
prefixes, since the Unix-OS/2 version of ext() requires them.

=item *

Entries cannot be plain object files, as many Win32 compilers will
not handle object files in the place of libraries.

=item *

Entries in C<$potential_libs> beginning with a colon and followed by
alphanumeric characters are treated as flags.  Unknown flags will be ignored.

An entry that matches C</:nodefault/i> disables the appending of default
libraries found in C<$Config{perllibs}> (this should be only needed very rarely).

An entry that matches C</:nosearch/i> disables all searching for
the libraries specified after it.  Translation of C<-Lfoo> and
C<-lfoo> still happens as appropriate (depending on compiler being used,
as reflected by C<$Config{cc}>), but the entries are not verified to be
valid files or directories.

An entry that matches C</:search/i> reenables searching for
the libraries specified after it.  You can put it at the end to
enable searching for default libraries specified by C<$Config{perllibs}>.

=item *

The libraries specified may be a mixture of static libraries and
import libraries (to link with DLLs).  Since both kinds are used
pretty transparently on the Win32 platform, we do not attempt to
distinguish between them.

=item *

LDLOADLIBS and EXTRALIBS are always identical under Win32, and BSLOADLIBS
and LD_RUN_PATH are always empty (this may change in future).

=item *

You must make sure that any paths and path components are properly
surrounded with double-quotes if they contain spaces. For example,
C<$potential_libs> could be (literally):

	"-Lc:\Program Files\vc\lib" msvcrt.lib "la test\foo bar.lib"

Note how the first and last entries are protected by quotes in order
to protect the spaces.

=item *

Since this module is most often used only indirectly from extension
C<Makefile.PL> files, here is an example C<Makefile.PL> entry to add
a library to the build process for an extension:

        LIBS => ['-lgl']

When using GCC, that entry specifies that MakeMaker should first look
for C<libgl.a> (followed by C<gl.a>) in all the locations specified by
C<$Config{libpth}>.

When using a compiler other than GCC, the above entry will search for
C<gl.lib> (followed by C<libgl.lib>).

If the library happens to be in a location not in C<$Config{libpth}>,
you need:

        LIBS => ['-Lc:\gllibs -lgl']

Here is a less often used example:

        LIBS => ['-lgl', ':nosearch -Ld:\mesalibs -lmesa -luser32']

This specifies a search for library C<gl> as before.  If that search
fails to find the library, it looks at the next item in the list. The
C<:nosearch> flag will prevent searching for the libraries that follow,
so it simply returns the value as C<-Ld:\mesalibs -lmesa -luser32>,
since GCC can use that value as is with its linker.

When using the Visual C compiler, the second item is returned as
C<-libpath:d:\mesalibs mesa.lib user32.lib>.

When using the Borland compiler, the second item is returned as
C<-Ld:\mesalibs mesa.lib user32.lib>, and MakeMaker takes care of
moving the C<-Ld:\mesalibs> to the correct place in the linker
command line.

=back


=head1 SEE ALSO

L<ExtUtils::MakeMaker>

=cut

PK       ! C@��F	  F	    perl5/ExtUtils/ParseXS/Eval.pmnu ��6�$        package ExtUtils::ParseXS::Eval;
use strict;
use warnings;

our $VERSION = '3.35';

=head1 NAME

ExtUtils::ParseXS::Eval - Clean package to evaluate code in

=head1 SYNOPSIS

  use ExtUtils::ParseXS::Eval;
  my $rv = ExtUtils::ParseXS::Eval::eval_typemap_code(
    $parsexs_obj, "some Perl code"
  );

=head1 SUBROUTINES

=head2 $pxs->eval_output_typemap_code($typemapcode, $other_hashref)

Sets up various bits of previously global state
(formerly ExtUtils::ParseXS package variables)
for eval'ing output typemap code that may refer to these
variables.

Warns the contents of C<$@> if any.

Not all these variables are necessarily considered "public" wrt. use in
typemaps, so beware. Variables set up from the ExtUtils::ParseXS object:

  $Package $Alias $func_name $Full_func_name $pname

Variables set up from C<$other_hashref>:

  $var $type $ntype $subtype $arg

=cut

sub eval_output_typemap_code {
  my ($_pxs, $_code, $_other) = @_;

  my ($Package, $ALIAS, $func_name, $Full_func_name, $pname)
    = @{$_pxs}{qw(Package ALIAS func_name Full_func_name pname)};

  my ($var, $type, $ntype, $subtype, $arg)
    = @{$_other}{qw(var type ntype subtype arg)};

  my $rv = eval $_code;
  warn $@ if $@;
  return $rv;
}

=head2 $pxs->eval_input_typemap_code($typemapcode, $other_hashref)

Sets up various bits of previously global state
(formerly ExtUtils::ParseXS package variables)
for eval'ing output typemap code that may refer to these
variables.

Warns the contents of C<$@> if any.

Not all these variables are necessarily considered "public" wrt. use in
typemaps, so beware. Variables set up from the ExtUtils::ParseXS object:

  $Package $Alias $func_name $Full_func_name $pname

Variables set up from C<$other_hashref>:

  $var $type $ntype $subtype $num $init $printed_name $arg $argoff

=cut

sub eval_input_typemap_code {
  my ($_pxs, $_code, $_other) = @_;

  my ($Package, $ALIAS, $func_name, $Full_func_name, $pname)
    = @{$_pxs}{qw(Package ALIAS func_name Full_func_name pname)};

  my ($var, $type, $num, $init, $printed_name, $arg, $ntype, $argoff, $subtype)
    = @{$_other}{qw(var type num init printed_name arg ntype argoff subtype)};

  my $rv = eval $_code;
  warn $@ if $@;
  return $rv;
}

=head1 TODO

Eventually, with better documentation and possible some cleanup,
this could be part of C<ExtUtils::Typemaps>.

=cut

1;

# vim: ts=2 sw=2 et:
PK       ! ��ڠC  C  #  perl5/ExtUtils/ParseXS/Utilities.pmnu ��6�$        package ExtUtils::ParseXS::Utilities;
use strict;
use warnings;
use Exporter;
use File::Spec;
use ExtUtils::ParseXS::Constants ();

our $VERSION = '3.35';

our (@ISA, @EXPORT_OK);
@ISA = qw(Exporter);
@EXPORT_OK = qw(
  standard_typemap_locations
  trim_whitespace
  C_string
  valid_proto_string
  process_typemaps
  map_type
  standard_XS_defs
  assign_func_args
  analyze_preprocessor_statements
  set_cond
  Warn
  current_line_number
  blurt
  death
  check_conditional_preprocessor_statements
  escape_file_for_line_directive
  report_typemap_failure
);

=head1 NAME

ExtUtils::ParseXS::Utilities - Subroutines used with ExtUtils::ParseXS

=head1 SYNOPSIS

  use ExtUtils::ParseXS::Utilities qw(
    standard_typemap_locations
    trim_whitespace
    C_string
    valid_proto_string
    process_typemaps
    map_type
    standard_XS_defs
    assign_func_args
    analyze_preprocessor_statements
    set_cond
    Warn
    blurt
    death
    check_conditional_preprocessor_statements
    escape_file_for_line_directive
    report_typemap_failure
  );

=head1 SUBROUTINES

The following functions are not considered to be part of the public interface.
They are documented here for the benefit of future maintainers of this module.

=head2 C<standard_typemap_locations()>

=over 4

=item * Purpose

Provide a list of filepaths where F<typemap> files may be found.  The
filepaths -- relative paths to files (not just directory paths) -- appear in this list in lowest-to-highest priority.

The highest priority is to look in the current directory.  

  'typemap'

The second and third highest priorities are to look in the parent of the
current directory and a directory called F<lib/ExtUtils> underneath the parent
directory.

  '../typemap',
  '../lib/ExtUtils/typemap',

The fourth through ninth highest priorities are to look in the corresponding
grandparent, great-grandparent and great-great-grandparent directories.

  '../../typemap',
  '../../lib/ExtUtils/typemap',
  '../../../typemap',
  '../../../lib/ExtUtils/typemap',
  '../../../../typemap',
  '../../../../lib/ExtUtils/typemap',

The tenth and subsequent priorities are to look in directories named
F<ExtUtils> which are subdirectories of directories found in C<@INC> --
I<provided> a file named F<typemap> actually exists in such a directory.
Example:

  '/usr/local/lib/perl5/5.10.1/ExtUtils/typemap',

However, these filepaths appear in the list returned by
C<standard_typemap_locations()> in reverse order, I<i.e.>, lowest-to-highest.

  '/usr/local/lib/perl5/5.10.1/ExtUtils/typemap',
  '../../../../lib/ExtUtils/typemap',
  '../../../../typemap',
  '../../../lib/ExtUtils/typemap',
  '../../../typemap',
  '../../lib/ExtUtils/typemap',
  '../../typemap',
  '../lib/ExtUtils/typemap',
  '../typemap',
  'typemap'

=item * Arguments

  my @stl = standard_typemap_locations( \@INC );

Reference to C<@INC>.

=item * Return Value

Array holding list of directories to be searched for F<typemap> files.

=back

=cut

SCOPE: {
  my @tm_template;

  sub standard_typemap_locations {
    my $include_ref = shift;

    if (not @tm_template) {
      @tm_template = qw(typemap);

      my $updir = File::Spec->updir();
      foreach my $dir (
          File::Spec->catdir(($updir) x 1),
          File::Spec->catdir(($updir) x 2),
          File::Spec->catdir(($updir) x 3),
          File::Spec->catdir(($updir) x 4),
      ) {
        unshift @tm_template, File::Spec->catfile($dir, 'typemap');
        unshift @tm_template, File::Spec->catfile($dir, lib => ExtUtils => 'typemap');
      }
    }

    my @tm = @tm_template;
    foreach my $dir (@{ $include_ref}) {
      my $file = File::Spec->catfile($dir, ExtUtils => 'typemap');
      unshift @tm, $file if -e $file;
    }
    return @tm;
  }
} # end SCOPE

=head2 C<trim_whitespace()>

=over 4

=item * Purpose

Perform an in-place trimming of leading and trailing whitespace from the
first argument provided to the function.

=item * Argument

  trim_whitespace($arg);

=item * Return Value

None.  Remember:  this is an I<in-place> modification of the argument.

=back

=cut

sub trim_whitespace {
  $_[0] =~ s/^\s+|\s+$//go;
}

=head2 C<C_string()>

=over 4

=item * Purpose

Escape backslashes (C<\>) in prototype strings.

=item * Arguments

      $ProtoThisXSUB = C_string($_);

String needing escaping.

=item * Return Value

Properly escaped string.

=back

=cut

sub C_string {
  my($string) = @_;

  $string =~ s[\\][\\\\]g;
  $string;
}

=head2 C<valid_proto_string()>

=over 4

=item * Purpose

Validate prototype string.

=item * Arguments

String needing checking.

=item * Return Value

Upon success, returns the same string passed as argument.

Upon failure, returns C<0>.

=back

=cut

sub valid_proto_string {
  my ($string) = @_;

  if ( $string =~ /^$ExtUtils::ParseXS::Constants::PrototypeRegexp+$/ ) {
    return $string;
  }

  return 0;
}

=head2 C<process_typemaps()>

=over 4

=item * Purpose

Process all typemap files.

=item * Arguments

  my $typemaps_object = process_typemaps( $args{typemap}, $pwd );

List of two elements:  C<typemap> element from C<%args>; current working
directory.

=item * Return Value

Upon success, returns an L<ExtUtils::Typemaps> object.

=back

=cut

sub process_typemaps {
  my ($tmap, $pwd) = @_;

  my @tm = ref $tmap ? @{$tmap} : ($tmap);

  foreach my $typemap (@tm) {
    die "Can't find $typemap in $pwd\n" unless -r $typemap;
  }

  push @tm, standard_typemap_locations( \@INC );

  require ExtUtils::Typemaps;
  my $typemap = ExtUtils::Typemaps->new;
  foreach my $typemap_loc (@tm) {
    next unless -f $typemap_loc;
    # skip directories, binary files etc.
    warn("Warning: ignoring non-text typemap file '$typemap_loc'\n"), next
      unless -T $typemap_loc;

    $typemap->merge(file => $typemap_loc, replace => 1);
  }

  return $typemap;
}

=head2 C<map_type()>

=over 4

=item * Purpose

Performs a mapping at several places inside C<PARAGRAPH> loop.

=item * Arguments

  $type = map_type($self, $type, $varname);

List of three arguments.

=item * Return Value

String holding augmented version of second argument.

=back

=cut

sub map_type {
  my ($self, $type, $varname) = @_;

  # C++ has :: in types too so skip this
  $type =~ tr/:/_/ unless $self->{RetainCplusplusHierarchicalTypes};
  $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
  if ($varname) {
    if ($type =~ / \( \s* \* (?= \s* \) ) /xg) {
      (substr $type, pos $type, 0) = " $varname ";
    }
    else {
      $type .= "\t$varname";
    }
  }
  return $type;
}

=head2 C<standard_XS_defs()>

=over 4

=item * Purpose

Writes to the C<.c> output file certain preprocessor directives and function
headers needed in all such files.

=item * Arguments

None.

=item * Return Value

Returns true.

=back

=cut

sub standard_XS_defs {
  print <<"EOF";
#ifndef PERL_UNUSED_VAR
#  define PERL_UNUSED_VAR(var) if (0) var = var
#endif

#ifndef dVAR
#  define dVAR		dNOOP
#endif


/* This stuff is not part of the API! You have been warned. */
#ifndef PERL_VERSION_DECIMAL
#  define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s)
#endif
#ifndef PERL_DECIMAL_VERSION
#  define PERL_DECIMAL_VERSION \\
	  PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION)
#endif
#ifndef PERL_VERSION_GE
#  define PERL_VERSION_GE(r,v,s) \\
	  (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s))
#endif
#ifndef PERL_VERSION_LE
#  define PERL_VERSION_LE(r,v,s) \\
	  (PERL_DECIMAL_VERSION <= PERL_VERSION_DECIMAL(r,v,s))
#endif

/* XS_INTERNAL is the explicit static-linkage variant of the default
 * XS macro.
 *
 * XS_EXTERNAL is the same as XS_INTERNAL except it does not include
 * "STATIC", ie. it exports XSUB symbols. You probably don't want that
 * for anything but the BOOT XSUB.
 *
 * See XSUB.h in core!
 */


/* TODO: This might be compatible further back than 5.10.0. */
#if PERL_VERSION_GE(5, 10, 0) && PERL_VERSION_LE(5, 15, 1)
#  undef XS_EXTERNAL
#  undef XS_INTERNAL
#  if defined(__CYGWIN__) && defined(USE_DYNAMIC_LOADING)
#    define XS_EXTERNAL(name) __declspec(dllexport) XSPROTO(name)
#    define XS_INTERNAL(name) STATIC XSPROTO(name)
#  endif
#  if defined(__SYMBIAN32__)
#    define XS_EXTERNAL(name) EXPORT_C XSPROTO(name)
#    define XS_INTERNAL(name) EXPORT_C STATIC XSPROTO(name)
#  endif
#  ifndef XS_EXTERNAL
#    if defined(HASATTRIBUTE_UNUSED) && !defined(__cplusplus)
#      define XS_EXTERNAL(name) void name(pTHX_ CV* cv __attribute__unused__)
#      define XS_INTERNAL(name) STATIC void name(pTHX_ CV* cv __attribute__unused__)
#    else
#      ifdef __cplusplus
#        define XS_EXTERNAL(name) extern "C" XSPROTO(name)
#        define XS_INTERNAL(name) static XSPROTO(name)
#      else
#        define XS_EXTERNAL(name) XSPROTO(name)
#        define XS_INTERNAL(name) STATIC XSPROTO(name)
#      endif
#    endif
#  endif
#endif

/* perl >= 5.10.0 && perl <= 5.15.1 */


/* The XS_EXTERNAL macro is used for functions that must not be static
 * like the boot XSUB of a module. If perl didn't have an XS_EXTERNAL
 * macro defined, the best we can do is assume XS is the same.
 * Dito for XS_INTERNAL.
 */
#ifndef XS_EXTERNAL
#  define XS_EXTERNAL(name) XS(name)
#endif
#ifndef XS_INTERNAL
#  define XS_INTERNAL(name) XS(name)
#endif

/* Now, finally, after all this mess, we want an ExtUtils::ParseXS
 * internal macro that we're free to redefine for varying linkage due
 * to the EXPORT_XSUB_SYMBOLS XS keyword. This is internal, use
 * XS_EXTERNAL(name) or XS_INTERNAL(name) in your code if you need to!
 */

#undef XS_EUPXS
#if defined(PERL_EUPXS_ALWAYS_EXPORT)
#  define XS_EUPXS(name) XS_EXTERNAL(name)
#else
   /* default to internal */
#  define XS_EUPXS(name) XS_INTERNAL(name)
#endif

EOF

  print <<"EOF";
#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)

/* prototype to pass -Wmissing-prototypes */
STATIC void
S_croak_xs_usage(const CV *const cv, const char *const params);

STATIC void
S_croak_xs_usage(const CV *const cv, const char *const params)
{
    const GV *const gv = CvGV(cv);

    PERL_ARGS_ASSERT_CROAK_XS_USAGE;

    if (gv) {
        const char *const gvname = GvNAME(gv);
        const HV *const stash = GvSTASH(gv);
        const char *const hvname = stash ? HvNAME(stash) : NULL;

        if (hvname)
	    Perl_croak_nocontext("Usage: %s::%s(%s)", hvname, gvname, params);
        else
	    Perl_croak_nocontext("Usage: %s(%s)", gvname, params);
    } else {
        /* Pants. I don't think that it should be possible to get here. */
	Perl_croak_nocontext("Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params);
    }
}
#undef  PERL_ARGS_ASSERT_CROAK_XS_USAGE

#define croak_xs_usage        S_croak_xs_usage

#endif

/* NOTE: the prototype of newXSproto() is different in versions of perls,
 * so we define a portable version of newXSproto()
 */
#ifdef newXS_flags
#define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0)
#else
#define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv)
#endif /* !defined(newXS_flags) */

#if PERL_VERSION_LE(5, 21, 5)
#  define newXS_deffile(a,b) Perl_newXS(aTHX_ a,b,file)
#else
#  define newXS_deffile(a,b) Perl_newXS_deffile(aTHX_ a,b)
#endif

EOF
  return 1;
}

=head2 C<assign_func_args()>

=over 4

=item * Purpose

Perform assignment to the C<func_args> attribute.

=item * Arguments

  $string = assign_func_args($self, $argsref, $class);

List of three elements.  Second is an array reference; third is a string.

=item * Return Value

String.

=back

=cut

sub assign_func_args {
  my ($self, $argsref, $class) = @_;
  my @func_args = @{$argsref};
  shift @func_args if defined($class);

  for my $arg (@func_args) {
    $arg =~ s/^/&/ if $self->{in_out}->{$arg};
  }
  return join(", ", @func_args);
}

=head2 C<analyze_preprocessor_statements()>

=over 4

=item * Purpose

Within each function inside each Xsub, print to the F<.c> output file certain
preprocessor statements.

=item * Arguments

      ( $self, $XSS_work_idx, $BootCode_ref ) =
        analyze_preprocessor_statements(
          $self, $statement, $XSS_work_idx, $BootCode_ref
        );

List of four elements.

=item * Return Value

Modifed values of three of the arguments passed to the function.  In
particular, the C<XSStack> and C<InitFileCode> attributes are modified.

=back

=cut

sub analyze_preprocessor_statements {
  my ($self, $statement, $XSS_work_idx, $BootCode_ref) = @_;

  if ($statement eq 'if') {
    $XSS_work_idx = @{ $self->{XSStack} };
    push(@{ $self->{XSStack} }, {type => 'if'});
  }
  else {
    $self->death("Error: '$statement' with no matching 'if'")
      if $self->{XSStack}->[-1]{type} ne 'if';
    if ($self->{XSStack}->[-1]{varname}) {
      push(@{ $self->{InitFileCode} }, "#endif\n");
      push(@{ $BootCode_ref },     "#endif");
    }

    my(@fns) = keys %{$self->{XSStack}->[-1]{functions}};
    if ($statement ne 'endif') {
      # Hide the functions defined in other #if branches, and reset.
      @{$self->{XSStack}->[-1]{other_functions}}{@fns} = (1) x @fns;
      @{$self->{XSStack}->[-1]}{qw(varname functions)} = ('', {});
    }
    else {
      my($tmp) = pop(@{ $self->{XSStack} });
      0 while (--$XSS_work_idx
           && $self->{XSStack}->[$XSS_work_idx]{type} ne 'if');
      # Keep all new defined functions
      push(@fns, keys %{$tmp->{other_functions}});
      @{$self->{XSStack}->[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
    }
  }
  return ($self, $XSS_work_idx, $BootCode_ref);
}

=head2 C<set_cond()>

=over 4

=item * Purpose

=item * Arguments

=item * Return Value

=back

=cut

sub set_cond {
  my ($ellipsis, $min_args, $num_args) = @_;
  my $cond;
  if ($ellipsis) {
    $cond = ($min_args ? qq(items < $min_args) : 0);
  }
  elsif ($min_args == $num_args) {
    $cond = qq(items != $min_args);
  }
  else {
    $cond = qq(items < $min_args || items > $num_args);
  }
  return $cond;
}

=head2 C<current_line_number()>

=over 4

=item * Purpose

Figures out the current line number in the XS file.

=item * Arguments

C<$self>

=item * Return Value

The current line number.

=back

=cut

sub current_line_number {
  my $self = shift;
  my $line_number = $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} } -1];
  return $line_number;
}

=head2 C<Warn()>

=over 4

=item * Purpose

=item * Arguments

=item * Return Value

=back

=cut

sub Warn {
  my $self = shift;
  my $warn_line_number = $self->current_line_number();
  print STDERR "@_ in $self->{filename}, line $warn_line_number\n";
}

=head2 C<blurt()>

=over 4

=item * Purpose

=item * Arguments

=item * Return Value

=back

=cut

sub blurt {
  my $self = shift;
  $self->Warn(@_);
  $self->{errors}++
}

=head2 C<death()>

=over 4

=item * Purpose

=item * Arguments

=item * Return Value

=back

=cut

sub death {
  my $self = shift;
  $self->Warn(@_);
  exit 1;
}

=head2 C<check_conditional_preprocessor_statements()>

=over 4

=item * Purpose

=item * Arguments

=item * Return Value

=back

=cut

sub check_conditional_preprocessor_statements {
  my ($self) = @_;
  my @cpp = grep(/^\#\s*(?:if|e\w+)/, @{ $self->{line} });
  if (@cpp) {
    my $cpplevel;
    for my $cpp (@cpp) {
      if ($cpp =~ /^\#\s*if/) {
        $cpplevel++;
      }
      elsif (!$cpplevel) {
        $self->Warn("Warning: #else/elif/endif without #if in this function");
        print STDERR "    (precede it with a blank line if the matching #if is outside the function)\n"
          if $self->{XSStack}->[-1]{type} eq 'if';
        return;
      }
      elsif ($cpp =~ /^\#\s*endif/) {
        $cpplevel--;
      }
    }
    $self->Warn("Warning: #if without #endif in this function") if $cpplevel;
  }
}

=head2 C<escape_file_for_line_directive()>

=over 4

=item * Purpose

Escapes a given code source name (typically a file name but can also
be a command that was read from) so that double-quotes and backslashes are escaped.

=item * Arguments

A string.

=item * Return Value

A string with escapes for double-quotes and backslashes.

=back

=cut

sub escape_file_for_line_directive {
  my $string = shift;
  $string =~ s/\\/\\\\/g;
  $string =~ s/"/\\"/g;
  return $string;
}

=head2 C<report_typemap_failure>

=over 4

=item * Purpose

Do error reporting for missing typemaps.

=item * Arguments

The C<ExtUtils::ParseXS> object.

An C<ExtUtils::Typemaps> object.

The string that represents the C type that was not found in the typemap.

Optionally, the string C<death> or C<blurt> to choose
whether the error is immediately fatal or not. Default: C<blurt>

=item * Return Value

Returns nothing. Depending on the arguments, this
may call C<death> or C<blurt>, the former of which is
fatal.

=back

=cut

sub report_typemap_failure {
  my ($self, $tm, $ctype, $error_method) = @_;
  $error_method ||= 'blurt';

  my @avail_ctypes = $tm->list_mapped_ctypes;

  my $err = "Could not find a typemap for C type '$ctype'.\n"
            . "The following C types are mapped by the current typemap:\n'"
            . join("', '", @avail_ctypes) . "'\n";

  $self->$error_method($err);
  return();
}

1;

# vim: ts=2 sw=2 et:
PK       ! ��"��  �  $  perl5/ExtUtils/ParseXS/CountLines.pmnu ��6�$        package ExtUtils::ParseXS::CountLines;
use strict;

our $VERSION = '3.35';

our $SECTION_END_MARKER;

sub TIEHANDLE {
  my ($class, $cfile, $fh) = @_;
  $cfile =~ s/\\/\\\\/g;
  $cfile =~ s/"/\\"/g;
  $SECTION_END_MARKER = qq{#line --- "$cfile"};

  return bless {
    buffer => '',
    fh => $fh,
    line_no => 1,
  }, $class;
}

sub PRINT {
  my $self = shift;
  for (@_) {
    $self->{buffer} .= $_;
    while ($self->{buffer} =~ s/^([^\n]*\n)//) {
      my $line = $1;
      ++$self->{line_no};
      $line =~ s|^\#line\s+---(?=\s)|#line $self->{line_no}|;
      print {$self->{fh}} $line;
    }
  }
}

sub PRINTF {
  my $self = shift;
  my $fmt = shift;
  $self->PRINT(sprintf($fmt, @_));
}

sub DESTROY {
  # Not necessary if we're careful to end with a "\n"
  my $self = shift;
  print {$self->{fh}} $self->{buffer};
}

sub UNTIE {
  # This sub does nothing, but is necessary for references to be released.
}

sub end_marker {
  return $SECTION_END_MARKER;
}

1;
PK       ! q9��x  x  #  perl5/ExtUtils/ParseXS/Constants.pmnu ��6�$        package ExtUtils::ParseXS::Constants;
use strict;
use warnings;
use Symbol;

our $VERSION = '3.35';

=head1 NAME

ExtUtils::ParseXS::Constants - Initialization values for some globals

=head1 SYNOPSIS

  use ExtUtils::ParseXS::Constants ();

  $PrototypeRegexp = $ExtUtils::ParseXS::Constants::PrototypeRegexp;

=head1 DESCRIPTION

Initialization of certain non-subroutine variables in ExtUtils::ParseXS and some of its
supporting packages has been moved into this package so that those values can
be defined exactly once and then re-used in any package.

Nothing is exported.  Use fully qualified variable names.

=cut

# FIXME: THESE ARE NOT CONSTANTS!
our @InitFileCode;

# Note that to reduce maintenance, $PrototypeRegexp is used
# by ExtUtils::Typemaps, too!
our $PrototypeRegexp = "[" . quotemeta('\$%&*@;[]_') . "]";
our @XSKeywords      = qw( 
  REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE
  OUTPUT CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE
  VERSIONCHECK INCLUDE INCLUDE_COMMAND SCOPE INTERFACE
  INTERFACE_MACRO C_ARGS POSTCALL OVERLOAD FALLBACK
  EXPORT_XSUB_SYMBOLS
);

our $XSKeywordsAlternation = join('|', @XSKeywords);

1;
PK       ! �f�y�  �    perl5/ExtUtils/xsubppnu ��6�$        #!perl
use 5.006;
BEGIN { pop @INC if $INC[-1] eq '.' }
use strict;
eval {
  require ExtUtils::ParseXS;
  1;
}
or do {
  my $err = $@ || 'Zombie error';
  my $v = $ExtUtils::ParseXS::VERSION;
  $v = '<undef>' if not defined $v;
  die "Failed to load or import from ExtUtils::ParseXS (version $v). Please check that ExtUtils::ParseXS is installed correctly and that the newest version will be found in your \@INC path: $err";
};

use Getopt::Long;

my %args = ();

my $usage = "Usage: xsubpp [-v] [-csuffix csuffix] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-nooptimize] [-noinout] [-noargtypes] [-strip|s pattern] [-typemap typemap]... file.xs\n";

Getopt::Long::Configure qw(no_auto_abbrev no_ignore_case);

@ARGV = grep {$_ ne '-C++'} @ARGV;  # Allow -C++ for backward compatibility
GetOptions(\%args, qw(hiertype!
		      prototypes!
		      versioncheck!
		      linenumbers!
		      optimize!
		      inout!
		      argtypes!
		      object_capi!
		      except!
		      v
		      typemap=s@
		      output=s
		      s|strip=s
		      csuffix=s
		     ))
  or die $usage;

if ($args{v}) {
  print "xsubpp version $ExtUtils::ParseXS::VERSION\n";
  exit;
}

@ARGV == 1 or die $usage;

$args{filename} = shift @ARGV;

my $pxs = ExtUtils::ParseXS->new;
$pxs->process_file(%args);
exit( $pxs->report_error_count() ? 1 : 0 );

__END__

=head1 NAME

xsubpp - compiler to convert Perl XS code into C code

=head1 SYNOPSIS

B<xsubpp> [B<-v>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-nooptimize>] [B<-typemap typemap>] [B<-output filename>]... file.xs

=head1 DESCRIPTION

This compiler is typically run by the makefiles created by L<ExtUtils::MakeMaker>
or by L<Module::Build> or other Perl module build tools.

I<xsubpp> will compile XS code into C code by embedding the constructs
necessary to let C functions manipulate Perl values and creates the glue
necessary to let Perl access those functions.  The compiler uses typemaps to
determine how to map C function parameters and variables to Perl values.

The compiler will search for typemap files called I<typemap>.  It will use
the following search path to find default typemaps, with the rightmost
typemap taking precedence.

	../../../typemap:../../typemap:../typemap:typemap

It will also use a default typemap installed as C<ExtUtils::typemap>.

=head1 OPTIONS

Note that the C<XSOPT> MakeMaker option may be used to add these options to
any makefiles generated by MakeMaker.

=over 5

=item B<-hiertype>

Retains '::' in type names so that C++ hierarchical types can be mapped.

=item B<-except>

Adds exception handling stubs to the C code.

=item B<-typemap typemap>

Indicates that a user-supplied typemap should take precedence over the
default typemaps.  This option may be used multiple times, with the last
typemap having the highest precedence.

=item B<-output filename>

Specifies the name of the output file to generate.  If no file is
specified, output will be written to standard output.

=item B<-v>

Prints the I<xsubpp> version number to standard output, then exits.

=item B<-prototypes>

By default I<xsubpp> will not automatically generate prototype code for
all xsubs. This flag will enable prototypes.

=item B<-noversioncheck>

Disables the run time test that determines if the object file (derived
from the C<.xs> file) and the C<.pm> files have the same version
number.

=item B<-nolinenumbers>

Prevents the inclusion of '#line' directives in the output.

=item B<-nooptimize>

Disables certain optimizations.  The only optimization that is currently
affected is the use of I<target>s by the output C code (see L<perlguts>).
This may significantly slow down the generated code, but this is the way
B<xsubpp> of 5.005 and earlier operated.

=item B<-noinout>

Disable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST> declarations.

=item B<-noargtypes>

Disable recognition of ANSI-like descriptions of function signature.

=item B<-C++>

Currently doesn't do anything at all.  This flag has been a no-op for
many versions of perl, at least as far back as perl5.003_07.  It's
allowed here for backwards compatibility.

=item B<-s=...> or B<-strip=...>

I<This option is obscure and discouraged.>

If specified, the given string will be stripped off from the beginning
of the C function name in the generated XS functions (if it starts with that prefix).
This only applies to XSUBs without C<CODE> or C<PPCODE> blocks.
For example, the XS:

  void foo_bar(int i);

when C<xsubpp> is invoked with C<-s foo_> will install a C<foo_bar>
function in Perl, but really call C<bar(i)> in C. Most of the time,
this is the opposite of what you want and failure modes are somewhat
obscure, so please avoid this option where possible.

=back

=head1 ENVIRONMENT

No environment variables are used.

=head1 AUTHOR

Originally by Larry Wall.  Turned into the C<ExtUtils::ParseXS> module
by Ken Williams.

=head1 MODIFICATION HISTORY

See the file F<Changes>.

=head1 SEE ALSO

perl(1), perlxs(1), perlxstut(1), ExtUtils::ParseXS

=cut

PK       ! ��+dP  P    perl5/Test/use/ok.pmnu ��6�$        package Test::use::ok;
use 5.005;

our $VERSION = '1.302183';


__END__

=head1 NAME

Test::use::ok - Alternative to Test::More::use_ok

=head1 SYNOPSIS

    use ok 'Some::Module';

=head1 DESCRIPTION

According to the B<Test::More> documentation, it is recommended to run
C<use_ok()> inside a C<BEGIN> block, so functions are exported at
compile-time and prototypes are properly honored.

That is, instead of writing this:

    use_ok( 'Some::Module' );
    use_ok( 'Other::Module' );

One should write this:

    BEGIN { use_ok( 'Some::Module' ); }
    BEGIN { use_ok( 'Other::Module' ); }

However, people often either forget to add C<BEGIN>, or mistakenly group
C<use_ok> with other tests in a single C<BEGIN> block, which can create subtle
differences in execution order.

With this module, simply change all C<use_ok> in test scripts to C<use ok>,
and they will be executed at C<BEGIN> time.  The explicit space after C<use>
makes it clear that this is a single compile-time action.

=head1 SEE ALSO

L<Test::More>

=head1 MAINTAINER

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=encoding utf8

=head1 CC0 1.0 Universal

To the extent possible under law, 唐鳳 has waived all copyright and related
or neighboring rights to L<Test-use-ok>.

This work is published from Taiwan.

L<http://creativecommons.org/publicdomain/zero/1.0>

=cut
PK       ! h�/�Z�  Z�    perl5/Test/Builder.pmnu ��6�$        package Test::Builder;

use 5.006;
use strict;
use warnings;

our $VERSION = '1.302183';

BEGIN {
    if( $] < 5.008 ) {
        require Test::Builder::IO::Scalar;
    }
}

use Scalar::Util qw/blessed reftype weaken/;

use Test2::Util qw/USE_THREADS try get_tid/;
use Test2::API qw/context release/;
# Make Test::Builder thread-safe for ithreads.
BEGIN {
    warn "Test::Builder was loaded after Test2 initialization, this is not recommended."
        if Test2::API::test2_init_done() || Test2::API::test2_load_done();

    if (USE_THREADS && ! Test2::API::test2_ipc_disabled()) {
        require Test2::IPC;
        require Test2::IPC::Driver::Files;
        Test2::IPC::Driver::Files->import;
        Test2::API::test2_ipc_enable_polling();
        Test2::API::test2_no_wait(1);
    }
}

use Test2::Event::Subtest;
use Test2::Hub::Subtest;

use Test::Builder::Formatter;
use Test::Builder::TodoDiag;

our $Level = 1;
our $Test = $ENV{TB_NO_EARLY_INIT} ? undef : Test::Builder->new;

sub _add_ts_hooks {
    my $self = shift;

    my $hub = $self->{Stack}->top;

    # Take a reference to the hash key, we do this to avoid closing over $self
    # which is the singleton. We use a reference because the value could change
    # in rare cases.
    my $epkgr = \$self->{Exported_To};

    #$hub->add_context_aquire(sub {$_[0]->{level} += $Level - 1});

    $hub->pre_filter(
        sub {
            my ($active_hub, $e) = @_;

            my $epkg = $$epkgr;
            my $cpkg = $e->{trace} ? $e->{trace}->{frame}->[0] : undef;

            no strict 'refs';
            no warnings 'once';
            my $todo;
            $todo = ${"$cpkg\::TODO"} if $cpkg;
            $todo = ${"$epkg\::TODO"} if $epkg && !$todo;

            return $e unless defined($todo);
            return $e unless length($todo);

            # Turn a diag into a todo diag
            return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag';

            $e->set_todo($todo) if $e->can('set_todo');
            $e->add_amnesty({tag => 'TODO', details => $todo});

            # Set todo on ok's
            if ($e->isa('Test2::Event::Ok')) {
                $e->set_effective_pass(1);

                if (my $result = $e->get_meta(__PACKAGE__)) {
                    $result->{reason} ||= $todo;
                    $result->{type}   ||= 'todo';
                    $result->{ok} = 1;
                }
            }

            return $e;
        },

        inherit => 1,

        intercept_inherit => {
            clean => sub {
                my %params = @_;

                my $state = $params{state};
                my $trace = $params{trace};

                my $epkg = $$epkgr;
                my $cpkg = $trace->{frame}->[0];

                no strict 'refs';
                no warnings 'once';

                $state->{+__PACKAGE__} = {};
                $state->{+__PACKAGE__}->{"$cpkg\::TODO"} = ${"$cpkg\::TODO"} if $cpkg;
                $state->{+__PACKAGE__}->{"$epkg\::TODO"} = ${"$epkg\::TODO"} if $epkg;

                ${"$cpkg\::TODO"} = undef if $cpkg;
                ${"$epkg\::TODO"} = undef if $epkg;
            },
            restore => sub {
                my %params = @_;
                my $state = $params{state};

                no strict 'refs';
                no warnings 'once';

                for my $item (keys %{$state->{+__PACKAGE__}}) {
                    no strict 'refs';
                    no warnings 'once';

                    ${"$item"} = $state->{+__PACKAGE__}->{$item};
                }
            },
        },
    );
}

{
    no warnings;
    INIT {
        use warnings;
        Test2::API::test2_load() unless Test2::API::test2_in_preload();
    }
}

sub new {
    my($class) = shift;
    unless($Test) {
        $Test = $class->create(singleton => 1);

        Test2::API::test2_add_callback_post_load(
            sub {
                $Test->{Original_Pid} = $$ if !$Test->{Original_Pid} || $Test->{Original_Pid} == 0;
                $Test->reset(singleton => 1);
                $Test->_add_ts_hooks;
            }
        );

        # Non-TB tools normally expect 0 added to the level. $Level is normally 1. So
        # we only want the level to change if $Level != 1.
        # TB->ctx compensates for this later.
        Test2::API::test2_add_callback_context_aquire(sub { $_[0]->{level} += $Level - 1 });

        Test2::API::test2_add_callback_exit(sub { $Test->_ending(@_) });

        Test2::API::test2_ipc()->set_no_fatal(1) if Test2::API::test2_has_ipc();
    }
    return $Test;
}

sub create {
    my $class = shift;
    my %params = @_;

    my $self = bless {}, $class;
    if ($params{singleton}) {
        $self->{Stack} = Test2::API::test2_stack();
    }
    else {
        $self->{Stack} = Test2::API::Stack->new;
        $self->{Stack}->new_hub(
            formatter => Test::Builder::Formatter->new,
            ipc       => Test2::API::test2_ipc(),
        );

        $self->reset(%params);
        $self->_add_ts_hooks;
    }

    return $self;
}

sub ctx {
    my $self = shift;
    context(
        # 1 for our frame, another for the -1 off of $Level in our hook at the top.
        level   => 2,
        fudge   => 1,
        stack   => $self->{Stack},
        hub     => $self->{Hub},
        wrapped => 1,
        @_
    );
}

sub parent {
    my $self = shift;
    my $ctx = $self->ctx;
    my $chub = $self->{Hub} || $ctx->hub;
    $ctx->release;

    my $meta = $chub->meta(__PACKAGE__, {});
    my $parent = $meta->{parent};

    return undef unless $parent;

    return bless {
        Original_Pid => $$,
        Stack => $self->{Stack},
        Hub => $parent,
    }, blessed($self);
}

sub child {
    my( $self, $name ) = @_;

    $name ||= "Child of " . $self->name;
    my $ctx = $self->ctx;

    my $parent = $ctx->hub;
    my $pmeta = $parent->meta(__PACKAGE__, {});
    $self->croak("You already have a child named ($pmeta->{child}) running")
        if $pmeta->{child};

    $pmeta->{child} = $name;

    # Clear $TODO for the child.
    my $orig_TODO = $self->find_TODO(undef, 1, undef);

    my $subevents = [];

    my $hub = $ctx->stack->new_hub(
        class => 'Test2::Hub::Subtest',
    );

    $hub->pre_filter(sub {
        my ($active_hub, $e) = @_;

        # Turn a diag into a todo diag
        return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag';

        return $e;
    }, inherit => 1) if $orig_TODO;

    $hub->listen(sub { push @$subevents => $_[1] });

    $hub->set_nested( $parent->nested + 1 );

    my $meta = $hub->meta(__PACKAGE__, {});
    $meta->{Name} = $name;
    $meta->{TODO} = $orig_TODO;
    $meta->{TODO_PKG} = $ctx->trace->package;
    $meta->{parent} = $parent;
    $meta->{Test_Results} = [];
    $meta->{subevents} = $subevents;
    $meta->{subtest_id} = $hub->id;
    $meta->{subtest_uuid} = $hub->uuid;
    $meta->{subtest_buffered} = $parent->format ? 0 : 1;

    $self->_add_ts_hooks;

    $ctx->release;
    return bless { Original_Pid => $$, Stack => $self->{Stack}, Hub => $hub, no_log_results => $self->{no_log_results} }, blessed($self);
}

sub finalize {
    my $self = shift;
    my $ok = 1;
    ($ok) = @_ if @_;

    my $st_ctx = $self->ctx;
    my $chub = $self->{Hub} || return $st_ctx->release;

    my $meta = $chub->meta(__PACKAGE__, {});
    if ($meta->{child}) {
        $self->croak("Can't call finalize() with child ($meta->{child}) active");
    }

    local $? = 0;     # don't fail if $subtests happened to set $? nonzero

    $self->{Stack}->pop($chub);

    $self->find_TODO($meta->{TODO_PKG}, 1, $meta->{TODO});

    my $parent = $self->parent;
    my $ctx = $parent->ctx;
    my $trace = $ctx->trace;
    delete $ctx->hub->meta(__PACKAGE__, {})->{child};

    $chub->finalize($trace->snapshot(hid => $chub->hid, nested => $chub->nested), 1)
        if $ok
        && $chub->count
        && !$chub->no_ending
        && !$chub->ended;

    my $plan   = $chub->plan || 0;
    my $count  = $chub->count;
    my $failed = $chub->failed;
    my $passed = $chub->is_passing;

    my $num_extra = $plan =~ m/\D/ ? 0 : $count - $plan;
    if ($count && $num_extra != 0) {
        my $s = $plan == 1 ? '' : 's';
        $st_ctx->diag(<<"FAIL");
Looks like you planned $plan test$s but ran $count.
FAIL
    }

    if ($failed) {
        my $s = $failed == 1 ? '' : 's';

        my $qualifier = $num_extra == 0 ? '' : ' run';

        $st_ctx->diag(<<"FAIL");
Looks like you failed $failed test$s of $count$qualifier.
FAIL
    }

    if (!$passed && !$failed && $count && !$num_extra) {
        $st_ctx->diag(<<"FAIL");
All assertions inside the subtest passed, but errors were encountered.
FAIL
    }

    $st_ctx->release;

    unless ($chub->bailed_out) {
        my $plan = $chub->plan;
        if ( $plan && $plan eq 'SKIP' ) {
            $parent->skip($chub->skip_reason, $meta->{Name});
        }
        elsif ( !$chub->count ) {
            $parent->ok( 0, sprintf q[No tests run for subtest "%s"], $meta->{Name} );
        }
        else {
            $parent->{subevents}  = $meta->{subevents};
            $parent->{subtest_id} = $meta->{subtest_id};
            $parent->{subtest_uuid} = $meta->{subtest_uuid};
            $parent->{subtest_buffered} = $meta->{subtest_buffered};
            $parent->ok( $chub->is_passing, $meta->{Name} );
        }
    }

    $ctx->release;
    return $chub->is_passing;
}

sub subtest {
    my $self = shift;
    my ($name, $code, @args) = @_;
    my $ctx = $self->ctx;
    $ctx->throw("subtest()'s second argument must be a code ref")
        unless $code && reftype($code) eq 'CODE';

    $name ||= "Child of " . $self->name;


    $_->($name,$code,@args)
        for Test2::API::test2_list_pre_subtest_callbacks();

    $ctx->note("Subtest: $name");

    my $child = $self->child($name);

    my $start_pid = $$;
    my $st_ctx;
    my ($ok, $err, $finished, $child_error);
    T2_SUBTEST_WRAPPER: {
        my $ctx = $self->ctx;
        $st_ctx = $ctx->snapshot;
        $ctx->release;
        $ok = eval { local $Level = 1; $code->(@args); 1 };
        ($err, $child_error) = ($@, $?);

        # They might have done 'BEGIN { skip_all => "whatever" }'
        if (!$ok && $err =~ m/Label not found for "last T2_SUBTEST_WRAPPER"/ || (blessed($err) && blessed($err) eq 'Test::Builder::Exception')) {
            $ok  = undef;
            $err = undef;
        }
        else {
            $finished = 1;
        }
    }

    if ($start_pid != $$ && !$INC{'Test2/IPC.pm'}) {
        warn $ok ? "Forked inside subtest, but subtest never finished!\n" : $err;
        exit 255;
    }

    my $trace = $ctx->trace;

    if (!$finished) {
        if(my $bailed = $st_ctx->hub->bailed_out) {
            my $chub = $child->{Hub};
            $self->{Stack}->pop($chub);
            $ctx->bail($bailed->reason);
        }
        my $code = $st_ctx->hub->exit_code;
        $ok = !$code;
        $err = "Subtest ended with exit code $code" if $code;
    }

    my $st_hub  = $st_ctx->hub;
    my $plan  = $st_hub->plan;
    my $count = $st_hub->count;

    if (!$count && (!defined($plan) || "$plan" ne 'SKIP')) {
        $st_ctx->plan(0) unless defined $plan;
        $st_ctx->diag('No tests run!');
    }

    $child->finalize($st_ctx->trace);

    $ctx->release;

    die $err unless $ok;

    $? = $child_error if defined $child_error;

    return $st_hub->is_passing;
}

sub name {
    my $self = shift;
    my $ctx = $self->ctx;
    release $ctx, $ctx->hub->meta(__PACKAGE__, {})->{Name};
}

sub reset {    ## no critic (Subroutines::ProhibitBuiltinHomonyms)
    my ($self, %params) = @_;

    Test2::API::test2_unset_is_end();

    # We leave this a global because it has to be localized and localizing
    # hash keys is just asking for pain.  Also, it was documented.
    $Level = 1;

    $self->{no_log_results} = $ENV{TEST_NO_LOG_RESULTS} ? 1 : 0
        unless $params{singleton};

    $self->{Original_Pid} = Test2::API::test2_in_preload() ? -1 : $$;

    my $ctx = $self->ctx;
    my $hub = $ctx->hub;
    $ctx->release;
    unless ($params{singleton}) {
        $hub->reset_state();
        $hub->_tb_reset();
    }

    $ctx = $self->ctx;

    my $meta = $ctx->hub->meta(__PACKAGE__, {});
    %$meta = (
        Name         => $0,
        Ending       => 0,
        Done_Testing => undef,
        Skip_All     => 0,
        Test_Results => [],
        parent       => $meta->{parent},
    );

    $self->{Exported_To} = undef unless $params{singleton};

    $self->{Orig_Handles} ||= do {
        my $format = $ctx->hub->format;
        my $out;
        if ($format && $format->isa('Test2::Formatter::TAP')) {
            $out = $format->handles;
        }
        $out ? [@$out] : [];
    };

    $self->use_numbers(1);
    $self->no_header(0) unless $params{singleton};
    $self->no_ending(0) unless $params{singleton};
    $self->reset_outputs;

    $ctx->release;

    return;
}


my %plan_cmds = (
    no_plan  => \&no_plan,
    skip_all => \&skip_all,
    tests    => \&_plan_tests,
);

sub plan {
    my( $self, $cmd, $arg ) = @_;

    return unless $cmd;

    my $ctx = $self->ctx;
    my $hub = $ctx->hub;

    $ctx->throw("You tried to plan twice") if $hub->plan;

    local $Level = $Level + 1;

    if( my $method = $plan_cmds{$cmd} ) {
        local $Level = $Level + 1;
        $self->$method($arg);
    }
    else {
        my @args = grep { defined } ( $cmd, $arg );
        $ctx->throw("plan() doesn't understand @args");
    }

    release $ctx, 1;
}


sub _plan_tests {
    my($self, $arg) = @_;

    my $ctx = $self->ctx;

    if($arg) {
        local $Level = $Level + 1;
        $self->expected_tests($arg);
    }
    elsif( !defined $arg ) {
        $ctx->throw("Got an undefined number of tests");
    }
    else {
        $ctx->throw("You said to run 0 tests");
    }

    $ctx->release;
}


sub expected_tests {
    my $self = shift;
    my($max) = @_;

    my $ctx = $self->ctx;

    if(@_) {
        $self->croak("Number of tests must be a positive integer.  You gave it '$max'")
          unless $max =~ /^\+?\d+$/;

        $ctx->plan($max);
    }

    my $hub = $ctx->hub;

    $ctx->release;

    my $plan = $hub->plan;
    return 0 unless $plan;
    return 0 if $plan =~ m/\D/;
    return $plan;
}


sub no_plan {
    my($self, $arg) = @_;

    my $ctx = $self->ctx;

    if (defined $ctx->hub->plan) {
        warn "Plan already set, no_plan() is a no-op, this will change to a hard failure in the future.";
        $ctx->release;
        return;
    }

    $ctx->alert("no_plan takes no arguments") if $arg;

    $ctx->hub->plan('NO PLAN');

    release $ctx, 1;
}


sub done_testing {
    my($self, $num_tests) = @_;

    my $ctx = $self->ctx;

    my $meta = $ctx->hub->meta(__PACKAGE__, {});

    if ($meta->{Done_Testing}) {
        my ($file, $line) = @{$meta->{Done_Testing}}[1,2];
        local $ctx->hub->{ended}; # OMG This is awful.
        $self->ok(0, "done_testing() was already called at $file line $line");
        $ctx->release;
        return;
    }
    $meta->{Done_Testing} = [$ctx->trace->call];

    my $plan = $ctx->hub->plan;
    my $count = $ctx->hub->count;

    # If done_testing() specified the number of tests, shut off no_plan
    if( defined $num_tests ) {
        $ctx->plan($num_tests) if !$plan || $plan eq 'NO PLAN';
    }
    elsif ($count && defined $num_tests && $count != $num_tests) {
        $self->ok(0, "planned to run @{[ $self->expected_tests ]} but done_testing() expects $num_tests");
    }
    else {
        $num_tests = $self->current_test;
    }

    if( $self->expected_tests && $num_tests != $self->expected_tests ) {
        $self->ok(0, "planned to run @{[ $self->expected_tests ]} ".
                     "but done_testing() expects $num_tests");
    }

    $ctx->plan($num_tests) if $ctx->hub->plan && $ctx->hub->plan eq 'NO PLAN';

    $ctx->hub->finalize($ctx->trace, 1);

    release $ctx, 1;
}


sub has_plan {
    my $self = shift;

    my $ctx = $self->ctx;
    my $plan = $ctx->hub->plan;
    $ctx->release;

    return( $plan ) if $plan && $plan !~ m/\D/;
    return('no_plan') if $plan && $plan eq 'NO PLAN';
    return(undef);
}


sub skip_all {
    my( $self, $reason ) = @_;

    my $ctx = $self->ctx;

    $ctx->hub->meta(__PACKAGE__, {})->{Skip_All} = $reason || 1;

    # Work around old perl bug
    if ($] < 5.020000) {
        my $begin = 0;
        my $level = 0;
        while (my @call = caller($level++)) {
            last unless @call && $call[0];
            next unless $call[3] =~ m/::BEGIN$/;
            $begin++;
            last;
        }
        # HACK!
        die 'Label not found for "last T2_SUBTEST_WRAPPER"' if $begin && $ctx->hub->meta(__PACKAGE__, {})->{parent};
    }

    $ctx->plan(0, SKIP => $reason);
}


sub exported_to {
    my( $self, $pack ) = @_;

    if( defined $pack ) {
        $self->{Exported_To} = $pack;
    }
    return $self->{Exported_To};
}


sub ok {
    my( $self, $test, $name ) = @_;

    my $ctx = $self->ctx;

    # $test might contain an object which we don't want to accidentally
    # store, so we turn it into a boolean.
    $test = $test ? 1 : 0;

    # In case $name is a string overloaded object, force it to stringify.
    no  warnings qw/uninitialized numeric/;
    $name = "$name" if defined $name;

    # Profiling showed that the regex here was a huge time waster, doing the
    # numeric addition first cuts our profile time from ~300ms to ~50ms
    $self->diag(<<"    ERR") if 0 + $name && $name =~ /^[\d\s]+$/;
    You named your test '$name'.  You shouldn't use numbers for your test names.
    Very confusing.
    ERR
    use warnings qw/uninitialized numeric/;

    my $trace = $ctx->{trace};
    my $hub   = $ctx->{hub};

    my $result = {
        ok => $test,
        actual_ok => $test,
        reason => '',
        type => '',
        (name => defined($name) ? $name : ''),
    };

    $hub->{_meta}->{+__PACKAGE__}->{Test_Results}[ $hub->{count} ] = $result unless $self->{no_log_results};

    my $orig_name = $name;

    my @attrs;
    my $subevents  = delete $self->{subevents};
    my $subtest_id = delete $self->{subtest_id};
    my $subtest_uuid = delete $self->{subtest_uuid};
    my $subtest_buffered = delete $self->{subtest_buffered};
    my $epkg = 'Test2::Event::Ok';
    if ($subevents) {
        $epkg = 'Test2::Event::Subtest';
        push @attrs => (subevents => $subevents, subtest_id => $subtest_id, subtest_uuid => $subtest_uuid, buffered => $subtest_buffered);
    }

    my $e = bless {
        trace => bless( {%$trace}, 'Test2::EventFacet::Trace'),
        pass  => $test,
        name  => $name,
        _meta => {'Test::Builder' => $result},
        effective_pass => $test,
        @attrs,
    }, $epkg;
    $hub->send($e);

    $self->_ok_debug($trace, $orig_name) unless($test);

    $ctx->release;
    return $test;
}

sub _ok_debug {
    my $self = shift;
    my ($trace, $orig_name) = @_;

    my $is_todo = $self->in_todo;

    my $msg = $is_todo ? "Failed (TODO)" : "Failed";

    my (undef, $file, $line) = $trace->call;
    if (defined $orig_name) {
        $self->diag(qq[  $msg test '$orig_name'\n  at $file line $line.\n]);
    }
    else {
        $self->diag(qq[  $msg test at $file line $line.\n]);
    }
}

sub _diag_fh {
    my $self = shift;
    local $Level = $Level + 1;
    return $self->in_todo ? $self->todo_output : $self->failure_output;
}

sub _unoverload {
    my ($self, $type, $thing) = @_;

    return unless ref $$thing;
    return unless blessed($$thing) || scalar $self->_try(sub{ $$thing->isa('UNIVERSAL') });
    {
        local ($!, $@);
        require overload;
    }
    my $string_meth = overload::Method( $$thing, $type ) || return;
    $$thing = $$thing->$string_meth();
}

sub _unoverload_str {
    my $self = shift;

    $self->_unoverload( q[""], $_ ) for @_;
}

sub _unoverload_num {
    my $self = shift;

    $self->_unoverload( '0+', $_ ) for @_;

    for my $val (@_) {
        next unless $self->_is_dualvar($$val);
        $$val = $$val + 0;
    }
}

# This is a hack to detect a dualvar such as $!
sub _is_dualvar {
    my( $self, $val ) = @_;

    # Objects are not dualvars.
    return 0 if ref $val;

    no warnings 'numeric';
    my $numval = $val + 0;
    return ($numval != 0 and $numval ne $val ? 1 : 0);
}


sub is_eq {
    my( $self, $got, $expect, $name ) = @_;

    my $ctx = $self->ctx;

    local $Level = $Level + 1;

    if( !defined $got || !defined $expect ) {
        # undef only matches undef and nothing else
        my $test = !defined $got && !defined $expect;

        $self->ok( $test, $name );
        $self->_is_diag( $got, 'eq', $expect ) unless $test;
        $ctx->release;
        return $test;
    }

    release $ctx, $self->cmp_ok( $got, 'eq', $expect, $name );
}


sub is_num {
    my( $self, $got, $expect, $name ) = @_;
    my $ctx = $self->ctx;
    local $Level = $Level + 1;

    if( !defined $got || !defined $expect ) {
        # undef only matches undef and nothing else
        my $test = !defined $got && !defined $expect;

        $self->ok( $test, $name );
        $self->_is_diag( $got, '==', $expect ) unless $test;
        $ctx->release;
        return $test;
    }

    release $ctx, $self->cmp_ok( $got, '==', $expect, $name );
}


sub _diag_fmt {
    my( $self, $type, $val ) = @_;

    if( defined $$val ) {
        if( $type eq 'eq' or $type eq 'ne' ) {
            # quote and force string context
            $$val = "'$$val'";
        }
        else {
            # force numeric context
            $self->_unoverload_num($val);
        }
    }
    else {
        $$val = 'undef';
    }

    return;
}


sub _is_diag {
    my( $self, $got, $type, $expect ) = @_;

    $self->_diag_fmt( $type, $_ ) for \$got, \$expect;

    local $Level = $Level + 1;
    return $self->diag(<<"DIAGNOSTIC");
         got: $got
    expected: $expect
DIAGNOSTIC

}

sub _isnt_diag {
    my( $self, $got, $type ) = @_;

    $self->_diag_fmt( $type, \$got );

    local $Level = $Level + 1;
    return $self->diag(<<"DIAGNOSTIC");
         got: $got
    expected: anything else
DIAGNOSTIC
}


sub isnt_eq {
    my( $self, $got, $dont_expect, $name ) = @_;
    my $ctx = $self->ctx;
    local $Level = $Level + 1;

    if( !defined $got || !defined $dont_expect ) {
        # undef only matches undef and nothing else
        my $test = defined $got || defined $dont_expect;

        $self->ok( $test, $name );
        $self->_isnt_diag( $got, 'ne' ) unless $test;
        $ctx->release;
        return $test;
    }

    release $ctx, $self->cmp_ok( $got, 'ne', $dont_expect, $name );
}

sub isnt_num {
    my( $self, $got, $dont_expect, $name ) = @_;
    my $ctx = $self->ctx;
    local $Level = $Level + 1;

    if( !defined $got || !defined $dont_expect ) {
        # undef only matches undef and nothing else
        my $test = defined $got || defined $dont_expect;

        $self->ok( $test, $name );
        $self->_isnt_diag( $got, '!=' ) unless $test;
        $ctx->release;
        return $test;
    }

    release $ctx, $self->cmp_ok( $got, '!=', $dont_expect, $name );
}


sub like {
    my( $self, $thing, $regex, $name ) = @_;
    my $ctx = $self->ctx;

    local $Level = $Level + 1;

    release $ctx, $self->_regex_ok( $thing, $regex, '=~', $name );
}

sub unlike {
    my( $self, $thing, $regex, $name ) = @_;
    my $ctx = $self->ctx;

    local $Level = $Level + 1;

    release $ctx, $self->_regex_ok( $thing, $regex, '!~', $name );
}


my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );

# Bad, these are not comparison operators. Should we include more?
my %cmp_ok_bl = map { ( $_, 1 ) } ( "=", "+=", ".=", "x=", "^=", "|=", "||=", "&&=", "...");

sub cmp_ok {
    my( $self, $got, $type, $expect, $name ) = @_;
    my $ctx = $self->ctx;

    if ($cmp_ok_bl{$type}) {
        $ctx->throw("$type is not a valid comparison operator in cmp_ok()");
    }

    my ($test, $succ);
    my $error;
    {
        ## no critic (BuiltinFunctions::ProhibitStringyEval)

        local( $@, $!, $SIG{__DIE__} );    # isolate eval

        my($pack, $file, $line) = $ctx->trace->call();
        my $warning_bits = $ctx->trace->warning_bits;
        # convert this to a code string so the BEGIN doesn't have to close
        # over it, which can lead to issues with Devel::Cover
        my $bits_code = defined $warning_bits ? qq["\Q$warning_bits\E"] : 'undef';

        # This is so that warnings come out at the caller's level
        $succ = eval qq[
BEGIN {\${^WARNING_BITS} = $bits_code};
#line $line "(eval in cmp_ok) $file"
\$test = (\$got $type \$expect);
1;
];
        $error = $@;
    }
    local $Level = $Level + 1;
    my $ok = $self->ok( $test, $name );

    # Treat overloaded objects as numbers if we're asked to do a
    # numeric comparison.
    my $unoverload
      = $numeric_cmps{$type}
      ? '_unoverload_num'
      : '_unoverload_str';

    $self->diag(<<"END") unless $succ;
An error occurred while using $type:
------------------------------------
$error
------------------------------------
END

    unless($ok) {
        $self->$unoverload( \$got, \$expect );

        if( $type =~ /^(eq|==)$/ ) {
            $self->_is_diag( $got, $type, $expect );
        }
        elsif( $type =~ /^(ne|!=)$/ ) {
            no warnings;
            my $eq = ($got eq $expect || $got == $expect)
                && (
                    (defined($got) xor defined($expect))
                 || (length($got)  !=  length($expect))
                );
            use warnings;

            if ($eq) {
                $self->_cmp_diag( $got, $type, $expect );
            }
            else {
                $self->_isnt_diag( $got, $type );
            }
        }
        else {
            $self->_cmp_diag( $got, $type, $expect );
        }
    }
    return release $ctx, $ok;
}

sub _cmp_diag {
    my( $self, $got, $type, $expect ) = @_;

    $got    = defined $got    ? "'$got'"    : 'undef';
    $expect = defined $expect ? "'$expect'" : 'undef';

    local $Level = $Level + 1;
    return $self->diag(<<"DIAGNOSTIC");
    $got
        $type
    $expect
DIAGNOSTIC
}

sub _caller_context {
    my $self = shift;

    my( $pack, $file, $line ) = $self->caller(1);

    my $code = '';
    $code .= "#line $line $file\n" if defined $file and defined $line;

    return $code;
}


sub BAIL_OUT {
    my( $self, $reason ) = @_;

    my $ctx = $self->ctx;

    $self->{Bailed_Out} = 1;

    $ctx->bail($reason);
}


{
    no warnings 'once';
    *BAILOUT = \&BAIL_OUT;
}

sub skip {
    my( $self, $why, $name ) = @_;
    $why ||= '';
    $name = '' unless defined $name;
    $self->_unoverload_str( \$why );

    my $ctx = $self->ctx;

    $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}[ $ctx->hub->count ] = {
        'ok'      => 1,
        actual_ok => 1,
        name      => $name,
        type      => 'skip',
        reason    => $why,
    } unless $self->{no_log_results};

    $name =~ s|#|\\#|g;    # # in a name can confuse Test::Harness.
    $name =~ s{\n}{\n# }sg;
    $why =~ s{\n}{\n# }sg;

    my $tctx = $ctx->snapshot;
    $tctx->skip('', $why);

    return release $ctx, 1;
}


sub todo_skip {
    my( $self, $why ) = @_;
    $why ||= '';

    my $ctx = $self->ctx;

    $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}[ $ctx->hub->count ] = {
        'ok'      => 1,
        actual_ok => 0,
        name      => '',
        type      => 'todo_skip',
        reason    => $why,
    } unless $self->{no_log_results};

    $why =~ s{\n}{\n# }sg;
    my $tctx = $ctx->snapshot;
    $tctx->send_event( 'Skip', todo => $why, todo_diag => 1, reason => $why, pass => 0);

    return release $ctx, 1;
}


sub maybe_regex {
    my( $self, $regex ) = @_;
    my $usable_regex = undef;

    return $usable_regex unless defined $regex;

    my( $re, $opts );

    # Check for qr/foo/
    if( _is_qr($regex) ) {
        $usable_regex = $regex;
    }
    # Check for '/foo/' or 'm,foo,'
    elsif(( $re, $opts )        = $regex =~ m{^ /(.*)/ (\w*) $ }sx              or
          ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
    )
    {
        $usable_regex = length $opts ? "(?$opts)$re" : $re;
    }

    return $usable_regex;
}

sub _is_qr {
    my $regex = shift;

    # is_regexp() checks for regexes in a robust manner, say if they're
    # blessed.
    return re::is_regexp($regex) if defined &re::is_regexp;
    return ref $regex eq 'Regexp';
}

sub _regex_ok {
    my( $self, $thing, $regex, $cmp, $name ) = @_;

    my $ok           = 0;
    my $usable_regex = $self->maybe_regex($regex);
    unless( defined $usable_regex ) {
        local $Level = $Level + 1;
        $ok = $self->ok( 0, $name );
        $self->diag("    '$regex' doesn't look much like a regex to me.");
        return $ok;
    }

    {
        my $test;
        my $context = $self->_caller_context;

        {
            ## no critic (BuiltinFunctions::ProhibitStringyEval)

            local( $@, $!, $SIG{__DIE__} );    # isolate eval

            # No point in issuing an uninit warning, they'll see it in the diagnostics
            no warnings 'uninitialized';

            $test = eval $context . q{$test = $thing =~ /$usable_regex/ ? 1 : 0};
        }

        $test = !$test if $cmp eq '!~';

        local $Level = $Level + 1;
        $ok = $self->ok( $test, $name );
    }

    unless($ok) {
        $thing = defined $thing ? "'$thing'" : 'undef';
        my $match = $cmp eq '=~' ? "doesn't match" : "matches";

        local $Level = $Level + 1;
        $self->diag( sprintf <<'DIAGNOSTIC', $thing, $match, $regex );
                  %s
    %13s '%s'
DIAGNOSTIC

    }

    return $ok;
}


sub is_fh {
    my $self     = shift;
    my $maybe_fh = shift;
    return 0 unless defined $maybe_fh;

    return 1 if ref $maybe_fh  eq 'GLOB';    # its a glob ref
    return 1 if ref \$maybe_fh eq 'GLOB';    # its a glob

    return eval { $maybe_fh->isa("IO::Handle") } ||
           eval { tied($maybe_fh)->can('TIEHANDLE') };
}


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

    if( defined $level ) {
        $Level = $level;
    }
    return $Level;
}


sub use_numbers {
    my( $self, $use_nums ) = @_;

    my $ctx = $self->ctx;
    my $format = $ctx->hub->format;
    unless ($format && $format->can('no_numbers') && $format->can('set_no_numbers')) {
        warn "The current formatter does not support 'use_numbers'" if $format;
        return release $ctx, 0;
    }

    $format->set_no_numbers(!$use_nums) if defined $use_nums;

    return release $ctx, $format->no_numbers ? 0 : 1;
}

BEGIN {
    for my $method (qw(no_header no_diag)) {
        my $set = "set_$method";
        my $code = sub {
            my( $self, $no ) = @_;

            my $ctx = $self->ctx;
            my $format = $ctx->hub->format;
            unless ($format && $format->can($set)) {
                warn "The current formatter does not support '$method'" if $format;
                $ctx->release;
                return
            }

            $format->$set($no) if defined $no;

            return release $ctx, $format->$method ? 1 : 0;
        };

        no strict 'refs';    ## no critic
        *$method = $code;
    }
}

sub no_ending {
    my( $self, $no ) = @_;

    my $ctx = $self->ctx;

    $ctx->hub->set_no_ending($no) if defined $no;

    return release $ctx, $ctx->hub->no_ending;
}

sub diag {
    my $self = shift;
    return unless @_;

    my $text = join '' => map {defined($_) ? $_ : 'undef'} @_;

    if (Test2::API::test2_in_preload()) {
        chomp($text);
        $text =~ s/^/# /msg;
        print STDERR $text, "\n";
        return 0;
    }

    my $ctx = $self->ctx;
    $ctx->diag($text);
    $ctx->release;
    return 0;
}


sub note {
    my $self = shift;
    return unless @_;

    my $text = join '' => map {defined($_) ? $_ : 'undef'} @_;

    if (Test2::API::test2_in_preload()) {
        chomp($text);
        $text =~ s/^/# /msg;
        print STDOUT $text, "\n";
        return 0;
    }

    my $ctx = $self->ctx;
    $ctx->note($text);
    $ctx->release;
    return 0;
}


sub explain {
    my $self = shift;

    local ($@, $!);
    require Data::Dumper;

    return map {
        ref $_
          ? do {
            my $dumper = Data::Dumper->new( [$_] );
            $dumper->Indent(1)->Terse(1);
            $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
            $dumper->Dump;
          }
          : $_
    } @_;
}


sub output {
    my( $self, $fh ) = @_;

    my $ctx = $self->ctx;
    my $format = $ctx->hub->format;
    $ctx->release;
    return unless $format && $format->isa('Test2::Formatter::TAP');

    $format->handles->[Test2::Formatter::TAP::OUT_STD()] = $self->_new_fh($fh)
        if defined $fh;

    return $format->handles->[Test2::Formatter::TAP::OUT_STD()];
}

sub failure_output {
    my( $self, $fh ) = @_;

    my $ctx = $self->ctx;
    my $format = $ctx->hub->format;
    $ctx->release;
    return unless $format && $format->isa('Test2::Formatter::TAP');

    $format->handles->[Test2::Formatter::TAP::OUT_ERR()] = $self->_new_fh($fh)
        if defined $fh;

    return $format->handles->[Test2::Formatter::TAP::OUT_ERR()];
}

sub todo_output {
    my( $self, $fh ) = @_;

    my $ctx = $self->ctx;
    my $format = $ctx->hub->format;
    $ctx->release;
    return unless $format && $format->isa('Test::Builder::Formatter');

    $format->handles->[Test::Builder::Formatter::OUT_TODO()] = $self->_new_fh($fh)
        if defined $fh;

    return $format->handles->[Test::Builder::Formatter::OUT_TODO()];
}

sub _new_fh {
    my $self = shift;
    my($file_or_fh) = shift;

    my $fh;
    if( $self->is_fh($file_or_fh) ) {
        $fh = $file_or_fh;
    }
    elsif( ref $file_or_fh eq 'SCALAR' ) {
        # Scalar refs as filehandles was added in 5.8.
        if( $] >= 5.008 ) {
            open $fh, ">>", $file_or_fh
              or $self->croak("Can't open scalar ref $file_or_fh: $!");
        }
        # Emulate scalar ref filehandles with a tie.
        else {
            $fh = Test::Builder::IO::Scalar->new($file_or_fh)
              or $self->croak("Can't tie scalar ref $file_or_fh");
        }
    }
    else {
        open $fh, ">", $file_or_fh
          or $self->croak("Can't open test output log $file_or_fh: $!");
        _autoflush($fh);
    }

    return $fh;
}

sub _autoflush {
    my($fh) = shift;
    my $old_fh = select $fh;
    $| = 1;
    select $old_fh;

    return;
}


sub reset_outputs {
    my $self = shift;

    my $ctx = $self->ctx;
    my $format = $ctx->hub->format;
    $ctx->release;
    return unless $format && $format->isa('Test2::Formatter::TAP');
    $format->set_handles([@{$self->{Orig_Handles}}]) if $self->{Orig_Handles};

    return;
}


sub carp {
    my $self = shift;
    my $ctx = $self->ctx;
    $ctx->alert(join "", @_);
    $ctx->release;
}

sub croak {
    my $self = shift;
    my $ctx = $self->ctx;
    $ctx->throw(join "", @_);
    $ctx->release;
}


sub current_test {
    my( $self, $num ) = @_;

    my $ctx = $self->ctx;
    my $hub = $ctx->hub;

    if( defined $num ) {
        $hub->set_count($num);

        unless ($self->{no_log_results}) {
            # If the test counter is being pushed forward fill in the details.
            my $test_results = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results};
            if ($num > @$test_results) {
                my $start = @$test_results ? @$test_results : 0;
                for ($start .. $num - 1) {
                    $test_results->[$_] = {
                        'ok'      => 1,
                        actual_ok => undef,
                        reason    => 'incrementing test number',
                        type      => 'unknown',
                        name      => undef
                    };
                }
            }
            # If backward, wipe history.  Its their funeral.
            elsif ($num < @$test_results) {
                $#{$test_results} = $num - 1;
            }
        }
    }
    return release $ctx, $hub->count;
}


sub is_passing {
    my $self = shift;

    my $ctx = $self->ctx;
    my $hub = $ctx->hub;

    if( @_ ) {
        my ($bool) = @_;
        $hub->set_failed(0) if $bool;
        $hub->is_passing($bool);
    }

    return release $ctx, $hub->is_passing;
}


sub summary {
    my($self) = shift;

    return if $self->{no_log_results};

    my $ctx = $self->ctx;
    my $data = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results};
    $ctx->release;
    return map { $_ ? $_->{'ok'} : () } @$data;
}


sub details {
    my $self = shift;

    return if $self->{no_log_results};

    my $ctx = $self->ctx;
    my $data = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results};
    $ctx->release;
    return @$data;
}


sub find_TODO {
    my( $self, $pack, $set, $new_value ) = @_;

    my $ctx = $self->ctx;

    $pack ||= $ctx->trace->package || $self->exported_to;
    $ctx->release;

    return unless $pack;

    no strict 'refs';    ## no critic
    no warnings 'once';
    my $old_value = ${ $pack . '::TODO' };
    $set and ${ $pack . '::TODO' } = $new_value;
    return $old_value;
}

sub todo {
    my( $self, $pack ) = @_;

    local $Level = $Level + 1;
    my $ctx = $self->ctx;
    $ctx->release;

    my $meta = $ctx->hub->meta(__PACKAGE__, {todo => []})->{todo};
    return $meta->[-1]->[1] if $meta && @$meta;

    $pack ||= $ctx->trace->package;

    return unless $pack;

    no strict 'refs';    ## no critic
    no warnings 'once';
    return ${ $pack . '::TODO' };
}

sub in_todo {
    my $self = shift;

    local $Level = $Level + 1;
    my $ctx = $self->ctx;
    $ctx->release;

    my $meta = $ctx->hub->meta(__PACKAGE__, {todo => []})->{todo};
    return 1 if $meta && @$meta;

    my $pack = $ctx->trace->package || return 0;

    no strict 'refs';    ## no critic
    no warnings 'once';
    my $todo = ${ $pack . '::TODO' };

    return 0 unless defined $todo;
    return 0 if "$todo" eq '';
    return 1;
}

sub todo_start {
    my $self = shift;
    my $message = @_ ? shift : '';

    my $ctx = $self->ctx;

    my $hub = $ctx->hub;
    my $filter = $hub->pre_filter(sub {
        my ($active_hub, $e) = @_;

        # Turn a diag into a todo diag
        return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag';

        # Set todo on ok's
        if ($hub == $active_hub && $e->isa('Test2::Event::Ok')) {
            $e->set_todo($message);
            $e->set_effective_pass(1);

            if (my $result = $e->get_meta(__PACKAGE__)) {
                $result->{reason} ||= $message;
                $result->{type}   ||= 'todo';
                $result->{ok}       = 1;
            }
        }

        return $e;
    }, inherit => 1);

    push @{$ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}} => [$filter, $message];

    $ctx->release;

    return;
}

sub todo_end {
    my $self = shift;

    my $ctx = $self->ctx;

    my $set = pop @{$ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}};

    $ctx->throw('todo_end() called without todo_start()') unless $set;

    $ctx->hub->pre_unfilter($set->[0]);

    $ctx->release;

    return;
}


sub caller {    ## no critic (Subroutines::ProhibitBuiltinHomonyms)
    my( $self ) = @_;

    my $ctx = $self->ctx;

    my $trace = $ctx->trace;
    $ctx->release;
    return wantarray ? $trace->call : $trace->package;
}


sub _try {
    my( $self, $code, %opts ) = @_;

    my $error;
    my $return;
    {
        local $!;               # eval can mess up $!
        local $@;               # don't set $@ in the test
        local $SIG{__DIE__};    # don't trip an outside DIE handler.
        $return = eval { $code->() };
        $error = $@;
    }

    die $error if $error and $opts{die_on_fail};

    return wantarray ? ( $return, $error ) : $return;
}

sub _ending {
    my $self = shift;
    my ($ctx, $real_exit_code, $new) = @_;

    unless ($ctx) {
        my $octx = $self->ctx;
        $ctx = $octx->snapshot;
        $octx->release;
    }

    return if $ctx->hub->no_ending;
    return if $ctx->hub->meta(__PACKAGE__, {})->{Ending}++;

    # Don't bother with an ending if this is a forked copy.  Only the parent
    # should do the ending.
    return unless $self->{Original_Pid} == $$;

    my $hub = $ctx->hub;
    return if $hub->bailed_out;

    my $plan  = $hub->plan;
    my $count = $hub->count;
    my $failed = $hub->failed;
    my $passed = $hub->is_passing;
    return unless $plan || $count || $failed;

    # Ran tests but never declared a plan or hit done_testing
    if( !$hub->plan and $hub->count ) {
        $self->diag("Tests were run but no plan was declared and done_testing() was not seen.");

        if($real_exit_code) {
            $self->diag(<<"FAIL");
Looks like your test exited with $real_exit_code just after $count.
FAIL
            $$new ||= $real_exit_code;
            return;
        }

        # But if the tests ran, handle exit code.
        if($failed > 0) {
            my $exit_code = $failed <= 254 ? $failed : 254;
            $$new ||= $exit_code;
            return;
        }

        $$new ||= 254;
        return;
    }

    if ($real_exit_code && !$count) {
        $self->diag("Looks like your test exited with $real_exit_code before it could output anything.");
        $$new ||= $real_exit_code;
        return;
    }

    return if $plan && "$plan" eq 'SKIP';

    if (!$count) {
        $self->diag('No tests run!');
        $$new ||= 255;
        return;
    }

    if ($real_exit_code) {
        $self->diag(<<"FAIL");
Looks like your test exited with $real_exit_code just after $count.
FAIL
        $$new ||= $real_exit_code;
        return;
    }

    if ($plan eq 'NO PLAN') {
        $ctx->plan( $count );
        $plan = $hub->plan;
    }

    # Figure out if we passed or failed and print helpful messages.
    my $num_extra = $count - $plan;

    if ($num_extra != 0) {
        my $s = $plan == 1 ? '' : 's';
        $self->diag(<<"FAIL");
Looks like you planned $plan test$s but ran $count.
FAIL
    }

    if ($failed) {
        my $s = $failed == 1 ? '' : 's';

        my $qualifier = $num_extra == 0 ? '' : ' run';

        $self->diag(<<"FAIL");
Looks like you failed $failed test$s of $count$qualifier.
FAIL
    }

    if (!$passed && !$failed && $count && !$num_extra) {
        $ctx->diag(<<"FAIL");
All assertions passed, but errors were encountered.
FAIL
    }

    my $exit_code = 0;
    if ($failed) {
        $exit_code = $failed <= 254 ? $failed : 254;
    }
    elsif ($num_extra != 0) {
        $exit_code = 255;
    }
    elsif (!$passed) {
        $exit_code = 255;
    }

    $$new ||= $exit_code;
    return;
}

# Some things used this even though it was private... I am looking at you
# Test::Builder::Prefix...
sub _print_comment {
    my( $self, $fh, @msgs ) = @_;

    return if $self->no_diag;
    return unless @msgs;

    # Prevent printing headers when compiling (i.e. -c)
    return if $^C;

    # Smash args together like print does.
    # Convert undef to 'undef' so its readable.
    my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;

    # Escape the beginning, _print will take care of the rest.
    $msg =~ s/^/# /;

    local( $\, $", $, ) = ( undef, ' ', '' );
    print $fh $msg;

    return 0;
}

# This is used by Test::SharedFork to turn on IPC after the fact. Not
# documenting because I do not want it used. The method name is borrowed from
# Test::Builder 2
# Once Test2 stuff goes stable this method will be removed and Test::SharedFork
# will be made smarter.
sub coordinate_forks {
    my $self = shift;

    {
        local ($@, $!);
        require Test2::IPC;
    }
    Test2::IPC->import;
    Test2::API::test2_ipc_enable_polling();
    Test2::API::test2_load();
    my $ipc = Test2::IPC::apply_ipc($self->{Stack});
    $ipc->set_no_fatal(1);
    Test2::API::test2_no_wait(1);
}

sub no_log_results { $_[0]->{no_log_results} = 1 }

1;

__END__

=head1 NAME

Test::Builder - Backend for building test libraries

=head1 SYNOPSIS

  package My::Test::Module;
  use base 'Test::Builder::Module';

  my $CLASS = __PACKAGE__;

  sub ok {
      my($test, $name) = @_;
      my $tb = $CLASS->builder;

      $tb->ok($test, $name);
  }


=head1 DESCRIPTION

L<Test::Simple> and L<Test::More> have proven to be popular testing modules,
but they're not always flexible enough.  Test::Builder provides a
building block upon which to write your own test libraries I<which can
work together>.

=head2 Construction

=over 4

=item B<new>

  my $Test = Test::Builder->new;

Returns a Test::Builder object representing the current state of the
test.

Since you only run one test per program C<new> always returns the same
Test::Builder object.  No matter how many times you call C<new()>, you're
getting the same object.  This is called a singleton.  This is done so that
multiple modules share such global information as the test counter and
where test output is going.

If you want a completely new Test::Builder object different from the
singleton, use C<create>.

=item B<create>

  my $Test = Test::Builder->create;

Ok, so there can be more than one Test::Builder object and this is how
you get it.  You might use this instead of C<new()> if you're testing
a Test::Builder based module, but otherwise you probably want C<new>.

B<NOTE>: the implementation is not complete.  C<level>, for example, is still
shared by B<all> Test::Builder objects, even ones created using this method.
Also, the method name may change in the future.

=item B<subtest>

    $builder->subtest($name, \&subtests, @args);

See documentation of C<subtest> in Test::More.

C<subtest> also, and optionally, accepts arguments which will be passed to the
subtests reference.

=item B<name>

 diag $builder->name;

Returns the name of the current builder.  Top level builders default to C<$0>
(the name of the executable).  Child builders are named via the C<child>
method.  If no name is supplied, will be named "Child of $parent->name".

=item B<reset>

  $Test->reset;

Reinitializes the Test::Builder singleton to its original state.
Mostly useful for tests run in persistent environments where the same
test might be run multiple times in the same process.

=back

=head2 Setting up tests

These methods are for setting up tests and declaring how many there
are.  You usually only want to call one of these methods.

=over 4

=item B<plan>

  $Test->plan('no_plan');
  $Test->plan( skip_all => $reason );
  $Test->plan( tests => $num_tests );

A convenient way to set up your tests.  Call this and Test::Builder
will print the appropriate headers and take the appropriate actions.

If you call C<plan()>, don't call any of the other methods below.

=item B<expected_tests>

    my $max = $Test->expected_tests;
    $Test->expected_tests($max);

Gets/sets the number of tests we expect this test to run and prints out
the appropriate headers.


=item B<no_plan>

  $Test->no_plan;

Declares that this test will run an indeterminate number of tests.


=item B<done_testing>

  $Test->done_testing();
  $Test->done_testing($num_tests);

Declares that you are done testing, no more tests will be run after this point.

If a plan has not yet been output, it will do so.

$num_tests is the number of tests you planned to run.  If a numbered
plan was already declared, and if this contradicts, a failing test
will be run to reflect the planning mistake.  If C<no_plan> was declared,
this will override.

If C<done_testing()> is called twice, the second call will issue a
failing test.

If C<$num_tests> is omitted, the number of tests run will be used, like
no_plan.

C<done_testing()> is, in effect, used when you'd want to use C<no_plan>, but
safer. You'd use it like so:

    $Test->ok($a == $b);
    $Test->done_testing();

Or to plan a variable number of tests:

    for my $test (@tests) {
        $Test->ok($test);
    }
    $Test->done_testing(scalar @tests);


=item B<has_plan>

  $plan = $Test->has_plan

Find out whether a plan has been defined. C<$plan> is either C<undef> (no plan
has been set), C<no_plan> (indeterminate # of tests) or an integer (the number
of expected tests).

=item B<skip_all>

  $Test->skip_all;
  $Test->skip_all($reason);

Skips all the tests, using the given C<$reason>.  Exits immediately with 0.

=item B<exported_to>

  my $pack = $Test->exported_to;
  $Test->exported_to($pack);

Tells Test::Builder what package you exported your functions to.

This method isn't terribly useful since modules which share the same
Test::Builder object might get exported to different packages and only
the last one will be honored.

=back

=head2 Running tests

These actually run the tests, analogous to the functions in Test::More.

They all return true if the test passed, false if the test failed.

C<$name> is always optional.

=over 4

=item B<ok>

  $Test->ok($test, $name);

Your basic test.  Pass if C<$test> is true, fail if $test is false.  Just
like Test::Simple's C<ok()>.

=item B<is_eq>

  $Test->is_eq($got, $expected, $name);

Like Test::More's C<is()>.  Checks if C<$got eq $expected>.  This is the
string version.

C<undef> only ever matches another C<undef>.

=item B<is_num>

  $Test->is_num($got, $expected, $name);

Like Test::More's C<is()>.  Checks if C<$got == $expected>.  This is the
numeric version.

C<undef> only ever matches another C<undef>.

=item B<isnt_eq>

  $Test->isnt_eq($got, $dont_expect, $name);

Like L<Test::More>'s C<isnt()>.  Checks if C<$got ne $dont_expect>.  This is
the string version.

=item B<isnt_num>

  $Test->isnt_num($got, $dont_expect, $name);

Like L<Test::More>'s C<isnt()>.  Checks if C<$got ne $dont_expect>.  This is
the numeric version.

=item B<like>

  $Test->like($thing, qr/$regex/, $name);
  $Test->like($thing, '/$regex/', $name);

Like L<Test::More>'s C<like()>.  Checks if $thing matches the given C<$regex>.

=item B<unlike>

  $Test->unlike($thing, qr/$regex/, $name);
  $Test->unlike($thing, '/$regex/', $name);

Like L<Test::More>'s C<unlike()>.  Checks if $thing B<does not match> the
given C<$regex>.

=item B<cmp_ok>

  $Test->cmp_ok($thing, $type, $that, $name);

Works just like L<Test::More>'s C<cmp_ok()>.

    $Test->cmp_ok($big_num, '!=', $other_big_num);

=back

=head2 Other Testing Methods

These are methods which are used in the course of writing a test but are not themselves tests.

=over 4

=item B<BAIL_OUT>

    $Test->BAIL_OUT($reason);

Indicates to the L<Test::Harness> that things are going so badly all
testing should terminate.  This includes running any additional test
scripts.

It will exit with 255.

=for deprecated
BAIL_OUT() used to be BAILOUT()

=item B<skip>

    $Test->skip;
    $Test->skip($why);

Skips the current test, reporting C<$why>.

=item B<todo_skip>

  $Test->todo_skip;
  $Test->todo_skip($why);

Like C<skip()>, only it will declare the test as failing and TODO.  Similar
to

    print "not ok $tnum # TODO $why\n";

=begin _unimplemented

=item B<skip_rest>

  $Test->skip_rest;
  $Test->skip_rest($reason);

Like C<skip()>, only it skips all the rest of the tests you plan to run
and terminates the test.

If you're running under C<no_plan>, it skips once and terminates the
test.

=end _unimplemented

=back


=head2 Test building utility methods

These methods are useful when writing your own test methods.

=over 4

=item B<maybe_regex>

  $Test->maybe_regex(qr/$regex/);
  $Test->maybe_regex('/$regex/');

This method used to be useful back when Test::Builder worked on Perls
before 5.6 which didn't have qr//.  Now its pretty useless.

Convenience method for building testing functions that take regular
expressions as arguments.

Takes a quoted regular expression produced by C<qr//>, or a string
representing a regular expression.

Returns a Perl value which may be used instead of the corresponding
regular expression, or C<undef> if its argument is not recognized.

For example, a version of C<like()>, sans the useful diagnostic messages,
could be written as:

  sub laconic_like {
      my ($self, $thing, $regex, $name) = @_;
      my $usable_regex = $self->maybe_regex($regex);
      die "expecting regex, found '$regex'\n"
          unless $usable_regex;
      $self->ok($thing =~ m/$usable_regex/, $name);
  }


=item B<is_fh>

    my $is_fh = $Test->is_fh($thing);

Determines if the given C<$thing> can be used as a filehandle.

=cut


=back


=head2 Test style


=over 4

=item B<level>

    $Test->level($how_high);

How far up the call stack should C<$Test> look when reporting where the
test failed.

Defaults to 1.

Setting C<$Test::Builder::Level> overrides.  This is typically useful
localized:

    sub my_ok {
        my $test = shift;

        local $Test::Builder::Level = $Test::Builder::Level + 1;
        $TB->ok($test);
    }

To be polite to other functions wrapping your own you usually want to increment C<$Level> rather than set it to a constant.

=item B<use_numbers>

    $Test->use_numbers($on_or_off);

Whether or not the test should output numbers.  That is, this if true:

  ok 1
  ok 2
  ok 3

or this if false

  ok
  ok
  ok

Most useful when you can't depend on the test output order, such as
when threads or forking is involved.

Defaults to on.

=item B<no_diag>

    $Test->no_diag($no_diag);

If set true no diagnostics will be printed.  This includes calls to
C<diag()>.

=item B<no_ending>

    $Test->no_ending($no_ending);

Normally, Test::Builder does some extra diagnostics when the test
ends.  It also changes the exit code as described below.

If this is true, none of that will be done.

=item B<no_header>

    $Test->no_header($no_header);

If set to true, no "1..N" header will be printed.

=back

=head2 Output

Controlling where the test output goes.

It's ok for your test to change where STDOUT and STDERR point to,
Test::Builder's default output settings will not be affected.

=over 4

=item B<diag>

    $Test->diag(@msgs);

Prints out the given C<@msgs>.  Like C<print>, arguments are simply
appended together.

Normally, it uses the C<failure_output()> handle, but if this is for a
TODO test, the C<todo_output()> handle is used.

Output will be indented and marked with a # so as not to interfere
with test output.  A newline will be put on the end if there isn't one
already.

We encourage using this rather than calling print directly.

Returns false.  Why?  Because C<diag()> is often used in conjunction with
a failing test (C<ok() || diag()>) it "passes through" the failure.

    return ok(...) || diag(...);

=for blame transfer
Mark Fowler <mark@twoshortplanks.com>

=item B<note>

    $Test->note(@msgs);

Like C<diag()>, but it prints to the C<output()> handle so it will not
normally be seen by the user except in verbose mode.

=item B<explain>

    my @dump = $Test->explain(@msgs);

Will dump the contents of any references in a human readable format.
Handy for things like...

    is_deeply($have, $want) || diag explain $have;

or

    is_deeply($have, $want) || note explain $have;

=item B<output>

=item B<failure_output>

=item B<todo_output>

    my $filehandle = $Test->output;
    $Test->output($filehandle);
    $Test->output($filename);
    $Test->output(\$scalar);

These methods control where Test::Builder will print its output.
They take either an open C<$filehandle>, a C<$filename> to open and write to
or a C<$scalar> reference to append to.  It will always return a C<$filehandle>.

B<output> is where normal "ok/not ok" test output goes.

Defaults to STDOUT.

B<failure_output> is where diagnostic output on test failures and
C<diag()> goes.  It is normally not read by Test::Harness and instead is
displayed to the user.

Defaults to STDERR.

C<todo_output> is used instead of C<failure_output()> for the
diagnostics of a failing TODO test.  These will not be seen by the
user.

Defaults to STDOUT.

=item reset_outputs

  $tb->reset_outputs;

Resets all the output filehandles back to their defaults.

=item carp

  $tb->carp(@message);

Warns with C<@message> but the message will appear to come from the
point where the original test function was called (C<< $tb->caller >>).

=item croak

  $tb->croak(@message);

Dies with C<@message> but the message will appear to come from the
point where the original test function was called (C<< $tb->caller >>).


=back


=head2 Test Status and Info

=over 4

=item B<no_log_results>

This will turn off result long-term storage. Calling this method will make
C<details> and C<summary> useless. You may want to use this if you are running
enough tests to fill up all available memory.

    Test::Builder->new->no_log_results();

There is no way to turn it back on.

=item B<current_test>

    my $curr_test = $Test->current_test;
    $Test->current_test($num);

Gets/sets the current test number we're on.  You usually shouldn't
have to set this.

If set forward, the details of the missing tests are filled in as 'unknown'.
if set backward, the details of the intervening tests are deleted.  You
can erase history if you really want to.


=item B<is_passing>

   my $ok = $builder->is_passing;

Indicates if the test suite is currently passing.

More formally, it will be false if anything has happened which makes
it impossible for the test suite to pass.  True otherwise.

For example, if no tests have run C<is_passing()> will be true because
even though a suite with no tests is a failure you can add a passing
test to it and start passing.

Don't think about it too much.


=item B<summary>

    my @tests = $Test->summary;

A simple summary of the tests so far.  True for pass, false for fail.
This is a logical pass/fail, so todos are passes.

Of course, test #1 is $tests[0], etc...


=item B<details>

    my @tests = $Test->details;

Like C<summary()>, but with a lot more detail.

    $tests[$test_num - 1] =
            { 'ok'       => is the test considered a pass?
              actual_ok  => did it literally say 'ok'?
              name       => name of the test (if any)
              type       => type of test (if any, see below).
              reason     => reason for the above (if any)
            };

'ok' is true if Test::Harness will consider the test to be a pass.

'actual_ok' is a reflection of whether or not the test literally
printed 'ok' or 'not ok'.  This is for examining the result of 'todo'
tests.

'name' is the name of the test.

'type' indicates if it was a special test.  Normal tests have a type
of ''.  Type can be one of the following:

    skip        see skip()
    todo        see todo()
    todo_skip   see todo_skip()
    unknown     see below

Sometimes the Test::Builder test counter is incremented without it
printing any test output, for example, when C<current_test()> is changed.
In these cases, Test::Builder doesn't know the result of the test, so
its type is 'unknown'.  These details for these tests are filled in.
They are considered ok, but the name and actual_ok is left C<undef>.

For example "not ok 23 - hole count # TODO insufficient donuts" would
result in this structure:

    $tests[22] =    # 23 - 1, since arrays start from 0.
      { ok        => 1,   # logically, the test passed since its todo
        actual_ok => 0,   # in absolute terms, it failed
        name      => 'hole count',
        type      => 'todo',
        reason    => 'insufficient donuts'
      };


=item B<todo>

    my $todo_reason = $Test->todo;
    my $todo_reason = $Test->todo($pack);

If the current tests are considered "TODO" it will return the reason,
if any.  This reason can come from a C<$TODO> variable or the last call
to C<todo_start()>.

Since a TODO test does not need a reason, this function can return an
empty string even when inside a TODO block.  Use C<< $Test->in_todo >>
to determine if you are currently inside a TODO block.

C<todo()> is about finding the right package to look for C<$TODO> in.  It's
pretty good at guessing the right package to look at.  It first looks for
the caller based on C<$Level + 1>, since C<todo()> is usually called inside
a test function.  As a last resort it will use C<exported_to()>.

Sometimes there is some confusion about where C<todo()> should be looking
for the C<$TODO> variable.  If you want to be sure, tell it explicitly
what $pack to use.

=item B<find_TODO>

    my $todo_reason = $Test->find_TODO();
    my $todo_reason = $Test->find_TODO($pack);

Like C<todo()> but only returns the value of C<$TODO> ignoring
C<todo_start()>.

Can also be used to set C<$TODO> to a new value while returning the
old value:

    my $old_reason = $Test->find_TODO($pack, 1, $new_reason);

=item B<in_todo>

    my $in_todo = $Test->in_todo;

Returns true if the test is currently inside a TODO block.

=item B<todo_start>

    $Test->todo_start();
    $Test->todo_start($message);

This method allows you declare all subsequent tests as TODO tests, up until
the C<todo_end> method has been called.

The C<TODO:> and C<$TODO> syntax is generally pretty good about figuring out
whether or not we're in a TODO test.  However, often we find that this is not
possible to determine (such as when we want to use C<$TODO> but
the tests are being executed in other packages which can't be inferred
beforehand).

Note that you can use this to nest "todo" tests

 $Test->todo_start('working on this');
 # lots of code
 $Test->todo_start('working on that');
 # more code
 $Test->todo_end;
 $Test->todo_end;

This is generally not recommended, but large testing systems often have weird
internal needs.

We've tried to make this also work with the TODO: syntax, but it's not
guaranteed and its use is also discouraged:

 TODO: {
     local $TODO = 'We have work to do!';
     $Test->todo_start('working on this');
     # lots of code
     $Test->todo_start('working on that');
     # more code
     $Test->todo_end;
     $Test->todo_end;
 }

Pick one style or another of "TODO" to be on the safe side.


=item C<todo_end>

 $Test->todo_end;

Stops running tests as "TODO" tests.  This method is fatal if called without a
preceding C<todo_start> method call.

=item B<caller>

    my $package = $Test->caller;
    my($pack, $file, $line) = $Test->caller;
    my($pack, $file, $line) = $Test->caller($height);

Like the normal C<caller()>, except it reports according to your C<level()>.

C<$height> will be added to the C<level()>.

If C<caller()> winds up off the top of the stack it report the highest context.

=back

=head1 EXIT CODES

If all your tests passed, Test::Builder will exit with zero (which is
normal).  If anything failed it will exit with how many failed.  If
you run less (or more) tests than you planned, the missing (or extras)
will be considered failures.  If no tests were ever run Test::Builder
will throw a warning and exit with 255.  If the test died, even after
having successfully completed all its tests, it will still be
considered a failure and will exit with 255.

So the exit codes are...

    0                   all tests successful
    255                 test died or all passed but wrong # of tests run
    any other number    how many failed (including missing or extras)

If you fail more than 254 tests, it will be reported as 254.

=head1 THREADS

In perl 5.8.1 and later, Test::Builder is thread-safe.  The test number is
shared by all threads.  This means if one thread sets the test number using
C<current_test()> they will all be effected.

While versions earlier than 5.8.1 had threads they contain too many
bugs to support.

Test::Builder is only thread-aware if threads.pm is loaded I<before>
Test::Builder.

You can directly disable thread support with one of the following:

    $ENV{T2_NO_IPC} = 1

or

    no Test2::IPC;

or

    Test2::API::test2_ipc_disable()

=head1 MEMORY

An informative hash, accessible via C<details()>, is stored for each
test you perform.  So memory usage will scale linearly with each test
run. Although this is not a problem for most test suites, it can
become an issue if you do large (hundred thousands to million)
combinatorics tests in the same run.

In such cases, you are advised to either split the test file into smaller
ones, or use a reverse approach, doing "normal" (code) compares and
triggering C<fail()> should anything go unexpected.

Future versions of Test::Builder will have a way to turn history off.


=head1 EXAMPLES

CPAN can provide the best examples.  L<Test::Simple>, L<Test::More>,
L<Test::Exception> and L<Test::Differences> all use Test::Builder.

=head1 SEE ALSO

=head2 INTERNALS

L<Test2>, L<Test2::API>

=head2 LEGACY

L<Test::Simple>, L<Test::More>

=head2 EXTERNAL

L<Test::Harness>

=head1 AUTHORS

Original code by chromatic, maintained by Michael G Schwern
E<lt>schwern@pobox.comE<gt>

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2002-2008 by chromatic E<lt>chromatic@wgz.orgE<gt> and
                       Michael G Schwern E<lt>schwern@pobox.comE<gt>.

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

See F<http://www.perl.com/perl/misc/Artistic.html>
PK       ! z{�9��  ��    perl5/Test/Deep.pmnu ��6�$        use strict;
use warnings;

package Test::Deep;
use Carp qw( confess );

use Test::Deep::Cache;
use Test::Deep::Stack;
use Test::Deep::RegexpVersion;

require overload;
use Scalar::Util;

my $Test;
unless (defined $Test::Deep::NoTest::NoTest)
{
# for people who want eq_deeply but not Test::Builder
  require Test::Builder;
  $Test = Test::Builder->new;
}

our ($Stack, %Compared, $CompareCache, %WrapCache, $Shallow);

our $VERSION = '1.130';
$VERSION =~ tr/_//d;

require Exporter;
our @ISA = qw( Exporter );

our $Snobby = 1; # should we compare classes?
our $Expects = 0; # are we comparing got vs expect or expect vs expect

our $LeafWrapper; # to wrap simple values in a test; if not set, shallow()

our $DNE = \"";
our $DNE_ADDR = Scalar::Util::refaddr($DNE);

# if no sub name is supplied then we use the package name in lower case
my @constructors = (
  All               => "",
  Any               => "",
  Array             => "",
  ArrayEach         => "array_each",
  ArrayElementsOnly => "",
  ArrayLength       => "",
  ArrayLengthOnly   => "",
  Blessed           => "",
  Boolean           => "bool",
  Code              => "",
  Hash              => "",
  HashEach          => "hash_each",
  HashKeys          => "",
  HashKeysOnly      => "",
  Ignore            => "",
  Isa               => "Isa",
  ListMethods       => "",
  Methods           => "",
  None              => "",
  Number            => "num",
  Obj               => "obj_isa",
  RefType           => "",
  Regexp            => "re",
  RegexpMatches     => "",
  RegexpOnly        => "",
  RegexpRef         => "",
  RegexpRefOnly     => "",
  ScalarRef         => "scalref",
  ScalarRefOnly     => "",
  Shallow           => "",
  String            => "str",
);

my @CONSTRUCTORS_FROM_CLASSES;

while (my ($pkg, $name) = splice @constructors, 0, 2)
{
  $name = lc($pkg) unless $name;
  my $full_pkg = "Test::Deep::$pkg";
  my $file = "$full_pkg.pm";
  $file =~ s#::#/#g;
  my $sub = sub {
    require $file;
    return $full_pkg->new(@_);
  };
  {
    no strict 'refs';
    *{$name} = $sub;
  }

  push @CONSTRUCTORS_FROM_CLASSES, $name;
}

{
  our @EXPORT_OK = qw(
    descend render_stack cmp_details deep_diag
    true false
  );

  our %EXPORT_TAGS;
  $EXPORT_TAGS{preload} = [];
  $EXPORT_TAGS{v0} = [
    qw(
      Isa
      blessed
      obj_isa

      all any array array_each arrayelementsonly arraylength arraylengthonly
      bag bool cmp_bag cmp_deeply cmp_methods cmp_set code eq_deeply
      hash hash_each hashkeys hashkeysonly ignore isa listmethods methods
      noclass none noneof num re reftype regexpmatches regexponly regexpref
      regexprefonly scalarrefonly scalref set shallow str subbagof subhashof
      subsetof superbagof superhashof supersetof useclass
    )
  ];

  $EXPORT_TAGS{v1} = [
    qw(
      obj_isa

      all any array array_each arrayelementsonly arraylength arraylengthonly
      bag bool cmp_bag cmp_deeply cmp_methods cmp_set code eq_deeply
      hash hash_each hashkeys hashkeysonly ignore listmethods methods
      noclass none noneof num re reftype regexpmatches regexponly regexpref
      regexprefonly scalarrefonly scalref set shallow str subbagof subhashof
      subsetof superbagof superhashof supersetof useclass
    )
  ];

  our @EXPORT = @{ $EXPORT_TAGS{ v0 } };

  $EXPORT_TAGS{all} = [ @EXPORT, @EXPORT_OK ];
}

sub import {
  my $self = shift;

  my $from_notest = grep {$_ eq '_notest'} @_;
  if ($from_notest) {
      @_ = grep {$_ ne '_notest'} @_;
  } else {
    require Test::Builder;
    $Test = Test::Builder->new;
  }

  my @sans_preload = grep {; $_ ne ':preload' } @_;
  if (@_ != @sans_preload) {
    require Test::Deep::All;
    require Test::Deep::Any;
    require Test::Deep::Array;
    require Test::Deep::ArrayEach;
    require Test::Deep::ArrayElementsOnly;
    require Test::Deep::ArrayLength;
    require Test::Deep::ArrayLengthOnly;
    require Test::Deep::Blessed;
    require Test::Deep::Boolean;
    require Test::Deep::Cache::Simple;
    require Test::Deep::Cache;
    require Test::Deep::Class;
    require Test::Deep::Cmp;
    require Test::Deep::Code;
    require Test::Deep::Hash;
    require Test::Deep::HashEach;
    require Test::Deep::HashElements;
    require Test::Deep::HashKeys;
    require Test::Deep::HashKeysOnly;
    require Test::Deep::Ignore;
    require Test::Deep::Isa;
    require Test::Deep::ListMethods;
    require Test::Deep::Methods;
    require Test::Deep::MM;
    require Test::Deep::None;
    require Test::Deep::Number;
    require Test::Deep::Obj;
    require Test::Deep::Ref;
    require Test::Deep::RefType;
    require Test::Deep::Regexp;
    require Test::Deep::RegexpMatches;
    require Test::Deep::RegexpOnly;
    require Test::Deep::RegexpRef;
    require Test::Deep::RegexpRefOnly;
    require Test::Deep::RegexpVersion;
    require Test::Deep::ScalarRef;
    require Test::Deep::ScalarRefOnly;
    require Test::Deep::Set;
    require Test::Deep::Shallow;
    require Test::Deep::Stack;
    require Test::Deep::String;
  }

  $self->export_to_level(1, $self, @_);
}

# this is ugly, I should never have exported a sub called isa now I
# have to try figure out if the recipient wanted my isa or if a class
# imported us and UNIVERSAL::isa is being called on that class.
# Luckily our isa always expects 1 argument and U::isa always expects
# 2, so we can figure out (assuming the caller is not buggy).
sub isa
{
  if (@_ == 1)
  {
    goto &Isa;
  }
  else
  {
    goto &UNIVERSAL::isa;
  }
}

sub cmp_deeply
{
  my ($d1, $d2, $name) = @_;

  my ($ok, $stack) = cmp_details($d1, $d2);

  if (not $Test->ok($ok, $name))
  {
    my $diag = deep_diag($stack);
    $Test->diag($diag);
  }

  return $ok;
}

sub cmp_details
{
  my ($d1, $d2) = @_;

  local $Stack = Test::Deep::Stack->new;
  local $CompareCache = Test::Deep::Cache->new;
  local %WrapCache;

  my $ok = descend($d1, $d2);

  return ($ok, $Stack);
}

sub eq_deeply
{
  my ($d1, $d2) = @_;

  my ($ok) = cmp_details($d1, $d2);

  return $ok
}

sub eq_deeply_cache
{
  # this is like cross between eq_deeply and descend(). It doesn't start
  # with a new $CompareCache but if the comparison fails it will leave
  # $CompareCache as if nothing happened. However, if the comparison
  # succeeds then $CompareCache retains all the new information

  # this allows Set and Bag to handle circular refs

  my ($d1, $d2, $name) = @_;

  local $Stack = Test::Deep::Stack->new;
  $CompareCache->local;

  my $ok = descend($d1, $d2);

  $CompareCache->finish($ok);

  return $ok;
}

sub deep_diag
{
  my $stack = shift;
  # ick! incArrow and other things expect the stack has to be visible
  # in a well known place . TODO clean this up
  local $Stack = $stack;

  my $where = render_stack('$data', $stack);

  confess "No stack to diagnose" unless $stack;
  my $last = $stack->getLast;

  my $diag;
  my $message;
  my $got;
  my $expected;

  my $exp = $last->{exp};
  if (Scalar::Util::blessed($exp))
  {
    if ($exp->can("diagnostics"))
    {
      $diag = $exp->diagnostics($where, $last);
      $diag =~ s/\n+$/\n/;
    }
    else
    {
      if ($exp->can("diag_message"))
      {
        $message = $exp->diag_message($where);
      }
    }
  }

  if (not defined $diag)
  {
    $got = $exp->renderGot($last->{got}) unless defined $got;
    $expected = $exp->renderExp unless defined $expected;
    $message = "Compared $where" unless defined $message;

    $diag = <<EOM
$message
   got : $got
expect : $expected
EOM
  }

  return $diag;
}

sub render_val
{
  my $val = shift;

  my $rendered;
  if (defined $val)
  {
     $rendered = ref($val) ?
       (Scalar::Util::refaddr($val) eq $DNE_ADDR ?
         "Does not exist" :
        overload::StrVal($val)
      ) :
      qq('$val');
  }
  else
  {
    $rendered = "undef";
  }

  return $rendered;
}

sub descend
{
  my ($d1, $d2) = @_;

  if (!ref $d1 and !ref $d2)
  {
    # Shortcut comparison for the non-reference case.
    if (defined $d1)
    {
      return 1 if defined $d2 and $d1 eq $d2;
    }
    else
    {
      return 1 if !defined $d2;
    }
  }

  if (! $Expects and Scalar::Util::blessed($d1) and $d1->isa("Test::Deep::Cmp"))
  {
    my $where = $Stack->render('$data');
    confess "Found a special comparison in $where\nYou can only use specials in the expects structure";
  }

  if (ref $d1 and ref $d2)
  {
    # this check is only done when we're comparing 2 expecteds against each
    # other

    if ($Expects and Scalar::Util::blessed($d1) and $d1->isa("Test::Deep::Cmp"))
    {
      # check they are the same class
      return 0 unless Test::Deep::blessed(Scalar::Util::blessed($d2))->descend($d1);
      if ($d1->can("compare"))
      {
        return $d1->compare($d2);
      }
    }

    my $s1 = Scalar::Util::refaddr($d1);
    my $s2 = Scalar::Util::refaddr($d2);

    if ($s1 eq $s2)
    {
      return 1;
    }
    if ($CompareCache->cmp($d1, $d2))
    {
      # we've tried comparing these already so either they turned out to
      # be the same or we must be in a loop and we have to assume they're
      # the same

      return 1;
    }
    else
    {
      $CompareCache->add($d1, $d2)
    }
  }

  $d2 = wrap($d2);

  $Stack->push({exp => $d2, got => $d1});

  if (ref($d1) and (Scalar::Util::refaddr($d1) == $DNE_ADDR))
  {
    # whatever it was supposed to be, it didn't exist and so it's an
    # automatic fail
    return 0;
  }

  if ($d2->descend($d1))
  {
#    print "d1 = $d1, d2 = $d2\nok\n";
    $Stack->pop;

    return 1;
  }
  else
  {
#    print "d1 = $d1, d2 = $d2\nnot ok\n";
    return 0;
  }
}

sub wrap
{
  my $data = shift;

  my $class = Scalar::Util::blessed($data);
  return $data if defined $class and $data->isa("Test::Deep::Cmp");

  if (defined $class and $data->can('as_test_deep_cmp')) {
    my $cmp = $data->as_test_deep_cmp;
    return $cmp if $cmp->isa('Test::Deep::Cmp');
    Carp::confess("object in expected structure provides as_test_deep_cmp but it did not return a Test::Deep::Cmp");
  }

  my $reftype = _td_reftype($data);

  my $cmp;

  if($reftype eq '')
  {
    $cmp = $Test::Deep::LeafWrapper
         ? $Test::Deep::LeafWrapper->($data)
         : shallow($data);
  }
  else
  {
    my $addr = Scalar::Util::refaddr($data);

    return $WrapCache{$addr} if $WrapCache{$addr};

    if($reftype eq 'ARRAY')
    {
      $cmp = array($data);
    }
    elsif($reftype eq 'HASH')
    {
      $cmp = hash($data);
    }
    elsif($reftype eq 'SCALAR' or $reftype eq 'REF')
    {
      $cmp = scalref($data);
    }
    elsif(($reftype eq 'Regexp') or ($reftype eq 'REGEXP'))
    {
      $cmp = regexpref($data);
    }
    else
    {
      $cmp = $Test::Deep::LeafWrapper
           ? $Test::Deep::LeafWrapper->($data)
           : shallow($data);
    }

    $WrapCache{$addr} = $cmp;
  }
  return $cmp;
}

sub _td_reftype
{
  my $val = shift;

  my $reftype = Scalar::Util::reftype($val);
  return '' unless defined $reftype;

  return $reftype unless $Test::Deep::RegexpVersion::OldStyle;

  my $blessed = Scalar::Util::blessed($val);
  return $reftype unless defined $blessed;

  if ($blessed && $blessed eq "Regexp" and $reftype eq "SCALAR")
  {
    $reftype = "Regexp"
  }

  return $reftype;
}

sub render_stack
{
  my ($var, $stack) = @_;

  return $stack->render($var);
}

sub cmp_methods
{
  local $Test::Builder::Level = $Test::Builder::Level + 1;
  return cmp_deeply(shift, methods(@{shift()}), shift);
}

sub requireclass
{
  require Test::Deep::Class;

  my $val = shift;

  return Test::Deep::Class->new(1, $val);
}

# docs and export say this is called useclass, doh!

*useclass = \&requireclass;

sub noclass
{
  require Test::Deep::Class;

  my $val = shift;

  return Test::Deep::Class->new(0, $val);
}

sub set
{
  require Test::Deep::Set;

  return Test::Deep::Set->new(1, "", @_);
}

sub supersetof
{
  require Test::Deep::Set;

  return Test::Deep::Set->new(1, "sup", @_);
}

sub subsetof
{
  require Test::Deep::Set;

  return Test::Deep::Set->new(1, "sub", @_);
}

sub noneof
{
  require Test::Deep::Set;

  return Test::Deep::Set->new(1, "none", @_);
}

sub cmp_set
{
  local $Test::Builder::Level = $Test::Builder::Level + 1;
  return cmp_deeply(shift, set(@{shift()}), shift);
}

sub bag
{
  require Test::Deep::Set;

  return Test::Deep::Set->new(0, "", @_);
}

sub superbagof
{
  require Test::Deep::Set;

  return Test::Deep::Set->new(0, "sup", @_);
}

sub subbagof
{
  require Test::Deep::Set;

  return Test::Deep::Set->new(0, "sub", @_);
}

sub cmp_bag
{
  local $Test::Builder::Level = $Test::Builder::Level + 1;
  my $ref = ref($_[1]) || "";
  confess "Argument 2 to cmp_bag is not an ARRAY ref (".render_val($_[1]).")"
    unless $ref eq "ARRAY";
  return cmp_deeply(shift, bag(@{shift()}), shift);
}

sub superhashof
{
  require Test::Deep::Hash;

  my $val = shift;

  return Test::Deep::SuperHash->new($val);
}

sub subhashof
{
  require Test::Deep::Hash;

  my $val = shift;

  return Test::Deep::SubHash->new($val);
}

sub true
{
  bool(1);
}

sub false
{
  bool(0);
}

sub builder
{
  if (@_)
  {
    $Test = shift;
  }
  return $Test;
}

1;

__END__

=head1 NAME

Test::Deep - Extremely flexible deep comparison

=head1 SYNOPSIS

  use Test::More tests => $Num_Tests;
  use Test::Deep;

  cmp_deeply(
    $actual_horrible_nested_data_structure,
    $expected_horrible_nested_data_structure,
    "got the right horrible nested data structure"
  );

  cmp_deeply(
    $object,
    methods(name => "John", phone => "55378008"),
    "object methods ok"
  );

  cmp_deeply(
    \@array,
    [$hash1, $hash2, ignore()],
    "first 2 elements are as expected, ignoring 3"
  );

  cmp_deeply(
    $object,
    noclass({value => 5}),
    "object looks ok, not checking its class"
  );

  cmp_deeply(
    \@result,
    bag('a', 'b', {key => [1, 2]}),
    "array has the 3 things we wanted in some order"
  );

=head1 DESCRIPTION

If you don't know anything about automated testing in Perl then you should
probably read about L<Test::Simple> and L<Test::More> before preceding.
Test::Deep uses the L<Test::Builder> framework.

Test::Deep gives you very flexible ways to check that the result you got is
the result you were expecting. At its simplest it compares two structures
by going through each level, ensuring that the values match, that arrays and
hashes have the same elements and that references are blessed into the
correct class. It also handles circular data structures without getting
caught in an infinite loop.

Where it becomes more interesting is in allowing you to do something besides
simple exact comparisons. With strings, the C<eq> operator checks that 2
strings are exactly equal but sometimes that's not what you want. When you
don't know exactly what the string should be but you do know some things
about how it should look, C<eq> is no good and you must use pattern matching
instead. Test::Deep provides pattern matching for complex data structures

Test::Deep has B<I<a lot>> of exports.  See L</EXPORTS> below.

=head1 EXAMPLES

How Test::Deep works is much easier to understand by seeing some examples.

=head2 Without Test::Deep

Say you want to test a function which returns a string. You know that your
string should be a 7 digit number beginning with 0, C<eq> is no good in this
situation, you need a regular expression. So you could use Test::More's
C<like()> function:

  like($string, qr/^0[0-9]{6}$/, "number looks good");

Similarly, to check that a string looks like a name, you could do:

  like($string, qr/^(Mr|Mrs|Miss) \w+ \w+$/,
    "got title, first and last name");

Now imagine your function produces a hash with some personal details in it.
You want to make sure that there are 2 keys, Name and Phone and that the
name looks like a name and the phone number looks like a phone number. You
could do:

  $hash = make_person();
  like($hash->{Name}, qr/^(Mr|Mrs|Miss) \w+ \w+$/, "name ok");
  like($hash->{Phone}, qr/^0[0-9]{6}$/, "phone ok");
  is(scalar keys %$hash, 2, "correct number of keys");

But that's not quite right, what if make_person has a serious problem and
didn't even return a hash? We really need to write

  if (ref($hash) eq "HASH")
  {
    like($hash->{Name}, qr/^(Mr|Mrs|Miss) \w+ \w+$/, "name ok");
    like($hash->{Phone}, qr/^0[0-9]{6}$/, "phone ok");
    is(scalar keys %$hash, 2, "correct number of keys");
  }
  else
  {
    fail("person not a hash");
    fail("person not a hash");
    fail("person not a hash"); # need 3 to keep the plan correct
  }

Already this is getting messy, now imagine another entry in the hash, an
array of children's names. This would require


  if (ref($hash) eq "HASH")
  {
    like($hash->{Name}, $name_pat, "name ok");
    like($hash->{Phone}, '/^0d{6}$/', "phone ok");
    my $cn = $hash->{ChildNames};
    if (ref($cn) eq "ARRAY")
    {
      foreach my $child (@$cn)
      {
        like($child, $name_pat);
      }
    }
    else
    {
        fail("child names not an array")
    }
  }
  else
  {
    fail("person not a hash");
  }

This is a horrible mess and because we don't know in advance how many
children's names there will be, we can't make a plan for our test anymore
(actually, we could but it would make things even more complicated).

Test::Deep to the rescue.

=head2 With Test::Deep

  my $name_re = re('^(Mr|Mrs|Miss) \w+ \w+$');
  cmp_deeply(
    $person,
    {
      Name => $name_re,
      Phone => re('^0d{6}$'),
      ChildNames => array_each($name_re)
    },
    "person ok"
  );

This will do everything that the messy code above does and it will give a
sensible message telling you exactly what went wrong if it finds a part of
$person that doesn't match the pattern. C<re()> and C<array_each()> are
special function imported from Test::Deep. They create a marker that tells
Test::Deep that something different is happening here. Instead of just doing
a simple comparison and checking are two things exactly equal, it should do
something else.

If a person was asked to check that 2 structures are equal, they could print
them both out and compare them line by line. The markers above are similar
to writing a note in red pen on one of the printouts telling the person that
for this piece of the structure, they should stop doing simple line by line
comparison and do something else.

C<re($regex)> means that Test::Deep should check that the current piece of
data matches the regex in C<$regex>. C<array_each($struct)> means that
Test::Deep should expect the current piece of data to be an array and it
should check that every element of that array matches C<$struct>.
In this case, every element of C<< $person->{ChildNames} >> should look like a
name. If say the 3rd one didn't you would get an error message something
like

  Using Regexp on $data->{ChildNames}[3]
     got    : 'Queen John Paul Sartre'
     expect : /^(Mr|Mrs|Miss) \w+ \w+$/

There are lots of other special comparisons available, see
L<SPECIAL COMPARISONS PROVIDED> below for the full list.

=head2 Reusing structures

Test::Deep is good for reusing test structures so you can do this

  my $name_re = re('^(Mr|Mrs|Miss) \w+ \w+$');
  my $person_cmp = {
    Name => $name_re,
    Phone => re('^0d{6}$'),
    ChildNames => array_each($name_re)
  };

  cmp_deeply($person1, $person_cmp, "person ok");
  cmp_deeply($person2, $person_cmp, "person ok");
  cmp_deeply($person3, $person_cmp, "person ok");

You can even put $person_cmp in a module and let other people use it when
they are writing test scripts for modules that use your modules.

To make things a little more difficult, lets change the person data
structure so that instead of a list of ChildNames, it contains a list of
hashes, one for each child. So in fact our person structure will contain
other person structures which may contain other person structures and so on.
This is easy to handle with Test::Deep because Test::Deep structures can
include themselves. Simply do

  my $name_re = re('^(Mr|Mrs|Miss) \w+ \w+$');
  my $person_cmp = {
    Name => $name_re,
    Phone => re('^0d{6}$'),
    # note no mention of Children here
  };

  $person_cmp->{Children} = array_each($person_cmp);

  cmp_deeply($person, $person_cmp, "person ok");

This will now check that $person->{Children} is an array and that every
element of that array also matches C<$person_cmp>, this includes checking
that its children also match the same pattern and so on.

=head2 Circular data structures

A circular data structure is one which loops back on itself, you can make
one easily by doing

  my @b;
  my @a = (1, 2, 3, \@b);
  push(@b, \@a);

now C<@a> contains a reference to be C<@b> and C<@b> contains a reference to
C<@a>. This causes problems if you have a program that wants to look inside
C<@a> and keep looking deeper and deeper at every level, it could get caught
in an infinite loop looking into C<@a> then C<@b> then C<@a> then C<@b> and
so on.

Test::Deep avoids this problem so we can extend our example further by
saying that a person should also list their parents.

  my $name_re = re('^(Mr|Mrs|Miss) \w+ \w+$');
  my $person_cmp = {
    Name => $name_re,
    Phone => re('^0d{6}$'),
    # note no mention of Children here
  };

  $person_cmp->{Children} = each_array($person_cmp);
  $person_cmp->{Parents} = each_array($person_cmp);

  cmp_deeply($person, $person_cmp, "person ok");

So this will check that for each child C<$child> in C<< $person->{Children} >>
that the C<< $child->{Parents} >> matches C<$person_cmp> however it is smart
enough not to get caught in an infinite loop where it keeps bouncing between
the same Parent and Child.

=head1 TERMINOLOGY

C<cmp_deeply($got, $expected, $name)> takes 3 arguments. C<$got> is the
structure that you are checking, you must not include any special
comparisons in this structure or you will get a fatal error. C<$expected>
describes what Test::Deep will be looking for in $got. You can put special
comparisons in $expected if you want to.

As Test::Deep descends through the 2 structures, it compares them one piece
at a time, so at any point in the process, Test::Deep is thinking about 2
things - the current value from C<$got> and the current value from
C<$expected>. In the documentation, I call them C<$got_v> and C<exp_v>
respectively.

=head1 COMPARISON FUNCTIONS

=head3 cmp_deeply

  my $ok = cmp_deeply($got, $expected, $name)

C<$got> is the result to be checked. C<$expected> is the structure against
which C<$got> will be check. C<$name> is the test name.

This is the main comparison function, the others are just wrappers around
this.  C<$got> and C<$expected> are compared recursively.  Each value in
C<$expected> defines what's expected at the corresponding location in C<$got>.
Simple scalars are compared with C<eq>.  References to structures like hashes
and arrays are compared recursively.

Items in C<$expected>, though, can also represent complex tests that check for
numbers in a given range, hashes with at least a certain set of keys, a string
matching a regex, or many other things.

See L</WHAT ARE SPECIAL COMPARISONS> for details.

=head3 cmp_bag

  my $ok = cmp_bag(\@got, \@bag, $name)

Is shorthand for cmp_deeply(\@got, bag(@bag), $name)

I<n.b.>: Both arguments must be array refs. If they aren't an exception will be
thrown.

=head3 cmp_set

  my $ok = cmp_set(\@got, \@set, $name)

Is shorthand for cmp_deeply(\@got, set(@set), $name)

=head3 cmp_methods

  my $ok = cmp_methods(\@got, \@methods, $name)

Is shorthand for cmp_deeply(\@got, methods(@methods), $name)

=head3 eq_deeply

  my $ok = eq_deeply($got, $expected)

This is the same as cmp_deeply() except it just returns true or
false. It does not create diagnostics or talk to L<Test::Builder>, but
if you want to use it in a non-testing environment then you should
import it through L<Test::Deep::NoTest>. For example

  use Test::Deep::NoTest;
  print "a equals b" unless eq_deeply($a, $b);

otherwise the L<Test::Builder> framework will be loaded and testing messages
will be output when your program ends.

=head3 cmp_details

  ($ok, $stack) = cmp_details($got, $expected)

This behaves much like eq_deeply, but it additionally allows you to
produce diagnostics in case of failure by passing the value in C<$stack>
to C<deep_diag>.

Do not make assumptions about the structure or content of C<$stack> and
do not use it if C<$ok> contains a true value.

See L</USING TEST::DEEP WITH TEST::BUILDER> for example uses.

=head1 SPECIAL COMPARISONS PROVIDED

In the documentation below, C<$got_v> is used to indicate any given value
within the C<$got> structure.

=head3 ignore

  cmp_deeply( $got, ignore() );

This makes Test::Deep skip tests on C<$got_v>. No matter what value C<$got_v>
has, Test::Deep will think it's correct. This is useful if some part of the
structure you are testing is very complicated and already tested elsewhere,
or if it is unpredictable.

  cmp_deeply(
    $got,
    {
      name    => 'John',
      random  => ignore(),
      address => [ '5 A street', 'a town', 'a country' ],
    }
  );

is the equivalent of checking

  $got->{name} eq 'John';
  exists $got->{random};
  cmp_deeply($got->{address}, ['5 A street', 'a town', 'a country']);

=head3 methods

  cmp_deeply( $got, methods(%hash) );

%hash is a hash of method call => expected value pairs.

This lets you call methods on an object and check the result of each call.
The methods will be called in the order supplied. If you want to pass
arguments to the method you should wrap the method name and arguments in an
array reference.

  cmp_deeply(
    $obj,
    methods(name => "John", ["favourite", "food"] => "taco")
  );

is roughly the equivalent of checking that

  $obj->name eq "John"
  $obj->favourite("food") eq "taco"

The methods will be called in the order you supply them and will be called
in scalar context. If you need to test methods called in list context then
you should use C<listmethods()>.

B<NOTE> Just as in a normal test script, you need to be careful if the
methods you call have side effects like changing the object or other objects
in the structure. Although the order of the methods is fixed, the order of
some other tests is not so if C<$expected> is

  {
    manager => methods(@manager_methods),
    coder => methods(@coder_methods)
  }

there is no way to know which if manager and coder will be tested first. If
the methods you are testing depend on and alter global variables or if
manager and coder are the same object then you may run into problems.

=head3 listmethods

  cmp_deeply( $got, listmethods(%hash) );

C<%hash> is a hash of pairs mapping method names to expected return values.

This is almost identical to methods() except the methods are called in list
context instead of scalar context. This means that the expected return
values supplied must be in array references.

  cmp_deeply(
    $obj,
    listmethods(
      name => [ "John" ],
      ["favourites", "food"] => ["Mapo tofu", "Gongbao chicken"]
    )
  );

is the equivalent of checking that

  cmp_deeply([$obj->name], ["John"]);
  cmp_deeply([$obj->favourites("food")], ["Mapo tofu", "Gongbao chicken"]);

The methods will be called in the order you supply them.

B<NOTE> The same caveats apply as for methods().

=head3 shallow

  cmp_deeply( $got, shallow($thing) );

C<$thing> is a ref.

This prevents Test::Deep from looking inside C<$thing>. It allows you to
check that C<$got_v> and C<$thing> are references to the same variable. So

  my @a = @b = (1, 2, 3);
  cmp_deeply(\@a, \@b);

will pass because C<@a> and C<@b> have the same elements however

  cmp_deeply(\@a, shallow(\@b))

will fail because although C<\@a> and C<\@b> both contain C<1, 2, 3> they are
references to different arrays.

=head3 noclass

  cmp_deeply( $got, noclass($thing) );

C<$thing> is a structure to be compared against.

This makes Test::Deep ignore the class of objects, so it just looks at the
data they contain. Class checking will be turned off until Test::Deep is
finished comparing C<$got_v> against C<$thing>. Once Test::Deep comes out of
C<$thing> it will go back to its previous setting for checking class.

This can be useful when you want to check that objects have been
constructed correctly but you don't want to write lots of
C<bless>es. If C<@people> is an array of Person objects then

  cmp_deeply(\@people, [
    bless {name => 'John', phone => '555-5555'}, "Person",
    bless {name => 'Anne', phone => '444-4444'}, "Person",
  ]);

can be replaced with

  cmp_deeply(\@people, noclass([
    {name => 'John', phone => '555-5555'},
    {name => 'Anne', phone => '444-4444'}
  ]));

However, this is testing so you should also check that the objects are
blessed correctly. You could use a map to bless all those hashes or you
could do a second test like

  cmp_deeply(\@people, array_each(isa("Person"));

=head3 useclass

  cmp_deeply( $got, useclass($thing) );

This turns back on the class comparison while inside a C<noclass()>.

  cmp_deeply(
    $got,
    noclass(
      [
        useclass( $object )
      ]
    )
  )

In this example the class of the array reference in C<$got> is ignored but
the class of C<$object> is checked, as is the class of everything inside
C<$object>.

=head3 re

  cmp_deeply( $got, re($regexp, $capture_data, $flags) );

C<$regexp> is either a regular expression reference produced with C<qr/.../>
or a string which will be used to construct a regular expression.

C<$capture_data> is optional and is used to check the strings captured by an
regex. This should can be an array ref or a Test::Deep comparator that works
on array refs.

C<$flags> is an optional string which controls whether the regex runs as a
global match. If C<$flags> is "g" then the regex will run as C<m/$regexp/g>.

Without C<$capture_data>, this simply compares C<$got_v> with the regular
expression provided. So

  cmp_deeply($got, [ re("ferg") ])

is the equivalent of

  $got->[0] =~ /ferg/

With C<$capture_data>,

  cmp_deeply($got, [re($regex, $capture_data)])

is the equivalent of

  my @data = $got->[0] =~ /$regex/;
  cmp_deeply(\@data, $capture_data);

So you can do something simple like

  cmp_deeply($got, re(qr/(\d\d)(\w\w)/, [25, "ab" ]))

to check that C<(\d\d)> was 25 and C<(\w\w)> was "ab" but you can also use
Test::Deep objects to do more complex testing of the captured values

  cmp_deeply(
    "cat=2,dog=67,sheep=3,goat=2,dog=5",
    re(
      qr/(\D+)=\d+,?/,
      set(qw( cat sheep dog )),
      "g"
    ),
  );

here, the regex will match the string and will capture the animal names and
check that they match the specified set, in this case it will fail,
complaining that "goat" is not in the set.

=head3 all

  cmp_deeply( $got, all(@expecteds) );

C<@expecteds> is an array of expected structures.

This allows you to compare data against multiple expected results and make
sure each of them matches.

  cmp_deeply($got, all(isa("Person"), methods(name => 'John')))

is equivalent to

  $got->isa("Person")
  $got->name eq 'John'

If either test fails then the whole thing is considered a fail. This is a
short-circuit test, the testing is stopped after the first failure, although
in the future it may complete all tests so that diagnostics can be output
for all failures. When reporting failure, the parts are counted from 1.

Thanks to the magic of overloading, you can write

  any( re("^wi"), all(isa("Person"), methods(name => 'John')) )

as

   re("^wi") | isa("Person") & methods(name => 'John')

Note B<single> C<|> not double, as C<||> cannot be overloaded. This will
only work when there is a special comparison involved. If you write

  "john" | "anne" | "robert"

Perl will turn this into

  "{onort"

which is presumably not what you wanted. This is because perl ors them
together as strings before Test::Deep gets a chance to do any overload
tricks.

=head3 any

  cmp_deeply( $got, any(@expecteds) );

C<@expecteds> is an array of expected structures.

This can be used to compare data against multiple expected results and make
sure that at least one of them matches. This is a short-circuit test so if
a test passes then none of the tests after that will be attempted.

You can also use overloading with C<|> similarly to all().

=head3 Isa

  cmp_deeply( $got, Isa($class) );

=head3 isa

  cmp_deeply( $got, isa($class) );

C<$class> is a class name.

This uses C<UNIVERSAL::isa()> to check that C<$got_v> is blessed into the
class C<$class>.

B<NOTE:> C<Isa()> does exactly as documented here, but C<isa()> is slightly
different. If C<isa()> is called with 1 argument it falls through to
C<Isa()>. If C<isa()> called with 2 arguments, it falls through to
C<UNIVERSAL::isa>. This is to prevent breakage when you import C<isa()> into
a package that is used as a class. Without this, anyone calling
C<Class-E<gt>isa($other_class)> would get the wrong answer. This is a hack
to patch over the fact that C<isa> is exported by default.

=head3 obj_isa

  cmp_deeply( $got, obj_isa($class) );

This test accepts only objects that are instances of C<$class> or a subclass.
Unlike the C<Isa> test, this test will never accept class names.

=head3 array_each

  cmp_deeply( \@got, array_each($thing) );

C<$thing> is a structure to be compared against.

<$got_v> must be an array reference. Each element of it will be compared to
C<$thing>. This is useful when you have an array of similar things, for example
objects of a known type and you don't want to have to repeat the same test
for each one.

  my $common_tests = all(
     isa("MyFile"),
     methods(
       handle => isa("IO::Handle")
       filename => re("^/home/ted/tmp"),
    )
  );

  cmp_deeply($got, array_each($common_tests));

is similar to

  foreach my $got_v (@$got) {
    cmp_deeply($got_v, $common_tests)
  }

Except it will not explode if C<$got> is not an array reference. It will
check that each of the objects in C<@$got> is a MyFile and that each one
gives the correct results for its methods.

You could go further, if for example there were 3 files and you knew the
size of each one you could do this

  cmp_deeply(
    $got,
    all(
      array_each($common_tests),
      [
        methods(size => 1000),
        methods(size => 200),
        methods(size => 20)
      ]
    )
  )
  cmp_deeply($got, array_each($structure));

=head3 hash_each

  cmp_deeply( \%got, hash_each($thing) );

This test behaves like C<array_each> (see above) but tests that each hash
value passes its tests.

=head3 str

  cmp_deeply( $got, str($string) );

$string is a string.

This will stringify C<$got_v> and compare it to C<$string> using C<eq>, even
if C<$got_v> is a ref. It is useful for checking the stringified value of an
overloaded reference.

=head3 num

  cmp_deeply( $got, num($number, $tolerance) );

C<$number> is a number.

C<$tolerance> is an optional number.

This will add 0 to C<$got_v> and check if it's numerically equal to
C<$number>, even if C<$got_v> is a ref. It is useful for checking the
numerical value of an overloaded reference. If C<$tolerance> is supplied
then this will check that C<$got_v> and C<$exp_v> are less than
C<$tolerance> apart. This is useful when comparing floating point numbers as
rounding errors can make it hard or impossible for C<$got_v> to be exactly
equal to C<$exp_v>. When C<$tolerance> is supplied, the test passes if
C<abs($got_v - $exp_v) <= $tolerance>.

B<Note> in Perl, C<"12blah" == 12> because Perl will be smart and convert
"12blah" into 12. You may not want this. There was a strict mode but that is
now gone. A "looks like a number" test will replace it soon. Until then you
can usually just use the string() comparison to be more strict. This will
work fine for almost all situations, however it will not work when <$got_v>
is an overloaded value who's string and numerical values differ.

=head3 bool, true, false

  cmp_deeply( $got, bool($value) );
  cmp_deeply( $got, true );
  cmp_deeply( $got, false );

C<$value> is anything you like but it's probably best to use 0 or 1

This will check that C<$got_v> and C<$value> have the same truth value, that
is they will give the same result when used in boolean context, like in an
C<if()> statement.

B<Note:> C<true> and C<false> are only imported by special request.

=head3 code

  cmp_deeply( $got, code(\&subref) );

C<\&subref> is a reference to a subroutine which will be passed a single
argument, it then should return a true or false and possibly a string

This will pass C<$got_v> to the subroutine which returns true or false to
indicate a pass or fail. Fails can be accompanied by a diagnostic string
which gives an explanation of why it's a fail.

  sub check_name
  {
    my $name = shift;
    if ($boss->likes($name))
    {
      return 1;
    }
    else
    {
      return (0, "the boss doesn't like your name");
    }
  }

  cmp_deeply("Brian", code(\&check_name));

=head2 SET COMPARISONS

Set comparisons give special semantics to array comparisons:

=over 4

=item * The order of items in a set is irrelevant

=item * The presence of duplicate items in a set is ignored.

=back

As such, in any set comparison, the following arrays are equal:

  [ 1, 2 ]
  [ 1, 1, 2 ]
  [ 1, 2, 1 ]
  [ 2, 1, 1 ]
  [ 1, 1, 2 ]

All are interpreted by C<set> semantics as if the set was only specified as:

  [ 1, 2 ]

All C<set> functions return an object which can have additional items added to
it:

  my $set = set( 1, 2 );
  $set->add(1, 3, 1 );  # Set is now ( 1, 2, 3 )

Special care must be taken when using special comparisons within sets. See
L</SPECIAL CARE WITH SPECIAL COMPARISONS IN SETS AND BAGS> for details.

=head3 set

  cmp_deeply( \@got, set(@elements) );

This does a set comparison, that is, it compares two arrays but ignores the
order of the elements and it ignores duplicate elements, but ensures that all
items in C<@elements> will be in C<$got> and all items in C<$got> will be
in C<@elements>.

So the following tests will be passes, and will be equivalent:

  cmp_deeply([1, 2, 2, 3], set(3, 2, 1, 1));
  cmp_deeply([1, 2, 3],    set(3, 2, 1));

=head3 supersetof

  cmp_deeply( \@got, supersetof(@elements) );

This function works much like L<< C<set>|/set >>, and performs a set comparison
of C<$got_v> with the elements of C<@elements>.

C<supersetof> is however slightly relaxed, such that C<$got> may contain things
not in C<@elements>, but must at least contain all C<@elements>.

These two statements are equivalent, and will be passes:

  cmp_deeply([1,2,3,3,4,5], supersetof(2,2,3));
  cmp_deeply([1,2,3,4,5],   supersetof(2,3));

But these will be failures:

  cmp_deeply([1,2,3,4,5],   supersetof(2,3,6)); # 6 not in superset
  cmp_deeply([1],           supersetof(1,2));   # 2 not in superset

=head3 subsetof

  cmp_deeply( \@got, subsetof(@elements) );

This function works much like L<< C<set>|/set >>, and performs a set comparison
of C<$got_v> with the elements of C<@elements>.

This is the inverse of C<supersetof>, which expects all unique elements found
in C<$got_v> must be in C<@elements>.

  cmp_deeply([1,2,4,5], subsetof(2,3,3)    ) # Fail: 1,4 & 5 extra
  cmp_deeply([2,3,3],   subsetof(1,2,4,5)  ) # Fail: 3 extra
  cmp_deeply([2,3,3],   subsetof(1,2,4,5,3)) # Pass

=head3 none

  cmp_deeply( $got, none(@elements) );

@elements is an array of elements, wherein no elements in C<@elements> may
be equal to C<$got_v>.

=head3 noneof

  cmp_deeply( \@got, noneof(@elements) );

@elements is an array of elements, wherein no elements in C<@elements> may be
found in C<$got_v>.

For example:

  # Got has no 1, no 2, and no 3
  cmp_deeply( [1], noneof( 1, 2, 3 ) ); # fail
  cmp_deeply( [5], noneof( 1, 2, 3 ) ); # pass

=head2 BAG COMPARISONS

Bag comparisons give special semantics to array comparisons, that are similar
to L<< set comparisons|/SET COMPARISONS >>, but slightly different.

=over 4

=item * The order of items in a bag is irrelevant

=item * The presence of duplicate items in a bag is B<PRESERVED>

=back

As such, in any bag comparison, the following arrays are equal:

  [ 1, 1, 2 ]
  [ 1, 2, 1 ]
  [ 2, 1, 1 ]
  [ 1, 1, 2 ]

However, they are B<NOT> equal to any of the following:

  [ 1, 2 ]
  [ 1, 2, 2 ]
  [ 1, 1, 1, 2 ]

All C<bag> functions return an object which can have additional items added to
it:

  my $bag = bag( 1, 2 );
  $bag->add(1, 3, 1 );  # Bag is now ( 1, 1, 1, 2, 3 )

Special care must be taken when using special comparisons within bags. See
L</SPECIAL CARE WITH SPECIAL COMPARISONS IN SETS AND BAGS> for details.

=head3 bag

  cmp_deeply( \@got, bag(@elements) );

This does an order-insensitive bag comparison between C<$got> and
C<@elements>, ensuring that:

=over 4

=item each item in C<@elements> is found in C<$got>

=item the number of times a C<$expected_v> is found in C<@elements> is
reflected in C<$got>

=item no items are found in C<$got> other than those in C<@elements>.

=back

As such, the following are passes, and are equivalent to each other:

  cmp_deeply([1, 2, 2], bag(2, 2, 1))
  cmp_deeply([2, 1, 2], bag(2, 2, 1))
  cmp_deeply([2, 2, 1], bag(2, 2, 1))

But the following are failures:

  cmp_deeply([1, 2, 2],     bag(2, 2, 1, 1)) # Not enough 1's in Got
  cmp_deeply([1, 2, 2, 1],  bag(2, 2, 1)   ) # Too many   1's in Got

=head3 superbagof

  cmp_deeply( \@got, superbagof( @elements ) );

This function works much like L<< C<bag>|/bag >>, and performs a bag comparison
of C<$got_v> with the elements of C<@elements>.

C<superbagof> is however slightly relaxed, such that C<$got> may contain things
not in C<@elements>, but must at least contain all C<@elements>.

So:

  # pass
  cmp_deeply( [1, 1, 2], superbagof( 1 )      );

  # fail: not enough 1's in superbag
  cmp_deeply( [1, 1, 2], superbagof( 1, 1, 1 ));

=head3 subbagof

  cmp_deeply( \@got, subbagof(@elements) );

This function works much like L<< C<bag>|/bag >>, and performs a bag comparison
of C<$got_v> with the elements of C<@elements>.

This is the inverse of C<superbagof>, and expects all elements in C<$got> to
be in C<@elements>, while allowing items to exist in C<@elements> that are not
in C<$got>

  # pass
  cmp_deeply( [1],        subbagof( 1, 1, 2 ) );

  # fail: too many 1's in subbag
  cmp_deeply( [1, 1, 1],  subbagof( 1, 1, 2 ) );

=head2 HASH COMPARISONS

Typically, if you're doing simple hash comparisons,

  cmp_deeply( \%got, \%expected )

is sufficient. C<cmp_deeply> will ensure C<%got> and C<%hash> have identical
keys, and each key from either has the same corresponding value.

=head3 superhashof

  cmp_deeply( \%got, superhashof(\%hash) );

This will check that the hash C<%$got> is a "super-hash" of C<%hash>. That
is that all the key and value pairs in C<%hash> appear in C<%$got> but
C<%$got> can have extra ones also.

For example

  cmp_deeply({a => 1, b => 2}, superhashof({a => 1}))

will pass but

  cmp_deeply({a => 1, b => 2}, superhashof({a => 1, c => 3}))

will fail.

=head3 subhashof

  cmp_deeply( \%got, subhashof(\%hash) );

This will check that the hash C<%$got> is a "sub-hash" of C<%hash>. That is
that all the key and value pairs in C<%$got> also appear in C<%hash>.

For example

  cmp_deeply({a => 1}, subhashof({a => 1, b => 2}))

will pass but

  cmp_deeply({a => 1, c => 3}, subhashof({a => 1, b => 2}))

will fail.

=head1 DIAGNOSTIC FUNCTIONS

=head3 deep_diag

  my $reason = deep_diag($stack);

C<$stack> is a value returned by cmp_details.  Do not call this function
if cmp_details returned a true value for C<$ok>.

C<deep_diag()> returns a human readable string describing how the
comparison failed.

=head1 ANOTHER EXAMPLE

You've written a module to handle people and their film interests. Say you
have a function that returns an array of people from a query, each person is
a hash with 2 keys: Name and Age and the array is sorted by Name. You can do

  cmp_deeply(
    $result,
    [
      {Name => 'Anne', Age => 26},
      {Name => "Bill", Age => 47}
      {Name => 'John', Age => 25},
    ]
  );

Soon after, your query function changes and all the results now have an ID
field. Now your test is failing again because you left out ID from each of
the hashes. The problem is that the IDs are generated by the database and
you have no way of knowing what each person's ID is. With Test::Deep you can
change your query to

  cmp_deeply(
    $result,
    [
      {Name => 'John', Age => 25, ID => ignore()},
      {Name => 'Anne', Age => 26, ID => ignore()},
      {Name => "Bill", Age => 47, ID => ignore()}
    ]
  );

But your test still fails. Now, because you're using a database, you no
longer know what order the people will appear in. You could add a sort into
the database query but that could slow down your application. Instead you
can get Test::Deep to ignore the order of the array by doing a bag
comparison instead.

  cmp_deeply(
    $result,
    bag(
      {Name => 'John', Age => 25, ID => ignore()},
      {Name => 'Anne', Age => 26, ID => ignore()},
      {Name => "Bill", Age => 47, ID => ignore()}
    )
  );

Finally person gets even more complicated and includes a new field called
Movies, this is a list of movies that the person has seen recently, again
these movies could also come back in any order so we need a bag inside our
other bag comparison, giving us something like

  cmp_deeply(
  $result,
    bag(
      {Name => 'John', Age => 25, ID => ignore(), Movies => bag(...)},
      {Name => 'Anne', Age => 26, ID => ignore(), Movies => bag(...)},
      {Name => "Bill", Age => 47, ID => ignore(), Movies => bag(...)}
    )
  );

=head1 USING TEST::DEEP WITH TEST::BUILDER

Combining C<cmp_details> and C<deep_diag> makes it possible to use
Test::Deep in your own test classes.

In a L<Test::Builder> subclass, create a test method in the following
form:

  sub behaves_ok {
    my $self = shift;
    my $expected = shift;
    my $test_name = shift;

    my $got = do_the_important_work_here();

    my ($ok, $stack) = cmp_details($got, $expected);
    unless ($Test->ok($ok, $test_name)) {
      my $diag = deep_diag($stack);
      $Test->diag($diag);
    }
  }

As the subclass defines a test class, not tests themselves, make sure it
uses L<Test::Deep::NoTest>, not C<Test::Deep> itself.

=head1 LIMITATIONS

Currently any CODE, GLOB or IO refs will be compared using shallow(), which
means only their memory addresses are compared.

=head1 BUGS

There is a bug in set and bag compare to do with competing SCs. It only
occurs when you put certain special comparisons inside bag or set
comparisons you don't need to worry about it. The full details are in the
C<bag()> docs. It will be fixed in an upcoming version.

=head1 CAVEATS

=head2 SPECIAL CARE WITH SPECIAL COMPARISONS IN SETS AND BAGS

If you use certain special comparisons within a bag or set comparison there is
a danger that a test will fail when it should have passed. It can only happen
if two or more special comparisons in the bag are competing to match elements.
Consider this comparison

  cmp_deeply(['furry', 'furball'], bag(re("^fur"), re("furb")))

There are two things that could happen, hopefully C<re("^fur")> is paired with
"furry" and C<re("^furb")> is paired with "furb" and everything is fine but it
could happen that C<re("^fur")> is paired with "furball" and then C<re("^furb")>
cannot find a match and so the test fails. Examples of other competing
comparisons are C<bag(1, 2, 2)> vs C<set(1, 2)> and
C<< methods(m1 => "v1", m2 => "v2") >> vs C<< methods(m1 => "v1") >>

This problem is could be solved by using a slower and more complicated
algorithm for set and bag matching. Something for the future...

=head1 WHAT ARE SPECIAL COMPARISONS?

A special comparison (SC) is simply an object that inherits from
Test::Deep::Cmp. Whenever C<$expected_v> is an SC then instead of checking
C<$got_v eq $expected_v>, we pass control over to the SC and let it do its
thing.

Test::Deep exports lots of SC constructors, to make it easy for you to use
them in your test scripts. For example is C<re("hello")> is just a handy way
of creating a Test::Deep::Regexp object that will match any string containing
"hello". So

  cmp_deeply([ 'a', 'b', 'hello world'], ['a', 'b', re("^hello")]);

will check C<'a' eq 'a'>, C<'b' eq 'b'> but when it comes to comparing
C<'hello world'> and C<re("^hello")> it will see that
$expected_v is an SC and so will pass control to the Test::Deep::Regexp class
by do something like C<< $expected_v->descend($got_v) >>. The C<descend()>
method should just return true or false.

This gives you enough to write your own SCs but I haven't documented how
diagnostics works because it's about to get an overhaul (theoretically).

=head1 EXPORTS

By default, Test::Deep will export everything in its C<v0> tag, as if you had
written:

  use Test::Deep ':v0';

Those things are:

  all any array array_each arrayelementsonly arraylength arraylengthonly bag
  blessed bool cmp_bag cmp_deeply cmp_methods cmp_set code eq_deeply hash
  hash_each hashkeys hashkeysonly ignore Isa isa listmethods methods noclass
  none noneof num obj_isa re reftype regexpmatches regexponly regexpref
  regexprefonly scalarrefonly scalref set shallow str subbagof subhashof
  subsetof superbagof superhashof supersetof useclass

A slightly better set of exports is the C<v1> set.  It's all the same things,
with the exception of C<Isa> and C<blessed>.  If you want to import
"everything", you probably want to C<< use Test::Deep ':V1'; >>.

There's another magic export group:  C<:preload>.  If that is specified, all of
the Test::Deep plugins will be loaded immediately instead of lazily.

=head1 SEE ALSO

L<Test::More>

=head1 MAINTAINER

  Ricardo Signes <rjbs@cpan.org>

=head1 AUTHOR

Fergal Daly E<lt>fergal@esatclear.ieE<gt>, with thanks to Michael G Schwern
for Test::More's is_deeply function which inspired this.

B<Please> do not bother Fergal Daly with bug reports.  Send them to the
maintainer (above) or submit them at L<the issue
tracker|https://github.com/rjbs/Test-Deep/issues>.

=head1 COPYRIGHT

Copyright 2003, 2004 by Fergal Daly E<lt>fergal@esatclear.ieE<gt>.

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

See F<http://www.perl.com/perl/misc/Artistic.html>

=cut
PK       ! �Ի    "  perl5/Test/Tester/CaptureRunner.pmnu ��6�$        # $Header: /home/fergal/my/cvs/Test-Tester/lib/Test/Tester/CaptureRunner.pm,v 1.3 2003/03/05 01:07:55 fergal Exp $
use strict;

package Test::Tester::CaptureRunner;

our $VERSION = '1.302183';


use Test::Tester::Capture;
require Exporter;

sub new
{
	my $pkg = shift;
	my $self = bless {}, $pkg;
	return $self;
}

sub run_tests
{
	my $self = shift;

	my $test = shift;

	capture()->reset;

	$self->{StartLevel} = $Test::Builder::Level;
	&$test();
}

sub get_results
{
	my $self = shift;
	my @results = capture()->details;

	my $start = $self->{StartLevel};
	foreach my $res (@results)
	{
		next if defined $res->{depth};
		my $depth = $res->{_depth} - $res->{_level} - $start - 3;
#		print "my $depth = $res->{_depth} - $res->{_level} - $start - 1\n";
		$res->{depth} = $depth;
	}

	return @results;
}

sub get_premature
{
	return capture()->premature;
}

sub capture
{
	return Test::Tester::Capture->new;
}

__END__

=head1 NAME

Test::Tester::CaptureRunner - Help testing test modules built with Test::Builder

=head1 DESCRIPTION

This stuff if needed to allow me to play with other ways of monitoring the
test results.

=head1 AUTHOR

Copyright 2003 by Fergal Daly <fergal@esatclear.ie>.

=head1 LICENSE

Under the same license as Perl itself

See http://www.perl.com/perl/misc/Artistic.html

=cut
PK       ! ���>H  H    perl5/Test/Tester/Capture.pmnu ��6�$        use strict;

package Test::Tester::Capture;

our $VERSION = '1.302183';


use Test::Builder;

use vars qw( @ISA );
@ISA = qw( Test::Builder );

# Make Test::Tester::Capture thread-safe for ithreads.
BEGIN {
	use Config;
	*share = sub { 0 };
	*lock  = sub { 0 };
}

my $Curr_Test = 0;      share($Curr_Test);
my @Test_Results = ();  share(@Test_Results);
my $Prem_Diag = {diag => ""};	 share($Curr_Test);

sub new
{
  # Test::Tester::Capgture::new used to just return __PACKAGE__
  # because Test::Builder::new enforced its singleton nature by
  # return __PACKAGE__. That has since changed, Test::Builder::new now
  # returns a blessed has and around version 0.78, Test::Builder::todo
  # started wanting to modify $self. To cope with this, we now return
  # a blessed hash. This is a short-term hack, the correct thing to do
  # is to detect which style of Test::Builder we're dealing with and
  # act appropriately.

  my $class = shift;
  return bless {}, $class;
}

sub ok {
	my($self, $test, $name) = @_;

	my $ctx = $self->ctx;

	# $test might contain an object which we don't want to accidentally
	# store, so we turn it into a boolean.
	$test = $test ? 1 : 0;

	lock $Curr_Test;
	$Curr_Test++;

	my($pack, $file, $line) = $self->caller;

	my $todo = $self->todo();

	my $result = {};
	share($result);

	unless( $test ) {
		@$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
	}
	else {
		@$result{ 'ok', 'actual_ok' } = ( 1, $test );
	}

	if( defined $name ) {
		$name =~ s|#|\\#|g;	 # # in a name can confuse Test::Harness.
		$result->{name} = $name;
	}
	else {
		$result->{name} = '';
	}

	if( $todo ) {
		my $what_todo = $todo;
		$result->{reason} = $what_todo;
		$result->{type}   = 'todo';
	}
	else {
		$result->{reason} = '';
		$result->{type}   = '';
	}

	$Test_Results[$Curr_Test-1] = $result;

	unless( $test ) {
		my $msg = $todo ? "Failed (TODO)" : "Failed";
		$result->{fail_diag} = ("	$msg test ($file at line $line)\n");
	} 

	$result->{diag} = "";
	$result->{_level} = $Test::Builder::Level;
	$result->{_depth} = Test::Tester::find_run_tests();

	$ctx->release;

	return $test ? 1 : 0;
}

sub skip {
	my($self, $why) = @_;
	$why ||= '';

	my $ctx = $self->ctx;

	lock($Curr_Test);
	$Curr_Test++;

	my %result;
	share(%result);
	%result = (
		'ok'	  => 1,
		actual_ok => 1,
		name	  => '',
		type	  => 'skip',
		reason	=> $why,
		diag    => "",
		_level   => $Test::Builder::Level,
		_depth => Test::Tester::find_run_tests(),
	);
	$Test_Results[$Curr_Test-1] = \%result;

	$ctx->release;
	return 1;
}

sub todo_skip {
	my($self, $why) = @_;
	$why ||= '';

	my $ctx = $self->ctx;

	lock($Curr_Test);
	$Curr_Test++;

	my %result;
	share(%result);
	%result = (
		'ok'	  => 1,
		actual_ok => 0,
		name	  => '',
		type	  => 'todo_skip',
		reason	=> $why,
		diag    => "",
		_level   => $Test::Builder::Level,
		_depth => Test::Tester::find_run_tests(),
	);

	$Test_Results[$Curr_Test-1] = \%result;

	$ctx->release;
	return 1;
}

sub diag {
	my($self, @msgs) = @_;
	return unless @msgs;

	# Prevent printing headers when compiling (i.e. -c)
	return if $^C;

	my $ctx = $self->ctx;

	# Escape each line with a #.
	foreach (@msgs) {
		$_ = 'undef' unless defined;
	}

	push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/;

	my $result = $Curr_Test ? $Test_Results[$Curr_Test - 1] : $Prem_Diag;

	$result->{diag} .= join("", @msgs);

	$ctx->release;
	return 0;
}

sub details {
	return @Test_Results;
}


# Stub. Feel free to send me a patch to implement this.
sub note {
}

sub explain {
	return Test::Builder::explain(@_);
}

sub premature
{
	return $Prem_Diag->{diag};
}

sub current_test
{
	if (@_ > 1)
	{
		die "Don't try to change the test number!";
	}
	else
	{
		return $Curr_Test;
	}
}

sub reset
{
	$Curr_Test = 0;
	@Test_Results = ();
	$Prem_Diag = {diag => ""};
}

1;

__END__

=head1 NAME

Test::Tester::Capture - Help testing test modules built with Test::Builder

=head1 DESCRIPTION

This is a subclass of Test::Builder that overrides many of the methods so
that they don't output anything. It also keeps track of its own set of test
results so that you can use Test::Builder based modules to perform tests on
other Test::Builder based modules.

=head1 AUTHOR

Most of the code here was lifted straight from Test::Builder and then had
chunks removed by Fergal Daly <fergal@esatclear.ie>.

=head1 LICENSE

Under the same license as Perl itself

See http://www.perl.com/perl/misc/Artistic.html

=cut
PK       ! ��uY;  ;    perl5/Test/Tester/Delegate.pmnu ��6�$        use strict;
use warnings;

package Test::Tester::Delegate;

our $VERSION = '1.302183';

use Scalar::Util();

use vars '$AUTOLOAD';

sub new
{
	my $pkg = shift;

	my $obj = shift;
	my $self = bless {}, $pkg;

	return $self;
}

sub AUTOLOAD
{
	my ($sub) = $AUTOLOAD =~ /.*::(.*?)$/;

	return if $sub eq "DESTROY";

	my $obj = $_[0]->{Object};

	my $ref = $obj->can($sub);
	shift(@_);
	unshift(@_, $obj);
	goto &$ref;
}

sub can {
	my $this = shift;
	my ($sub) = @_;

	return $this->{Object}->can($sub) if Scalar::Util::blessed($this);

	return $this->SUPER::can(@_);
}

1;
PK       ! ���\  \    perl5/Test/Simple.pmnu ��6�$        package Test::Simple;

use 5.006;

use strict;

our $VERSION = '1.302183';

use Test::Builder::Module;
our @ISA    = qw(Test::Builder::Module);
our @EXPORT = qw(ok);

my $CLASS = __PACKAGE__;

=head1 NAME

Test::Simple - Basic utilities for writing tests.

=head1 SYNOPSIS

  use Test::Simple tests => 1;

  ok( $foo eq $bar, 'foo is bar' );


=head1 DESCRIPTION

** If you are unfamiliar with testing B<read L<Test::Tutorial> first!> **

This is an extremely simple, extremely basic module for writing tests
suitable for CPAN modules and other pursuits.  If you wish to do more
complicated testing, use the Test::More module (a drop-in replacement
for this one).

The basic unit of Perl testing is the ok.  For each thing you want to
test your program will print out an "ok" or "not ok" to indicate pass
or fail.  You do this with the C<ok()> function (see below).

The only other constraint is you must pre-declare how many tests you
plan to run.  This is in case something goes horribly wrong during the
test and your test program aborts, or skips a test or whatever.  You
do this like so:

    use Test::Simple tests => 23;

You must have a plan.


=over 4

=item B<ok>

  ok( $foo eq $bar, $name );
  ok( $foo eq $bar );

C<ok()> is given an expression (in this case C<$foo eq $bar>).  If it's
true, the test passed.  If it's false, it didn't.  That's about it.

C<ok()> prints out either "ok" or "not ok" along with a test number (it
keeps track of that for you).

  # This produces "ok 1 - Hell not yet frozen over" (or not ok)
  ok( get_temperature($hell) > 0, 'Hell not yet frozen over' );

If you provide a $name, that will be printed along with the "ok/not
ok" to make it easier to find your test when if fails (just search for
the name).  It also makes it easier for the next guy to understand
what your test is for.  It's highly recommended you use test names.

All tests are run in scalar context.  So this:

    ok( @stuff, 'I have some stuff' );

will do what you mean (fail if stuff is empty)

=cut

sub ok ($;$) {    ## no critic (Subroutines::ProhibitSubroutinePrototypes)
    return $CLASS->builder->ok(@_);
}

=back

Test::Simple will start by printing number of tests run in the form
"1..M" (so "1..5" means you're going to run 5 tests).  This strange
format lets L<Test::Harness> know how many tests you plan on running in
case something goes horribly wrong.

If all your tests passed, Test::Simple will exit with zero (which is
normal).  If anything failed it will exit with how many failed.  If
you run less (or more) tests than you planned, the missing (or extras)
will be considered failures.  If no tests were ever run Test::Simple
will throw a warning and exit with 255.  If the test died, even after
having successfully completed all its tests, it will still be
considered a failure and will exit with 255.

So the exit codes are...

    0                   all tests successful
    255                 test died or all passed but wrong # of tests run
    any other number    how many failed (including missing or extras)

If you fail more than 254 tests, it will be reported as 254.

This module is by no means trying to be a complete testing system.
It's just to get you started.  Once you're off the ground its
recommended you look at L<Test::More>.


=head1 EXAMPLE

Here's an example of a simple .t file for the fictional Film module.

    use Test::Simple tests => 5;

    use Film;  # What you're testing.

    my $btaste = Film->new({ Title    => 'Bad Taste',
                             Director => 'Peter Jackson',
                             Rating   => 'R',
                             NumExplodingSheep => 1
                           });
    ok( defined($btaste) && ref $btaste eq 'Film',     'new() works' );

    ok( $btaste->Title      eq 'Bad Taste',     'Title() get'    );
    ok( $btaste->Director   eq 'Peter Jackson', 'Director() get' );
    ok( $btaste->Rating     eq 'R',             'Rating() get'   );
    ok( $btaste->NumExplodingSheep == 1,        'NumExplodingSheep() get' );

It will produce output like this:

    1..5
    ok 1 - new() works
    ok 2 - Title() get
    ok 3 - Director() get
    not ok 4 - Rating() get
    #   Failed test 'Rating() get'
    #   in t/film.t at line 14.
    ok 5 - NumExplodingSheep() get
    # Looks like you failed 1 tests of 5

Indicating the Film::Rating() method is broken.


=head1 CAVEATS

Test::Simple will only report a maximum of 254 failures in its exit
code.  If this is a problem, you probably have a huge test script.
Split it into multiple files.  (Otherwise blame the Unix folks for
using an unsigned short integer as the exit status).

Because VMS's exit codes are much, much different than the rest of the
universe, and perl does horrible mangling to them that gets in my way,
it works like this on VMS.

    0     SS$_NORMAL        all tests successful
    4     SS$_ABORT         something went wrong

Unfortunately, I can't differentiate any further.


=head1 NOTES

Test::Simple is B<explicitly> tested all the way back to perl 5.6.0.

Test::Simple is thread-safe in perl 5.8.1 and up.

=head1 HISTORY

This module was conceived while talking with Tony Bowden in his
kitchen one night about the problems I was having writing some really
complicated feature into the new Testing module.  He observed that the
main problem is not dealing with these edge cases but that people hate
to write tests B<at all>.  What was needed was a dead simple module
that took all the hard work out of testing and was really, really easy
to learn.  Paul Johnson simultaneously had this idea (unfortunately,
he wasn't in Tony's kitchen).  This is it.


=head1 SEE ALSO

=over 4

=item L<Test::More>

More testing functions!  Once you outgrow Test::Simple, look at
L<Test::More>.  Test::Simple is 100% forward compatible with L<Test::More>
(i.e. you can just use L<Test::More> instead of Test::Simple in your
programs and things will still work).

=back

Look in L<Test::More>'s SEE ALSO for more testing modules.


=head1 AUTHORS

Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.

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

See F<http://www.perl.com/perl/misc/Artistic.html>

=cut

1;
PK       ! O����)  �)    perl5/Test/utf8.pmnu ��6�$        package Test::utf8;

use 5.007003;

use strict;
use warnings;

use base qw(Exporter);

use Encode;
use charnames ':full';

our $VERSION = "1.02";

our @EXPORT = qw(
  is_valid_string is_dodgy_utf8 is_sane_utf8
  is_within_ascii is_within_latin1 is_within_latin_1
  is_flagged_utf8 isnt_flagged_utf8
);

# A Regexp string to match valid UTF8 bytes
# this info comes from page 78 of "The Unicode Standard 4.0"
# published by the Unicode Consortium
our $valid_utf8_regexp = <<'REGEX' ;
        [\x{00}-\x{7f}]
      | [\x{c2}-\x{df}][\x{80}-\x{bf}]
      |         \x{e0} [\x{a0}-\x{bf}][\x{80}-\x{bf}]
      | [\x{e1}-\x{ec}][\x{80}-\x{bf}][\x{80}-\x{bf}]
      |         \x{ed} [\x{80}-\x{9f}][\x{80}-\x{bf}]
      | [\x{ee}-\x{ef}][\x{80}-\x{bf}][\x{80}-\x{bf}]
      |         \x{f0} [\x{90}-\x{bf}][\x{80}-\x{bf}]
      | [\x{f1}-\x{f3}][\x{80}-\x{bf}][\x{80}-\x{bf}][\x{80}-\x{bf}]
      |         \x{f4} [\x{80}-\x{8f}][\x{80}-\x{bf}][\x{80}-\x{bf}]
REGEX

=head1 NAME

Test::utf8 - handy utf8 tests

=head1 SYNOPSIS

  # check the string is good
  is_valid_string($string);   # check the string is valid
  is_sane_utf8($string);      # check not double encoded

  # check the string has certain attributes
  is_flagged_utf8($string1);   # has utf8 flag set
  is_within_ascii($string2);   # only has ascii chars in it
  isnt_within_ascii($string3); # has chars outside the ascii range
  is_within_latin_1($string4); # only has latin-1 chars in it
  isnt_within_ascii($string5); # has chars outside the latin-1 range

=head1 DESCRIPTION

This module is a collection of tests useful for dealing with utf8 strings in
Perl.

This module has two types of tests: The validity tests check if a string is
valid and not corrupt, whereas the characteristics tests will check that string
has a given set of characteristics.

=head2 Validity Tests

=over

=item is_valid_string($string, $testname)

Checks if the string is "valid", i.e. this passes and returns true unless
the internal utf8 flag hasn't been set on scalar that isn't made up of a valid
utf-8 byte sequence.

This should I<never> happen and, in theory, this test should always pass. Unless
you (or a module you use) goes monkeying around inside a scalar using Encode's
private functions or XS code you shouldn't ever end up in a situation where
you've got a corrupt scalar.  But if you do, and you do, then this function
should help you detect the problem.

To be clear, here's an example of the error case this can detect:

  my $mark = "Mark";
  my $leon = "L\x{e9}on";
  is_valid_string($mark);  # passes, not utf-8
  is_valid_string($leon);  # passes, not utf-8

  my $iloveny = "I \x{2665} NY";
  is_valid_string($iloveny);      # passes, proper utf-8

  my $acme = "L\x{c3}\x{a9}on";
  Encode::_utf8_on($acme);      # (please don't do things like this)
  is_valid_string($acme);       # passes, proper utf-8 byte sequence upgraded

  Encode::_utf8_on($leon);      # (this is why you don't do things like this)
  is_valid_string($leon);       # fails! the byte \x{e9} isn't valid utf-8

=cut

sub is_valid_string($;$)
{
  my $string = shift;
  my $name = shift || "valid string test";

  # check we're a utf8 string - if not, we pass.
  unless (Encode::is_utf8($string))
    { return _pass($name) }

  # work out at what byte (if any) we have an invalid byte sequence
  # and return the correct test result
  my $pos = _invalid_sequence_at_byte($string);
  if (_ok(!defined($pos), $name)) { return 1 }
  _diag("malformed byte sequence starting at byte $pos");
  return;
}

sub _invalid_sequence_at_byte($)
{
  my $string = shift;

  # examine the bytes that make up the string (not the chars)
  # by turning off the utf8 flag (no, use bytes doesn't
  # work, we're dealing with a regexp)
  Encode::_utf8_off($string);  ## no critic (ProtectPrivateSubs)

  # work out the index of the first non matching byte
  my $result = $string =~ m/^($valid_utf8_regexp)*/ogx;

  # if we matched all the string return the empty list
  my $pos = pos $string || 0;
  return if $pos == length($string);

  # otherwise return the position we found
  return $pos
}

=item is_sane_utf8($string, $name)

This test fails if the string contains something that looks like it
might be dodgy utf8, i.e. containing something that looks like the
multi-byte sequence for a latin-1 character but perl hasn't been
instructed to treat as such.  Strings that are not utf8 always
automatically pass.

Some examples may help:

  # This will pass as it's a normal latin-1 string
  is_sane_utf8("Hello L\x{e9}eon");

  # this will fail because the \x{c3}\x{a9} looks like the
  # utf8 byte sequence for e-acute
  my $string = "Hello L\x{c3}\x{a9}on";
  is_sane_utf8($string);

  # this will pass because the utf8 is correctly interpreted as utf8
  Encode::_utf8_on($string)
  is_sane_utf8($string);

Obviously this isn't a hundred percent reliable.  The edge case where
this will fail is where you have C<\x{c2}> (which is "LATIN CAPITAL
LETTER WITH CIRCUMFLEX") or C<\x{c3}> (which is "LATIN CAPITAL LETTER
WITH TILDE") followed by one of the latin-1 punctuation symbols.

  # a capital letter A with tilde surrounded by smart quotes
  # this will fail because it'll see the "\x{c2}\x{94}" and think
  # it's actually the utf8 sequence for the end smart quote
  is_sane_utf8("\x{93}\x{c2}\x{94}");

However, since this hardly comes up this test is reasonably reliable
in most cases.  Still, care should be applied in cases where dynamic
data is placed next to latin-1 punctuation to avoid false negatives.

There exists two situations to cause this test to fail; The string
contains utf8 byte sequences and the string hasn't been flagged as
utf8 (this normally means that you got it from an external source like
a C library; When Perl needs to store a string internally as utf8 it
does it's own encoding and flagging transparently) or a utf8 flagged
string contains byte sequences that when translated to characters
themselves look like a utf8 byte sequence.  The test diagnostics tells
you which is the case.

=cut

# build my regular expression out of the latin-1 bytes
# NOTE: This won't work if our locale is nonstandard will it?
my $re_bit = join "|", map { Encode::encode("utf8",chr($_)) } (127..255);

sub is_sane_utf8($;$)
{
  my $string = shift;
  my $name   = shift || "sane utf8";

  # regexp in scalar context with 'g', meaning this loop will run for
  # each match.  Should only have to run it once, but will redo if
  # the failing case turns out to be allowed in %allowed.
  while ($string =~ /($re_bit)/o)
  {
    # work out what the double encoded string was
    my $bytes = $1;

    my $index = $+[0] - length($bytes);
    my $codes = join '', map { sprintf '<%00x>', ord($_) } split //, $bytes;

    # what character does that represent?
    my $char = Encode::decode("utf8",$bytes);
    my $ord  = ord($char);
    my $hex  = sprintf '%00x', $ord;
    $char = charnames::viacode($ord);

    # print out diagnostic messages
    _fail($name);
    _diag(qq{Found dodgy chars "$codes" at char $index\n});
    if (Encode::is_utf8($string))
      { _diag("Chars in utf8 string look like utf8 byte sequence.") }
    else
      { _diag("String not flagged as utf8...was it meant to be?\n") }
    _diag("Probably originally a $char char - codepoint $ord (dec),"
         ." $hex (hex)\n");

    return 0;
  }

  # got this far, must have passed.
  _ok(1,$name);
  return 1;
}

# historic name of method; deprecated
sub is_dodgy_utf8 { goto &is_sane_utf8 }

=back

=head2 String Characteristic Tests

These routines allow you to check the range of characters in a string.
Note that these routines are blind to the actual encoding perl
internally uses to store the characters, they just check if the
string contains only characters that can be represented in the named
encoding:

=over

=item is_within_ascii

Tests that a string only contains characters that are in the ASCII
character set.

=cut

sub is_within_ascii($;$)
{
  my $string = shift;
  my $name   = shift || "within ascii";

  # look for anything that isn't ascii or pass
  $string =~ /([^\x{00}-\x{7f}])/ or return _pass($name);

  # explain why we failed
  my $dec = ord($1);
  my $hex = sprintf '%02x', $dec;

  _fail($name);
  _diag("Char $+[0] not ASCII (it's $dec dec / $hex hex)");

  return 0;
}

=item is_within_latin_1

Tests that a string only contains characters that are in latin-1.

=cut

sub is_within_latin_1($;$)
{
  my $string = shift;
  my $name   = shift || "within latin-1";

  # look for anything that isn't ascii or pass
  $string =~ /([^\x{00}-\x{ff}])/ or return _pass($name);

  # explain why we failed
  my $dec = ord($1);
  my $hex = sprintf '%x', $dec;

  _fail($name);
  _diag("Char $+[0] not Latin-1 (it's $dec dec / $hex hex)");

  return 0;
}

sub is_within_latin1 { goto &is_within_latin_1 }

=back

Simply check if a scalar is or isn't flagged as utf8 by perl's
internals:

=over

=item is_flagged_utf8($string, $name)

Passes if the string is flagged by perl's internals as utf8, fails if
it's not.

=cut

sub is_flagged_utf8
{
  my $string = shift;
  my $name = shift || "flagged as utf8";
  return _ok(Encode::is_utf8($string),$name);
}

=item isnt_flagged_utf8($string,$name)

The opposite of C<is_flagged_utf8>, passes if and only if the string
isn't flagged as utf8 by perl's internals.

Note: you can refer to this function as C<isn't_flagged_utf8> if you
really want to.

=cut

sub isnt_flagged_utf8($;$)
{
  my $string = shift;
  my $name   = shift || "not flagged as utf8";
  return _ok(!Encode::is_utf8($string), $name);
}

sub isn::t_flagged_utf8($;$)
{
  my $string = shift;
  my $name   = shift || "not flagged as utf8";
  return _ok(!Encode::is_utf8($string), $name);
}

=back

=head1 AUTHOR

Written by Mark Fowler B<mark@twoshortplanks.com>

=head1 COPYRIGHT

Copyright Mark Fowler 2004,2012.  All rights reserved.

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

=head1 BUGS

None known.  Please report any to me via the CPAN RT system.  See
http://rt.cpan.org/ for more details.

=head1 SEE ALSO

L<Test::DoubleEncodedEntities> for testing for double encoded HTML
entities.

=cut

##########

# shortcuts for Test::Builder.

use Test::Builder;
my $tester = Test::Builder->new();

sub _ok
{
  local $Test::Builder::Level = $Test::Builder::Level + 1;
  return $tester->ok(@_)
}
sub _diag
{
  local $Test::Builder::Level = $Test::Builder::Level + 1;
  $tester->diag(@_);
  return;
}

sub _fail
{
  local $Test::Builder::Level = $Test::Builder::Level + 1;
  return _ok(0,@_)
}

sub _pass
{
  local $Test::Builder::Level = $Test::Builder::Level + 1;
  return _ok(1,@_)
}


1;
PK       ! (죸ќ  ќ    perl5/Test/File.pmnu ��6�$        package Test::File;
use strict;

use base qw(Exporter);
use vars qw(@EXPORT $VERSION);

use File::Spec;
use Test::Builder;

@EXPORT = qw(
	file_exists_ok file_not_exists_ok
	file_empty_ok file_not_empty_ok file_size_ok file_max_size_ok
	file_min_size_ok file_readable_ok file_not_readable_ok file_writeable_ok
	file_not_writeable_ok file_executable_ok file_not_executable_ok
	file_mode_is file_mode_isnt
	file_mode_has file_mode_hasnt
	file_is_symlink_ok
	symlink_target_exists_ok symlink_target_is
	symlink_target_dangles_ok
	dir_exists_ok dir_contains_ok
	link_count_is_ok link_count_gt_ok link_count_lt_ok
	owner_is owner_isnt
	group_is group_isnt
	file_line_count_is file_line_count_isnt file_line_count_between
	file_contains_like file_contains_unlike
	file_contains_utf8_like file_contains_utf8_unlike
	file_contains_encoded_like file_contains_encoded_unlike
	file_mtime_gt_ok file_mtime_lt_ok file_mtime_age_ok
	);

$VERSION = '1.443';

{
use warnings;
}

my $Test = Test::Builder->new();

=encoding utf8

=head1 NAME

Test::File -- test file attributes

=head1 SYNOPSIS

  use Test::File;

=head1 DESCRIPTION

This modules provides a collection of test utilities for file
attributes.

Some file attributes depend on the owner of the process testing the
file in the same way the file test operators do.  For instance, root
(or super-user or Administrator) may always be able to read files no
matter the permissions.

Some attributes don't make sense outside of Unix, either, so some
tests automatically skip if they think they won't work on the
platform.  If you have a way to make these functions work on Windows,
for instance, please send me a patch. :) IF you want to pretend to be
Windows on a non-Windows machine (for instance, to test C<skip()>),
you can set the C<PRETEND_TO_BE_WINDOWS> environment variable.

The optional NAME parameter for every function allows you to specify a
name for the test.  If not supplied, a reasonable default will be
generated.

=head2 Functions

=cut

sub _normalize
	{
	my $file = shift;
	return unless defined $file;

	return $file =~ m|/|
		? File::Spec->catfile( split m|/|, $file )
		: $file;
	}

sub _win32
	{
	return 0 if $^O eq 'darwin';
	return $ENV{PRETEND_TO_BE_WIN32} if defined $ENV{PRETEND_TO_BE_WIN32};
	return $^O =~ m/Win/;
	}

# returns true if symlinks can't exist
sub _no_symlinks_here { ! eval { symlink("",""); 1 } }

# owner_is and owner_isn't should skip on OS where the question makes no
# sense.  I really don't know a good way to test for that, so I'm going
# to skip on the two OS's that I KNOW aren't multi-user.  I'd love to add
# more if anyone knows of any
#   Note:  I don't have a dos or mac os < 10 machine to test this on
sub _obviously_non_multi_user
	{
	foreach my $os ( qw(dos MacOS) ) { return 1 if $^O eq $os }

	return 0 if $^O eq 'MSWin32';

	eval { my $holder = getpwuid(0) };
	return 1 if $@;

	eval { my $holder = getgrgid(0) };
	return 1 if $@;

	return 0;
	}

=over 4

=item file_exists_ok( FILENAME [, NAME ] )

Ok if the file exists, and not ok otherwise.

=cut

sub file_exists_ok
	{
	my $filename = _normalize( shift );
	my $name     = shift || "$filename exists";

	my $ok = -e $filename;

	if( $ok )
		{
		$Test->ok(1, $name);
		}
	else
		{
		$Test->diag("File [$filename] does not exist");
		$Test->ok(0, $name);
		}
	}

=item file_not_exists_ok( FILENAME [, NAME ] )

Ok if the file does not exist, and not okay if it does exist.

=cut

sub file_not_exists_ok
	{
	my $filename = _normalize( shift );
	my $name     = shift || "$filename does not exist";

	my $ok = not -e $filename;

	if( $ok )
		{
		$Test->ok(1, $name);
		}
	else
		{
		$Test->diag("File [$filename] exists");
		$Test->ok(0, $name);
		}
	}

=item file_empty_ok( FILENAME [, NAME ] )

Ok if the file exists and has empty size, not ok if the
file does not exist or exists with non-zero size.

=cut

sub file_empty_ok
	{
	my $filename = _normalize( shift );
	my $name     = shift || "$filename is empty";

	unless( -e $filename )
		{
		$Test->diag( "File [$filename] does not exist!" );
		return $Test->ok(0, $name);
		}

	my $ok = -z $filename;

	if( $ok )
		{
		$Test->ok(1, $name);
		}
	else
		{
		$Test->diag( "File [$filename] exists with non-zero size!" );
		$Test->ok(0, $name);
		}
	}

=item file_not_empty_ok( FILENAME [, NAME ] )

Ok if the file exists and has non-zero size, not ok if the
file does not exist or exists with zero size.

=cut

sub file_not_empty_ok
	{
	my $filename = _normalize( shift );
	my $name     = shift || "$filename is not empty";

	unless( -e $filename )
		{
		$Test->diag( "File [$filename] does not exist!" );
		return $Test->ok(0, $name);
		}

	my $ok = not -z _;

	if( $ok )
		{
		$Test->ok(1, $name);
		}
	else
		{
		$Test->diag( "File [$filename] exists with zero size!" );
		$Test->ok(0, $name);
		}
	}

=item file_size_ok( FILENAME, SIZE [, NAME ]  )

Ok if the file exists and has SIZE size in bytes (exactly), not ok if
the file does not exist or exists with size other than SIZE.

=cut

sub file_size_ok
	{
	my $filename = _normalize( shift );
	my $expected = int shift;
	my $name     = shift || "$filename has right size";

	unless( -e $filename )
		{
		$Test->diag( "File [$filename] does not exist!" );
		return $Test->ok(0, $name);
		}

	my $ok = ( -s $filename ) == $expected;

	if( $ok )
		{
		$Test->ok(1, $name);
		}
	else
		{
		my $actual = -s $filename;
		$Test->diag(
			"File [$filename] has actual size [$actual] not [$expected]!" );

		$Test->ok(0, $name);
		}
	}

=item file_max_size_ok( FILENAME, MAX [, NAME ] )

Ok if the file exists and has size less than or equal to MAX bytes, not
ok if the file does not exist or exists with size greater than MAX
bytes.

=cut

sub file_max_size_ok
	{
	my $filename = _normalize( shift );
	my $max      = int shift;
	my $name     = shift || "$filename is under $max bytes";

	unless( -e $filename )
		{
		$Test->diag( "File [$filename] does not exist!" );
		return $Test->ok(0, $name);
		}

	my $ok = ( -s $filename ) <= $max;

	if( $ok )
		{
		$Test->ok(1, $name);
		}
	else
		{
		my $actual = -s $filename;
		$Test->diag(
			"File [$filename] has actual size [$actual] " .
			"greater than [$max]!"
			);

		$Test->ok(0, $name);
		}
	}

=item file_min_size_ok( FILENAME, MIN [, NAME ] )

Ok if the file exists and has size greater than or equal to MIN bytes,
not ok if the file does not exist or exists with size less than MIN
bytes.

=cut

sub file_min_size_ok
	{
	my $filename = _normalize( shift );
	my $min      = int shift;
	my $name     = shift || "$filename is over $min bytes";

	unless( -e $filename )
		{
		$Test->diag( "File [$filename] does not exist!" );
		return $Test->ok(0, $name);
		}

	my $ok = ( -s $filename ) >= $min;

	if( $ok )
		{
		$Test->ok(1, $name);
		}
	else
		{
		my $actual = -s $filename;
		$Test->diag(
			"File [$filename] has actual size ".
			"[$actual] less than [$min]!"
			);

		$Test->ok(0, $name);
		}
	}

=item file_line_count_is( FILENAME, COUNT [, NAME ]  )

Ok if the file exists and has COUNT lines (exactly), not ok if the
file does not exist or exists with a line count other than COUNT.

This function uses the current value of C<$/> as the line ending and
counts the lines by reading them and counting how many it read.

=cut

sub _ENOFILE   () { -1 }
sub _ECANTOPEN () { -2 }

sub _file_line_counter
	{
	my $filename = shift;

	return _ENOFILE   unless -e $filename;  # does not exist

	return _ECANTOPEN unless open my( $fh ), "<", $filename;

	my $count = 0;
	while( <$fh> ) { $count++ }

	return $count;
	}

# XXX: lots of cut and pasting here, needs refactoring
# looks like the refactoring might be worse than this though
sub file_line_count_is
	{
	my $filename = _normalize( shift );
	my $expected = shift;
	my $name     = do {
		no warnings 'uninitialized';
		shift || "$filename line count is $expected lines";
		};

	unless( defined $expected && int( $expected ) == $expected )
		{
		no warnings 'uninitialized';
		$Test->diag( "file_line_count_is expects a positive whole number for " .
			"the second argument. Got [$expected]!" );
		return $Test->ok( 0, $name );
		}

	my $got = _file_line_counter( $filename );

	if( $got eq _ENOFILE )
		{
		$Test->diag( "File [$filename] does not exist!" );
		$Test->ok( 0, $name );
		}
	elsif( $got == _ECANTOPEN )
		{
		$Test->diag( "Could not open [$filename]: \$! is [$!]!" );
		$Test->ok( 0, $name );
		}
	elsif( $got == $expected )
		{
		$Test->ok( 1, $name );
		}
	else
		{
		$Test->diag( "Expected [$expected] lines in [$filename], " .
			"got [$got] lines!" );
		$Test->ok( 0, $name );
		}

	}

=item file_line_count_isnt( FILENAME, COUNT [, NAME ]  )

Ok if the file exists and doesn't have exactly COUNT lines, not ok if the
file does not exist or exists with a line count of COUNT. Read that
carefully: the file must exist for this test to pass!

This function uses the current value of C<$/> as the line ending and
counts the lines by reading them and counting how many it read.

=cut

sub file_line_count_isnt
	{
	my $filename = _normalize( shift );
	my $expected = shift;
	my $name     = do {
		no warnings 'uninitialized';
		shift || "$filename line count is not $expected lines";
		};

	unless( defined $expected && int( $expected ) == $expected )
		{
		no warnings 'uninitialized';
		$Test->diag( "file_line_count_is expects a positive whole number for " .
			"the second argument. Got [$expected]!" );
		return $Test->ok( 0, $name );
		}

	my $got = _file_line_counter( $filename );

	if( $got eq _ENOFILE )
		{
		$Test->diag( "File [$filename] does not exist!" );
		$Test->ok( 0, $name );
		}
	elsif( $got == _ECANTOPEN )
		{
		$Test->diag( "Could not open [$filename]: \$! is [$!]!" );
		$Test->ok( 0, $name );
		}
	elsif( $got != $expected )
		{
		$Test->ok( 1, $name );
		}
	else
		{
		$Test->diag( "Expected something other than [$expected] lines in [$filename], " .
			"but got [$got] lines!" );
		$Test->ok( 0, $name );
		}

	}

=item file_line_count_between( FILENAME, MIN, MAX, [, NAME ]  )

Ok if the file exists and has a line count between MIN and MAX, inclusively.

This function uses the current value of C<$/> as the line ending and
counts the lines by reading them and counting how many it read.

=cut

sub file_line_count_between
	{
	my $filename = _normalize( shift );
	my $min      = shift;
	my $max      = shift;

	my $name = do {
		no warnings 'uninitialized';
		shift || "$filename line count is between [$min] and [$max] lines";
		};

	foreach my $ref ( \$min, \$max )
		{
		unless( defined $$ref && int( $$ref ) == $$ref )
			{
			no warnings 'uninitialized';
			$Test->diag( "file_line_count_between expects positive whole numbers for " .
				"the second and third arguments. Got [$min] and [$max]!" );
			return $Test->ok( 0, $name );
			}
		}


	my $got = _file_line_counter( $filename );

	if( $got eq _ENOFILE )
		{
		$Test->diag( "File [$filename] does not exist!" );
		$Test->ok( 0, $name );
		}
	elsif( $got == _ECANTOPEN )
		{
		$Test->diag( "Could not open [$filename]: \$! is [$!]!" );
		$Test->ok( 0, $name );
		}
	elsif( $min <= $got and $got <= $max )
		{
		$Test->ok( 1, $name );
		}
	else
		{
		$Test->diag( "Expected a line count between [$min] and [$max] " .
			"in [$filename], but got [$got] lines!"
			);
		$Test->ok( 0, $name );
		}

	}

=item file_contains_like ( FILENAME, PATTERN [, NAME ] )

Ok if the file exists and its contents (as one big string) match
PATTERN, not ok if the file does not exist, is not readable, or exists
but doesn't match PATTERN.

Since the file contents are read into memory, you should not use this
for large files.  Besides memory consumption, test diagnostics for
failing tests might be difficult to decipher.  However, for short
files this works very well.

Because the entire contents are treated as one large string, you can
make a pattern that tests multiple lines.  Don't forget that you may
need to use the /s modifier for such patterns:

	# make sure file has one or more paragraphs with CSS class X
	file_contains_like($html_file, qr{<p class="X">.*?</p>}s);

Contrariwise, if you need to match at the beginning or end of a line
inside the file, use the /m modifier:

	# make sure file has a setting for foo
	file_contains_like($config_file, qr/^ foo \s* = \s* \w+ $/mx);

If you want to test your file contents against multiple patterns, but
don't want to have the file read in repeatedly, you can pass an
arrayref of patterns instead of a single pattern, like so:

	# make sure our template has rendered correctly
	file_contains_like($template_out,
		[
		qr/^ $title_line $/mx,
		map { qr/^ $_ $/mx } @chapter_headings,
		qr/^ $footer_line $/mx,
		]);

Please note that if you do this, and your file does not exist or is
not readable, you'll only get one test failure instead of a failure
for each pattern.  This could cause your test plan to be off, although
you may not care at that point because your test failed anyway.  If
you do care, either skip the test plan altogether by employing
L<Test::More>'s C<done_testing()> function, or use
L</file_readable_ok> in conjunction with a C<SKIP> block.

Contributed by Buddy Burden C<< <barefoot@cpan.org> >>.

=item file_contains_unlike ( FILENAME, PATTERN [, NAME ] )

Ok if the file exists and its contents (as one big string) do B<not>
match PATTERN, not ok if the file does not exist, is not readable, or
exists but matches PATTERN.

All notes and caveats for L</file_contains_like> apply to this
function as well.

Contributed by Buddy Burden C<< <barefoot@cpan.org> >>.

=item file_contains_utf8_like ( FILENAME, PATTERN [, NAME ] )

The same as C<file_contains_like>, except the file is opened as UTF-8.

=item file_contains_utf8_unlike ( FILENAME, PATTERN [, NAME ] )

The same as C<file_contains_unlike>, except the file is opened as UTF-8.

=item file_contains_encoded_like ( FILENAME, ENCODING, PATTERN [, NAME ] )

The same as C<file_contains_like>, except the file is opened with ENCODING

=item file_contains_encoded_unlike ( FILENAME, ENCODING, PATTERN [, NAME ] )

The same as C<file_contains_unlike>, except the file is opened with ENCODING.

=cut

sub file_contains_like
	{
		local $Test::Builder::Level = $Test::Builder::Level + 1;
		_file_contains(like => "contains", undef, @_);
	}

sub file_contains_unlike
	{
		local $Test::Builder::Level = $Test::Builder::Level + 1;
		_file_contains(unlike => "doesn't contain", undef, @_);
	}

sub file_contains_utf8_like
	{
		local $Test::Builder::Level = $Test::Builder::Level + 1;
		_file_contains(like => "contains", 'UTF-8', @_);
	}
sub file_contains_utf8_unlike
	{
		local $Test::Builder::Level = $Test::Builder::Level + 1;
		_file_contains(unlike => "doesn't contain", 'UTF-8', @_);
	}

sub file_contains_encoded_like
	{
		local $Test::Builder::Level = $Test::Builder::Level + 1;
		my $filename = shift;
		my $encoding = shift;
		_file_contains(like => "contains", $encoding, $filename, @_);
	}
sub file_contains_encoded_unlike
	{
		local $Test::Builder::Level = $Test::Builder::Level + 1;
		my $filename = shift;
		my $encoding = shift;
		_file_contains(unlike => "doesn't contain", $encoding, $filename, @_);
	}

sub _file_contains
	{
	my $method   = shift;
	my $verb     = shift;
	my $encoding = shift;
	my $filename = _normalize( shift );
	my $patterns = shift;
	my $name     = shift;

	my (@patterns, %patterns);
	if (ref $patterns eq 'ARRAY')
		{
		@patterns = @$patterns;
		%patterns = map { $_ => $name || "$filename $verb $_" } @patterns;
		}
		else
		{
		@patterns = ($patterns);
		%patterns = ( $patterns => $name || "$filename $verb $patterns" );
		}

	# for purpose of checking the file's existence, just use the first
	# test name as the name
	$name = $patterns{$patterns[0]};

	unless( -e $filename )
		{
		$Test->diag( "File [$filename] does not exist!" );
		return $Test->ok(0, $name);
		}

	unless( -r $filename )
		{
		$Test->diag( "File [$filename] is not readable!" );
		return $Test->ok(0, $name);
		}

	# do the slurp
	my $file_contents;
	{
	unless (open(FH, $filename))
		{
		$Test->diag( "Could not open [$filename]: \$! is [$!]!" );
		return $Test->ok( 0, $name );
		}

	if (defined $encoding) {
		binmode FH, ":encoding($encoding)";
	}

	local $/ = undef;
	$file_contents = <FH>;
	close FH;
	}

	foreach my $p (@patterns)
		{
		$Test->$method($file_contents, $p, $patterns{$p});
		}
	}

=item file_readable_ok( FILENAME [, NAME ] )

Ok if the file exists and is readable, not ok
if the file does not exist or is not readable.

=cut

sub file_readable_ok
	{
	my $filename = _normalize( shift );
	my $name     = shift || "$filename is readable";

	my $ok = -r $filename;

	if( $ok )
		{
		$Test->ok(1, $name);
		}
	else
		{
		$Test->diag( "File [$filename] is not readable!" );
		$Test->ok(0, $name);
		}
	}

=item file_not_readable_ok( FILENAME [, NAME ] )

Ok if the file exists and is not readable, not ok
if the file does not exist or is readable.

=cut

sub file_not_readable_ok
	{
	my $filename = _normalize( shift );
	my $name     = shift || "$filename is not readable";

	my $ok = not -r $filename;

	if( $ok )
		{
		$Test->ok(1, $name);
		}
	else
		{
		$Test->diag( "File [$filename] is readable!" );
		$Test->ok(0, $name);
		}
	}

=item file_writeable_ok( FILENAME [, NAME ] )

Ok if the file exists and is writeable, not ok
if the file does not exist or is not writeable.

=cut

sub file_writeable_ok
	{
	my $filename = _normalize( shift );
	my $name     = shift || "$filename is writeable";

	my $ok = -w $filename;

	if( $ok )
		{
		$Test->ok(1, $name);
		}
	else
		{
		$Test->diag( "File [$filename] is not writeable!" );
		$Test->ok(0, $name);
		}
	}

=item file_not_writeable_ok( FILENAME [, NAME ] )

Ok if the file exists and is not writeable, not ok
if the file does not exist or is writeable.

=cut

sub file_not_writeable_ok
	{
	my $filename = _normalize( shift );
	my $name     = shift || "$filename is not writeable";

	my $ok = not -w $filename;

	if( $ok )
		{
		$Test->ok(1, $name);
		}
	else
		{
		$Test->diag("File [$filename] is writeable!");
		$Test->ok(0, $name);
		}
	}

=item file_executable_ok( FILENAME [, NAME ] )

Ok if the file exists and is executable, not ok
if the file does not exist or is not executable.

This test automatically skips if it thinks it is on a
Windows platform.

=cut

sub file_executable_ok
	{
	if( _win32() )
		{
		$Test->skip( "file_executable_ok doesn't work on Windows!" );
		return;
		}

	my $filename = _normalize( shift );
	my $name     = shift || "$filename is executable";

	my $ok = -x $filename;

	if( $ok )
		{
		$Test->ok(1, $name);
		}
	else
		{
		$Test->diag("File [$filename] is not executable!");
		$Test->ok(0, $name);
		}
	}

=item file_not_executable_ok( FILENAME [, NAME ] )

Ok if the file exists and is not executable, not ok
if the file does not exist or is executable.

This test automatically skips if it thinks it is on a
Windows platform.

=cut

sub file_not_executable_ok
	{
	if( _win32() )
		{
		$Test->skip( "file_not_executable_ok doesn't work on Windows!" );
		return;
		}

	my $filename = _normalize( shift );
	my $name     = shift || "$filename is not executable";

	my $ok = not -x $filename;

	if( $ok )
		{
		$Test->ok(1, $name);
		}
	else
		{
		$Test->diag("File [$filename] is executable!");
		$Test->ok(0, $name);
		}
	}

=item file_mode_is( FILENAME, MODE [, NAME ] )

Ok if the file exists and the mode matches, not ok
if the file does not exist or the mode does not match.

This test automatically skips if it thinks it is on a
Windows platform.

Contributed by Shawn Sorichetti C<< <ssoriche@coloredblocks.net> >>

=cut

sub file_mode_is
	{
	if( _win32() )
		{
		$Test->skip( "file_mode_is doesn't work on Windows!" );
		return;
		}

	my $filename = _normalize( shift );
	my $mode     = shift;

	my $name     = shift || sprintf("%s mode is %04o", $filename, $mode);

	my $ok = -e $filename && ((stat($filename))[2] & 07777) == $mode;

	if( $ok )
		{
		$Test->ok(1, $name);
		}
	else
		{
		$Test->diag(sprintf("File [%s] mode is not %04o!", $filename, $mode) );
		$Test->ok(0, $name);
		}
	}

=item file_mode_isnt( FILENAME, MODE [, NAME ] )

Ok if the file exists and mode does not match, not ok
if the file does not exist or mode does match.

This test automatically skips if it thinks it is on a
Windows platform.

Contributed by Shawn Sorichetti C<< <ssoriche@coloredblocks.net> >>

=cut

sub file_mode_isnt
	{
	if( _win32() )
		{
		$Test->skip( "file_mode_isnt doesn't work on Windows!" );
		return;
		}

	my $filename = _normalize( shift );
	my $mode     = shift;

	my $name     = shift || sprintf("%s mode is not %04o",$filename,$mode);

	my $ok = not (-e $filename && ((stat($filename))[2] & 07777) == $mode);

	if( $ok )
		{
		$Test->ok(1, $name);
		}
	else
		{
		$Test->diag(sprintf("File [%s] mode is %04o!",$filename,$mode));
		$Test->ok(0, $name);
		}
	}

=item file_mode_has( FILENAME, MODE [, NAME ] )

Ok if the file exists and has all the bits in mode turned on, not ok
if the file does not exist or the mode does not match.  That is,
C<< FILEMODE & MODE == MODE >> must be true.

This test automatically skips if it thinks it is on a
Windows platform.

Contributed by Ricardo Signes C<< <rjbs@cpan.org> >>

=cut

sub file_mode_has
	{
	if( _win32() )
		{
		$Test->skip( "file_mode_has doesn't work on Windows!" );
		return;
		}

	my $filename = _normalize( shift );
	my $mode     = shift;

	my $name     = shift || sprintf("%s mode has all bits of %04o", $filename, $mode);

	my $present = -e $filename;
	my $gotmode = $present ? (stat($filename))[2] : undef;
	my $ok      = $present && ($gotmode & $mode) == $mode;

	if( $ok )
		{
		$Test->ok(1, $name);
		}
	else
		{
		my $missing = ($gotmode ^ $mode) & $mode;
		$Test->diag(sprintf("File [%s] mode is missing component %04o!", $filename, $missing) );
		$Test->ok(0, $name);
		}
	}

=item file_mode_hasnt( FILENAME, MODE [, NAME ] )

Ok if the file exists and has all the bits in mode turned off, not ok
if the file does not exist or the mode does not match.  That is,
C<< FILEMODE & MODE == 0 >> must be true.

This test automatically skips if it thinks it is on a
Windows platform.

Contributed by Ricardo Signes C<< <rjbs@cpan.org> >>

=cut

sub file_mode_hasnt
	{
	if( _win32() )
		{
		$Test->skip( "file_mode_hasnt doesn't work on Windows!" );
		return;
		}

	my $filename = _normalize( shift );
	my $mode     = shift;

	my $name     = shift || sprintf("%s mode has no bits of %04o", $filename, $mode);

	my $present = -e $filename;
	my $gotmode = $present ? (stat($filename))[2] : undef;
	my $ok      = $present && ($gotmode & $mode) == 0;

	if( $ok )
		{
		$Test->ok(1, $name);
		}
	else
		{
		my $bad = $gotmode & $mode;
		$Test->diag(sprintf("File [%s] mode has forbidden component %04o!", $filename, $bad) );
		$Test->ok(0, $name);
		}
	}

=item file_is_symlink_ok( FILENAME [, NAME ] )

Ok if FILENAME is a symlink, even if it points to a non-existent
file. This test automatically skips if the operating system does
not support symlinks. If the file does not exist, the test fails.

=cut

sub file_is_symlink_ok
	{
	if( _no_symlinks_here() )
		{
		$Test->skip(
			"file_is_symlink_ok doesn't work on systems without symlinks!" );
		return;
		}

	my $file = shift;
	my $name = shift || "$file is a symlink";

	if( -l $file )
		{
		$Test->ok(1, $name)
		}
	else
		{
		$Test->diag( "File [$file] is not a symlink!" );
		$Test->ok(0, $name);
		}
	}

=item symlink_target_exists_ok( SYMLINK [, TARGET] [, NAME ] )

Ok if FILENAME is a symlink and it points to a existing file. With the
optional TARGET argument, the test fails if SYMLINK's target is not
TARGET. This test automatically skips if the operating system does not
support symlinks. If the file does not exist, the test fails.

=cut

sub symlink_target_exists_ok
	{
	if( _no_symlinks_here() )
		{
		$Test->skip(
			"symlink_target_exists_ok doesn't work on systems without symlinks!"
			);
		return;
		}

	my $file = shift;
	my $dest = shift || readlink( $file );
	my $name = shift || "$file is a symlink";

	unless( -l $file )
		{
		$Test->diag( "File [$file] is not a symlink!" );
		return $Test->ok( 0, $name );
		}

	unless( -e $dest )
		{
		$Test->diag( "Symlink [$file] points to non-existent target [$dest]!" );
		return $Test->ok( 0, $name );
		}

	my $actual = readlink( $file );
	unless( $dest eq $actual )
		{
		$Test->diag(
			"Symlink [$file] points to\n" .
			"         got: $actual\n" .
			"    expected: $dest\n"
			);
		return $Test->ok( 0, $name );
		}

	$Test->ok( 1, $name );
	}

=item symlink_target_dangles_ok( SYMLINK [, NAME ] )

Ok if FILENAME is a symlink and if it doesn't point to a existing
file. This test automatically skips if the operating system does not
support symlinks. If the file does not exist, the test fails.

=cut

sub symlink_target_dangles_ok
	{
	if( _no_symlinks_here() )
		{
		$Test->skip(
			"symlink_target_dangles_ok doesn't work on systems without symlinks!" );
		return;
		}

	my $file = shift;
	my $dest = readlink( $file );
	my $name = shift || "$file is a symlink";

	unless( -l $file )
		{
		$Test->diag( "File [$file] is not a symlink!" );
		return $Test->ok( 0, $name );
		}

	if( -e $dest )
		{
		$Test->diag(
			"Symlink [$file] points to existing file [$dest] but shouldn't!" );
		return $Test->ok( 0, $name );
		}

	$Test->ok( 1, $name );
	}

=item symlink_target_is( SYMLINK, TARGET [, NAME ] )

Ok if FILENAME is a symlink and if points to TARGET. This test
automatically skips if the operating system does not support symlinks.
If the file does not exist, the test fails.

=cut

sub symlink_target_is
	{
	if( _no_symlinks_here() )
		{
		$Test->skip(
			"symlink_target_is doesn't work on systems without symlinks!" );
		return;
		}

	my $file = shift;
	my $dest = shift;
	my $name = shift || "symlink $file points to $dest";

	unless( -l $file )
		{
		$Test->diag( "File [$file] is not a symlink!" );
		return $Test->ok( 0, $name );
		}

	my $actual_dest = readlink( $file );
	my $link_error  = $!;

	unless( defined $actual_dest )
		{
		$Test->diag( "Symlink [$file] does not have a defined target!" );
		$Test->diag( "readlink error: $link_error" ) if defined $link_error;
		return $Test->ok( 0, $name );
		}

	if( $dest eq $actual_dest )
		{
		$Test->ok( 1, $name );
		}
	else
		{
		$Test->ok( 0, $name );
		$Test->diag("       got: $actual_dest" );
		$Test->diag("  expected: $dest" );
		}
	}

=item symlink_target_is_absolute_ok( SYMLINK [, NAME ] )

Ok if FILENAME is a symlink and if its target is an absolute path.
This test automatically skips if the operating system does not support
symlinks. If the file does not exist, the test fails.

=cut

sub symlink_target_is_absolute_ok
	{
	if( _no_symlinks_here() )
		{
		$Test->skip(
			"symlink_target_exists_ok doesn't work on systems without symlinks" );
		return;
		}

	my( $from, $from_base, $to, $to_base, $name ) = @_;
	my $link     = readlink( $from );
	my $link_err = defined( $link ) ? '' : $!; # $! doesn't always get reset
	my $link_abs = abs_path( rel2abs($link, $from_base) );
	my $to_abs   = abs_path( rel2abs($to, $to_base) );

	if (defined( $link_abs ) && defined( $to_abs ) && $link_abs eq $to_abs) {
		$Test->ok( 1, $name );
		}
	else {
		$Test->ok( 0, $name );
		$link     ||= 'undefined';
		$link_abs ||= 'undefined';
		$to_abs   ||= 'undefined';

		$Test->diag("    link: $from");
		$Test->diag("     got: $link");
		$Test->diag("    (abs): $link_abs");
		$Test->diag("  expected: $to");
		$Test->diag("    (abs): $to_abs");
		$Test->diag("  readlink() error: $link_err") if ($link_err);
		}
	}

=item dir_exists_ok( DIRECTORYNAME [, NAME ] )

Ok if the file exists and is a directory, not ok if the file doesn't exist, or exists but isn't a
directory.

Contributed by Buddy Burden C<< <barefoot@cpan.org> >>.

=cut

sub dir_exists_ok
	{
	my $filename = _normalize( shift );
	my $name     = shift || "$filename is a directory";

	unless( -e $filename )
		{
		$Test->diag( "File [$filename] does not exist!" );
		return $Test->ok(0, $name);
		}

	my $ok = -d $filename;

	if( $ok )
		{
		$Test->ok(1, $name);
		}
	else
		{
		$Test->diag( "File [$filename] exists but is not a directory!" );
		$Test->ok(0, $name);
		}
	}

=item dir_contains_ok( DIRECTORYNAME, FILENAME [, NAME ] )

Ok if the directory exists and contains the file, not ok if the directory doesn't exist, or exists
but doesn't contain the file.

Contributed by Buddy Burden C<< <barefoot@cpan.org> >>.

=cut

sub dir_contains_ok
	{
	my $dirname  = _normalize( shift );
	my $filename = _normalize( shift );
	my $name     = shift || "directory $dirname contains file $filename";

	unless( -d $dirname )
		{
		$Test->diag( "Directory [$dirname] does not exist!" );
		return $Test->ok(0, $name);
		}

	my $ok = -e File::Spec->catfile($dirname, $filename);

	if( $ok )
		{
		$Test->ok(1, $name);
		}
	else
		{
		$Test->diag( "File [$filename] does not exist in directory $dirname!" );
		$Test->ok(0, $name);
		}
	}

=item link_count_is_ok( FILE, LINK_COUNT [, NAME ] )

Ok if the link count to FILE is LINK_COUNT. LINK_COUNT is interpreted
as an integer. A LINK_COUNT that evaluates to 0 returns Ok if the file
does not exist.


=cut

sub link_count_is_ok
	{
	my $file   = shift;
	my $count  = int( 0 + shift );

	my $name   = shift || "$file has a link count of [$count]";

	my $actual = ( stat $file )[3];

	unless( $actual == $count )
		{
		$Test->diag(
			"File [$file] points has [$actual] links: expected [$count]!" );
		return $Test->ok( 0, $name );
		}

	$Test->ok( 1, $name );
	}

=item link_count_gt_ok( FILE, LINK_COUNT [, NAME ] )

Ok if the link count to FILE is greater than LINK_COUNT. LINK_COUNT is
interpreted as an integer. A LINK_COUNT that evaluates to 0 returns Ok
if the file has at least one link.

=cut

sub link_count_gt_ok
	{
	my $file   = shift;
	my $count  = int( 0 + shift );

	my $name   = shift || "$file has a link count of [$count]";

	my $actual = (stat $file )[3];

	unless( $actual > $count )
		{
		$Test->diag(
			"File [$file] points has [$actual] links: ".
			"expected more than [$count]!" );
		return $Test->ok( 0, $name );
		}

	$Test->ok( 1, $name );
	}

=item link_count_lt_ok( FILE, LINK_COUNT [, NAME ] )

Ok if the link count to FILE is less than LINK_COUNT. LINK_COUNT is
interpreted as an integer. A LINK_COUNT that evaluates to 0 returns Ok
if the file has at least one link.

=cut

sub link_count_lt_ok
	{
	my $file   = shift;
	my $count  = int( 0 + shift );

	my $name   = shift || "$file has a link count of [$count]";

	my $actual = (stat $file )[3];

	unless( $actual < $count )
		{
		$Test->diag(
			"File [$file] points has [$actual] links: ".
			"expected less than [$count]!" );
		return $Test->ok( 0, $name );
		}

	$Test->ok( 1, $name );
	}


# owner_is, owner_isnt, group_is and group_isnt are almost
# identical in the beginning, so I'm writing a skeleton they can all use.
# I can't think of a better name...
sub _dm_skeleton
	{
	no warnings 'uninitialized';

	if( _obviously_non_multi_user() )
		{
		my $calling_sub = (caller(1))[3];
		$Test->skip( $calling_sub . " only works on a multi-user OS!" );
		return 'skip';
		}

	my $filename      = _normalize( shift );
	my $testing_for   = shift;
	my $name          = shift;

	unless( defined $filename )
		{
		$Test->diag( "File name not specified!" );
		return $Test->ok( 0, $name );
		}

	unless( -e $filename )
		{
		$Test->diag( "File [$filename] does not exist!" );
		return $Test->ok( 0, $name );
		}

	return;
	}

=item owner_is( FILE , OWNER [, NAME ] )

Ok if FILE's owner is the same as OWNER.  OWNER may be a text user name
or a numeric userid.  Test skips on Dos, and Mac OS <= 9.
If the file does not exist, the test fails.

Contributed by Dylan Martin

=cut

sub owner_is
	{
	my $filename      = shift;
	my $owner         = shift;
	my $name          = shift || "$filename belongs to $owner";

	my $err = _dm_skeleton( $filename, $owner, $name );
	return if( defined( $err ) && $err eq 'skip' );
	return $err if defined($err);

	my $owner_uid = _get_uid( $owner );
	unless( defined $owner_uid )
		{
		$Test->diag("User [$owner] does not exist on this system!");
		return $Test->ok( 0, $name );
		}

	my $file_uid = ( stat $filename )[4];

	unless( defined $file_uid )
		{
		$Test->skip("stat failed to return owner uid for $filename!");
		return;
		}

	return $Test->ok( 1, $name ) if $file_uid == $owner_uid;

	my $real_owner = ( getpwuid $file_uid )[0];
	unless( defined $real_owner )
		{
		$Test->diag("File does not belong to $owner!");
		return $Test->ok( 0, $name );
		}

	$Test->diag( "File [$filename] belongs to $real_owner ($file_uid), ".
			"not $owner ($owner_uid)!" );
	return $Test->ok( 0, $name );
	}

=item owner_isnt( FILE, OWNER [, NAME ] )

Ok if FILE's owner is not the same as OWNER.  OWNER may be a text user name
or a numeric userid.  Test skips on Dos and Mac OS <= 9.  If the file
does not exist, the test fails.

Contributed by Dylan Martin

=cut

sub owner_isnt
	{
	my $filename      = shift;
	my $owner         = shift;
	my $name          = shift || "$filename doesn't belong to $owner";

	my $err = _dm_skeleton( $filename, $owner, $name );
	return if( defined( $err ) && $err eq 'skip' );
	return $err if defined($err);

	my $owner_uid = _get_uid( $owner );
	unless( defined $owner_uid )
		{
		return $Test->ok( 1, $name );
		}

	my $file_uid  = ( stat $filename )[4];

	#$Test->diag( "owner_isnt: $owner_uid $file_uid" );
	return $Test->ok( 1, $name ) if $file_uid != $owner_uid;

	$Test->diag( "File [$filename] belongs to $owner ($owner_uid)!" );
	return $Test->ok( 0, $name );
	}

=item group_is( FILE , GROUP [, NAME ] )

Ok if FILE's group is the same as GROUP.  GROUP may be a text group name or
a numeric group id.  Test skips on Dos, Mac OS <= 9 and any other operating
systems that do not support getpwuid() and friends.  If the file does not
exist, the test fails.

Contributed by Dylan Martin

=cut

sub group_is
	{
	my $filename      = shift;
	my $group         = shift;
	my $name          = ( shift || "$filename belongs to group $group" );

	my $err = _dm_skeleton( $filename, $group, $name );
	return if( defined( $err ) && $err eq 'skip' );
	return $err if defined($err);

	my $group_gid = _get_gid( $group );
	unless( defined $group_gid )
		{
		$Test->diag("Group [$group] does not exist on this system!");
		return $Test->ok( 0, $name );
		}

	my $file_gid  = ( stat $filename )[5];

	unless( defined $file_gid )
		{
		$Test->skip("stat failed to return group gid for $filename!");
		return;
		}

	return $Test->ok( 1, $name ) if $file_gid == $group_gid;

	my $real_group = ( getgrgid $file_gid )[0];
	unless( defined $real_group )
		{
		$Test->diag("File does not belong to $group!");
		return $Test->ok( 0, $name );
		}

	$Test->diag( "File [$filename] belongs to $real_group ($file_gid), ".
			"not $group ($group_gid)!" );

	return $Test->ok( 0, $name );
	}

=item group_isnt( FILE , GROUP [, NAME ] )

Ok if FILE's group is not the same as GROUP.  GROUP may be a text group name or
a numeric group id.  Test skips on Dos, Mac OS <= 9 and any other operating
systems that do not support getpwuid() and friends.  If the file does not
exist, the test fails.

Contributed by Dylan Martin

=cut

sub group_isnt
	{
	my $filename      = shift;
	my $group         = shift;
	my $name          = shift || "$filename does not belong to group $group";

	my $err = _dm_skeleton( $filename, $group, $name );
	return if( defined( $err ) && $err eq 'skip' );
	return $err if defined($err);

	my $group_gid = _get_gid( $group );
	my $file_gid  = ( stat $filename )[5];

	unless( defined $file_gid )
		{
		$Test->skip("stat failed to return group gid for $filename!");
		return;
		}

	return $Test->ok( 1, $name ) if $file_gid != $group_gid;

	$Test->diag( "File [$filename] belongs to $group ($group_gid)!" );
		return $Test->ok( 0, $name );
	}

sub _get_uid
	{
	my $owner = shift;
	my $owner_uid;

	if ($owner =~ /^\d+/)
		{
		$owner_uid = $owner;
		$owner = ( getpwuid $owner )[0];
		}
	else
		{
		$owner_uid = (getpwnam($owner))[2];
		}

	$owner_uid;
	}

sub _get_gid
	{
	my $group = shift;
	my $group_uid;

	if ($group =~ /^\d+/)
		{
		$group_uid = $group;
		$group = ( getgrgid $group )[0];
		}
	else
		{
		$group_uid = (getgrnam($group))[2];
		}

	$group_uid;
	}


=item file_mtime_age_ok( FILE [, WITHIN_SECONDS ] [, NAME ] )

Ok if FILE's modified time is WITHIN_SECONDS inclusive of the system's current time.
This test uses stat() to obtain the mtime. If the file does not exist the test
returns failure. If stat() fails, the test is skipped.

=cut

sub file_mtime_age_ok
	{
	my $filename    = shift;
	my $within_secs = int shift || 0;
	my $name        = shift || "$filename mtime within $within_secs seconds of current time";

	my $time        = time();

	my $filetime = _stat_file($filename, 9);

	return if ( $filetime == -1 ); #skip

	return $Test->ok(1, $name) if ( $filetime + $within_secs > $time-1  );

	$Test->diag( "Filename [$filename] mtime [$filetime] is not $within_secs seconds within current system time [$time].");
	return $Test->ok(0, $name);
	}

=item file_mtime_gt_ok( FILE, UNIXTIME [, NAME ] )

Ok if FILE's mtime is > UNIXTIME. This test uses stat() to get the mtime. If stat() fails
this test is skipped. If FILE does not exist, this test fails.

=cut

sub file_mtime_gt_ok
	{
	my $filename    = shift;
	my $time        = int shift;
	my $name        = shift || "$filename mtime is less than unix timestamp $time";

	my $filetime = _stat_file($filename, 9);

	return if ( $filetime == -1 ); #skip

	return $Test->ok(1, $name) if ( $filetime > $time );

	$Test->diag( "Filename [$filename] mtime [$filetime] not greater than $time" );
	$Test->ok(0, $name);
  }

=item file_mtime_lt_ok( FILE, UNIXTIME, [, NAME ] )

Ok if FILE's modified time is < UNIXTIME.  This test uses stat() to get the mtime. If stat() fails
this test is skipped. If FILE does not exist, this test fails.

=cut

sub file_mtime_lt_ok
	{
	my $filename = shift;
	my $time = int shift;
	my $name = shift || "$filename mtime less than unix timestamp $time";

  # gets mtime
	my $filetime = _stat_file($filename, 9);

	return if ( $filetime == -1 ); #skip

	return $Test->ok(1, $name) if ( $filetime < $time );

	$Test->diag( "Filename [$filename] mtime [$filetime] not less than $time" );
	$Test->ok(0, $name);
	}

# private function to safely stat a file
#
# Arugments:
# filename     file to perform on
# attr_pos     pos of the array returned from stat we want to compare. perldoc -f stat
#
# Returns:
# -1        - stat failed
#  0        - failure (file doesn't exist etc)
#  filetime - on success, time requested provided by stat
#
sub _stat_file
	{
	my $filename    = _normalize( shift );
	my $attr_pos    = shift;

	unless( defined $filename )
		{
		$Test->diag( "Filename not specified!" );
		return 0;
		}

	unless( -e $filename )
		{
		$Test->diag( "Filename [$filename] does not exist!" );
		return 0;
		}

	my $filetime = ( stat($filename) )[$attr_pos];

	unless( $filetime )
		{
		$Test->diag( "stat of $filename failed" );
		return -1; #skip on stat failure
		}

	return $filetime;
	}

=back

=head1 TO DO

* check properties for other users (readable_by_root, for instance)

* check times

* check number of links to file

* check path parts (directory, filename, extension)

=head1 SEE ALSO

L<Test::Builder>,
L<Test::More>

=head1 SOURCE AVAILABILITY

This module is in Github:

	git://github.com/briandfoy/test-file.git

=head1 AUTHOR

brian d foy, C<< <bdfoy@cpan.org> >>

=head1 CREDITS

Shawn Sorichetti C<< <ssoriche@coloredblocks.net> >> provided
some functions.

Tom Metro helped me figure out some Windows capabilities.

Dylan Martin added C<owner_is> and C<owner_isnt>.

David Wheeler added C<file_line_count_is>.

Buddy Burden C<< <barefoot@cpan.org> >> provided C<dir_exists_ok>,
C<dir_contains_ok>, C<file_contains_like>, and
C<file_contains_unlike>.

xmikew C<< <https://github.com/xmikew> >> provided the C<mtime_age>
stuff.

=head1 COPYRIGHT AND LICENSE

Copyright © 2002-2016, brian d foy <bdfoy@cpan.org>. All rights reserved.

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

=cut

"The quick brown fox jumped over the lazy dog";
PK       ! ӿ�        perl5/Test/Deep/ListMethods.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::ListMethods;

use base 'Test::Deep::Methods';

sub call_method
{
  my $self = shift;

  return [$self->SUPER::call_method(@_)];
}

sub render_stack
{
  my $self = shift;

  my $var = $self->SUPER::render_stack(@_);

  return "[$var]";
}

1;
PK       ! ���i�  �    perl5/Test/Deep/Cmp.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::Cmp;

use overload
  '&' => \&make_all,
  '|' => \&make_any,
  '""' => \&string,
  fallback => 1,
;

use Scalar::Util ();

sub import
{
  my $pkg = shift;

  my $callpkg = caller();
  if ($callpkg =~ /^Test::Deep::/)
  {
    no strict 'refs';

    push @{$callpkg."::ISA"}, $pkg;
  }
}

sub new
{
  my $pkg = shift;

  my $self = bless {}, $pkg;

  $self->init(@_);
  return $self;
}

sub init
{
}

sub make_all
{
  my ($e1, $e2) = @_;

  return Test::Deep::all($e1, $e2);
}

sub make_any
{
  my ($e1, $e2) = @_;

  return Test::Deep::any($e1, $e2);
}

sub cmp
{
  my ($a1, $a2, $rev) = @_;

  ($a1, $a2) = ($a2, $a1) if $rev;

  return (overload::StrVal($a1) cmp overload::StrVal($a2));
}

sub string
{
  my $self = shift;

  return overload::StrVal($self);
}

sub render_stack
{
  my $self = shift;
  my $var = shift;

  return $var;
}

sub renderExp
{
  my $self = shift;

  return $self->renderGot($self->{val});
}

sub renderGot
{
  my $self = shift;

  return Test::Deep::render_val(@_);
}

sub reset_arrow
{
  return 1;
}

sub data
{
  my $self = shift;

  return $Test::Deep::Stack->getLast;
}

1;
PK       ! b�w�       perl5/Test/Deep/RegexpVersion.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::RegexpVersion;

# Older versions of Perl treated Regexp refs as opaque scalars blessed
# into the "Regexp" class. Several bits of code need this so we
# centralise the test for that kind of version.
our $OldStyle = ($] < 5.011);

1;
PK       ! y�׀  �     perl5/Test/Deep/ScalarRefOnly.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::ScalarRefOnly;

use Test::Deep::Cmp;

sub init
{
  my $self = shift;

  my $val = shift;

  $self->{val} = $val;
}

sub descend
{
  my $self = shift;

  my $got = shift;

  my $exp = $self->{val};

  return Test::Deep::descend($$got, $$exp);
}

sub render_stack
{
  my $self = shift;
  my ($var, $data) = @_;

  return "\${$var}";
}

1;
PK       ! �L�      perl5/Test/Deep/ArrayEach.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::ArrayEach;

use Test::Deep::Cmp;
use Scalar::Util ();

sub init
{
  my $self = shift;

  my $val = shift;

  $self->{val} = $val;
}

sub descend
{
  my $self = shift;
  my $got = shift;

  return unless ref $got && Scalar::Util::reftype($got) eq 'ARRAY';
  my $exp = [ ($self->{val}) x @$got ];

  return Test::Deep::descend($got, $exp);
}

sub renderExp
{
  my $self = shift;
  my $exp = shift;

  return '[ ' . $self->SUPER::renderExp($self->{val}) . ', ... ]';
}

1;
PK       ! _���   �     perl5/Test/Deep/Ignore.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::Ignore;

use Test::Deep::Cmp;

my $Singleton = __PACKAGE__->SUPER::new;

sub new
{
  return $Singleton;
}

sub descend
{
  return 1;
}

1;
PK       ! H)T��  �    perl5/Test/Deep/Any.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::Any;

use Scalar::Util ();
use Test::Deep::Cmp;

sub init
{
  my $self = shift;

  my @list = map {
    (Scalar::Util::blessed($_) && $_->isa('Test::Deep::Any'))
    ? @{ $_->{val} }
    : $_
  } @_;

  $self->{val} = \@list;
}

sub descend
{
  my $self = shift;
  my $got = shift;

  foreach my $cmp (@{$self->{val}})
  {
    return 1 if Test::Deep::eq_deeply_cache($got, $cmp);
  }

  return 0;
}

sub renderExp
{
  my $self = shift;

  my @expect = map {; Test::Deep::wrap($_) } @{ $self->{val} };
  my $things = join(", ", map {$_->renderExp} @expect);

  return "Any of ( $things )";
}

sub diagnostics
{
  my $self = shift;
  my ($where, $last) = @_;

  my $got = $self->renderGot($last->{got});
  my $exp = $self->renderExp;

  my $diag = <<EOM;
Comparing $where with Any
got      : $got
expected : $exp
EOM

  $diag =~ s/\n+$/\n/;
  return $diag;
}

4;
PK       ! ��      perl5/Test/Deep/HashKeysOnly.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::HashKeysOnly;

use Test::Deep::Ref;

sub init
{
  my $self = shift;

  my %keys;
  @keys{@_} = ();
  $self->{val} = \%keys;
  $self->{keys} = [sort @_];
}

sub descend
{
  my $self = shift;
  my $hash = shift;

  my $data = $self->data;
  my $exp = $self->{val};
  my %got;
  @got{keys %$hash} = ();

  my @missing;
  my @extra;

  while (my ($key, $value) = each %$exp)
  {
    if (exists $got{$key})
    {
      delete $got{$key};
    }
    else
    {
      push(@missing, $key);
    }
  }

  my @diags;
  if (@missing and (not $self->ignoreMissing))
  {
    push(@diags, "Missing: ".nice_list(\@missing));
  }

  if (%got and (not $self->ignoreExtra))
  {
    push(@diags, "Extra: ".nice_list([keys %got]));
  }

  if (@diags)
  {
    $data->{diag} = join("\n", @diags);
    return 0;
  }

  return 1;
}

sub diagnostics
{
  my $self = shift;
  my ($where, $last) = @_;

  my $type = $self->{IgnoreDupes} ? "Set" : "Bag";

  my $error = $last->{diag};
  my $diag = <<EOM;
Comparing hash keys of $where
$error
EOM

  return $diag;
}

sub nice_list
{
  my $list = shift;

  return join(", ",
    (map {"'$_'"} sort @$list),
  );
}

sub ignoreMissing
{
  return 0;
}

sub ignoreExtra
{
  return 0;
}

package Test::Deep::SuperHashKeysOnly;

use base 'Test::Deep::HashKeysOnly';

sub ignoreMissing
{
  return 0;
}

sub ignoreExtra
{
  return 1;
}

package Test::Deep::SubHashKeysOnly;

use base 'Test::Deep::HashKeysOnly';

sub ignoreMissing
{
  return 1;
}

sub ignoreExtra
{
  return 0;
}

1;
PK       ! �K��  �    perl5/Test/Deep/HashKeys.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::HashKeys;

use Test::Deep::Ref;

sub init
{
  my $self = shift;

  my %keys;
  @keys{@_} = ();
  $self->{val} = \%keys;
  $self->{keys} = [sort @_];
}

sub descend
{
  my $self = shift;
  my $got = shift;

  my $exp = $self->{val};

  return 0 unless $self->test_reftype($got, "HASH");

  return Test::Deep::descend($got, $self->hashkeysonly($exp));
}

sub hashkeysonly
{
  require Test::Deep::HashKeysOnly;

  my $self = shift;
  my $exp = shift;

  return Test::Deep::HashKeysOnly->new(keys %$exp)
}

package Test::Deep::SuperHashKeys;

use base 'Test::Deep::HashKeys';

sub hashkeysonly
{
  require Test::Deep::HashKeysOnly;

  my $self = shift;
  my $exp = shift;

  return Test::Deep::SuperHashKeysOnly->new(keys %$exp)
}

package Test::Deep::SubHashKeys;

use base 'Test::Deep::HashKeys';

sub hashkeysonly
{
  require Test::Deep::HashKeysOnly;

  my $self = shift;
  my $exp = shift;

  return Test::Deep::SubHashKeysOnly->new(keys %$exp)
}

1;
PK       ! �l�C�  �  "  perl5/Test/Deep/ArrayLengthOnly.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::ArrayLengthOnly;

use Test::Deep::Ref;

sub init
{
  my $self = shift;

  my $val = shift;

  $self->{val} = $val;
}

sub descend
{
  my $self = shift;
  my $got = shift;

  my $len = $self->{val};

  return @$got == $len;
}

sub render_stack
{
  my $self = shift;
  my ($var, $data) = @_;

  return "array length of $var";
}

sub renderVal
{
  my $self = shift;

  my $val = shift;

  return "array with $val element(s)"
}

sub renderGot
{
  my $self = shift;

  my $got = shift;

  return $self->renderVal(@$got + 0);
}

sub renderExp
{
  my $self = shift;

  return $self->renderVal($self->{val});
}

1;
PK       ! ��Dm.  .    perl5/Test/Deep/Boolean.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::Boolean;

use Test::Deep::Cmp;

sub init
{
  my $self = shift;

  $self->{val} = shift() ? 1 : 0;
}

sub descend
{
  my $self = shift;
  my $got = shift;

  return !( $got xor $self->{val} );
}

sub diag_message
{
  my $self = shift;
  my $where = shift;
  return "Comparing $where as a boolean";
}

sub renderExp
{
  my $self = shift;

  $self->renderGot($self->{val});
}

sub renderGot
{
  my $self = shift;

  my $val = shift;

  return ($val ? "true" : "false")." (".Test::Deep::render_val($val).")";
}

1;
PK       ! �0S[#  #    perl5/Test/Deep/RefType.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::RefType;

use Test::Deep::Cmp;

use Scalar::Util qw( reftype );

sub init
{
  my $self = shift;

  $self->{val} = shift;
}

sub descend
{
  my $self = shift;

  my $got = shift;

  my $exp = $self->{val};
  my $reftype = reftype($got);

  return Test::Deep::descend($reftype, Test::Deep::shallow($exp));
}

sub render_stack
{
  my $self = shift;
  my $var = shift;

  return "reftype($var)";
}

sub renderGot
{
  my $self = shift;

  my $got = shift;

  $self->SUPER::renderGot(reftype($got));
}

1;
PK       ! ��} �  �    perl5/Test/Deep/ScalarRef.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::ScalarRef;

use Test::Deep::Ref;

sub init
{
  my $self = shift;

  my $val = shift;

  $self->{val} = $val;
}

sub descend
{
  my $self = shift;

  my $got = shift;
  my $exp = $self->{val};

  return 0 unless $self->test_class($got);
  return 0 unless $self->test_reftype($got, Scalar::Util::reftype($exp));
  return Test::Deep::descend($got, Test::Deep::scalarrefonly($exp));
}

1;
PK       ! �j~q  q    perl5/Test/Deep/String.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::String;

use Test::Deep::Cmp;

sub init
{
  my $self = shift;

  $self->{val} = shift;
}

sub descend
{
  my $self = shift;
  my $got = shift()."";

  $self->data->{got} = $got;

  return $got eq $self->{val};
}

sub diag_message
{
  my $self = shift;

  my $where = shift;

  return "Comparing $where as a string";
}

1;
PK       ! !`���  �    perl5/Test/Deep/Ref.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::Ref;

use Test::Deep::Cmp;

use Scalar::Util qw( blessed );

sub test_class
{
  my $self = shift;
  my $got = shift;

  my $exp = $self->{val};
  
  if ($Test::Deep::Snobby)
  {
    return Test::Deep::descend($got, Test::Deep::blessed(blessed($exp)));
  }
  else
  {
    return 1;
  }
}

sub test_reftype
{
  my $self = shift;
  my $got = shift;
  my $reftype = shift;

  return Test::Deep::descend($got, Test::Deep::reftype($reftype));
}

1;
PK       ! �l�	�  �    perl5/Test/Deep/HashElements.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::HashElements;

use Test::Deep::Ref;

sub init
{
  my $self = shift;

  my $val = shift;

  $self->{val} = $val;
}

sub descend
{
  my $self = shift;

  my $got = shift;

  my $exp = $self->{val};

  my $data = $self->data;

  my $master = $self->getMaster($got, $exp);

  foreach my $key (keys %$master)
  {
    $data->{index} = $key;

    my $got_elem = exists $got->{$key} ? $got->{$key} : $Test::Deep::DNE;
    my $exp_elem = exists $exp->{$key} ? $exp->{$key} : $Test::Deep::DNE;

    next if Test::Deep::descend($got_elem, $exp_elem);

    return 0;
  }

  return 1;
}

sub getMaster
{
  my $self = shift;

  my ($got, $exp) = @_;

  return keys %$got > keys %$exp ? $got : $exp;
}

sub render_stack
{
  my $self = shift;
  my ($var, $data) = @_;
  $var .= "->" unless $Test::Deep::Stack->incArrow;
  $var .= '{"'.quotemeta($data->{index}).'"}';

  return $var;
}

sub reset_arrow
{
  return 0;
}

package Test::Deep::SuperHashElements;

use base 'Test::Deep::HashElements';

sub getMaster
{
  my $self = shift;

  my ($got, $exp) = @_;

  return $exp;
}

package Test::Deep::SubHashElements;

use base 'Test::Deep::HashElements';

sub getMaster
{
  my $self = shift;

  my ($got, $exp) = @_;

  return $got;
}

1;
PK       !  �u~p  p    perl5/Test/Deep/Set.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::Set;

use Test::Deep::Cmp;

sub init
{
  my $self = shift;

  $self->{IgnoreDupes} = shift;
  $self->{SubSup} = shift;

  $self->{val} = [];

  $self->add(@_);
}

sub descend
{
  my $self = shift;
  my $d1 = shift;

  my $d2 = $self->{val};

  my $IgnoreDupes = $self->{IgnoreDupes};

  my $data = $self->data;

  my $SubSup = $self->{SubSup};

  my $type = $IgnoreDupes ? "Set" : "Bag";

  my $diag;

  if (ref $d1 ne 'ARRAY')
  {
    my $got = Test::Deep::render_val($d1);
    $diag = <<EOM;
got    : $got
expect : An array to use as a $type
EOM
  }

  if (not $diag)
  {
    my @got = @$d1;
    my @found;
    my @missing;
    foreach my $expect (@$d2)
    {
      my $found = 0;

      for (my $i = $#got; $i >= 0; $i--)
      {
        if (Test::Deep::eq_deeply_cache($got[$i], $expect))
        {
          $found = 1;
          push(@found, $expect);
          splice(@got, $i, 1);

          last unless $IgnoreDupes;
        }
      }

      push(@missing, $expect) unless $found;
    }

    my @diags;
    if (@missing and $SubSup ne "sub" && $SubSup ne "none")
    {
      push(@diags, "Missing: ".nice_list(\@missing));
    }

    if (@got and $SubSup ne "sup" && $SubSup ne "none")
    {
      my $got = __PACKAGE__->new($IgnoreDupes, "", @got);
      push(@diags, "Extra: ".nice_list($got->{val}));
    }

    if (@found and $SubSup eq "none")
    {
      my $found = __PACKAGE__->new($IgnoreDupes, "", @found);
      push(@diags, "Extra: ".nice_list($found->{val}));
    }

    $diag = join("\n", @diags);
  }

  if ($diag)
  {
    $data->{diag} = $diag;

    return 0;
  }
  else
  {
    return 1;
  }
}

sub diagnostics
{
  my $self = shift;
  my ($where, $last) = @_;

  my $type = $self->{IgnoreDupes} ? "Set" : "Bag";
  $type = "Sub$type" if $self->{SubSup} eq "sub";
  $type = "Super$type" if $self->{SubSup} eq "sup";
        $type = "NoneOf" if $self->{SubSup} eq "none";

  my $error = $last->{diag};
  my $diag = <<EOM;
Comparing $where as a $type
$error
EOM

  return $diag;
}

sub add
{
  # this takes an array.

  # For each element A of the array, it looks for an element, B, already in
  # the set which are deeply equal to A. If no matching B is found then A is
  # added to the set. If a B is found and IgnoreDupes is true, then A will
  # be discarded, if IgnoreDupes is false, then B will be added to the set
  # again.
  
  my $self = shift;

  my @array = @_;

  my $IgnoreDupes = $self->{IgnoreDupes};

  my $already = $self->{val};

  local $Test::Deep::Expects = 1;
  foreach my $new_elem (@array)
  {
    my $want_push = 1;
    my $push_this = $new_elem;
    foreach my $old_elem (@$already)
    {
      if (Test::Deep::eq_deeply($new_elem, $old_elem))
      {
        $push_this = $old_elem;
        $want_push = ! $IgnoreDupes;
        last;
      }
    }
    push(@$already, $push_this) if $want_push;
  }

  # so we can compare 2 Test::Deep::Set objects using array comparison

  @$already = sort {(defined $a ? $a : "") cmp (defined $b ? $b : "")} @$already;
}

sub nice_list
{
  my $list = shift;

  my @scalars = grep ! ref $_, @$list;
  my $refs = grep ref $_, @$list;

  my @ref_string = "$refs reference" if $refs;
  $ref_string[0] .= "s" if $refs > 1;

  # sort them so we can predict the diagnostic output

  return join(", ",
    (map {Test::Deep::render_val($_)} sort {(defined $a ? $a : "") cmp (defined $b ? $b : "")} @scalars),
    @ref_string
  );
}

sub compare
{
  my $self = shift;

  my $other = shift;

  return 0 if $self->{IgnoreDupes} != $other->{IgnoreDupes};

  # this works (kind of) because the arrays are sorted

  return Test::Deep::descend($self->{val}, $other->{val});
}

1;
PK       ! vì��  �    perl5/Test/Deep/All.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::All;

use Scalar::Util ();
use Test::Deep::Cmp;

sub init
{
  my $self = shift;

  my @list = map {
    (Scalar::Util::blessed($_) && $_->isa('Test::Deep::All'))
    ? @{ $_->{val} }
    : $_
  } @_;

  $self->{val} = \@list;
}

sub descend
{
  my $self = shift;
  my $got = shift;

  my $data = $self->data;

  my $index = 1;

  foreach my $cmp (@{$self->{val}})
  {
    $data->{index} = $index;
    $index++;

    next if Test::Deep::descend($got, $cmp);
    return 0
  }

  return 1;
}

sub render_stack
{
  my $self = shift;
  my $var = shift;
  my $data = shift;

  my $max = @{$self->{val}};

  return "(Part $data->{index} of $max in $var)";
}

1;
PK       ! @���  �    perl5/Test/Deep/MM.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::MM;

sub import
{
  my $self = shift;

  my ($pkg) = caller();
  my $mpkg = $pkg."::Methods";
  foreach my $attr (@_)
  {
    if ($attr =~ /^[a-z]/)
    {
      no strict 'refs';
      *{$mpkg."::$attr"} = \&{$attr};
    }
    else
    {
      my $get_name = $mpkg."::get$attr";
      my $set_name = $mpkg."::set$attr";
      my $get_sub = sub {
        return $_[0]->{$attr};
      };
      my $set_sub = sub {
        return $_[0]->{$attr} = $_[1];
      };

      {
        no strict 'refs';
        *$get_name = $get_sub;
        *$set_name = $set_sub;
        push(@{$pkg."::ISA"}, $mpkg);
      }
    }
  }
}

sub new
{
  my $pkg = shift;

  my $self = bless {}, $pkg;

  $self->init(@_);

  return $self;
}

sub init
{
  my $self = shift;

  while (@_)
  {
    my $name = shift || confess("No name");

    my $method = "set$name";
    $self->$method(shift);
  }
}

1;
PK       ! J8�@  @    perl5/Test/Deep/Number.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::Number;

use Test::Deep::Cmp;

use Scalar::Util;

sub init
{
  my $self = shift;

  $self->{val} = shift(@_) + 0;
  $self->{tolerance} = shift;
}

sub descend
{
  my $self = shift;
  my $got = shift;
  $self->data->{got_string} = $got;
  {
    no warnings 'numeric';
    $got += 0;
  }

  $self->data->{got} = $got;
  if (defined(my $tolerance = $self->{tolerance}))
  {
    return abs($got - $self->{val}) <= $tolerance;
  }
  else
  {
    return $got == $self->{val};
  }
}

sub diag_message
{
  my $self = shift;

  my $where = shift;

  return "Comparing $where as a number";
}

sub renderGot
{
  my $self = shift;
  my $val = shift;

  my $got_string = $self->data->{got_string};
  if ("$val" ne "$got_string")
  {
    $got_string = $self->SUPER::renderGot($got_string);
    return "$val ($got_string)"
  }
  else
  {
    return $val;
  }
}
sub renderExp
{
  my $self = shift;

  my $exp = $self->{val};

  if (defined(my $tolerance = $self->{tolerance}))
  {
    return "$exp +/- $tolerance";
  }
  else
  {
    return $exp;
  }
}

1;
PK       ! r N34  4    perl5/Test/Deep/Stack.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::Stack;

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

use Test::Deep::MM qw( new init Stack Arrow );

sub init
{
  my $self = shift;

  $self->SUPER::init(@_);

  $self->setStack([]) unless $self->getStack;
}

sub push
{
  my $self = shift;

  push(@{$self->getStack}, @_);
}

sub pop
{
  my $self = shift;

  return pop @{$self->getStack};
}

sub render
{
  my $self = shift;
  my $var = shift;

  my $stack = $self->getStack;

  $self->setArrow(0);

  foreach my $data (@$stack)
  {
    my $exp = $data->{exp};
    if (Scalar::Util::blessed($exp) and $exp->isa("Test::Deep::Cmp"))
    {
      $var = $exp->render_stack($var, $data);

      $self->setArrow(0) if $exp->reset_arrow;
    }
    else
    {
      confess "Don't know how to render '$exp'";
    }
  }

  return $var;
}

sub getLast
{
  my $self = shift;

  return $self->getStack->[-1];
}

sub incArrow
{
  my $self = shift;

  my $a = $self->getArrow;
  $self->setArrow($a + 1);

  return $a;
}

sub length
{
  my $self = shift;

  return @{$self->getStack} + 0;
}

1;
PK       ! ��r      perl5/Test/Deep/Cache.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::Cache;

use Test::Deep::Cache::Simple;

sub new
{
  my $pkg = shift;

  my $self = bless {}, $pkg;

  $self->{expects} = [Test::Deep::Cache::Simple->new];
  $self->{normal} = [Test::Deep::Cache::Simple->new];

  $self->local;

  return $self;
}

sub add
{
  my $self = shift;

  my $type = $self->type;

  $self->{$type}->[-1]->add(@_);
}

sub cmp
{
  # go through all the caches to see if we know this one

  my $self = shift;

  my $type = $self->type;

  foreach my $cache (@{$self->{$type}})
  {
    return 1 if $cache->cmp(@_);
  }

  return 0
}

sub local
{
  my $self = shift;

  foreach my $type (qw( expects normal ))
  {
    push(@{$self->{$type}}, Test::Deep::Cache::Simple->new);
  }
}

sub finish
{
  my $self = shift;

  my $keep = shift;

  foreach my $type (qw( expects normal ))
  {
    my $caches = $self->{$type};

    my $last = pop @$caches;

    $caches->[-1]->absorb($last) if $keep;
  }
}

sub type
{
  return $Test::Deep::Expects ? "expects" : "normal";
}

1;
PK       ! J�b�U  U    perl5/Test/Deep/Shallow.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::Shallow;

use Test::Deep::Cmp;

use Scalar::Util qw( refaddr );

sub init
{
  my $self = shift;

  my $val = shift;
  $self->{val} = $val;
}

sub descend
{
  my $self = shift;

  my $got = shift;
  my $exp = $self->{val};

  my $ok;

  if (!defined $got and !defined $exp)
  {
    $ok = 1;
  }
  elsif (defined $got xor defined $exp)
  {
    $ok = 0;
  }
  elsif (ref $got and ref $exp)
  {
    $ok = refaddr($got) == refaddr($exp);
  }
  elsif (ref $got xor ref $exp)
  {
    $ok = 0;
  }
  else
  {
    $ok = $got eq $exp;
  }

  return $ok;
}

1;
PK       ! Aݤ�4  4    perl5/Test/Deep/Blessed.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::Blessed;

use Test::Deep::Cmp;

use Scalar::Util qw( blessed );

sub init
{
  my $self = shift;

  my $val = shift;

  $self->{val} = $val;
}

sub descend
{
  my $self = shift;
  my $got = shift;

  my $exp = $self->{val};
  my $blessed = blessed($got);

  return Test::Deep::descend($blessed, Test::Deep::shallow($exp));
}

sub render_stack
{
  my $self = shift;
  my $var = shift;

  return "blessed($var)"
}

sub renderGot
{
  my $self = shift;

  my $got = shift;

  $self->SUPER::renderGot(blessed($got));
}

1;
PK       ! �D�      perl5/Test/Deep/Isa.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::Isa;

use Test::Deep::Cmp;
use Scalar::Util;

sub init
{
  my $self = shift;

  my $val = shift;
  $self->{val} = $val;
}

sub descend
{
  my $self = shift;
  my $got = shift;

  return Scalar::Util::blessed($got)
    ? $got->isa($self->{val})
    : ref($got) eq $self->{val};
}

sub diag_message
{
  my $self = shift;

  my $where = shift;

  return "Checking class of $where with isa()";
}

sub renderExp
{
  my $self = shift;

  return "blessed into or ref of type '$self->{val}'";
}

1;
PK       ! 8<`�k  k    perl5/Test/Deep/Class.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::Class;

use Test::Deep::Cmp;

sub init
{
  my $self = shift;

  my $snobby = shift;
  my $val = shift;

  $self->{snobby} = $snobby;
  $self->{val} = $val;
}

sub descend
{
  my $self = shift;
  my $got = shift;

  local $Test::Deep::Snobby = $self->{snobby};

  Test::Deep::wrap($self->{val})->descend($got);
}

1;
PK       ! n��΀  �    perl5/Test/Deep/Regexp.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::Regexp;

use Test::Deep::Cmp;
use Test::Deep::RegexpMatches;

sub init
{
  my $self = shift;

  my $val = shift;

  $val = ref $val ? $val : qr/$val/;

  $self->{val} = $val;

  if (my $matches = shift)
  {
    $self->{matches} = Test::Deep::regexpmatches($matches, $val);

    $self->{flags} = shift || "";
  }
}

sub descend
{
  my $self = shift;
  my $got = shift;

  my $re = $self->{val};
  if (my $match_exp = $self->{matches})
  {
    my $flags = $self->{flags};
    my @match_got;
    if ($flags eq "g")
    {
      @match_got = $got =~ /$re/g;
    }
    else
    {
      @match_got = $got =~ /$re/;
    }

    if (@match_got)
    {
      return Test::Deep::descend(\@match_got, $match_exp);
    }
    else
    {
      return 0;
    }
  }
  else
  {
    return ($got =~ $re) ? 1 : 0;
  }
}

sub diag_message
{
  my $self = shift;

  my $where = shift;

  return "Using Regexp on $where";
}

sub render_stack1
{
  my $self = shift;

  my $stack = shift;
  return "($stack =~ $self->{regex})";
}

sub renderExp
{
  my $self = shift;

  return "$self->{val}";
}

sub renderGot
{
  my $self = shift;
  my $got  = shift;

  if (defined (my $class = Scalar::Util::blessed($got)))
  {
    my $ostr = qq{$got};
    if ($ostr ne overload::StrVal($got))
    {
      return qq{'$ostr' (instance of $class)};
    }
  }

  return Test::Deep::render_val($got);
}

1;
PK       ! =�?�        perl5/Test/Deep/Methods.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::Methods;

use Test::Deep::Cmp;
use Scalar::Util;

sub init
{
  my $self = shift;

  # get them all into [$name,@args] => $value format
  my @methods;
  while (@_)
  {
    my $name = shift;
    my $value = shift;
    push(@methods,
      [
        ref($name) ? $name : [ $name ],
        $value
      ]
    );
  }
  $self->{methods} = \@methods;
}

sub descend
{
  my $self = shift;
  my $got = shift;

  my $data = $self->data;

  foreach my $method (@{$self->{methods}})
  {
    $data->{method} = $method;

    my ($call, $exp_res) = @$method;
    my ($name, @args) = @$call;

    local $@;

    my $got_res;
    if (! eval { $got_res = $self->call_method($got, $call); 1 }) {
      die $@ unless $@ =~ /\ACan't locate object method "\Q$name"/;
      $got_res = $Test::Deep::DNE;
    }

    next if Test::Deep::descend($got_res, $exp_res);

    return 0;
  }

  return 1;
}

sub call_method
{
  my $self = shift;
  my ($got, $call) = @_;
  my ($name, @args) = @$call;

  return $got->$name(@args);
}

sub render_stack
{
  my $self = shift;
  my ($var, $data) = @_;

  my $method = $data->{method};
  my ($call, $expect) = @$method;
  my ($name, @args) = @$call;

  my $args = @args ? "(".join(", ", @args).")" : "";
  $var .= "->$name$args";

  return $var;
}

1;
PK       ! �1��  �    perl5/Test/Deep/Code.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::Code;

use Test::Deep::Cmp;

sub init
{
  my $self = shift;

  my $code = shift || die "No coderef supplied";

  $self->{code} = $code;
}

sub descend
{
  my $self = shift;
  my $got = shift;

  my ($ok, $diag) = &{$self->{code}}($got);

  $self->data->{diag} = $diag;

  return $ok;
}

sub diagnostics
{
  my $self = shift;
  my ($where, $last) = @_;

  my $error = $last->{diag};
  my $data = Test::Deep::render_val($last->{got});
  my $diag = <<EOM;
Ran coderef at $where on

$data
EOM
  if (defined($error))
  {
    $diag .= <<EOM;
and it said
$error
EOM
  }
  else
  {
    $diag .= <<EOM;
it failed but it didn't say why.
EOM
  }

  return $diag;
}

1;
PK       ! �ԭ�      perl5/Test/Deep/NoTest.pmnu ��6�$        use strict;
use warnings;

# this is for people who don't want Test::Builder to be loaded but want to
# use eq_deeply. It's a bit hacky...

package Test::Deep::NoTest;

our $NoTest;

{
  local $NoTest = 1;
  require Test::Deep;
}

sub import {
  my $import = Test::Deep->can("import");
  # make the stack look like it should for use Test::Deep
  my $pkg = shift;
  unshift(@_, "Test::Deep");
  push @_, '_notest';
  goto &$import;
}

1;

=head1 NAME

Test::Deep::NoTest - Use Test::Deep outside of the testing framework

=head1 SYNOPSIS

  use Test::Deep::NoTest;

  if (eq_deeply($a, $b)) {
    print "they were deeply equal\n";
  }

=head1 DESCRIPTION

This exports all the same things as Test::Deep but it does not load
Test::Builder so it can be used in ordinary non-test situations.
PK       ! ���ѵ  �    perl5/Test/Deep/Cache/Simple.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::Cache::Simple;
use Carp qw( confess );

use Scalar::Util qw( refaddr );

BEGIN
{
  if (grep /^weaken$/, @Scalar::Util::EXPORT_FAIL)
  {
    # we're running on a version of perl that has no weak refs, so we
    # just install a no-op sub for weaken instead of importing it
    *weaken = sub {};
  }
  else
  {
    Scalar::Util->import('weaken');
  }
}

sub new
{
  my $pkg = shift;

  my $self = bless {}, $pkg;

  return $self;
}

sub add
{
  my $self = shift;

  my ($d1, $d2) = @_;
  {
    local $SIG{__DIE__};

    local $@;

    # cannot weaken read only refs, no harm if we can't as they never
    # disappear
    eval{weaken($d1)};
    eval{weaken($d2)};
  }

  $self->{fn_get_key(@_)} = [$d1, $d2];
}

sub cmp
{
  my $self = shift;

  my $key = fn_get_key(@_);
  my $pair = $self->{$key};

  # are both weakened refs still valid, if not delete this entry
  if (ref($pair->[0]) and ref($pair->[1]))
  {
    return 1;
  }
  else
  {
    delete $self->{$key};
    return 0;
  }
}

sub absorb
{
  my $self = shift;

  my $other = shift;

  @{$self}{keys %$other} = values %$other;
}

sub fn_get_key
{
  return join(",", sort (map {refaddr($_)} @_));
}
1;
PK       ! �C�"v  v    perl5/Test/Deep/ArrayLength.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::ArrayLength;

use Test::Deep::Ref;

sub init
{
  my $self = shift;

  my $val = shift;

  $self->{val} = $val;
}

sub descend
{
  my $self = shift;
  my $got = shift;

  my $exp = $self->{val};

  return 0 unless $self->test_reftype($got, "ARRAY");

  return Test::Deep::descend($got, Test::Deep::arraylengthonly($exp));
}

1;
PK       ! ���ݥ  �  $  perl5/Test/Deep/ArrayElementsOnly.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::ArrayElementsOnly;

use Test::Deep::Ref;

sub init
{
  my $self = shift;

  my $val = shift;

  $self->{val} = $val;
}

sub descend
{
  my $self = shift;
  my $got = shift;

  my $exp = $self->{val};

  my $data = $self->data;

  for my $i (0..$#{$exp})
  {
    $data->{index} = $i;

    my $got_elem = $got->[$i];
    my $exp_elem = $exp->[$i];

    return 0 unless Test::Deep::descend($got_elem, $exp_elem)
  }

  return 1;
}

sub render_stack
{
  my $self = shift;
  my ($var, $data) = @_;
  $var .= "->" unless $Test::Deep::Stack->incArrow;
  $var .= "[$data->{index}]";

  return $var;
}

sub reset_arrow
{
  return 0;
}

1;
PK       ! x^6	  	    perl5/Test/Deep/RegexpOnly.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::RegexpOnly;

use Test::Deep::Cmp;

use Scalar::Util qw( blessed );

sub init
{
  my $self = shift;

  my $val = shift;

  $val = ref $val ? $val : qr/$val/;

  $self->{val} = $val;
}

sub descend
{
  my $self = shift;
  my $got = shift;

  my $re = $self->{val};

  return $got =~ $self->{val} ? 1 : 0;
}

sub diag_message
{
  my $self = shift;

  my $where = shift;

  return "Using Regexp on $where";
}

sub renderExp
{
  my $self = shift;

  return "$self->{val}";
}

1;
PK       ! j`��  �    perl5/Test/Deep/Hash.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::Hash;

use Test::Deep::Ref;

sub init
{
  my $self = shift;

  my $val = shift;

  $self->{val} = $val;
}

sub descend
{
  my $self = shift;

  my $got = shift;

  my $exp = $self->{val};

  my $data = $self->data;

  return 0 unless Test::Deep::descend($got, $self->hash_keys($exp));

  return 0 unless $self->test_class($got);

  return Test::Deep::descend($got, $self->hash_elements($exp));
}

sub hash_elements
{
  require Test::Deep::HashElements;

  my $self = shift;

  return Test::Deep::HashElements->new(@_);
}

sub hash_keys
{
  require Test::Deep::HashKeys;

  my $self = shift;
  my $exp = shift;

  return Test::Deep::HashKeys->new(keys %$exp);
}

sub reset_arrow
{
  return 0;
}

package Test::Deep::SuperHash;

use base 'Test::Deep::Hash';

sub hash_elements
{
  require Test::Deep::HashElements;

  my $self = shift;

  return Test::Deep::SuperHashElements->new(@_);
}

sub hash_keys
{
  require Test::Deep::HashKeys;

  my $self = shift;
  my $exp = shift;

  return Test::Deep::SuperHashKeys->new(keys %$exp);
}

package Test::Deep::SubHash;

use base 'Test::Deep::Hash';

sub hash_elements
{
  require Test::Deep::HashElements;

  my $self = shift;

  return Test::Deep::SubHashElements->new(@_);
}

sub hash_keys
{
  require Test::Deep::HashKeys;

  my $self = shift;
  my $exp = shift;

  return Test::Deep::SubHashKeys->new(keys %$exp);
}

1;
PK       ! �)�  �     perl5/Test/Deep/RegexpRefOnly.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::RegexpRefOnly;

use Test::Deep::Ref;

sub init
{
  my $self = shift;

  my $val = shift;

  $self->{val} = $val;
}

sub descend
{
  my $self = shift;

  my $got = shift;

  my $exp = $self->{val};

  return $got eq $exp;
}

sub render_stack
{
  my $self = shift;
  my ($var, $data) = @_;

  return "m/$var/";
}

sub renderGot
{
  my $self = shift;

  return shift()."";
}

1;
PK       ! �u�  �    perl5/Test/Deep/Array.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::Array;

use Test::Deep::Ref;

sub init
{
  my $self = shift;

  my $val = shift;

  $self->{val} = $val;
}

sub descend
{
  my $self = shift;
  my $got = shift;

  my $exp = $self->{val};

  return 0 unless Test::Deep::descend($got, Test::Deep::arraylength(scalar @$exp));

  return 0 unless $self->test_class($got);

  return Test::Deep::descend($got, Test::Deep::arrayelementsonly($exp));
}

sub reset_arrow
{
  return 0;
}

1;
PK       ! NNk#�  �     perl5/Test/Deep/RegexpMatches.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::RegexpMatches;

use Test::Deep::Array;

use base 'Test::Deep::Array';

use Scalar::Util qw( blessed );

sub init
{
  my $self = shift;

  my $val = shift;

  $val = Test::Deep::array($val) unless
    blessed($val) and $val->isa("Test::Deep::Cmp");

  $self->{val} = $val;
  $self->{regex} = shift;
}

sub descend
{
  my $self = shift;

  my $got = shift;

  return Test::Deep::descend($got, $self->{val});
}

sub render_stack
{
  my $self = shift;

  my $stack = shift;

  $stack = "[$stack =~ $self->{regex}]";

  return $stack;
#  return $self->SUPER::render_stack($stack);
}

sub reset_arrow
{
  return 1;
}

1;
PK       ! ��ƈ      perl5/Test/Deep/RegexpRef.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::RegexpRef;

use Test::Deep::Ref;
use Test::Deep::RegexpVersion;

sub init
{
  my $self = shift;

  my $val = shift;

  $self->{val} = $val;
}

sub descend
{
  my $self = shift;

  my $got = shift;

  my $exp = $self->{val};

  if ($Test::Deep::RegexpVersion::OldStyle) {
    return 0 unless $self->test_class($got, "Regexp");
    return 0 unless $self->test_reftype($got, "SCALAR");
  } else {
    return 0 unless $self->test_reftype($got, "REGEXP");
  }

  return Test::Deep::descend($got, Test::Deep::regexprefonly($exp));
}

sub renderGot
{
  my $self = shift;

  return shift()."";
}

1;
PK       ! J��[F  F    perl5/Test/Deep/HashEach.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::HashEach;

use Test::Deep::Cmp;

sub init
{
  my $self = shift;

  my $val = shift;

  $self->{val} = $val;
}

sub descend
{
  my $self = shift;
  my $got = shift;

  my %exp;

  @exp{keys %$got} = ($self->{val}) x (keys %$got);

  return Test::Deep::descend($got, \%exp);
}

1;
PK       ! ��[*e  e    perl5/Test/Deep/None.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::None;

use Test::Deep::Cmp;

sub init
{
  my $self = shift;

  my @list = map {
    eval { $_->isa('Test::Deep::None') }
    ? @{ $_->{val} }
    : $_
  } @_;

  $self->{val} = \@list;
}

sub descend
{
  my $self = shift;
  my $got = shift;

  foreach my $cmp (@{$self->{val}})
  {
    return 0 if Test::Deep::eq_deeply_cache($got, $cmp);
  }

  return 1;
}

sub renderExp
{
  my $self = shift;

  my @expect = map {; Test::Deep::wrap($_) } @{ $self->{val} };
  my $things = join(", ", map {$_->renderExp} @expect);

  return "None of ( $things )";
}

sub diagnostics
{
  my $self = shift;
  my ($where, $last) = @_;

  my $got = $self->renderGot($last->{got});
  my $exp = $self->renderExp;

  my $diag = <<EOM;
Comparing $where with None
got      : $got
expected : $exp
EOM

  $diag =~ s/\n+$/\n/;
  return $diag;
}

1;
PK       ! ��|�
  
    perl5/Test/Deep/Obj.pmnu ��6�$        use strict;
use warnings;

package Test::Deep::Obj;

use Test::Deep::Cmp;
use Scalar::Util;

sub init
{
  my $self = shift;

  my $val = shift;
  $self->{val} = $val;
}

sub descend
{
  my $self = shift;
  my $got = shift;

  return Scalar::Util::blessed($got)
    && $got->isa($self->{val});
}

sub diag_message
{
  my $self = shift;

  my $where = shift;

  return "Checking class of $where with isa()";
}

sub renderExp
{
  my $self = shift;

  return "blessed into '$self->{val}' or subclass of '$self->{val}'";
}

1;
PK       ! �%��:  :    perl5/Test/Fatal.pmnu ��6�$        use strict;
use warnings;
package Test::Fatal;
# ABSTRACT: incredibly simple helpers for testing code with exceptions
$Test::Fatal::VERSION = '0.016';
#pod =head1 SYNOPSIS
#pod
#pod   use Test::More;
#pod   use Test::Fatal;
#pod
#pod   use System::Under::Test qw(might_die);
#pod
#pod   is(
#pod     exception { might_die; },
#pod     undef,
#pod     "the code lived",
#pod   );
#pod
#pod   like(
#pod     exception { might_die; },
#pod     qr/turns out it died/,
#pod     "the code died as expected",
#pod   );
#pod
#pod   isa_ok(
#pod     exception { might_die; },
#pod     'Exception::Whatever',
#pod     'the thrown exception',
#pod   );
#pod
#pod =head1 DESCRIPTION
#pod
#pod Test::Fatal is an alternative to the popular L<Test::Exception>.  It does much
#pod less, but should allow greater flexibility in testing exception-throwing code
#pod with about the same amount of typing.
#pod
#pod It exports one routine by default: C<exception>.
#pod
#pod B<Achtung!>  C<exception> intentionally does not manipulate the call stack.
#pod User-written test functions that use C<exception> must be careful to avoid
#pod false positives if exceptions use stack traces that show arguments.  For a more
#pod magical approach involving globally overriding C<caller>, see
#pod L<Test::Exception>.
#pod
#pod =cut

use Carp ();
use Try::Tiny 0.07;

use Exporter 5.57 'import';

our @EXPORT    = qw(exception);
our @EXPORT_OK = qw(exception success dies_ok lives_ok);

#pod =func exception
#pod
#pod   my $exception = exception { ... };
#pod
#pod C<exception> takes a bare block of code and returns the exception thrown by
#pod that block.  If no exception was thrown, it returns undef.
#pod
#pod B<Achtung!>  If the block results in a I<false> exception, such as 0 or the
#pod empty string, Test::Fatal itself will die.  Since either of these cases
#pod indicates a serious problem with the system under testing, this behavior is
#pod considered a I<feature>.  If you must test for these conditions, you should use
#pod L<Try::Tiny>'s try/catch mechanism.  (Try::Tiny is the underlying exception
#pod handling system of Test::Fatal.)
#pod
#pod Note that there is no TAP assert being performed.  In other words, no "ok" or
#pod "not ok" line is emitted.  It's up to you to use the rest of C<exception> in an
#pod existing test like C<ok>, C<isa_ok>, C<is>, et cetera.  Or you may wish to use
#pod the C<dies_ok> and C<lives_ok> wrappers, which do provide TAP output.
#pod
#pod C<exception> does I<not> alter the stack presented to the called block, meaning
#pod that if the exception returned has a stack trace, it will include some frames
#pod between the code calling C<exception> and the thing throwing the exception.
#pod This is considered a I<feature> because it avoids the occasionally twitchy
#pod C<Sub::Uplevel> mechanism.
#pod
#pod B<Achtung!>  This is not a great idea:
#pod
#pod   sub exception_like(&$;$) {
#pod       my ($code, $pattern, $name) = @_;
#pod       like( &exception($code), $pattern, $name );
#pod   }
#pod
#pod   exception_like(sub { }, qr/foo/, 'foo appears in the exception');
#pod
#pod If the code in the C<...> is going to throw a stack trace with the arguments to
#pod each subroutine in its call stack (for example via C<Carp::confess>,
#pod the test name, "foo appears in the exception" will itself be matched by the
#pod regex.  Instead, write this:
#pod
#pod   like( exception { ... }, qr/foo/, 'foo appears in the exception' );
#pod
#pod If you really want a test function that passes the test name, wrap the
#pod arguments in an array reference to hide the literal text from a stack trace:
#pod
#pod   sub exception_like(&$) {
#pod       my ($code, $args) = @_;
#pod       my ($pattern, $name) = @$args;
#pod       like( &exception($code), $pattern, $name );
#pod   }
#pod
#pod   exception_like(sub { }, [ qr/foo/, 'foo appears in the exception' ] );
#pod
#pod To aid in avoiding the problem where the pattern is seen in the exception
#pod because of the call stack, C<$Carp::MAxArgNums> is locally set to -1 when the
#pod code block is called.  If you really don't want that, set it back to whatever
#pod value you like at the beginning of the code block.  Obviously, this solution
#pod doens't affect all possible ways that args of subroutines in the call stack
#pod might taint the test.  The intention here is to prevent some false passes from
#pod people who didn't read the documentation.  Your punishment for reading it is
#pod that you must consider whether to do anything about this.
#pod
#pod B<Achtung>: One final bad idea:
#pod
#pod   isnt( exception { ... }, undef, "my code died!");
#pod
#pod It's true that this tests that your code died, but you should really test that
#pod it died I<for the right reason>.  For example, if you make an unrelated mistake
#pod in the block, like using the wrong dereference, your test will pass even though
#pod the code to be tested isn't really run at all.  If you're expecting an
#pod inspectable exception with an identifier or class, test that.  If you're
#pod expecting a string exception, consider using C<like>.
#pod
#pod =cut

our ($REAL_TBL, $REAL_CALCULATED_TBL) = (1, 1);

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

  return try {
    my $incremented = defined $Test::Builder::Level
                    ? $Test::Builder::Level - $REAL_CALCULATED_TBL
                    : 0;
    local $Test::Builder::Level = $REAL_CALCULATED_TBL;
    if ($incremented) {
        # each call to exception adds 5 stack frames
        $Test::Builder::Level += 5;
        for my $i (1..$incremented) {
            # -2 because we want to see it from the perspective of the call to
            # is() within the call to $code->()
            my $caller = caller($Test::Builder::Level - 2);
            if ($caller eq __PACKAGE__) {
                # each call to exception adds 5 stack frames
                $Test::Builder::Level = $Test::Builder::Level + 5;
            }
            else {
                $Test::Builder::Level = $Test::Builder::Level + 1;
            }
        }
    }

    local $REAL_CALCULATED_TBL = $Test::Builder::Level;
    local $Carp::MaxArgNums = -1;
    $code->();
    return undef;
  } catch {
    return $_ if $_;

    my $problem = defined $_ ? 'false' : 'undef';
    Carp::confess("$problem exception caught by Test::Fatal::exception");
  };
}

#pod =func success
#pod
#pod   try {
#pod     should_live;
#pod   } catch {
#pod     fail("boo, we died");
#pod   } success {
#pod     pass("hooray, we lived");
#pod   };
#pod
#pod C<success>, exported only by request, is a L<Try::Tiny> helper with semantics
#pod identical to L<C<finally>|Try::Tiny/finally>, but the body of the block will
#pod only be run if the C<try> block ran without error.
#pod
#pod Although almost any needed exception tests can be performed with C<exception>,
#pod success blocks may sometimes help organize complex testing.
#pod
#pod =cut

sub success (&;@) {
  my $code = shift;
  return finally( sub {
    return if @_; # <-- only run on success
    $code->();
  }, @_ );
}

#pod =func dies_ok
#pod
#pod =func lives_ok
#pod
#pod Exported only by request, these two functions run a given block of code, and
#pod provide TAP output indicating if it did, or did not throw an exception. 
#pod These provide an easy upgrade path for replacing existing unit tests based on
#pod C<Test::Exception>.
#pod
#pod RJBS does not suggest using this except as a convenience while porting tests to
#pod use Test::Fatal's C<exception> routine.
#pod
#pod   use Test::More tests => 2;
#pod   use Test::Fatal qw(dies_ok lives_ok);
#pod
#pod   dies_ok { die "I failed" } 'code that fails';
#pod
#pod   lives_ok { return "I'm still alive" } 'code that does not fail';
#pod
#pod =cut

my $Tester;

# Signature should match that of Test::Exception
sub dies_ok (&;$) {
  my $code = shift;
  my $name = shift;

  require Test::Builder;
  $Tester ||= Test::Builder->new;

  my $tap_pos = $Tester->current_test;

  my $exception = exception( \&$code );

  $name ||= $tap_pos != $Tester->current_test
        ? "...and code should throw an exception"
        : "code should throw an exception";

  my $ok = $Tester->ok( $exception, $name );
  $ok or $Tester->diag( "expected an exception but none was raised" );
  return $ok;
}

sub lives_ok (&;$) {
  my $code = shift;
  my $name = shift;

  require Test::Builder;
  $Tester ||= Test::Builder->new;

  my $tap_pos = $Tester->current_test;

  my $exception = exception( \&$code );

  $name ||= $tap_pos != $Tester->current_test
        ? "...and code should not throw an exception"
        : "code should not throw an exception";

  my $ok = $Tester->ok( ! $exception, $name );
  $ok or $Tester->diag( "expected return but an exception was raised" );
  return $ok;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test::Fatal - incredibly simple helpers for testing code with exceptions

=head1 VERSION

version 0.016

=head1 SYNOPSIS

  use Test::More;
  use Test::Fatal;

  use System::Under::Test qw(might_die);

  is(
    exception { might_die; },
    undef,
    "the code lived",
  );

  like(
    exception { might_die; },
    qr/turns out it died/,
    "the code died as expected",
  );

  isa_ok(
    exception { might_die; },
    'Exception::Whatever',
    'the thrown exception',
  );

=head1 DESCRIPTION

Test::Fatal is an alternative to the popular L<Test::Exception>.  It does much
less, but should allow greater flexibility in testing exception-throwing code
with about the same amount of typing.

It exports one routine by default: C<exception>.

B<Achtung!>  C<exception> intentionally does not manipulate the call stack.
User-written test functions that use C<exception> must be careful to avoid
false positives if exceptions use stack traces that show arguments.  For a more
magical approach involving globally overriding C<caller>, see
L<Test::Exception>.

=head1 FUNCTIONS

=head2 exception

  my $exception = exception { ... };

C<exception> takes a bare block of code and returns the exception thrown by
that block.  If no exception was thrown, it returns undef.

B<Achtung!>  If the block results in a I<false> exception, such as 0 or the
empty string, Test::Fatal itself will die.  Since either of these cases
indicates a serious problem with the system under testing, this behavior is
considered a I<feature>.  If you must test for these conditions, you should use
L<Try::Tiny>'s try/catch mechanism.  (Try::Tiny is the underlying exception
handling system of Test::Fatal.)

Note that there is no TAP assert being performed.  In other words, no "ok" or
"not ok" line is emitted.  It's up to you to use the rest of C<exception> in an
existing test like C<ok>, C<isa_ok>, C<is>, et cetera.  Or you may wish to use
the C<dies_ok> and C<lives_ok> wrappers, which do provide TAP output.

C<exception> does I<not> alter the stack presented to the called block, meaning
that if the exception returned has a stack trace, it will include some frames
between the code calling C<exception> and the thing throwing the exception.
This is considered a I<feature> because it avoids the occasionally twitchy
C<Sub::Uplevel> mechanism.

B<Achtung!>  This is not a great idea:

  sub exception_like(&$;$) {
      my ($code, $pattern, $name) = @_;
      like( &exception($code), $pattern, $name );
  }

  exception_like(sub { }, qr/foo/, 'foo appears in the exception');

If the code in the C<...> is going to throw a stack trace with the arguments to
each subroutine in its call stack (for example via C<Carp::confess>,
the test name, "foo appears in the exception" will itself be matched by the
regex.  Instead, write this:

  like( exception { ... }, qr/foo/, 'foo appears in the exception' );

If you really want a test function that passes the test name, wrap the
arguments in an array reference to hide the literal text from a stack trace:

  sub exception_like(&$) {
      my ($code, $args) = @_;
      my ($pattern, $name) = @$args;
      like( &exception($code), $pattern, $name );
  }

  exception_like(sub { }, [ qr/foo/, 'foo appears in the exception' ] );

To aid in avoiding the problem where the pattern is seen in the exception
because of the call stack, C<$Carp::MAxArgNums> is locally set to -1 when the
code block is called.  If you really don't want that, set it back to whatever
value you like at the beginning of the code block.  Obviously, this solution
doens't affect all possible ways that args of subroutines in the call stack
might taint the test.  The intention here is to prevent some false passes from
people who didn't read the documentation.  Your punishment for reading it is
that you must consider whether to do anything about this.

B<Achtung>: One final bad idea:

  isnt( exception { ... }, undef, "my code died!");

It's true that this tests that your code died, but you should really test that
it died I<for the right reason>.  For example, if you make an unrelated mistake
in the block, like using the wrong dereference, your test will pass even though
the code to be tested isn't really run at all.  If you're expecting an
inspectable exception with an identifier or class, test that.  If you're
expecting a string exception, consider using C<like>.

=head2 success

  try {
    should_live;
  } catch {
    fail("boo, we died");
  } success {
    pass("hooray, we lived");
  };

C<success>, exported only by request, is a L<Try::Tiny> helper with semantics
identical to L<C<finally>|Try::Tiny/finally>, but the body of the block will
only be run if the C<try> block ran without error.

Although almost any needed exception tests can be performed with C<exception>,
success blocks may sometimes help organize complex testing.

=head2 dies_ok

=head2 lives_ok

Exported only by request, these two functions run a given block of code, and
provide TAP output indicating if it did, or did not throw an exception. 
These provide an easy upgrade path for replacing existing unit tests based on
C<Test::Exception>.

RJBS does not suggest using this except as a convenience while porting tests to
use Test::Fatal's C<exception> routine.

  use Test::More tests => 2;
  use Test::Fatal qw(dies_ok lives_ok);

  dies_ok { die "I failed" } 'code that fails';

  lives_ok { return "I'm still alive" } 'code that does not fail';

=head1 AUTHOR

Ricardo Signes <rjbs@cpan.org>

=head1 CONTRIBUTORS

=for stopwords David Golden Graham Knop Jesse Luehrs Joel Bernstein Karen Etheridge

=over 4

=item *

David Golden <dagolden@cpan.org>

=item *

Graham Knop <haarg@haarg.org>

=item *

Jesse Luehrs <doy@tozt.net>

=item *

Joel Bernstein <joel@fysh.org>

=item *

Karen Etheridge <ether@cpan.org>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2010 by Ricardo Signes.

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

=cut
PK       ! 	]&C�t  �t    perl5/Test/Alien.pmnu ��6�$        package Test::Alien;

use strict;
use warnings;
use 5.008004;
use Env qw( @PATH );
use File::Which 1.10 qw( which );
use Capture::Tiny qw( capture capture_merged );
use Alien::Build::Temp;
use File::Copy qw( move );
use Text::ParseWords qw( shellwords );
use Test2::API qw( context run_subtest );
use Exporter qw( import );
use Path::Tiny qw( path );
use Alien::Build::Util qw( _dump );
use Config;

our @EXPORT = qw( alien_ok run_ok xs_ok ffi_ok with_subtest synthetic helper_ok interpolate_template_is interpolate_run_ok plugin_ok );

# ABSTRACT: Testing tools for Alien modules
our $VERSION = '2.83'; # VERSION


our @aliens;

sub alien_ok ($;$)
{
  my($alien, $message) = @_;

  my $name = ref $alien ? ref($alien) . '[instance]' : $alien;
  $name = 'undef' unless defined $name;
  my @methods = qw( cflags libs dynamic_libs bin_dir );
  $message ||= "$name responds to: @methods";

  my $ok;
  my @diag;

  if(defined $alien)
  {
    my @missing = grep { ! $alien->can($_) } @methods;

    $ok = !@missing;
    push @diag, map { "  missing method $_" } @missing;

    if($ok)
    {
      push @aliens, $alien;
      if($^O eq 'MSWin32' && $alien->isa('Alien::MSYS'))
      {
        unshift @PATH, Alien::MSYS::msys_path();
      }
      else
      {
        unshift @PATH, $alien->bin_dir;
      }
    }

    if($alien->can('alien_helper'))
    {
      my($intr) = _interpolator();

      my $help = eval { $alien->alien_helper };

      if(my $error = $@)
      {
        $ok = 0;
        push @diag, "  error getting helpers: $error";
      }

      foreach my $name (keys %$help)
      {
        my $code = $help->{$name};
        $intr->replace_helper($name, $code);
      }
    }
  }
  else
  {
    $ok = 0;
    push @diag, "  undefined alien";
  }

  my $ctx = context();
  $ctx->ok($ok, $message);
  $ctx->diag($_) for @diag;
  $ctx->release;

  $ok;
}


sub synthetic
{
  my($opt) = @_;
  $opt ||= {};
  my %alien = %$opt;
  require Test::Alien::Synthetic;
  bless \%alien, 'Test::Alien::Synthetic',
}


sub run_ok
{
  my($command, $message) = @_;

  my(@command) = ref $command ? @$command : (do {
    my $command = $command; # make a copy

    # Double the backslashes so that when they are unescaped by shellwords(),
    # they become a single backslash. This should be fine on Windows since
    # backslashes are not used to escape metacharacters in cmd.exe.
    $command =~ s/\\/\\\\/g if $^O eq 'MSWin32';
    shellwords $command;
  });
  $message ||= ref $command ? "run @command" : "run $command";

  require Test::Alien::Run;
  my $run = bless {
    out    => '',
    err    => '',
    exit   => 0,
    sig    => 0,
    cmd    => [@command],
  }, 'Test::Alien::Run';

  my $ctx = context();
  my $exe = which $command[0];
  if(defined $exe)
  {
    if(ref $command)
    {
      shift @command;
      $run->{cmd} = [$exe, @command];
    }
    else
    {
      $run->{cmd} = [$command];
    }
    my @diag;
    my $ok = 1;
    my($exit, $errno);
    ($run->{out}, $run->{err}, $exit, $errno) = capture {

      if(ref $command)
      {
        system $exe, @command;
      }
      else
      {
        system $command;
      }

      ($?,$!);
    };

    if($exit == -1)
    {
      $ok = 0;
      $run->{fail} = "failed to execute: $errno";
      push @diag, "  failed to execute: $errno";
    }
    elsif($exit & 127)
    {
      $ok = 0;
      push @diag, "  killed with signal: @{[ $exit & 127 ]}";
      $run->{sig} = $exit & 127;
    }
    else
    {
      $run->{exit} = $exit >> 8;
    }

    $ctx->ok($ok, $message);
    $ok
      ? $ctx->note("  using $exe")
      : $ctx->diag("  using $exe");
    $ctx->diag(@diag) for @diag;

  }
  else
  {
    $ctx->ok(0, $message);
    $ctx->diag("  command not found");
    $run->{fail} = 'command not found';
  }

  unless(@aliens || $ENV{TEST_ALIEN_ALIENS_MISSING})
  {
    $ctx->diag("run_ok called without any aliens, you may want to call alien_ok");
  }

  $ctx->release;

  $run;
}


sub _flags
{
  my($class, $method) = @_;
  my $static = "${method}_static";
  $class->can($static) && $class->can('install_type') && $class->install_type eq 'share' && (!$class->can('xs_load'))
    ? $class->$static
    : $class->$method;
}

sub xs_ok
{
  my $cb;
  $cb = pop if defined $_[-1] && ref $_[-1] eq 'CODE';
  my($xs, $message) = @_;
  $message ||= 'xs';

  $xs = { xs => $xs } unless ref $xs;
  # make sure this is a copy because we may
  # modify it.
  $xs->{xs} = "@{[ $xs->{xs} ]}";
  $xs->{pxs}              ||= {};
  $xs->{cbuilder_check}   ||= 'have_compiler';
  $xs->{cbuilder_config}  ||= {};
  $xs->{cbuilder_compile} ||= {};
  $xs->{cbuilder_link}    ||= {};

  require ExtUtils::CBuilder;
  my $skip = do {
    my $have_compiler = $xs->{cbuilder_check};
    my %config = %{ $xs->{cbuilder_config} };
    !ExtUtils::CBuilder->new( config => \%config )->$have_compiler;
  };

  if($skip)
  {
    my $ctx = context();
    $ctx->skip($message, 'test requires a compiler');
    $ctx->skip("$message subtest", 'test requires a compiler') if $cb;
    $ctx->release;
    return;
  }

  if($xs->{cpp} || $xs->{'C++'})
  {
    my $ctx = context();
    $ctx->bail("The cpp and C++ options have been removed from xs_ok");
  }
  else
  {
    $xs->{c_ext} ||= 'c';
  }

  my $verbose = $xs->{verbose} || 0;
  my $ok = 1;
  my @diag;
  my $dir = Alien::Build::Temp->newdir(
    TEMPLATE => 'test-alien-XXXXXX',
    CLEANUP  => $^O =~ /^(MSWin32|cygwin|msys)$/ ? 0 : 1,
  );

  my $xs_filename = path($dir)->child('test.xs')->stringify;
  my $c_filename  = path($dir)->child("test.@{[ $xs->{c_ext} ]}")->stringify;

  my $ctx = context();
  my $module;

  if($ENV{TEST_ALIEN_ALWAYS_KEEP})
  {
    $dir->unlink_on_destroy(0);
    $ctx->note("keeping XS temporary directory $dir at user request");
  }

  if($xs->{xs} =~ /\bTA_MODULE\b/)
  {
    our $count;
    $count = 0 unless defined $count;
    my $name = sprintf "Test::Alien::XS::Mod%s%s", $count, chr(65 + $count % 26 ) x 4;
    $count++;
    my $code = $xs->{xs};
    $code =~ s{\bTA_MODULE\b}{$name}g;
    $xs->{xs} = $code;
  }

  # this regex copied shamefully from ExtUtils::ParseXS
  # in part because we need the module name to do the bootstrap
  # and also because if this regex doesn't match then ParseXS
  # does an exit() which we don't want.
  if($xs->{xs} =~ /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/m)
  {
    $module = $1;
    $ctx->note("detect module name $module") if $verbose;
  }
  else
  {
    $ok = 0;
    push @diag, '  XS does not have a module decleration that we could find';
  }

  if($ok)
  {
    open my $fh, '>', $xs_filename;
    print $fh $xs->{xs};
    close $fh;

    require ExtUtils::ParseXS;
    my $pxs = ExtUtils::ParseXS->new;

    my($out, $err) = capture_merged {
      eval {
        $pxs->process_file(
          filename     => $xs_filename,
          output       => $c_filename,
          versioncheck => 0,
          prototypes   => 0,
          %{ $xs->{pxs} },
        );
      };
      $@;
    };

    $ctx->note("parse xs $xs_filename => $c_filename") if $verbose;
    $ctx->note($out) if $verbose;
    $ctx->note("error: $err") if $verbose && $err;

    unless($pxs->report_error_count == 0)
    {
      $ok = 0;
      push @diag, '  ExtUtils::ParseXS failed:';
      push @diag, "    $err" if $err;
      push @diag, "    $_" for split /\r?\n/, $out;
    }
  }

  push @diag, "xs_ok called without any aliens, you may want to call alien_ok" unless @aliens || $ENV{TEST_ALIEN_ALIENS_MISSING};

  if($ok)
  {
    my $cb = ExtUtils::CBuilder->new(
      config => do {
        my %config = %{ $xs->{cbuilder_config} };
        my $lddlflags = join(' ', grep !/^-l/, shellwords map { _flags $_, 'libs' } @aliens) . " $Config{lddlflags}";
        $config{lddlflags} = defined $config{lddlflags} ? "$lddlflags $config{lddlflags}" : $lddlflags;
        \%config;
      },
    );

    my %compile_options = (
      source               => $c_filename,
      %{ $xs->{cbuilder_compile} },
    );

    if(defined $compile_options{extra_compiler_flags} && ref($compile_options{extra_compiler_flags}) eq '')
    {
      $compile_options{extra_compiler_flags} = [ shellwords $compile_options{extra_compiler_flags} ];
    }

    push @{ $compile_options{extra_compiler_flags} }, shellwords map { _flags $_, 'cflags' } @aliens;

    my($out, $obj, $err) = capture_merged {
      my $obj = eval {
        $cb->compile(%compile_options);
      };
      ($obj, $@);
    };

    $ctx->note("compile $c_filename") if $verbose;
    $ctx->note($out) if $verbose;
    $ctx->note($err) if $verbose && $err;

    if($verbose > 1)
    {
      $ctx->note(_dump({ compile_options => \%compile_options }));
    }

    unless($obj)
    {
      $ok = 0;
      push @diag, '  ExtUtils::CBuilder->compile failed';
      push @diag, "    $err" if $err;
      push @diag, "    $_" for split /\r?\n/, $out;
    }

    if($ok)
    {

      my %link_options = (
        objects            => [$obj],
        module_name        => $module,
        %{ $xs->{cbuilder_link} },
      );

      if(defined $link_options{extra_linker_flags} && ref($link_options{extra_linker_flags}) eq '')
      {
        $link_options{extra_linker_flags} = [ shellwords $link_options{extra_linker_flags} ];
      }

      unshift @{ $link_options{extra_linker_flags} }, grep /^-l/, shellwords map { _flags $_, 'libs' } @aliens;

      my($out, $lib, $err) = capture_merged {
        my $lib = eval {
          $cb->link(%link_options);
        };
        ($lib, $@);
      };

      $ctx->note("link $obj") if $verbose;
      $ctx->note($out) if $verbose;
      $ctx->note($err) if $verbose && $err;

      if($verbose > 1)
      {
        $ctx->note(_dump({ link_options => \%link_options }));
      }

      if($lib && -f $lib)
      {
        $ctx->note("created lib $lib") if $xs->{verbose};
      }
      else
      {
        $ok = 0;
        push @diag, '  ExtUtils::CBuilder->link failed';
        push @diag, "    $err" if $err;
        push @diag, "    $_" for split /\r?\n/, $out;
      }

      if($ok)
      {
        my @modparts = split(/::/,$module);
        my $dl_dlext = $Config{dlext};
        my $modfname = $modparts[-1];

        my $libpath = path($dir)->child('auto', @modparts, "$modfname.$dl_dlext");
        $libpath->parent->mkpath;
        move($lib, "$libpath") || die "unable to copy $lib => $libpath $!";

        pop @modparts;
        my $pmpath = path($dir)->child(@modparts, "$modfname.pm");
        $pmpath->parent->mkpath;
        open my $fh, '>', "$pmpath";

        my($alien_with_xs_load, @rest) = grep { $_->can('xs_load') } @aliens;

        if($alien_with_xs_load)
        {
          {
            no strict 'refs';
            @{join '::', $module, 'rest'} = @rest;
            ${join '::', $module, 'alien_with_xs_load'} = $alien_with_xs_load;
          }
          print $fh '# line '. __LINE__ . ' "' . __FILE__ . qq("\n) . qq{
            package $module;

            use strict;
            use warnings;
            our \$VERSION = '0.01';
            our \@rest;
            our \$alien_with_xs_load;

            \$alien_with_xs_load->xs_load('$module', \$VERSION, \@rest);

            1;
          };
        }
        else
        {
          print $fh '# line '. __LINE__ . ' "' . __FILE__ . qq("\n) . qq{
            package $module;

            use strict;
            use warnings;
            require XSLoader;
            our \$VERSION = '0.01';
            XSLoader::load('$module',\$VERSION);

            1;
          };
        }
        close $fh;

        {
          local @INC = @INC;
          unshift @INC, "$dir";
          ## no critic
          eval '# line '. __LINE__ . ' "' . __FILE__ . qq("\n) . qq{
            use $module;
          };
          ## use critic
        }

        if(my $error = $@)
        {
          $ok = 0;
          push @diag, '  XSLoader failed';
          push @diag, "    $error";
        }
      }
    }
  }

  $ctx->ok($ok, $message);
  $ctx->diag($_) for @diag;
  $ctx->release;

  unless($ok || defined $ENV{TEST_ALIEN_ALWAYS_KEEP})
  {
    $ctx->note("keeping XS temporary directory $dir due to failure");
    $dir->unlink_on_destroy(0);
  }

  if($cb)
  {
    $cb = sub {
      my $ctx = context();
      $ctx->plan(0, 'SKIP', "subtest requires xs success");
      $ctx->release;
    } unless $ok;

    @_ = ("$message subtest", $cb, 1, $module);

    goto \&Test2::API::run_subtest;
  }

  $ok;
}

sub with_subtest (&)
{
  my($code) = @_;

  # it may be possible to catch a segmentation fault,
  # but not with signal handlers apparently.  See:
  # https://feepingcreature.github.io/handling.html
  return $code if $^O eq 'MSWin32';

  # try to catch a segmentation fault and bail out
  # with a useful diagnostic.  prove test to swallow
  # the diagnostic on such failures.
  sub {
    local $SIG{SEGV} = sub {
      my $ctx = context();
      $ctx->bail("Segmentation fault");
    };
    $code->(@_);
  }
}


sub ffi_ok
{
  my $cb;
  $cb = pop if defined $_[-1] && ref $_[-1] eq 'CODE';
  my($opt, $message) = @_;

  $message ||= 'ffi';

  my $ok = 1;
  my $skip;
  my $ffi;
  my @diag;

  {
    my $min = '0.12'; # the first CPAN release
    $min = '0.15' if $opt->{ignore_not_found};
    $min = '0.18' if $opt->{lang};
    $min = '0.99' if defined $opt->{api} && $opt->{api} > 0;
    unless(eval { require FFI::Platypus; FFI::Platypus->VERSION($min) })
    {
      $ok = 0;
      $skip = "Test requires FFI::Platypus $min";
    }
  }

  if($ok && $opt->{lang})
  {
    my $class = "FFI::Platypus::Lang::@{[ $opt->{lang} ]}";
    {
      my $pm = "$class.pm";
      $pm =~ s/::/\//g;
      eval { require $pm };
    }
    if($@)
    {
      $ok = 0;
      $skip = "Test requires FFI::Platypus::Lang::@{[ $opt->{lang} ]}";
    }
  }

  unless(@aliens || $ENV{TEST_ALIEN_ALIENS_MISSING})
  {
    push @diag, 'ffi_ok called without any aliens, you may want to call alien_ok';
  }

  if($ok)
  {
    $ffi = FFI::Platypus->new(
      do {
        my @args = (
          lib              => [map { $_->dynamic_libs } @aliens],
          ignore_not_found => $opt->{ignore_not_found},
          lang             => $opt->{lang},
        );
        push @args, api => $opt->{api} if defined $opt->{api};
        @args;
      }
    );
    foreach my $symbol (@{ $opt->{symbols} || [] })
    {
      unless($ffi->find_symbol($symbol))
      {
        $ok = 0;
        push @diag, "  $symbol not found"
      }
    }
  }

  my $ctx = context();

  if($skip)
  {
    $ctx->skip($message, $skip);
  }
  else
  {
    $ctx->ok($ok, $message);
  }
  $ctx->diag($_) for @diag;

  $ctx->release;

  if($cb)
  {
    $cb = sub {
      my $ctx = context();
      $ctx->plan(0, 'SKIP', "subtest requires ffi success");
      $ctx->release;
    } unless $ok;

    @_ = ("$message subtest", $cb, 1, $ffi);

    goto \&Test2::API::run_subtest;
  }

  $ok;
}


{
  my @ret;

  sub _interpolator
  {
    return @ret if @ret;

    require Alien::Build::Interpolate::Default;
    my $intr = Alien::Build::Interpolate::Default->new;

    require Alien::Build;
    my $build = Alien::Build->new;
    $build->meta->interpolator($intr);

    @ret = ($intr, $build);
  }
}

sub helper_ok
{
  my($name, $message) = @_;

  $message ||= "helper $name exists";

  my($intr) = _interpolator;

  my $code = $intr->has_helper($name);

  my $ok = defined $code;

  my $ctx = context();
  $ctx->ok($ok, $message);
  $ctx->diag("helper_ok called without any aliens, you may want to call alien_ok") unless @aliens || $ENV{TEST_ALIEN_ALIENS_MISSING};
  $ctx->release;

  $ok;
}


sub plugin_ok
{
  my($name, $message) = @_;

  my @args;

  ($name, @args) = @$name if ref $name;

  $message ||= "plugin $name";

  my($intr, $build) = _interpolator;

  my $class = "Alien::Build::Plugin::$name";
  my $pm = "$class.pm";
  $pm =~ s/::/\//g;

  my $ctx = context();

  my $plugin = eval {
    require $pm unless $class->can('new');
    $class->new(@args);
  };

  if(my $error = $@)
  {
    $ctx->ok(0, $message, ['unable to create $name plugin', $error]);
    $ctx->release;
    return 0;
  }

  eval {
    $plugin->init($build->meta);
  };

  if($^O eq 'MSWin32' && ($plugin->isa('Alien::Build::Plugin::Build::MSYS') || $plugin->isa('Alien::Build::Plugin::Build::Autoconf')))
  {
    require Alien::MSYS;
    unshift @PATH, Alien::MSYS::msys_path();
  }

  if(my $error = $@)
  {
    $ctx->ok(0, $message, ['unable to initiate $name plugin', $error]);
    $ctx->release;
    return 0;
  }
  else
  {
    $ctx->ok(1, $message);
    $ctx->release;
    return 1;
  }
}


sub interpolate_template_is
{
  my($template, $pattern, $message) = @_;

  $message ||= "template matches";

  my($intr) = _interpolator;

  my $value = eval { $intr->interpolate($template) };
  my $error = $@;
  my @diag;
  my $ok;

  if($error)
  {
    $ok = 0;
    push @diag, "error in evaluation:";
    push @diag, "  $error";
  }
  elsif(ref($pattern) eq 'Regexp')
  {
    $ok = $value =~ $pattern;
    push @diag, "value '$value' does not match $pattern'" unless $ok;
  }
  else
  {
    $ok = $value eq "$pattern";
    push @diag, "value '$value' does not equal '$pattern'" unless $ok;
  }

  my $ctx = context();
  $ctx->ok($ok, $message, [@diag]);
  $ctx->diag('interpolate_template_is called without any aliens, you may want to call alien_ok') unless @aliens || $ENV{TEST_ALIEN_ALIENS_MISSING};
  $ctx->release;

  $ok;
}


sub interpolate_run_ok
{
  my($template, $message) = @_;

  my(@template) = ref $template ? @$template : ($template);

  my($intr) = _interpolator;

  my $ok = 1;
  my @diag;
  my @command;

  foreach my $template (@template)
  {
    my $command = eval { $intr->interpolate($template) };
    if(my $error = $@)
    {
      $ok = 0;
      push @diag, "error in evaluation:";
      push @diag, "  $error";
    }
    else
    {
      push @command, $command;
    }
  }

  my $ctx = context();

  if($ok)
  {
    my $command = ref $template ? \@command : $command[0];
    $ok = run_ok($command, $message);
  }
  else
  {
    $message ||= "run @template";
    $ctx->ok($ok, $message, [@diag]);
    $ctx->diag('interpolate_run_ok called without any aliens, you may want to call alien_ok') unless @aliens || $ENV{TEST_ALIEN_ALIENS_MISSING};
  }

  $ctx->release;

  $ok;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test::Alien - Testing tools for Alien modules

=head1 VERSION

version 2.83

=head1 SYNOPSIS

Test commands that come with your Alien:

 use Test2::V0;
 use Test::Alien;
 use Alien::patch;
 
 alien_ok 'Alien::patch';
 run_ok([ 'patch', '--version' ])
   ->success
   # we only accept the version written
   # by Larry ...
   ->out_like(qr{Larry Wall});
 
 done_testing;

Test that your library works with C<XS>:

 use Test2::V0;
 use Test::Alien;
 use Alien::Editline;
 
 alien_ok 'Alien::Editline';
 my $xs = do { local $/; <DATA> };
 xs_ok $xs, with_subtest {
   my($module) = @_;
   ok $module->version;
 };
 
 done_testing;
 
 __DATA__
 
 #include "EXTERN.h"
 #include "perl.h"
 #include "XSUB.h"
 #include <editline/readline.h>
 
 const char *
 version(const char *class)
 {
   return rl_library_version;
 }
 
 MODULE = TA_MODULE PACKAGE = TA_MODULE
 
 const char *version(class);
     const char *class;

Test that your library works with L<FFI::Platypus>:

 use Test2::V0;
 use Test::Alien;
 use Alien::LibYAML;
 
 alien_ok 'Alien::LibYAML';
 ffi_ok { symbols => ['yaml_get_version'] }, with_subtest {
   my($ffi) = @_;
   my $get_version = $ffi->function(yaml_get_version => ['int*','int*','int*'] => 'void');
   $get_version->call(\my $major, \my $minor, \my $patch);
   like $major, qr{[0-9]+};
   like $minor, qr{[0-9]+};
   like $patch, qr{[0-9]+};
 };
 
 done_testing;

=head1 DESCRIPTION

This module provides tools for testing L<Alien> modules.  It has hooks
to work easily with L<Alien::Base> based modules, but can also be used
via the synthetic interface to test non L<Alien::Base> based L<Alien>
modules.  It has very modest prerequisites.

Prior to this module the best way to test a L<Alien> module was via L<Test::CChecker>.
The main downside to that module is that it is heavily influenced by and uses
L<ExtUtils::CChecker>, which is a tool for checking at install time various things
about your compiler.  It was also written before L<Alien::Base> became as stable as it
is today.  In particular, L<Test::CChecker> does its testing by creating an executable
and running it.  Unfortunately Perl uses extensions by creating dynamic libraries
and linking them into the Perl process, which is different in subtle and error prone
ways.  This module attempts to test the libraries in the way that they will actually
be used, via either C<XS> or L<FFI::Platypus>.  It also provides a mechanism for
testing binaries that are provided by the various L<Alien> modules (for example
L<Alien::gmake> and L<Alien::patch>).

L<Alien> modules can actually be useable without a compiler, or without L<FFI::Platypus>
(for example, if the library is provided by the system, and you are using L<FFI::Platypus>,
or if you are building from source and you are using C<XS>), so tests with missing
prerequisites are automatically skipped.  For example, L</xs_ok> will automatically skip
itself if a compiler is not found, and L</ffi_ok> will automatically skip itself
if L<FFI::Platypus> is not installed.

=head1 FUNCTIONS

=head2 alien_ok

 alien_ok $alien, $message;
 alien_ok $alien;

Load the given L<Alien> instance or class.  Checks that the instance or class conforms to the same
interface as L<Alien::Base>.  Will be used by subsequent tests.  The C<$alien> module only needs to
provide these methods in order to conform to the L<Alien::Base> interface:

=over 4

=item cflags

String containing the compiler flags

=item libs

String containing the linker and library flags

=item dynamic_libs

List of dynamic libraries.  Returns empty list if the L<Alien> module does not provide this.

=item bin_dir

Directory containing tool binaries.  Returns empty list if the L<Alien> module does not provide
this.

=back

If your L<Alien> module does not conform to this interface then you can create a synthetic L<Alien>
module using the L</synthetic> function.

=head2 synthetic

 my $alien = synthetic \%config;

Create a synthetic L<Alien> module which can be passed into L</alien_ok>.  C<\%config>
can contain these keys (all of which are optional):

=over 4

=item cflags

String containing the compiler flags.

=item cflags_static

String containing the static compiler flags (optional).

=item libs

String containing the linker and library flags.

=item libs_static

String containing the static linker flags (optional).

=item dynamic_libs

List reference containing the dynamic libraries.

=item bin_dir

Tool binary directory.

=item runtime_prop

Runtime properties.

=back

See L<Test::Alien::Synthetic> for more details.

=head2 run_ok

 my $run = run_ok $command;
 my $run = run_ok $command, $message;

Runs the given command, falling back on any C<Alien::Base#bin_dir> methods provided by L<Alien> modules
specified with L</alien_ok>.

C<$command> can be either a string or an array reference.

Only fails if the command cannot be found, or if it is killed by a signal!  Returns a L<Test::Alien::Run>
object, which you can use to test the exit status, output and standard error.

Always returns an instance of L<Test::Alien::Run>, even if the command could not be found.

=head2 xs_ok

 xs_ok $xs;
 xs_ok $xs, $message;

Compiles, links the given C<XS> code and attaches to Perl.

If you use the special module name C<TA_MODULE> in your C<XS>
code, it will be replaced by an automatically generated
package name.  This can be useful if you want to pass the same
C<XS> code to multiple calls to C<xs_ok> without subsequent
calls replacing previous ones.

C<$xs> may be either a string containing the C<XS> code,
or a hash reference with these keys:

=over 4

=item xs

The XS code.  This is the only required element.

=item pxs

Extra L<ExtUtils::ParseXS> arguments passed in as a hash reference.

=item cbuilder_check

The compile check that should be done prior to attempting to build.
Should be one of C<have_compiler> or C<have_cplusplus>.  Defaults
to C<have_compiler>.

=item cbuilder_config

Hash to override values normally provided by C<Config>.

=item cbuilder_compile

Extra The L<ExtUtils::CBuilder> arguments passed in as a hash reference.

=item cbuilder_link

Extra The L<ExtUtils::CBuilder> arguments passed in as a hash reference.

=item verbose

Spew copious debug information via test note.

=back

You can use the C<with_subtest> keyword to conditionally
run a subtest if the C<xs_ok> call succeeds.  If C<xs_ok>
does not work, then the subtest will automatically be
skipped.  Example:

 xs_ok $xs, with_subtest {
   # skipped if $xs fails for some reason
   my($module) = @_;
   is $module->foo, 1;
 };

The module name detected during the XS parsing phase will
be passed in to the subtest.  This is helpful when you are
using a generated module name.

If you need to test XS C++ interfaces, see L<Test::Alien::CPP>.

Caveats: C<xs_ok> uses L<ExtUtils::ParseXS>, which may call C<exit>
under certain error conditions.  While this is not really good
thing to happen in the middle of a test, it usually indicates
a real failure condition, and it should return a failure condition
so the test should still fail overall.

[version 2.53]

As of version 2.53, C<xs_ok> will only remove temporary generated files
if the test is successful by default.  You can force either always
or never removing the temporary generated files using the
C<TEST_ALIEN_ALWAYS_KEEP> environment variable (see L</ENVIRONMENT> below).

=head2 ffi_ok

 ffi_ok;
 ffi_ok \%opt;
 ffi_ok \%opt, $message;

Test that L<FFI::Platypus> works.

C<\%opt> is a hash reference with these keys (all optional):

=over 4

=item symbols

List references of symbols that must be found for the test to succeed.

=item ignore_not_found

Ignores symbols that aren't found.  This affects functions accessed via
L<FFI::Platypus#attach> and L<FFI::Platypus#function> methods, and does
not influence the C<symbols> key above.

=item lang

Set the language.  Used primarily for language specific native types.

=item api

Set the API.  C<api = 1> requires FFI::Platypus 0.99 or later.  This
option was added with Test::Alien version 1.90, so your use line should
include this version as a safeguard to make sure it works:

 use Test::Alien 1.90;
 ...
 ffi_ok ...;

=back

As with L</xs_ok> above, you can use the C<with_subtest> keyword to specify
a subtest to be run if C<ffi_ok> succeeds (it will skip otherwise).  The
L<FFI::Platypus> instance is passed into the subtest as the first argument.
For example:

 ffi_ok with_subtest {
   my($ffi) = @_;
   is $ffi->function(foo => [] => 'void')->call, 42;
 };

=head2 helper_ok

 helper_ok $name;
 helper_ok $name, $message;

Tests that the given helper has been defined.

=head2 plugin_ok

[version 2.52]

 plugin_ok $plugin_name, $message;
 plugin_ok [$plugin_name, @args], $message;

This applies an L<Alien::Build::Plugin> to the interpolator used by L</helper_ok>, L</interpolate_template_is>
and L</interpolate_run_ok> so that you can test with any helpers that plugin provides.  Useful,
for example for getting C<%{configure}> from L<Alien::Build::Plugin::Build::Autoconf>.

=head2 interpolate_template_is

 interpolate_template_is $template, $string;
 interpolate_template_is $template, $string, $message;
 interpolate_template_is $template, $regex;
 interpolate_template_is $template, $regex, $message;

Tests that the given template when evaluated with the appropriate helpers will match
either the given string or regular expression.

=head2 interpolate_run_ok

[version 2.52]

 my $run = interpolate_run_ok $command;
 my $run = interpolate_run_ok $command, $message;

This is the same as L</run_ok> except it runs the command through the interpolator first.

=head1 ENVIRONMENT

=over 4

=item C<TEST_ALIEN_ALWAYS_KEEP>

If this is defined then it will override the built in logic that decides if
the temporary files generated by L</xs_ok> should be kept when the test file
terminates.  If set to true the generated files will always be kept.  If
set to false, then they will always be removed.

=item C<TEST_ALIEN_ALIENS_MISSING>

By default, this module will warn you if some tools are used without first
invoking L</alien_ok>.  This is usually a mistake, but if you really do
want to use one of these tools with no aliens loaded, you can set this
environment variable to false.

=back

=head1 SEE ALSO

=over 4

=item L<Alien>

=item L<Alien::Base>

=item L<Alien::Build>

=item L<alienfile>

=item L<Test2>

=item L<Test::Alien::Run>

=item L<Test::Alien::CanCompile>

=item L<Test::Alien::CanPlatypus>

=item L<Test::Alien::Synthetic>

=item L<Test::Alien::CPP>

=back

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! /p5��K  �K    perl5/Test/Tutorial.podnu ��6�$        =head1 NAME

Test::Tutorial - A tutorial about writing really basic tests

=head1 DESCRIPTION


I<AHHHHHHH!!!!  NOT TESTING!  Anything but testing!
Beat me, whip me, send me to Detroit, but don't make
me write tests!>

I<*sob*>

I<Besides, I don't know how to write the damned things.>


Is this you?  Is writing tests right up there with writing
documentation and having your fingernails pulled out?  Did you open up
a test and read

    ######## We start with some black magic

and decide that's quite enough for you?

It's ok.  That's all gone now.  We've done all the black magic for
you.  And here are the tricks...


=head2 Nuts and bolts of testing.

Here's the most basic test program.

    #!/usr/bin/perl -w

    print "1..1\n";

    print 1 + 1 == 2 ? "ok 1\n" : "not ok 1\n";

Because 1 + 1 is 2, it prints:

    1..1
    ok 1

What this says is: C<1..1> "I'm going to run one test." [1] C<ok 1>
"The first test passed".  And that's about all magic there is to
testing.  Your basic unit of testing is the I<ok>.  For each thing you
test, an C<ok> is printed.  Simple.  L<Test::Harness> interprets your test
results to determine if you succeeded or failed (more on that later).

Writing all these print statements rapidly gets tedious.  Fortunately,
there's L<Test::Simple>.  It has one function, C<ok()>.

    #!/usr/bin/perl -w

    use Test::Simple tests => 1;

    ok( 1 + 1 == 2 );

That does the same thing as the previous code.  C<ok()> is the backbone
of Perl testing, and we'll be using it instead of roll-your-own from
here on.  If C<ok()> gets a true value, the test passes.  False, it
fails.

    #!/usr/bin/perl -w

    use Test::Simple tests => 2;
    ok( 1 + 1 == 2 );
    ok( 2 + 2 == 5 );

From that comes:

    1..2
    ok 1
    not ok 2
    #     Failed test (test.pl at line 5)
    # Looks like you failed 1 tests of 2.

C<1..2> "I'm going to run two tests."  This number is a I<plan>. It helps to
ensure your test program ran all the way through and didn't die or skip some
tests.  C<ok 1> "The first test passed."  C<not ok 2> "The second test failed".
Test::Simple helpfully prints out some extra commentary about your tests.

It's not scary.  Come, hold my hand.  We're going to give an example
of testing a module.  For our example, we'll be testing a date
library, L<Date::ICal>.  It's on CPAN, so download a copy and follow
along. [2]


=head2 Where to start?

This is the hardest part of testing, where do you start?  People often get
overwhelmed at the apparent enormity of the task of testing a whole module.
The best place to start is at the beginning.  L<Date::ICal> is an
object-oriented module, and that means you start by making an object.  Test
C<new()>.

    #!/usr/bin/perl -w

    # assume these two lines are in all subsequent examples
    use strict;
    use warnings;

    use Test::Simple tests => 2;

    use Date::ICal;

    my $ical = Date::ICal->new;         # create an object
    ok( defined $ical );                # check that we got something
    ok( $ical->isa('Date::ICal') );     # and it's the right class

Run that and you should get:

    1..2
    ok 1
    ok 2

Congratulations! You've written your first useful test.


=head2 Names

That output isn't terribly descriptive, is it?  When you have two tests you can
figure out which one is #2, but what if you have 102 tests?

Each test can be given a little descriptive name as the second
argument to C<ok()>.

    use Test::Simple tests => 2;

    ok( defined $ical,              'new() returned something' );
    ok( $ical->isa('Date::ICal'),   "  and it's the right class" );

Now you'll see:

    1..2
    ok 1 - new() returned something
    ok 2 -   and it's the right class


=head2 Test the manual

The simplest way to build up a decent testing suite is to just test what
the manual says it does. [3] Let's pull something out of the
L<Date::ICal/SYNOPSIS> and test that all its bits work.

    #!/usr/bin/perl -w

    use Test::Simple tests => 8;

    use Date::ICal;

    $ical = Date::ICal->new( year => 1964, month => 10, day => 16,
                             hour => 16,   min   => 12, sec => 47,
                             tz   => '0530' );

    ok( defined $ical,            'new() returned something' );
    ok( $ical->isa('Date::ICal'), "  and it's the right class" );
    ok( $ical->sec   == 47,       '  sec()'   );
    ok( $ical->min   == 12,       '  min()'   );
    ok( $ical->hour  == 16,       '  hour()'  );
    ok( $ical->day   == 17,       '  day()'   );
    ok( $ical->month == 10,       '  month()' );
    ok( $ical->year  == 1964,     '  year()'  );

Run that and you get:

    1..8
    ok 1 - new() returned something
    ok 2 -   and it's the right class
    ok 3 -   sec()
    ok 4 -   min()
    ok 5 -   hour()
    not ok 6 -   day()
    #     Failed test (- at line 16)
    ok 7 -   month()
    ok 8 -   year()
    # Looks like you failed 1 tests of 8.

Whoops, a failure! [4] L<Test::Simple> helpfully lets us know on what line the
failure occurred, but not much else.  We were supposed to get 17, but we
didn't.  What did we get??  Dunno.  You could re-run the test in the debugger
or throw in some print statements to find out.

Instead, switch from L<Test::Simple> to L<Test::More>.  L<Test::More>
does everything L<Test::Simple> does, and more!  In fact, L<Test::More> does
things I<exactly> the way L<Test::Simple> does.  You can literally swap
L<Test::Simple> out and put L<Test::More> in its place.  That's just what
we're going to do.

L<Test::More> does more than L<Test::Simple>.  The most important difference at
this point is it provides more informative ways to say "ok".  Although you can
write almost any test with a generic C<ok()>, it can't tell you what went
wrong.  The C<is()> function lets us declare that something is supposed to be
the same as something else:

    use Test::More tests => 8;

    use Date::ICal;

    $ical = Date::ICal->new( year => 1964, month => 10, day => 16,
                             hour => 16,   min   => 12, sec => 47,
                             tz   => '0530' );

    ok( defined $ical,            'new() returned something' );
    ok( $ical->isa('Date::ICal'), "  and it's the right class" );
    is( $ical->sec,     47,       '  sec()'   );
    is( $ical->min,     12,       '  min()'   );
    is( $ical->hour,    16,       '  hour()'  );
    is( $ical->day,     17,       '  day()'   );
    is( $ical->month,   10,       '  month()' );
    is( $ical->year,    1964,     '  year()'  );

"Is C<< $ical->sec >> 47?"  "Is C<< $ical->min >> 12?"  With C<is()> in place,
you get more information:

    1..8
    ok 1 - new() returned something
    ok 2 -   and it's the right class
    ok 3 -   sec()
    ok 4 -   min()
    ok 5 -   hour()
    not ok 6 -   day()
    #     Failed test (- at line 16)
    #          got: '16'
    #     expected: '17'
    ok 7 -   month()
    ok 8 -   year()
    # Looks like you failed 1 tests of 8.

Aha. C<< $ical->day >> returned 16, but we expected 17.  A
quick check shows that the code is working fine, we made a mistake
when writing the tests.  Change it to:

    is( $ical->day,     16,       '  day()'   );

... and everything works.

Any time you're doing a "this equals that" sort of test, use C<is()>.
It even works on arrays.  The test is always in scalar context, so you
can test how many elements are in an array this way. [5]

    is( @foo, 5, 'foo has 5 elements' );


=head2 Sometimes the tests are wrong

This brings up a very important lesson.  Code has bugs.  Tests are
code.  Ergo, tests have bugs.  A failing test could mean a bug in the
code, but don't discount the possibility that the test is wrong.

On the flip side, don't be tempted to prematurely declare a test
incorrect just because you're having trouble finding the bug.
Invalidating a test isn't something to be taken lightly, and don't use
it as a cop out to avoid work.


=head2 Testing lots of values

We're going to be wanting to test a lot of dates here, trying to trick
the code with lots of different edge cases.  Does it work before 1970?
After 2038?  Before 1904?  Do years after 10,000 give it trouble?
Does it get leap years right?  We could keep repeating the code above,
or we could set up a little try/expect loop.

    use Test::More tests => 32;
    use Date::ICal;

    my %ICal_Dates = (
            # An ICal string     And the year, month, day
            #                    hour, minute and second we expect.
            '19971024T120000' =>    # from the docs.
                                [ 1997, 10, 24, 12,  0,  0 ],
            '20390123T232832' =>    # after the Unix epoch
                                [ 2039,  1, 23, 23, 28, 32 ],
            '19671225T000000' =>    # before the Unix epoch
                                [ 1967, 12, 25,  0,  0,  0 ],
            '18990505T232323' =>    # before the MacOS epoch
                                [ 1899,  5,  5, 23, 23, 23 ],
    );


    while( my($ical_str, $expect) = each %ICal_Dates ) {
        my $ical = Date::ICal->new( ical => $ical_str );

        ok( defined $ical,            "new(ical => '$ical_str')" );
        ok( $ical->isa('Date::ICal'), "  and it's the right class" );

        is( $ical->year,    $expect->[0],     '  year()'  );
        is( $ical->month,   $expect->[1],     '  month()' );
        is( $ical->day,     $expect->[2],     '  day()'   );
        is( $ical->hour,    $expect->[3],     '  hour()'  );
        is( $ical->min,     $expect->[4],     '  min()'   );
        is( $ical->sec,     $expect->[5],     '  sec()'   );
    }

Now we can test bunches of dates by just adding them to
C<%ICal_Dates>.  Now that it's less work to test with more dates, you'll
be inclined to just throw more in as you think of them.
Only problem is, every time we add to that we have to keep adjusting
the C<< use Test::More tests => ## >> line.  That can rapidly get
annoying.  There are ways to make this work better.

First, we can calculate the plan dynamically using the C<plan()>
function.

    use Test::More;
    use Date::ICal;

    my %ICal_Dates = (
        ...same as before...
    );

    # For each key in the hash we're running 8 tests.
    plan tests => keys(%ICal_Dates) * 8;

    ...and then your tests...

To be even more flexible, use C<done_testing>.  This means we're just
running some tests, don't know how many. [6]

    use Test::More;   # instead of tests => 32

    ... # tests here

    done_testing();   # reached the end safely

If you don't specify a plan, L<Test::More> expects to see C<done_testing()>
before your program exits. It will warn you if you forget it. You can give
C<done_testing()> an optional number of tests you expected to run, and if the
number ran differs, L<Test::More> will give you another kind of warning.


=head2 Informative names

Take a look at the line:

    ok( defined $ical,            "new(ical => '$ical_str')" );

We've added more detail about what we're testing and the ICal string
itself we're trying out to the name.  So you get results like:

    ok 25 - new(ical => '19971024T120000')
    ok 26 -   and it's the right class
    ok 27 -   year()
    ok 28 -   month()
    ok 29 -   day()
    ok 30 -   hour()
    ok 31 -   min()
    ok 32 -   sec()

If something in there fails, you'll know which one it was and that
will make tracking down the problem easier.  Try to put a bit of
debugging information into the test names.

Describe what the tests test, to make debugging a failed test easier
for you or for the next person who runs your test.


=head2 Skipping tests

Poking around in the existing L<Date::ICal> tests, I found this in
F<t/01sanity.t> [7]

    #!/usr/bin/perl -w

    use Test::More tests => 7;
    use Date::ICal;

    # Make sure epoch time is being handled sanely.
    my $t1 = Date::ICal->new( epoch => 0 );
    is( $t1->epoch, 0,          "Epoch time of 0" );

    # XXX This will only work on unix systems.
    is( $t1->ical, '19700101Z', "  epoch to ical" );

    is( $t1->year,  1970,       "  year()"  );
    is( $t1->month, 1,          "  month()" );
    is( $t1->day,   1,          "  day()"   );

    # like the tests above, but starting with ical instead of epoch
    my $t2 = Date::ICal->new( ical => '19700101Z' );
    is( $t2->ical, '19700101Z', "Start of epoch in ICal notation" );

    is( $t2->epoch, 0,          "  and back to ICal" );

The beginning of the epoch is different on most non-Unix operating systems [8].
Even though Perl smooths out the differences for the most part, certain ports
do it differently.  MacPerl is one off the top of my head. [9]  Rather than
putting a comment in the test and hoping someone will read the test while
debugging the failure, we can explicitly say it's never going to work and skip
the test.

    use Test::More tests => 7;
    use Date::ICal;

    # Make sure epoch time is being handled sanely.
    my $t1 = Date::ICal->new( epoch => 0 );
    is( $t1->epoch, 0,          "Epoch time of 0" );

    SKIP: {
        skip('epoch to ICal not working on Mac OS', 6)
            if $^O eq 'MacOS';

        is( $t1->ical, '19700101Z', "  epoch to ical" );

        is( $t1->year,  1970,       "  year()"  );
        is( $t1->month, 1,          "  month()" );
        is( $t1->day,   1,          "  day()"   );

        # like the tests above, but starting with ical instead of epoch
        my $t2 = Date::ICal->new( ical => '19700101Z' );
        is( $t2->ical, '19700101Z', "Start of epoch in ICal notation" );

        is( $t2->epoch, 0,          "  and back to ICal" );
    }

A little bit of magic happens here.  When running on anything but MacOS, all
the tests run normally.  But when on MacOS, C<skip()> causes the entire
contents of the SKIP block to be jumped over.  It never runs.  Instead,
C<skip()> prints special output that tells L<Test::Harness> that the tests have
been skipped.

    1..7
    ok 1 - Epoch time of 0
    ok 2 # skip epoch to ICal not working on MacOS
    ok 3 # skip epoch to ICal not working on MacOS
    ok 4 # skip epoch to ICal not working on MacOS
    ok 5 # skip epoch to ICal not working on MacOS
    ok 6 # skip epoch to ICal not working on MacOS
    ok 7 # skip epoch to ICal not working on MacOS

This means your tests won't fail on MacOS.  This means fewer emails
from MacPerl users telling you about failing tests that you know will
never work.  You've got to be careful with skip tests.  These are for
tests which don't work and I<never will>.  It is not for skipping
genuine bugs (we'll get to that in a moment).

The tests are wholly and completely skipped. [10]  This will work.

    SKIP: {
        skip("I don't wanna die!");

        die, die, die, die, die;
    }


=head2 Todo tests

While thumbing through the L<Date::ICal> man page, I came across this:

   ical

       $ical_string = $ical->ical;

   Retrieves, or sets, the date on the object, using any
   valid ICal date/time string.

"Retrieves or sets".  Hmmm. I didn't see a test for using C<ical()> to set
the date in the Date::ICal test suite.  So I wrote one:

    use Test::More tests => 1;
    use Date::ICal;

    my $ical = Date::ICal->new;
    $ical->ical('20201231Z');
    is( $ical->ical, '20201231Z',   'Setting via ical()' );

Run that. I saw:

    1..1
    not ok 1 - Setting via ical()
    #     Failed test (- at line 6)
    #          got: '20010814T233649Z'
    #     expected: '20201231Z'
    # Looks like you failed 1 tests of 1.

Whoops!  Looks like it's unimplemented.  Assume you don't have the time to fix
this. [11] Normally, you'd just comment out the test and put a note in a todo
list somewhere.  Instead, explicitly state "this test will fail" by wrapping it
in a C<TODO> block:

    use Test::More tests => 1;

    TODO: {
        local $TODO = 'ical($ical) not yet implemented';

        my $ical = Date::ICal->new;
        $ical->ical('20201231Z');

        is( $ical->ical, '20201231Z',   'Setting via ical()' );
    }

Now when you run, it's a little different:

    1..1
    not ok 1 - Setting via ical() # TODO ical($ical) not yet implemented
    #          got: '20010822T201551Z'
    #     expected: '20201231Z'

L<Test::More> doesn't say "Looks like you failed 1 tests of 1".  That '#
TODO' tells L<Test::Harness> "this is supposed to fail" and it treats a
failure as a successful test.  You can write tests even before
you've fixed the underlying code.

If a TODO test passes, L<Test::Harness> will report it "UNEXPECTEDLY
SUCCEEDED".  When that happens, remove the TODO block with C<local $TODO> and
turn it into a real test.


=head2 Testing with taint mode.

Taint mode is a funny thing.  It's the globalest of all global
features.  Once you turn it on, it affects I<all> code in your program
and I<all> modules used (and all the modules they use).  If a single
piece of code isn't taint clean, the whole thing explodes.  With that
in mind, it's very important to ensure your module works under taint
mode.

It's very simple to have your tests run under taint mode.  Just throw
a C<-T> into the C<#!> line.  L<Test::Harness> will read the switches
in C<#!> and use them to run your tests.

    #!/usr/bin/perl -Tw

    ...test normally here...

When you say C<make test> it will run with taint mode on.


=head1 FOOTNOTES

=over 4

=item 1

The first number doesn't really mean anything, but it has to be 1.
It's the second number that's important.

=item 2

For those following along at home, I'm using version 1.31.  It has
some bugs, which is good -- we'll uncover them with our tests.

=item 3

You can actually take this one step further and test the manual
itself.  Have a look at L<Test::Inline> (formerly L<Pod::Tests>).

=item 4

Yes, there's a mistake in the test suite.  What!  Me, contrived?

=item 5

We'll get to testing the contents of lists later.

=item 6

But what happens if your test program dies halfway through?!  Since we
didn't say how many tests we're going to run, how can we know it
failed?  No problem, L<Test::More> employs some magic to catch that death
and turn the test into a failure, even if every test passed up to that
point.

=item 7

I cleaned it up a little.

=item 8

Most Operating Systems record time as the number of seconds since a
certain date.  This date is the beginning of the epoch.  Unix's starts
at midnight January 1st, 1970 GMT.

=item 9

MacOS's epoch is midnight January 1st, 1904.  VMS's is midnight,
November 17th, 1858, but vmsperl emulates the Unix epoch so it's not a
problem.

=item 10

As long as the code inside the SKIP block at least compiles.  Please
don't ask how.  No, it's not a filter.

=item 11

Do NOT be tempted to use TODO tests as a way to avoid fixing simple
bugs!

=back

=head1 AUTHORS

Michael G Schwern E<lt>schwern@pobox.comE<gt> and the perl-qa dancers!

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2001 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.

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

Irrespective of its distribution, all code examples in these files
are hereby placed into the public domain.  You are permitted and
encouraged to use this code in your own programs for fun
or for profit as you see fit.  A simple comment in the code giving
credit would be courteous but is not required.

=cut
PK       ! vB~��  �    perl5/Test/Pod.pmnu ��6�$        package Test::Pod;

use strict;
use warnings;

=head1 NAME

Test::Pod - check for POD errors in files

=head1 VERSION

Version 1.52

=cut

our $VERSION = '1.52';

=head1 SYNOPSIS

C<Test::Pod> lets you check the validity of a POD file, and report
its results in standard C<Test::Simple> fashion.

    use Test::Pod tests => $num_tests;
    pod_file_ok( $file, "Valid POD file" );

Module authors can include the following in a F<t/pod.t> file and
have C<Test::Pod> automatically find and check all POD files in a
module distribution:

    use Test::More;
    eval "use Test::Pod 1.00";
    plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
    all_pod_files_ok();

You can also specify a list of files to check, using the
C<all_pod_files()> function supplied:

    use strict;
    use Test::More;
    eval "use Test::Pod 1.00";
    plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
    my @poddirs = qw( blib script );
    all_pod_files_ok( all_pod_files( @poddirs ) );

Or even (if you're running under L<Apache::Test>):

    use strict;
    use Test::More;
    eval "use Test::Pod 1.00";
    plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;

    my @poddirs = qw( blib script );
    use File::Spec::Functions qw( catdir updir );
    all_pod_files_ok(
        all_pod_files( map { catdir updir, $_ } @poddirs )
    );

=head1 DESCRIPTION

Check POD files for errors or warnings in a test file, using
C<Pod::Simple> to do the heavy lifting.

=cut

use Test::Builder;
use Pod::Simple;

our %ignore_dirs = (
    '.bzr' => 'Bazaar',
    '.git' => 'Git',
    '.hg'  => 'Mercurial',
    '.pc'  => 'quilt',
    '.svn' => 'Subversion',
    CVS    => 'CVS',
    RCS    => 'RCS',
    SCCS   => 'SCCS',
    _darcs => 'darcs',
    _sgbak => 'Vault/Fortress',
);

my $Test = Test::Builder->new;

sub import {
    my $self = shift;
    my $caller = caller;

    for my $func ( qw( pod_file_ok all_pod_files all_pod_files_ok ) ) {
        no strict 'refs';
        *{$caller."::".$func} = \&$func;
    }

    $Test->exported_to($caller);
    $Test->plan(@_);
}

sub _additional_test_pod_specific_checks {
    my ($ok, $errata, $file) = @_;

    return $ok;
}

=head1 FUNCTIONS

=head2 pod_file_ok( FILENAME[, TESTNAME ] )

C<pod_file_ok()> will okay the test if the POD parses correctly.  Certain
conditions are not reported yet, such as a file with no pod in it at all.

When it fails, C<pod_file_ok()> will show any pod checking errors as
diagnostics.

The optional second argument TESTNAME is the name of the test.  If it
is omitted, C<pod_file_ok()> chooses a default test name "POD test
for FILENAME".

=cut

sub pod_file_ok {
    my $file = shift;
    my $name = @_ ? shift : "POD test for $file";

    if ( !-f $file ) {
        $Test->ok( 0, $name );
        $Test->diag( "$file does not exist" );
        return;
    }

    my $checker = Pod::Simple->new;

    $checker->output_string( \my $trash ); # Ignore any output
    $checker->parse_file( $file );

    my $ok = !$checker->any_errata_seen;
       $ok = _additional_test_pod_specific_checks( $ok, ($checker->{errata}||={}), $file );

    $name .= ' (no pod)' if !$checker->content_seen;
    $Test->ok( $ok, $name );
    if ( !$ok ) {
        my $lines = $checker->{errata};
        for my $line ( sort { $a<=>$b } keys %$lines ) {
            my $errors = $lines->{$line};
            $Test->diag( "$file ($line): $_" ) for @$errors;
        }
    }

    return $ok;
} # pod_file_ok

=head2 all_pod_files_ok( [@entries] )

Checks all the files under C<@entries> for valid POD. It runs
L<all_pod_files()> on directories and assumes everything else to be a file to
be tested. It calls the C<plan()> function for you (one test for each file),
so you can't have already called C<plan>.

If C<@entries> is empty or not passed, the function finds all POD files in
files in the F<blib> directory if it exists, or the F<lib> directory if not.
A POD file matches the conditions specified below in L</all_pod_files>.

If you're testing a module, just make a F<t/pod.t>:

    use Test::More;
    eval "use Test::Pod 1.00";
    plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
    all_pod_files_ok();

Returns true if all pod files are ok, or false if any fail.

=cut

sub all_pod_files_ok {
    my @args = @_ ? @_ : _starting_points();
    my @files = map { -d $_ ? all_pod_files($_) : $_ } @args;

    unless (@files) {
        $Test->skip_all( "No files found in (@args)\n" );
        return 1;
    }

    $Test->plan( tests => scalar @files );

    my $ok = 1;
    foreach my $file ( @files ) {
        pod_file_ok( $file ) or undef $ok;
    }
    return $ok;
}

=head2 all_pod_files( [@dirs] )
X<all_pod_files>

Returns a list of all the POD files in I<@dirs> and in directories below. If
no directories are passed, it defaults to F<blib> if F<blib> exists, or else
F<lib> if not. Skips any files in F<CVS>, F<.svn>, F<.git> and similar
directories. See C<%Test::Pod::ignore_dirs> for a list of them.

A POD file is:

=over 4

=item * Any file that ends in F<.pl>, F<.PL>, F<.pm>, F<.pod>, F<.psgi> or F<.t>.

=item * Any file that has a first line with a shebang and "perl" on it.

=item * Any file that ends in F<.bat> and has a first line with "--*-Perl-*--" on it.

=back

The order of the files returned is machine-dependent.  If you want them
sorted, you'll have to sort them yourself.

=cut

sub all_pod_files {
    my @pod;
    require File::Find;
    File::Find::find({
        preprocess => sub { grep {
            !exists $ignore_dirs{$_}
            || !-d File::Spec->catfile($File::Find::dir, $_)
        } @_ },
        wanted   => sub { -f $_ && _is_perl($_) && push @pod, $File::Find::name },
        no_chdir => 1,
    }, @_ ? @_ : _starting_points());
    return @pod;
}

sub _starting_points {
    return 'blib' if -e 'blib';
    return 'lib';
}

sub _is_perl {
    my $file = shift;

    # accept as a Perl file everything that ends with a well known Perl suffix ...
    return 1 if $file =~ /[.](?:PL|p(?:[lm]|od|sgi)|t)$/;

    open my $fh, '<', $file or return;
    my $first = <$fh>;
    close $fh;
    return unless $first;

    # ... or that has a she-bang as first line ...
    return 1 if $first =~ /^#!.*perl/;

    # ... or that is a .bat ad has a Perl comment line first
    return 1 if $file =~ /[.]bat$/i && $first =~ /--[*]-Perl-[*]--/;

    return;
}

=head1 SUPPORT

This module is managed in an open L<GitHub
repository|http://github.com/perl-pod/test-pod/>. Feel free to fork and
contribute, or to clone L<git://github.com/perl-pod/test-pod.git> and send
patches!

Found a bug? Please L<post|http://github.com/perl-pod/test-pod/issues> or
L<email|mailto:bug-test-pod@rt.cpan.org> a report!

=head1 AUTHORS

=over

=item David E. Wheeler <david@justatheory.com>

Current maintainer.

=item Andy Lester C<< <andy at petdance.com> >>

Maintainer emeritus.

=item brian d foy

Original author.

=back

=head1 ACKNOWLEDGEMENTS

Thanks brian d foy for the original code, and to these folks for contributions:

=over

=item * Andy Lester

=item * David E. Wheeler

=item * Paul Miller

=item * Peter Edwards

=item * Luca Ferrari

=back

=head1 COPYRIGHT AND LICENSE

Copyright 2006-2010, Andy Lester; 2010-2015 David E. Wheeler. Some Rights
Reserved.

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

=cut

1;
PK       ! �e��G  �G    perl5/Test/Tester.pmnu ��6�$        use strict;

package Test::Tester;

BEGIN
{
	if (*Test::Builder::new{CODE})
	{
		warn "You should load Test::Tester before Test::Builder (or anything that loads Test::Builder)"
	}
}

use Test::Builder;
use Test::Tester::CaptureRunner;
use Test::Tester::Delegate;

require Exporter;

use vars qw( @ISA @EXPORT );

our $VERSION = '1.302183';

@EXPORT = qw( run_tests check_tests check_test cmp_results show_space );
@ISA = qw( Exporter );

my $Test = Test::Builder->new;
my $Capture = Test::Tester::Capture->new;
my $Delegator = Test::Tester::Delegate->new;
$Delegator->{Object} = $Test;

my $runner = Test::Tester::CaptureRunner->new;

my $want_space = $ENV{TESTTESTERSPACE};

sub show_space
{
	$want_space = 1;
}

my $colour = '';
my $reset = '';

if (my $want_colour = $ENV{TESTTESTERCOLOUR} || $ENV{TESTTESTERCOLOR})
{
	if (eval { require Term::ANSIColor; 1 })
	{
		eval { require Win32::Console::ANSI } if 'MSWin32' eq $^O;  # support color on windows platforms
		my ($f, $b) = split(",", $want_colour);
		$colour = Term::ANSIColor::color($f).Term::ANSIColor::color("on_$b");
		$reset = Term::ANSIColor::color("reset");
	}

}

sub new_new
{
	return $Delegator;
}

sub capture
{
	return Test::Tester::Capture->new;
}

sub fh
{
	# experiment with capturing output, I don't like it
	$runner = Test::Tester::FHRunner->new;

	return $Test;
}

sub find_run_tests
{
	my $d = 1;
	my $found = 0;
	while ((not $found) and (my ($sub) = (caller($d))[3]) )
	{
#		print "$d: $sub\n";
		$found = ($sub eq "Test::Tester::run_tests");
		$d++;
	}

#	die "Didn't find 'run_tests' in caller stack" unless $found;
	return $d;
}

sub run_tests
{
	local($Delegator->{Object}) = $Capture;

	$runner->run_tests(@_);

	return ($runner->get_premature, $runner->get_results);
}

sub check_test
{
	my $test = shift;
	my $expect = shift;
	my $name = shift;
	$name = "" unless defined($name);

	@_ = ($test, [$expect], $name);
	goto &check_tests;
}

sub check_tests
{
	my $test = shift;
	my $expects = shift;
	my $name = shift;
	$name = "" unless defined($name);

	my ($prem, @results) = eval { run_tests($test, $name) };

	$Test->ok(! $@, "Test '$name' completed") || $Test->diag($@);
	$Test->ok(! length($prem), "Test '$name' no premature diagnostication") ||
		$Test->diag("Before any testing anything, your tests said\n$prem");

	local $Test::Builder::Level = $Test::Builder::Level + 1;
	cmp_results(\@results, $expects, $name);
	return ($prem, @results);
}

sub cmp_field
{
	my ($result, $expect, $field, $desc) = @_;

	if (defined $expect->{$field})
	{
		$Test->is_eq($result->{$field}, $expect->{$field},
			"$desc compare $field");
	}
}

sub cmp_result
{
	my ($result, $expect, $name) = @_;

	my $sub_name = $result->{name};
	$sub_name = "" unless defined($name);

	my $desc = "subtest '$sub_name' of '$name'";

	{
		local $Test::Builder::Level = $Test::Builder::Level + 1;

		cmp_field($result, $expect, "ok", $desc);

		cmp_field($result, $expect, "actual_ok", $desc);

		cmp_field($result, $expect, "type", $desc);

		cmp_field($result, $expect, "reason", $desc);

		cmp_field($result, $expect, "name", $desc);
	}

	# if we got no depth then default to 1
	my $depth = 1;
	if (exists $expect->{depth})
	{
		$depth = $expect->{depth};
	}

	# if depth was explicitly undef then don't test it
	if (defined $depth)
	{
		$Test->is_eq($result->{depth}, $depth, "checking depth") ||
			$Test->diag('You need to change $Test::Builder::Level');
	}

	if (defined(my $exp = $expect->{diag}))
	{

        my $got = '';
        if (ref $exp eq 'Regexp') {

            if (not $Test->like($result->{diag}, $exp,
                "subtest '$sub_name' of '$name' compare diag"))
            {
                $got = $result->{diag};
            }

        } else {

            # if there actually is some diag then put a \n on the end if it's not
            # there already
            $exp .= "\n" if (length($exp) and $exp !~ /\n$/);

            if (not $Test->ok($result->{diag} eq $exp,
    			"subtest '$sub_name' of '$name' compare diag"))
            {
                $got = $result->{diag};
            }
        }

        if ($got) {
    		my $glen = length($got);
    		my $elen = length($exp);
    		for ($got, $exp)
    		{
    			my @lines = split("\n", $_);
     			$_ = join("\n", map {
    				if ($want_space)
    				{
    					$_ = $colour.escape($_).$reset;
    				}
    				else
    				{
    					"'$colour$_$reset'"
    				}
    			} @lines);
    		}

        	$Test->diag(<<EOM);
Got diag ($glen bytes):
$got
Expected diag ($elen bytes):
$exp
EOM
        }
	}
}

sub escape
{
	my $str = shift;
	my $res = '';
	for my $char (split("", $str))
	{
		my $c = ord($char);
		if(($c>32 and $c<125) or $c == 10)
		{
			$res .= $char;
		}
		else
		{
			$res .= sprintf('\x{%x}', $c)
		}
	}
	return $res;
}

sub cmp_results
{
	my ($results, $expects, $name) = @_;

	$Test->is_num(scalar @$results, scalar @$expects, "Test '$name' result count");

	for (my $i = 0; $i < @$expects; $i++)
	{
		my $expect = $expects->[$i];
		my $result = $results->[$i];

		local $Test::Builder::Level = $Test::Builder::Level + 1;
		cmp_result($result, $expect, $name);
	}
}

######## nicked from Test::More
sub plan {
	my(@plan) = @_;

	my $caller = caller;

	$Test->exported_to($caller);

	my @imports = ();
	foreach my $idx (0..$#plan) {
		if( $plan[$idx] eq 'import' ) {
			my($tag, $imports) = splice @plan, $idx, 2;
			@imports = @$imports;
			last;
		}
	}

	$Test->plan(@plan);

	__PACKAGE__->_export_to_level(1, __PACKAGE__, @imports);
}

sub import {
	my($class) = shift;
		{
			no warnings 'redefine';
			*Test::Builder::new = \&new_new;
		}
	goto &plan;
}

sub _export_to_level
{
        my $pkg = shift;
	my $level = shift;
	(undef) = shift;	# redundant arg
	my $callpkg = caller($level);
	$pkg->export($callpkg, @_);
}


############

1;

__END__

=head1 NAME

Test::Tester - Ease testing test modules built with Test::Builder

=head1 SYNOPSIS

  use Test::Tester tests => 6;

  use Test::MyStyle;

  check_test(
    sub {
      is_mystyle_eq("this", "that", "not eq");
    },
    {
      ok => 0, # expect this to fail
      name => "not eq",
      diag => "Expected: 'this'\nGot: 'that'",
    }
  );

or

  use Test::Tester tests => 6;

  use Test::MyStyle;

  check_test(
    sub {
      is_mystyle_qr("this", "that", "not matching");
    },
    {
      ok => 0, # expect this to fail
      name => "not matching",
      diag => qr/Expected: 'this'\s+Got: 'that'/,
    }
  );

or

  use Test::Tester;

  use Test::More tests => 3;
  use Test::MyStyle;

  my ($premature, @results) = run_tests(
    sub {
      is_database_alive("dbname");
    }
  );

  # now use Test::More::like to check the diagnostic output

  like($results[0]->{diag}, "/^Database ping took \\d+ seconds$"/, "diag");

=head1 DESCRIPTION

If you have written a test module based on Test::Builder then Test::Tester
allows you to test it with the minimum of effort.

=head1 HOW TO USE (THE EASY WAY)

From version 0.08 Test::Tester no longer requires you to included anything
special in your test modules. All you need to do is

  use Test::Tester;

in your test script B<before> any other Test::Builder based modules and away
you go.

Other modules based on Test::Builder can be used to help with the
testing.  In fact you can even use functions from your module to test
other functions from the same module (while this is possible it is
probably not a good idea, if your module has bugs, then
using it to test itself may give the wrong answers).

The easiest way to test is to do something like

  check_test(
    sub { is_mystyle_eq("this", "that", "not eq") },
    {
      ok => 0, # we expect the test to fail
      name => "not eq",
      diag => "Expected: 'this'\nGot: 'that'",
    }
  );

this will execute the is_mystyle_eq test, capturing its results and
checking that they are what was expected.

You may need to examine the test results in a more flexible way, for
example, the diagnostic output may be quite long or complex or it may involve
something that you cannot predict in advance like a timestamp. In this case
you can get direct access to the test results:

  my ($premature, @results) = run_tests(
    sub {
      is_database_alive("dbname");
    }
  );

  like($result[0]->{diag}, "/^Database ping took \\d+ seconds$"/, "diag");

or

  check_test(
    sub { is_mystyle_qr("this", "that", "not matching") },
    {
      ok => 0, # we expect the test to fail
      name => "not matching",
      diag => qr/Expected: 'this'\s+Got: 'that'/,
    }
  );

We cannot predict how long the database ping will take so we use
Test::More's like() test to check that the diagnostic string is of the right
form.

=head1 HOW TO USE (THE HARD WAY)

I<This is here for backwards compatibility only>

Make your module use the Test::Tester::Capture object instead of the
Test::Builder one. How to do this depends on your module but assuming that
your module holds the Test::Builder object in $Test and that all your test
routines access it through $Test then providing a function something like this

  sub set_builder
  {
    $Test = shift;
  }

should allow your test scripts to do

  Test::YourModule::set_builder(Test::Tester->capture);

and after that any tests inside your module will captured.

=head1 TEST RESULTS

The result of each test is captured in a hash. These hashes are the same as
the hashes returned by Test::Builder->details but with a couple of extra
fields.

These fields are documented in L<Test::Builder> in the details() function

=over 2

=item ok

Did the test pass?

=item actual_ok

Did the test really pass? That is, did the pass come from
Test::Builder->ok() or did it pass because it was a TODO test?

=item name

The name supplied for the test.

=item type

What kind of test? Possibilities include, skip, todo etc. See
L<Test::Builder> for more details.

=item reason

The reason for the skip, todo etc. See L<Test::Builder> for more details.

=back

These fields are exclusive to Test::Tester.

=over 2

=item diag

Any diagnostics that were output for the test. This only includes
diagnostics output B<after> the test result is declared.

Note that Test::Builder ensures that any diagnostics end in a \n and
it in earlier versions of Test::Tester it was essential that you have
the final \n in your expected diagnostics. From version 0.10 onward,
Test::Tester will add the \n if you forgot it. It will not add a \n if
you are expecting no diagnostics. See below for help tracking down
hard to find space and tab related problems.

=item depth

This allows you to check that your test module is setting the correct value
for $Test::Builder::Level and thus giving the correct file and line number
when a test fails. It is calculated by looking at caller() and
$Test::Builder::Level. It should count how many subroutines there are before
jumping into the function you are testing. So for example in

  run_tests( sub { my_test_function("a", "b") } );

the depth should be 1 and in

  sub deeper { my_test_function("a", "b") }

  run_tests(sub { deeper() });

depth should be 2, that is 1 for the sub {} and one for deeper(). This
might seem a little complex but if your tests look like the simple
examples in this doc then you don't need to worry as the depth will
always be 1 and that's what Test::Tester expects by default.

B<Note>: if you do not specify a value for depth in check_test() then it
automatically compares it against 1, if you really want to skip the depth
test then pass in undef.

B<Note>: depth will not be correctly calculated for tests that run from a
signal handler or an END block or anywhere else that hides the call stack.

=back

Some of Test::Tester's functions return arrays of these hashes, just
like Test::Builder->details. That is, the hash for the first test will
be array element 1 (not 0). Element 0 will not be a hash it will be a
string which contains any diagnostic output that came before the first
test. This should usually be empty, if it's not, it means something
output diagnostics before any test results showed up.

=head1 SPACES AND TABS

Appearances can be deceptive, especially when it comes to emptiness. If you
are scratching your head trying to work out why Test::Tester is saying that
your diagnostics are wrong when they look perfectly right then the answer is
probably whitespace. From version 0.10 on, Test::Tester surrounds the
expected and got diag values with single quotes to make it easier to spot
trailing whitespace. So in this example

  # Got diag (5 bytes):
  # 'abcd '
  # Expected diag (4 bytes):
  # 'abcd'

it is quite clear that there is a space at the end of the first string.
Another way to solve this problem is to use colour and inverse video on an
ANSI terminal, see below COLOUR below if you want this.

Unfortunately this is sometimes not enough, neither colour nor quotes will
help you with problems involving tabs, other non-printing characters and
certain kinds of problems inherent in Unicode. To deal with this, you can
switch Test::Tester into a mode whereby all "tricky" characters are shown as
\{xx}. Tricky characters are those with ASCII code less than 33 or higher
than 126. This makes the output more difficult to read but much easier to
find subtle differences between strings. To turn on this mode either call
C<show_space()> in your test script or set the C<TESTTESTERSPACE> environment
variable to be a true value. The example above would then look like

  # Got diag (5 bytes):
  # abcd\x{20}
  # Expected diag (4 bytes):
  # abcd

=head1 COLOUR

If you prefer to use colour as a means of finding tricky whitespace
characters then you can set the C<TESTTESTCOLOUR> environment variable to a
comma separated pair of colours, the first for the foreground, the second
for the background. For example "white,red" will print white text on a red
background. This requires the Term::ANSIColor module. You can specify any
colour that would be acceptable to the Term::ANSIColor::color function.

If you spell colour differently, that's no problem. The C<TESTTESTERCOLOR>
variable also works (if both are set then the British spelling wins out).

=head1 EXPORTED FUNCTIONS

=head3 ($premature, @results) = run_tests(\&test_sub)

\&test_sub is a reference to a subroutine.

run_tests runs the subroutine in $test_sub and captures the results of any
tests inside it. You can run more than 1 test inside this subroutine if you
like.

$premature is a string containing any diagnostic output from before
the first test.

@results is an array of test result hashes.

=head3 cmp_result(\%result, \%expect, $name)

\%result is a ref to a test result hash.

\%expect is a ref to a hash of expected values for the test result.

cmp_result compares the result with the expected values. If any differences
are found it outputs diagnostics. You may leave out any field from the
expected result and cmp_result will not do the comparison of that field.

=head3 cmp_results(\@results, \@expects, $name)

\@results is a ref to an array of test results.

\@expects is a ref to an array of hash refs.

cmp_results checks that the results match the expected results and if any
differences are found it outputs diagnostics. It first checks that the
number of elements in \@results and \@expects is the same. Then it goes
through each result checking it against the expected result as in
cmp_result() above.

=head3 ($premature, @results) = check_tests(\&test_sub, \@expects, $name)

\&test_sub is a reference to a subroutine.

\@expect is a ref to an array of hash refs which are expected test results.

check_tests combines run_tests and cmp_tests into a single call. It also
checks if the tests died at any stage.

It returns the same values as run_tests, so you can further examine the test
results if you need to.

=head3 ($premature, @results) = check_test(\&test_sub, \%expect, $name)

\&test_sub is a reference to a subroutine.

\%expect is a ref to an hash of expected values for the test result.

check_test is a wrapper around check_tests. It combines run_tests and
cmp_tests into a single call, checking if the test died. It assumes
that only a single test is run inside \&test_sub and include a test to
make sure this is true.

It returns the same values as run_tests, so you can further examine the test
results if you need to.

=head3 show_space()

Turn on the escaping of characters as described in the SPACES AND TABS
section.

=head1 HOW IT WORKS

Normally, a test module (let's call it Test:MyStyle) calls
Test::Builder->new to get the Test::Builder object. Test::MyStyle calls
methods on this object to record information about test results. When
Test::Tester is loaded, it replaces Test::Builder's new() method with one
which returns a Test::Tester::Delegate object. Most of the time this object
behaves as the real Test::Builder object. Any methods that are called are
delegated to the real Test::Builder object so everything works perfectly.
However once we go into test mode, the method calls are no longer passed to
the real Test::Builder object, instead they go to the Test::Tester::Capture
object. This object seems exactly like the real Test::Builder object,
except, instead of outputting test results and diagnostics, it just records
all the information for later analysis.

=head1 CAVEATS

Support for calling Test::Builder->note is minimal. It's implemented
as an empty stub, so modules that use it will not crash but the calls
are not recorded for testing purposes like the others. Patches
welcome.

=head1 SEE ALSO

L<Test::Builder> the source of testing goodness. L<Test::Builder::Tester>
for an alternative approach to the problem tackled by Test::Tester -
captures the strings output by Test::Builder. This means you cannot get
separate access to the individual pieces of information and you must predict
B<exactly> what your test will output.

=head1 AUTHOR

This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
are based on other people's work.

Plan handling lifted from Test::More. written by Michael G Schwern
<schwern@pobox.com>.

Test::Tester::Capture is a cut down and hacked up version of Test::Builder.
Test::Builder was written by chromatic <chromatic@wgz.org> and Michael G
Schwern <schwern@pobox.com>.

=head1 LICENSE

Under the same license as Perl itself

See http://www.perl.com/perl/misc/Artistic.html

=cut
PK       ! Tm����  ��    perl5/Test/More.pmnu ��6�$        package Test::More;

use 5.006;
use strict;
use warnings;

#---- perlcritic exemptions. ----#

# We use a lot of subroutine prototypes
## no critic (Subroutines::ProhibitSubroutinePrototypes)

# Can't use Carp because it might cause C<use_ok()> to accidentally succeed
# even though the module being used forgot to use Carp.  Yes, this
# actually happened.
sub _carp {
    my( $file, $line ) = ( caller(1) )[ 1, 2 ];
    return warn @_, " at $file line $line\n";
}

our $VERSION = '1.302183';

use Test::Builder::Module;
our @ISA    = qw(Test::Builder::Module);
our @EXPORT = qw(ok use_ok require_ok
  is isnt like unlike is_deeply
  cmp_ok
  skip todo todo_skip
  pass fail
  eq_array eq_hash eq_set
  $TODO
  plan
  done_testing
  can_ok isa_ok new_ok
  diag note explain
  subtest
  BAIL_OUT
);

=head1 NAME

Test::More - yet another framework for writing test scripts

=head1 SYNOPSIS

  use Test::More tests => 23;
  # or
  use Test::More skip_all => $reason;
  # or
  use Test::More;   # see done_testing()

  require_ok( 'Some::Module' );

  # Various ways to say "ok"
  ok($got eq $expected, $test_name);

  is  ($got, $expected, $test_name);
  isnt($got, $expected, $test_name);

  # Rather than print STDERR "# here's what went wrong\n"
  diag("here's what went wrong");

  like  ($got, qr/expected/, $test_name);
  unlike($got, qr/expected/, $test_name);

  cmp_ok($got, '==', $expected, $test_name);

  is_deeply($got_complex_structure, $expected_complex_structure, $test_name);

  SKIP: {
      skip $why, $how_many unless $have_some_feature;

      ok( foo(),       $test_name );
      is( foo(42), 23, $test_name );
  };

  TODO: {
      local $TODO = $why;

      ok( foo(),       $test_name );
      is( foo(42), 23, $test_name );
  };

  can_ok($module, @methods);
  isa_ok($object, $class);

  pass($test_name);
  fail($test_name);

  BAIL_OUT($why);

  # UNIMPLEMENTED!!!
  my @status = Test::More::status;


=head1 DESCRIPTION

B<STOP!> If you're just getting started writing tests, have a look at
L<Test2::Suite> first.

This is a drop in replacement for Test::Simple which you can switch to once you
get the hang of basic testing.

The purpose of this module is to provide a wide range of testing
utilities.  Various ways to say "ok" with better diagnostics,
facilities to skip tests, test future features and compare complicated
data structures.  While you can do almost anything with a simple
C<ok()> function, it doesn't provide good diagnostic output.


=head2 I love it when a plan comes together

Before anything else, you need a testing plan.  This basically declares
how many tests your script is going to run to protect against premature
failure.

The preferred way to do this is to declare a plan when you C<use Test::More>.

  use Test::More tests => 23;

There are cases when you will not know beforehand how many tests your
script is going to run.  In this case, you can declare your tests at
the end.

  use Test::More;

  ... run your tests ...

  done_testing( $number_of_tests_run );

B<NOTE> C<done_testing()> should never be called in an C<END { ... }> block.

Sometimes you really don't know how many tests were run, or it's too
difficult to calculate.  In which case you can leave off
$number_of_tests_run.

In some cases, you'll want to completely skip an entire testing script.

  use Test::More skip_all => $skip_reason;

Your script will declare a skip with the reason why you skipped and
exit immediately with a zero (success).  See L<Test::Harness> for
details.

If you want to control what functions Test::More will export, you
have to use the 'import' option.  For example, to import everything
but 'fail', you'd do:

  use Test::More tests => 23, import => ['!fail'];

Alternatively, you can use the C<plan()> function.  Useful for when you
have to calculate the number of tests.

  use Test::More;
  plan tests => keys %Stuff * 3;

or for deciding between running the tests at all:

  use Test::More;
  if( $^O eq 'MacOS' ) {
      plan skip_all => 'Test irrelevant on MacOS';
  }
  else {
      plan tests => 42;
  }

=cut

sub plan {
    my $tb = Test::More->builder;

    return $tb->plan(@_);
}

# This implements "use Test::More 'no_diag'" but the behavior is
# deprecated.
sub import_extra {
    my $class = shift;
    my $list  = shift;

    my @other = ();
    my $idx   = 0;
    my $import;
    while( $idx <= $#{$list} ) {
        my $item = $list->[$idx];

        if( defined $item and $item eq 'no_diag' ) {
            $class->builder->no_diag(1);
        }
        elsif( defined $item and $item eq 'import' ) {
            if ($import) {
                push @$import, @{$list->[ ++$idx ]};
            }
            else {
                $import = $list->[ ++$idx ];
                push @other, $item, $import;
            }
        }
        else {
            push @other, $item;
        }

        $idx++;
    }

    @$list = @other;

    if ($class eq __PACKAGE__ && (!$import || grep $_ eq '$TODO', @$import)) {
        my $to = $class->builder->exported_to;
        no strict 'refs';
        *{"$to\::TODO"} = \our $TODO;
        if ($import) {
            @$import = grep $_ ne '$TODO', @$import;
        }
        else {
            push @$list, import => [grep $_ ne '$TODO', @EXPORT];
        }
    }

    return;
}

=over 4

=item B<done_testing>

    done_testing();
    done_testing($number_of_tests);

If you don't know how many tests you're going to run, you can issue
the plan when you're done running tests.

$number_of_tests is the same as C<plan()>, it's the number of tests you
expected to run.  You can omit this, in which case the number of tests
you ran doesn't matter, just the fact that your tests ran to
conclusion.

This is safer than and replaces the "no_plan" plan.

B<Note:> You must never put C<done_testing()> inside an C<END { ... }> block.
The plan is there to ensure your test does not exit before testing has
completed. If you use an END block you completely bypass this protection.

=back

=cut

sub done_testing {
    my $tb = Test::More->builder;
    $tb->done_testing(@_);
}

=head2 Test names

By convention, each test is assigned a number in order.  This is
largely done automatically for you.  However, it's often very useful to
assign a name to each test.  Which would you rather see:

  ok 4
  not ok 5
  ok 6

or

  ok 4 - basic multi-variable
  not ok 5 - simple exponential
  ok 6 - force == mass * acceleration

The later gives you some idea of what failed.  It also makes it easier
to find the test in your script, simply search for "simple
exponential".

All test functions take a name argument.  It's optional, but highly
suggested that you use it.

=head2 I'm ok, you're not ok.

The basic purpose of this module is to print out either "ok #" or "not
ok #" depending on if a given test succeeded or failed.  Everything
else is just gravy.

All of the following print "ok" or "not ok" depending on if the test
succeeded or failed.  They all also return true or false,
respectively.

=over 4

=item B<ok>

  ok($got eq $expected, $test_name);

This simply evaluates any expression (C<$got eq $expected> is just a
simple example) and uses that to determine if the test succeeded or
failed.  A true expression passes, a false one fails.  Very simple.

For example:

    ok( $exp{9} == 81,                   'simple exponential' );
    ok( Film->can('db_Main'),            'set_db()' );
    ok( $p->tests == 4,                  'saw tests' );
    ok( !grep(!defined $_, @items),      'all items defined' );

(Mnemonic:  "This is ok.")

$test_name is a very short description of the test that will be printed
out.  It makes it very easy to find a test in your script when it fails
and gives others an idea of your intentions.  $test_name is optional,
but we B<very> strongly encourage its use.

Should an C<ok()> fail, it will produce some diagnostics:

    not ok 18 - sufficient mucus
    #   Failed test 'sufficient mucus'
    #   in foo.t at line 42.

This is the same as L<Test::Simple>'s C<ok()> routine.

=cut

sub ok ($;$) {
    my( $test, $name ) = @_;
    my $tb = Test::More->builder;

    return $tb->ok( $test, $name );
}

=item B<is>

=item B<isnt>

  is  ( $got, $expected, $test_name );
  isnt( $got, $expected, $test_name );

Similar to C<ok()>, C<is()> and C<isnt()> compare their two arguments
with C<eq> and C<ne> respectively and use the result of that to
determine if the test succeeded or failed.  So these:

    # Is the ultimate answer 42?
    is( ultimate_answer(), 42,          "Meaning of Life" );

    # $foo isn't empty
    isnt( $foo, '',     "Got some foo" );

are similar to these:

    ok( ultimate_answer() eq 42,        "Meaning of Life" );
    ok( $foo ne '',     "Got some foo" );

C<undef> will only ever match C<undef>.  So you can test a value
against C<undef> like this:

    is($not_defined, undef, "undefined as expected");

(Mnemonic:  "This is that."  "This isn't that.")

So why use these?  They produce better diagnostics on failure.  C<ok()>
cannot know what you are testing for (beyond the name), but C<is()> and
C<isnt()> know what the test was and why it failed.  For example this
test:

    my $foo = 'waffle';  my $bar = 'yarblokos';
    is( $foo, $bar,   'Is foo the same as bar?' );

Will produce something like this:

    not ok 17 - Is foo the same as bar?
    #   Failed test 'Is foo the same as bar?'
    #   in foo.t at line 139.
    #          got: 'waffle'
    #     expected: 'yarblokos'

So you can figure out what went wrong without rerunning the test.

You are encouraged to use C<is()> and C<isnt()> over C<ok()> where possible,
however do not be tempted to use them to find out if something is
true or false!

  # XXX BAD!
  is( exists $brooklyn{tree}, 1, 'A tree grows in Brooklyn' );

This does not check if C<exists $brooklyn{tree}> is true, it checks if
it returns 1.  Very different.  Similar caveats exist for false and 0.
In these cases, use C<ok()>.

  ok( exists $brooklyn{tree},    'A tree grows in Brooklyn' );

A simple call to C<isnt()> usually does not provide a strong test but there
are cases when you cannot say much more about a value than that it is
different from some other value:

  new_ok $obj, "Foo";

  my $clone = $obj->clone;
  isa_ok $obj, "Foo", "Foo->clone";

  isnt $obj, $clone, "clone() produces a different object";

For those grammatical pedants out there, there's an C<isn't()>
function which is an alias of C<isnt()>.

=cut

sub is ($$;$) {
    my $tb = Test::More->builder;

    return $tb->is_eq(@_);
}

sub isnt ($$;$) {
    my $tb = Test::More->builder;

    return $tb->isnt_eq(@_);
}

*isn't = \&isnt;
# ' to unconfuse syntax higlighters

=item B<like>

  like( $got, qr/expected/, $test_name );

Similar to C<ok()>, C<like()> matches $got against the regex C<qr/expected/>.

So this:

    like($got, qr/expected/, 'this is like that');

is similar to:

    ok( $got =~ m/expected/, 'this is like that');

(Mnemonic "This is like that".)

The second argument is a regular expression.  It may be given as a
regex reference (i.e. C<qr//>) or (for better compatibility with older
perls) as a string that looks like a regex (alternative delimiters are
currently not supported):

    like( $got, '/expected/', 'this is like that' );

Regex options may be placed on the end (C<'/expected/i'>).

Its advantages over C<ok()> are similar to that of C<is()> and C<isnt()>.  Better
diagnostics on failure.

=cut

sub like ($$;$) {
    my $tb = Test::More->builder;

    return $tb->like(@_);
}

=item B<unlike>

  unlike( $got, qr/expected/, $test_name );

Works exactly as C<like()>, only it checks if $got B<does not> match the
given pattern.

=cut

sub unlike ($$;$) {
    my $tb = Test::More->builder;

    return $tb->unlike(@_);
}

=item B<cmp_ok>

  cmp_ok( $got, $op, $expected, $test_name );

Halfway between C<ok()> and C<is()> lies C<cmp_ok()>.  This allows you
to compare two arguments using any binary perl operator.  The test
passes if the comparison is true and fails otherwise.

    # ok( $got eq $expected );
    cmp_ok( $got, 'eq', $expected, 'this eq that' );

    # ok( $got == $expected );
    cmp_ok( $got, '==', $expected, 'this == that' );

    # ok( $got && $expected );
    cmp_ok( $got, '&&', $expected, 'this && that' );
    ...etc...

Its advantage over C<ok()> is when the test fails you'll know what $got
and $expected were:

    not ok 1
    #   Failed test in foo.t at line 12.
    #     '23'
    #         &&
    #     undef

It's also useful in those cases where you are comparing numbers and
C<is()>'s use of C<eq> will interfere:

    cmp_ok( $big_hairy_number, '==', $another_big_hairy_number );

It's especially useful when comparing greater-than or smaller-than 
relation between values:

    cmp_ok( $some_value, '<=', $upper_limit );


=cut

sub cmp_ok($$$;$) {
    my $tb = Test::More->builder;

    return $tb->cmp_ok(@_);
}

=item B<can_ok>

  can_ok($module, @methods);
  can_ok($object, @methods);

Checks to make sure the $module or $object can do these @methods
(works with functions, too).

    can_ok('Foo', qw(this that whatever));

is almost exactly like saying:

    ok( Foo->can('this') && 
        Foo->can('that') && 
        Foo->can('whatever') 
      );

only without all the typing and with a better interface.  Handy for
quickly testing an interface.

No matter how many @methods you check, a single C<can_ok()> call counts
as one test.  If you desire otherwise, use:

    foreach my $meth (@methods) {
        can_ok('Foo', $meth);
    }

=cut

sub can_ok ($@) {
    my( $proto, @methods ) = @_;
    my $class = ref $proto || $proto;
    my $tb = Test::More->builder;

    unless($class) {
        my $ok = $tb->ok( 0, "->can(...)" );
        $tb->diag('    can_ok() called with empty class or reference');
        return $ok;
    }

    unless(@methods) {
        my $ok = $tb->ok( 0, "$class->can(...)" );
        $tb->diag('    can_ok() called with no methods');
        return $ok;
    }

    my @nok = ();
    foreach my $method (@methods) {
        $tb->_try( sub { $proto->can($method) } ) or push @nok, $method;
    }

    my $name = (@methods == 1) ? "$class->can('$methods[0]')" :
                                 "$class->can(...)"           ;

    my $ok = $tb->ok( !@nok, $name );

    $tb->diag( map "    $class->can('$_') failed\n", @nok );

    return $ok;
}

=item B<isa_ok>

  isa_ok($object,   $class, $object_name);
  isa_ok($subclass, $class, $object_name);
  isa_ok($ref,      $type,  $ref_name);

Checks to see if the given C<< $object->isa($class) >>.  Also checks to make
sure the object was defined in the first place.  Handy for this sort
of thing:

    my $obj = Some::Module->new;
    isa_ok( $obj, 'Some::Module' );

where you'd otherwise have to write

    my $obj = Some::Module->new;
    ok( defined $obj && $obj->isa('Some::Module') );

to safeguard against your test script blowing up.

You can also test a class, to make sure that it has the right ancestor:

    isa_ok( 'Vole', 'Rodent' );

It works on references, too:

    isa_ok( $array_ref, 'ARRAY' );

The diagnostics of this test normally just refer to 'the object'.  If
you'd like them to be more specific, you can supply an $object_name
(for example 'Test customer').

=cut

sub isa_ok ($$;$) {
    my( $thing, $class, $thing_name ) = @_;
    my $tb = Test::More->builder;

    my $whatami;
    if( !defined $thing ) {
        $whatami = 'undef';
    }
    elsif( ref $thing ) {
        $whatami = 'reference';

        local($@,$!);
        require Scalar::Util;
        if( Scalar::Util::blessed($thing) ) {
            $whatami = 'object';
        }
    }
    else {
        $whatami = 'class';
    }

    # We can't use UNIVERSAL::isa because we want to honor isa() overrides
    my( $rslt, $error ) = $tb->_try( sub { $thing->isa($class) } );

    if($error) {
        die <<WHOA unless $error =~ /^Can't (locate|call) method "isa"/;
WHOA! I tried to call ->isa on your $whatami and got some weird error.
Here's the error.
$error
WHOA
    }

    # Special case for isa_ok( [], "ARRAY" ) and like
    if( $whatami eq 'reference' ) {
        $rslt = UNIVERSAL::isa($thing, $class);
    }

    my($diag, $name);
    if( defined $thing_name ) {
        $name = "'$thing_name' isa '$class'";
        $diag = defined $thing ? "'$thing_name' isn't a '$class'" : "'$thing_name' isn't defined";
    }
    elsif( $whatami eq 'object' ) {
        my $my_class = ref $thing;
        $thing_name = qq[An object of class '$my_class'];
        $name = "$thing_name isa '$class'";
        $diag = "The object of class '$my_class' isn't a '$class'";
    }
    elsif( $whatami eq 'reference' ) {
        my $type = ref $thing;
        $thing_name = qq[A reference of type '$type'];
        $name = "$thing_name isa '$class'";
        $diag = "The reference of type '$type' isn't a '$class'";
    }
    elsif( $whatami eq 'undef' ) {
        $thing_name = 'undef';
        $name = "$thing_name isa '$class'";
        $diag = "$thing_name isn't defined";
    }
    elsif( $whatami eq 'class' ) {
        $thing_name = qq[The class (or class-like) '$thing'];
        $name = "$thing_name isa '$class'";
        $diag = "$thing_name isn't a '$class'";
    }
    else {
        die;
    }

    my $ok;
    if($rslt) {
        $ok = $tb->ok( 1, $name );
    }
    else {
        $ok = $tb->ok( 0, $name );
        $tb->diag("    $diag\n");
    }

    return $ok;
}

=item B<new_ok>

  my $obj = new_ok( $class );
  my $obj = new_ok( $class => \@args );
  my $obj = new_ok( $class => \@args, $object_name );

A convenience function which combines creating an object and calling
C<isa_ok()> on that object.

It is basically equivalent to:

    my $obj = $class->new(@args);
    isa_ok $obj, $class, $object_name;

If @args is not given, an empty list will be used.

This function only works on C<new()> and it assumes C<new()> will return
just a single object which isa C<$class>.

=cut

sub new_ok {
    my $tb = Test::More->builder;
    $tb->croak("new_ok() must be given at least a class") unless @_;

    my( $class, $args, $object_name ) = @_;

    $args ||= [];

    my $obj;
    my( $success, $error ) = $tb->_try( sub { $obj = $class->new(@$args); 1 } );
    if($success) {
        local $Test::Builder::Level = $Test::Builder::Level + 1;
        isa_ok $obj, $class, $object_name;
    }
    else {
        $class = 'undef' if !defined $class;
        $tb->ok( 0, "$class->new() died" );
        $tb->diag("    Error was:  $error");
    }

    return $obj;
}

=item B<subtest>

    subtest $name => \&code, @args;

C<subtest()> runs the &code as its own little test with its own plan and
its own result.  The main test counts this as a single test using the
result of the whole subtest to determine if its ok or not ok.

For example...

  use Test::More tests => 3;
 
  pass("First test");

  subtest 'An example subtest' => sub {
      plan tests => 2;

      pass("This is a subtest");
      pass("So is this");
  };

  pass("Third test");

This would produce.

  1..3
  ok 1 - First test
      # Subtest: An example subtest
      1..2
      ok 1 - This is a subtest
      ok 2 - So is this
  ok 2 - An example subtest
  ok 3 - Third test

A subtest may call C<skip_all>.  No tests will be run, but the subtest is
considered a skip.

  subtest 'skippy' => sub {
      plan skip_all => 'cuz I said so';
      pass('this test will never be run');
  };

Returns true if the subtest passed, false otherwise.

Due to how subtests work, you may omit a plan if you desire.  This adds an
implicit C<done_testing()> to the end of your subtest.  The following two
subtests are equivalent:

  subtest 'subtest with implicit done_testing()', sub {
      ok 1, 'subtests with an implicit done testing should work';
      ok 1, '... and support more than one test';
      ok 1, '... no matter how many tests are run';
  };

  subtest 'subtest with explicit done_testing()', sub {
      ok 1, 'subtests with an explicit done testing should work';
      ok 1, '... and support more than one test';
      ok 1, '... no matter how many tests are run';
      done_testing();
  };

Extra arguments given to C<subtest> are passed to the callback. For example:

    sub my_subtest {
        my $range = shift;
        ...
    }

    for my $range (1, 10, 100, 1000) {
        subtest "testing range $range", \&my_subtest, $range;
    }

=cut

sub subtest {
    my $tb = Test::More->builder;
    return $tb->subtest(@_);
}

=item B<pass>

=item B<fail>

  pass($test_name);
  fail($test_name);

Sometimes you just want to say that the tests have passed.  Usually
the case is you've got some complicated condition that is difficult to
wedge into an C<ok()>.  In this case, you can simply use C<pass()> (to
declare the test ok) or fail (for not ok).  They are synonyms for
C<ok(1)> and C<ok(0)>.

Use these very, very, very sparingly.

=cut

sub pass (;$) {
    my $tb = Test::More->builder;

    return $tb->ok( 1, @_ );
}

sub fail (;$) {
    my $tb = Test::More->builder;

    return $tb->ok( 0, @_ );
}

=back


=head2 Module tests

Sometimes you want to test if a module, or a list of modules, can
successfully load.  For example, you'll often want a first test which
simply loads all the modules in the distribution to make sure they
work before going on to do more complicated testing.

For such purposes we have C<use_ok> and C<require_ok>.

=over 4

=item B<require_ok>

   require_ok($module);
   require_ok($file);

Tries to C<require> the given $module or $file.  If it loads
successfully, the test will pass.  Otherwise it fails and displays the
load error.

C<require_ok> will guess whether the input is a module name or a
filename.

No exception will be thrown if the load fails.

    # require Some::Module
    require_ok "Some::Module";

    # require "Some/File.pl";
    require_ok "Some/File.pl";

    # stop testing if any of your modules will not load
    for my $module (@module) {
        require_ok $module or BAIL_OUT "Can't load $module";
    }

=cut

sub require_ok ($) {
    my($module) = shift;
    my $tb = Test::More->builder;

    my $pack = caller;

    # Try to determine if we've been given a module name or file.
    # Module names must be barewords, files not.
    $module = qq['$module'] unless _is_module_name($module);

    my $code = <<REQUIRE;
package $pack;
require $module;
1;
REQUIRE

    my( $eval_result, $eval_error ) = _eval($code);
    my $ok = $tb->ok( $eval_result, "require $module;" );

    unless($ok) {
        chomp $eval_error;
        $tb->diag(<<DIAGNOSTIC);
    Tried to require '$module'.
    Error:  $eval_error
DIAGNOSTIC

    }

    return $ok;
}

sub _is_module_name {
    my $module = shift;

    # Module names start with a letter.
    # End with an alphanumeric.
    # The rest is an alphanumeric or ::
    $module =~ s/\b::\b//g;

    return $module =~ /^[a-zA-Z]\w*$/ ? 1 : 0;
}


=item B<use_ok>

   BEGIN { use_ok($module); }
   BEGIN { use_ok($module, @imports); }

Like C<require_ok>, but it will C<use> the $module in question and
only loads modules, not files.

If you just want to test a module can be loaded, use C<require_ok>.

If you just want to load a module in a test, we recommend simply using
C<use> directly.  It will cause the test to stop.

It's recommended that you run C<use_ok()> inside a BEGIN block so its
functions are exported at compile-time and prototypes are properly
honored.

If @imports are given, they are passed through to the use.  So this:

   BEGIN { use_ok('Some::Module', qw(foo bar)) }

is like doing this:

   use Some::Module qw(foo bar);

Version numbers can be checked like so:

   # Just like "use Some::Module 1.02"
   BEGIN { use_ok('Some::Module', 1.02) }

Don't try to do this:

   BEGIN {
       use_ok('Some::Module');

       ...some code that depends on the use...
       ...happening at compile time...
   }

because the notion of "compile-time" is relative.  Instead, you want:

  BEGIN { use_ok('Some::Module') }
  BEGIN { ...some code that depends on the use... }

If you want the equivalent of C<use Foo ()>, use a module but not
import anything, use C<require_ok>.

  BEGIN { require_ok "Foo" }

=cut

sub use_ok ($;@) {
    my( $module, @imports ) = @_;
    @imports = () unless @imports;
    my $tb = Test::More->builder;

    my %caller;
    @caller{qw/pack file line sub args want eval req strict warn/} = caller(0);

    my ($pack, $filename, $line, $warn) = @caller{qw/pack file line warn/};
    $filename =~ y/\n\r/_/; # so it doesn't run off the "#line $line $f" line

    my $code;
    if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) {
        # probably a version check.  Perl needs to see the bare number
        # for it to work with non-Exporter based modules.
        $code = <<USE;
package $pack;
BEGIN { \${^WARNING_BITS} = \$args[-1] if defined \$args[-1] }
#line $line $filename
use $module $imports[0];
1;
USE
    }
    else {
        $code = <<USE;
package $pack;
BEGIN { \${^WARNING_BITS} = \$args[-1] if defined \$args[-1] }
#line $line $filename
use $module \@{\$args[0]};
1;
USE
    }

    my ($eval_result, $eval_error) = _eval($code, \@imports, $warn);
    my $ok = $tb->ok( $eval_result, "use $module;" );

    unless($ok) {
        chomp $eval_error;
        $@ =~ s{^BEGIN failed--compilation aborted at .*$}
                {BEGIN failed--compilation aborted at $filename line $line.}m;
        $tb->diag(<<DIAGNOSTIC);
    Tried to use '$module'.
    Error:  $eval_error
DIAGNOSTIC

    }

    return $ok;
}

sub _eval {
    my( $code, @args ) = @_;

    # Work around oddities surrounding resetting of $@ by immediately
    # storing it.
    my( $sigdie, $eval_result, $eval_error );
    {
        local( $@, $!, $SIG{__DIE__} );    # isolate eval
        $eval_result = eval $code;              ## no critic (BuiltinFunctions::ProhibitStringyEval)
        $eval_error  = $@;
        $sigdie      = $SIG{__DIE__} || undef;
    }
    # make sure that $code got a chance to set $SIG{__DIE__}
    $SIG{__DIE__} = $sigdie if defined $sigdie;

    return( $eval_result, $eval_error );
}


=back


=head2 Complex data structures

Not everything is a simple eq check or regex.  There are times you
need to see if two data structures are equivalent.  For these
instances Test::More provides a handful of useful functions.

B<NOTE> I'm not quite sure what will happen with filehandles.

=over 4

=item B<is_deeply>

  is_deeply( $got, $expected, $test_name );

Similar to C<is()>, except that if $got and $expected are references, it
does a deep comparison walking each data structure to see if they are
equivalent.  If the two structures are different, it will display the
place where they start differing.

C<is_deeply()> compares the dereferenced values of references, the
references themselves (except for their type) are ignored.  This means
aspects such as blessing and ties are not considered "different".

C<is_deeply()> currently has very limited handling of function reference
and globs.  It merely checks if they have the same referent.  This may
improve in the future.

L<Test::Differences> and L<Test::Deep> provide more in-depth functionality
along these lines.

B<NOTE> is_deeply() has limitations when it comes to comparing strings and
refs:

    my $path = path('.');
    my $hash = {};
    is_deeply( $path, "$path" ); # ok
    is_deeply( $hash, "$hash" ); # fail

This happens because is_deeply will unoverload all arguments unconditionally.
It is probably best not to use is_deeply with overloading. For legacy reasons
this is not likely to ever be fixed. If you would like a much better tool for
this you should see L<Test2::Suite> Specifically L<Test2::Tools::Compare> has
an C<is()> function that works like C<is_deeply> with many improvements.

=cut

our( @Data_Stack, %Refs_Seen );
my $DNE = bless [], 'Does::Not::Exist';

sub _dne {
    return ref $_[0] eq ref $DNE;
}

## no critic (Subroutines::RequireArgUnpacking)
sub is_deeply {
    my $tb = Test::More->builder;

    unless( @_ == 2 or @_ == 3 ) {
        my $msg = <<'WARNING';
is_deeply() takes two or three args, you gave %d.
This usually means you passed an array or hash instead 
of a reference to it
WARNING
        chop $msg;    # clip off newline so carp() will put in line/file

        _carp sprintf $msg, scalar @_;

        return $tb->ok(0);
    }

    my( $got, $expected, $name ) = @_;

    $tb->_unoverload_str( \$expected, \$got );

    my $ok;
    if( !ref $got and !ref $expected ) {    # neither is a reference
        $ok = $tb->is_eq( $got, $expected, $name );
    }
    elsif( !ref $got xor !ref $expected ) {    # one's a reference, one isn't
        $ok = $tb->ok( 0, $name );
        $tb->diag( _format_stack({ vals => [ $got, $expected ] }) );
    }
    else {                                     # both references
        local @Data_Stack = ();
        if( _deep_check( $got, $expected ) ) {
            $ok = $tb->ok( 1, $name );
        }
        else {
            $ok = $tb->ok( 0, $name );
            $tb->diag( _format_stack(@Data_Stack) );
        }
    }

    return $ok;
}

sub _format_stack {
    my(@Stack) = @_;

    my $var       = '$FOO';
    my $did_arrow = 0;
    foreach my $entry (@Stack) {
        my $type = $entry->{type} || '';
        my $idx = $entry->{'idx'};
        if( $type eq 'HASH' ) {
            $var .= "->" unless $did_arrow++;
            $var .= "{$idx}";
        }
        elsif( $type eq 'ARRAY' ) {
            $var .= "->" unless $did_arrow++;
            $var .= "[$idx]";
        }
        elsif( $type eq 'REF' ) {
            $var = "\${$var}";
        }
    }

    my @vals = @{ $Stack[-1]{vals} }[ 0, 1 ];
    my @vars = ();
    ( $vars[0] = $var ) =~ s/\$FOO/     \$got/;
    ( $vars[1] = $var ) =~ s/\$FOO/\$expected/;

    my $out = "Structures begin differing at:\n";
    foreach my $idx ( 0 .. $#vals ) {
        my $val = $vals[$idx];
        $vals[$idx]
          = !defined $val ? 'undef'
          : _dne($val)    ? "Does not exist"
          : ref $val      ? "$val"
          :                 "'$val'";
    }

    $out .= "$vars[0] = $vals[0]\n";
    $out .= "$vars[1] = $vals[1]\n";

    $out =~ s/^/    /msg;
    return $out;
}

sub _type {
    my $thing = shift;

    return '' if !ref $thing;

    for my $type (qw(Regexp ARRAY HASH REF SCALAR GLOB CODE VSTRING)) {
        return $type if UNIVERSAL::isa( $thing, $type );
    }

    return '';
}

=back


=head2 Diagnostics

If you pick the right test function, you'll usually get a good idea of
what went wrong when it failed.  But sometimes it doesn't work out
that way.  So here we have ways for you to write your own diagnostic
messages which are safer than just C<print STDERR>.

=over 4

=item B<diag>

  diag(@diagnostic_message);

Prints a diagnostic message which is guaranteed not to interfere with
test output.  Like C<print> @diagnostic_message is simply concatenated
together.

Returns false, so as to preserve failure.

Handy for this sort of thing:

    ok( grep(/foo/, @users), "There's a foo user" ) or
        diag("Since there's no foo, check that /etc/bar is set up right");

which would produce:

    not ok 42 - There's a foo user
    #   Failed test 'There's a foo user'
    #   in foo.t at line 52.
    # Since there's no foo, check that /etc/bar is set up right.

You might remember C<ok() or diag()> with the mnemonic C<open() or
die()>.

B<NOTE> The exact formatting of the diagnostic output is still
changing, but it is guaranteed that whatever you throw at it won't
interfere with the test.

=item B<note>

  note(@diagnostic_message);

Like C<diag()>, except the message will not be seen when the test is run
in a harness.  It will only be visible in the verbose TAP stream.

Handy for putting in notes which might be useful for debugging, but
don't indicate a problem.

    note("Tempfile is $tempfile");

=cut

sub diag {
    return Test::More->builder->diag(@_);
}

sub note {
    return Test::More->builder->note(@_);
}

=item B<explain>

  my @dump = explain @diagnostic_message;

Will dump the contents of any references in a human readable format.
Usually you want to pass this into C<note> or C<diag>.

Handy for things like...

    is_deeply($have, $want) || diag explain $have;

or

    note explain \%args;
    Some::Class->method(%args);

=cut

sub explain {
    return Test::More->builder->explain(@_);
}

=back


=head2 Conditional tests

Sometimes running a test under certain conditions will cause the
test script to die.  A certain function or method isn't implemented
(such as C<fork()> on MacOS), some resource isn't available (like a 
net connection) or a module isn't available.  In these cases it's
necessary to skip tests, or declare that they are supposed to fail
but will work in the future (a todo test).

For more details on the mechanics of skip and todo tests see
L<Test::Harness>.

The way Test::More handles this is with a named block.  Basically, a
block of tests which can be skipped over or made todo.  It's best if I
just show you...

=over 4

=item B<SKIP: BLOCK>

  SKIP: {
      skip $why, $how_many if $condition;

      ...normal testing code goes here...
  }

This declares a block of tests that might be skipped, $how_many tests
there are, $why and under what $condition to skip them.  An example is
the easiest way to illustrate:

    SKIP: {
        eval { require HTML::Lint };

        skip "HTML::Lint not installed", 2 if $@;

        my $lint = new HTML::Lint;
        isa_ok( $lint, "HTML::Lint" );

        $lint->parse( $html );
        is( $lint->errors, 0, "No errors found in HTML" );
    }

If the user does not have HTML::Lint installed, the whole block of
code I<won't be run at all>.  Test::More will output special ok's
which Test::Harness interprets as skipped, but passing, tests.

It's important that $how_many accurately reflects the number of tests
in the SKIP block so the # of tests run will match up with your plan.
If your plan is C<no_plan> $how_many is optional and will default to 1.

It's perfectly safe to nest SKIP blocks.  Each SKIP block must have
the label C<SKIP>, or Test::More can't work its magic.

You don't skip tests which are failing because there's a bug in your
program, or for which you don't yet have code written.  For that you
use TODO.  Read on.

=cut

## no critic (Subroutines::RequireFinalReturn)
sub skip {
    my( $why, $how_many ) = @_;
    my $tb = Test::More->builder;

    # If the plan is set, and is static, then skip needs a count. If the plan
    # is 'no_plan' we are fine. As well if plan is undefined then we are
    # waiting for done_testing.
    unless (defined $how_many) {
        my $plan = $tb->has_plan;
        _carp "skip() needs to know \$how_many tests are in the block"
            if $plan && $plan =~ m/^\d+$/;
        $how_many = 1;
    }

    if( defined $how_many and $how_many =~ /\D/ ) {
        _carp
          "skip() was passed a non-numeric number of tests.  Did you get the arguments backwards?";
        $how_many = 1;
    }

    for( 1 .. $how_many ) {
        $tb->skip($why);
    }

    no warnings 'exiting';
    last SKIP;
}

=item B<TODO: BLOCK>

    TODO: {
        local $TODO = $why if $condition;

        ...normal testing code goes here...
    }

Declares a block of tests you expect to fail and $why.  Perhaps it's
because you haven't fixed a bug or haven't finished a new feature:

    TODO: {
        local $TODO = "URI::Geller not finished";

        my $card = "Eight of clubs";
        is( URI::Geller->your_card, $card, 'Is THIS your card?' );

        my $spoon;
        URI::Geller->bend_spoon;
        is( $spoon, 'bent',    "Spoon bending, that's original" );
    }

With a todo block, the tests inside are expected to fail.  Test::More
will run the tests normally, but print out special flags indicating
they are "todo".  L<Test::Harness> will interpret failures as being ok.
Should anything succeed, it will report it as an unexpected success.
You then know the thing you had todo is done and can remove the
TODO flag.

The nice part about todo tests, as opposed to simply commenting out a
block of tests, is that it is like having a programmatic todo list.  You know
how much work is left to be done, you're aware of what bugs there are,
and you'll know immediately when they're fixed.

Once a todo test starts succeeding, simply move it outside the block.
When the block is empty, delete it.


=item B<todo_skip>

    TODO: {
        todo_skip $why, $how_many if $condition;

        ...normal testing code...
    }

With todo tests, it's best to have the tests actually run.  That way
you'll know when they start passing.  Sometimes this isn't possible.
Often a failing test will cause the whole program to die or hang, even
inside an C<eval BLOCK> with and using C<alarm>.  In these extreme
cases you have no choice but to skip over the broken tests entirely.

The syntax and behavior is similar to a C<SKIP: BLOCK> except the
tests will be marked as failing but todo.  L<Test::Harness> will
interpret them as passing.

=cut

sub todo_skip {
    my( $why, $how_many ) = @_;
    my $tb = Test::More->builder;

    unless( defined $how_many ) {
        # $how_many can only be avoided when no_plan is in use.
        _carp "todo_skip() needs to know \$how_many tests are in the block"
          unless $tb->has_plan eq 'no_plan';
        $how_many = 1;
    }

    for( 1 .. $how_many ) {
        $tb->todo_skip($why);
    }

    no warnings 'exiting';
    last TODO;
}

=item When do I use SKIP vs. TODO?

B<If it's something the user might not be able to do>, use SKIP.
This includes optional modules that aren't installed, running under
an OS that doesn't have some feature (like C<fork()> or symlinks), or maybe
you need an Internet connection and one isn't available.

B<If it's something the programmer hasn't done yet>, use TODO.  This
is for any code you haven't written yet, or bugs you have yet to fix,
but want to put tests in your testing script (always a good idea).


=back


=head2 Test control

=over 4

=item B<BAIL_OUT>

    BAIL_OUT($reason);

Indicates to the harness that things are going so badly all testing
should terminate.  This includes the running of any additional test scripts.

This is typically used when testing cannot continue such as a critical
module failing to compile or a necessary external utility not being
available such as a database connection failing.

The test will exit with 255.

For even better control look at L<Test::Most>.

=cut

sub BAIL_OUT {
    my $reason = shift;
    my $tb     = Test::More->builder;

    $tb->BAIL_OUT($reason);
}

=back


=head2 Discouraged comparison functions

The use of the following functions is discouraged as they are not
actually testing functions and produce no diagnostics to help figure
out what went wrong.  They were written before C<is_deeply()> existed
because I couldn't figure out how to display a useful diff of two
arbitrary data structures.

These functions are usually used inside an C<ok()>.

    ok( eq_array(\@got, \@expected) );

C<is_deeply()> can do that better and with diagnostics.  

    is_deeply( \@got, \@expected );

They may be deprecated in future versions.

=over 4

=item B<eq_array>

  my $is_eq = eq_array(\@got, \@expected);

Checks if two arrays are equivalent.  This is a deep check, so
multi-level structures are handled correctly.

=cut

#'#
sub eq_array {
    local @Data_Stack = ();
    _deep_check(@_);
}

sub _eq_array {
    my( $a1, $a2 ) = @_;

    if( grep _type($_) ne 'ARRAY', $a1, $a2 ) {
        warn "eq_array passed a non-array ref";
        return 0;
    }

    return 1 if $a1 eq $a2;

    my $ok = 1;
    my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
    for( 0 .. $max ) {
        my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
        my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];

        next if _equal_nonrefs($e1, $e2);

        push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] };
        $ok = _deep_check( $e1, $e2 );
        pop @Data_Stack if $ok;

        last unless $ok;
    }

    return $ok;
}

sub _equal_nonrefs {
    my( $e1, $e2 ) = @_;

    return if ref $e1 or ref $e2;

    if ( defined $e1 ) {
        return 1 if defined $e2 and $e1 eq $e2;
    }
    else {
        return 1 if !defined $e2;
    }

    return;
}

sub _deep_check {
    my( $e1, $e2 ) = @_;
    my $tb = Test::More->builder;

    my $ok = 0;

    # Effectively turn %Refs_Seen into a stack.  This avoids picking up
    # the same referenced used twice (such as [\$a, \$a]) to be considered
    # circular.
    local %Refs_Seen = %Refs_Seen;

    {
        $tb->_unoverload_str( \$e1, \$e2 );

        # Either they're both references or both not.
        my $same_ref = !( !ref $e1 xor !ref $e2 );
        my $not_ref = ( !ref $e1 and !ref $e2 );

        if( defined $e1 xor defined $e2 ) {
            $ok = 0;
        }
        elsif( !defined $e1 and !defined $e2 ) {
            # Shortcut if they're both undefined.
            $ok = 1;
        }
        elsif( _dne($e1) xor _dne($e2) ) {
            $ok = 0;
        }
        elsif( $same_ref and( $e1 eq $e2 ) ) {
            $ok = 1;
        }
        elsif($not_ref) {
            push @Data_Stack, { type => '', vals => [ $e1, $e2 ] };
            $ok = 0;
        }
        else {
            if( $Refs_Seen{$e1} ) {
                return $Refs_Seen{$e1} eq $e2;
            }
            else {
                $Refs_Seen{$e1} = "$e2";
            }

            my $type = _type($e1);
            $type = 'DIFFERENT' unless _type($e2) eq $type;

            if( $type eq 'DIFFERENT' ) {
                push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
                $ok = 0;
            }
            elsif( $type eq 'ARRAY' ) {
                $ok = _eq_array( $e1, $e2 );
            }
            elsif( $type eq 'HASH' ) {
                $ok = _eq_hash( $e1, $e2 );
            }
            elsif( $type eq 'REF' ) {
                push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
                $ok = _deep_check( $$e1, $$e2 );
                pop @Data_Stack if $ok;
            }
            elsif( $type eq 'SCALAR' ) {
                push @Data_Stack, { type => 'REF', vals => [ $e1, $e2 ] };
                $ok = _deep_check( $$e1, $$e2 );
                pop @Data_Stack if $ok;
            }
            elsif($type) {
                push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
                $ok = 0;
            }
            else {
                _whoa( 1, "No type in _deep_check" );
            }
        }
    }

    return $ok;
}

sub _whoa {
    my( $check, $desc ) = @_;
    if($check) {
        die <<"WHOA";
WHOA!  $desc
This should never happen!  Please contact the author immediately!
WHOA
    }
}

=item B<eq_hash>

  my $is_eq = eq_hash(\%got, \%expected);

Determines if the two hashes contain the same keys and values.  This
is a deep check.

=cut

sub eq_hash {
    local @Data_Stack = ();
    return _deep_check(@_);
}

sub _eq_hash {
    my( $a1, $a2 ) = @_;

    if( grep _type($_) ne 'HASH', $a1, $a2 ) {
        warn "eq_hash passed a non-hash ref";
        return 0;
    }

    return 1 if $a1 eq $a2;

    my $ok = 1;
    my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
    foreach my $k ( keys %$bigger ) {
        my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
        my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;

        next if _equal_nonrefs($e1, $e2);

        push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] };
        $ok = _deep_check( $e1, $e2 );
        pop @Data_Stack if $ok;

        last unless $ok;
    }

    return $ok;
}

=item B<eq_set>

  my $is_eq = eq_set(\@got, \@expected);

Similar to C<eq_array()>, except the order of the elements is B<not>
important.  This is a deep check, but the irrelevancy of order only
applies to the top level.

    ok( eq_set(\@got, \@expected) );

Is better written:

    is_deeply( [sort @got], [sort @expected] );

B<NOTE> By historical accident, this is not a true set comparison.
While the order of elements does not matter, duplicate elements do.

B<NOTE> C<eq_set()> does not know how to deal with references at the top
level.  The following is an example of a comparison which might not work:

    eq_set([\1, \2], [\2, \1]);

L<Test::Deep> contains much better set comparison functions.

=cut

sub eq_set {
    my( $a1, $a2 ) = @_;
    return 0 unless @$a1 == @$a2;

    no warnings 'uninitialized';

    # It really doesn't matter how we sort them, as long as both arrays are
    # sorted with the same algorithm.
    #
    # Ensure that references are not accidentally treated the same as a
    # string containing the reference.
    #
    # Have to inline the sort routine due to a threading/sort bug.
    # See [rt.cpan.org 6782]
    #
    # I don't know how references would be sorted so we just don't sort
    # them.  This means eq_set doesn't really work with refs.
    return eq_array(
        [ grep( ref, @$a1 ), sort( grep( !ref, @$a1 ) ) ],
        [ grep( ref, @$a2 ), sort( grep( !ref, @$a2 ) ) ],
    );
}

=back


=head2 Extending and Embedding Test::More

Sometimes the Test::More interface isn't quite enough.  Fortunately,
Test::More is built on top of L<Test::Builder> which provides a single,
unified backend for any test library to use.  This means two test
libraries which both use <Test::Builder> B<can> be used together in the
same program>.

If you simply want to do a little tweaking of how the tests behave,
you can access the underlying L<Test::Builder> object like so:

=over 4

=item B<builder>

    my $test_builder = Test::More->builder;

Returns the L<Test::Builder> object underlying Test::More for you to play
with.


=back


=head1 EXIT CODES

If all your tests passed, L<Test::Builder> will exit with zero (which is
normal).  If anything failed it will exit with how many failed.  If
you run less (or more) tests than you planned, the missing (or extras)
will be considered failures.  If no tests were ever run L<Test::Builder>
will throw a warning and exit with 255.  If the test died, even after
having successfully completed all its tests, it will still be
considered a failure and will exit with 255.

So the exit codes are...

    0                   all tests successful
    255                 test died or all passed but wrong # of tests run
    any other number    how many failed (including missing or extras)

If you fail more than 254 tests, it will be reported as 254.

B<NOTE>  This behavior may go away in future versions.


=head1 COMPATIBILITY

Test::More works with Perls as old as 5.8.1.

Thread support is not very reliable before 5.10.1, but that's
because threads are not very reliable before 5.10.1.

Although Test::More has been a core module in versions of Perl since 5.6.2, Test::More has evolved since then, and not all of the features you're used to will be present in the shipped version of Test::More. If you are writing a module, don't forget to indicate in your package metadata the minimum version of Test::More that you require. For instance, if you want to use C<done_testing()> but want your test script to run on Perl 5.10.0, you will need to explicitly require Test::More > 0.88.

Key feature milestones include:

=over 4

=item subtests

Subtests were released in Test::More 0.94, which came with Perl 5.12.0. Subtests did not implicitly call C<done_testing()> until 0.96; the first Perl with that fix was Perl 5.14.0 with 0.98.

=item C<done_testing()>

This was released in Test::More 0.88 and first shipped with Perl in 5.10.1 as part of Test::More 0.92. 

=item C<cmp_ok()>

Although C<cmp_ok()> was introduced in 0.40, 0.86 fixed an important bug to make it safe for overloaded objects; the fixed first shipped with Perl in 5.10.1 as part of Test::More 0.92.

=item C<new_ok()> C<note()> and C<explain()>

These were was released in Test::More 0.82, and first shipped with Perl in 5.10.1 as part of Test::More 0.92. 

=back

There is a full version history in the Changes file, and the Test::More versions included as core can be found using L<Module::CoreList>:

    $ corelist -a Test::More


=head1 CAVEATS and NOTES

=over 4

=item utf8 / "Wide character in print"

If you use utf8 or other non-ASCII characters with Test::More you
might get a "Wide character in print" warning.  Using
C<< binmode STDOUT, ":utf8" >> will not fix it.
L<Test::Builder> (which powers
Test::More) duplicates STDOUT and STDERR.  So any changes to them,
including changing their output disciplines, will not be seen by
Test::More.

One work around is to apply encodings to STDOUT and STDERR as early
as possible and before Test::More (or any other Test module) loads.

    use open ':std', ':encoding(utf8)';
    use Test::More;

A more direct work around is to change the filehandles used by
L<Test::Builder>.

    my $builder = Test::More->builder;
    binmode $builder->output,         ":encoding(utf8)";
    binmode $builder->failure_output, ":encoding(utf8)";
    binmode $builder->todo_output,    ":encoding(utf8)";


=item Overloaded objects

String overloaded objects are compared B<as strings> (or in C<cmp_ok()>'s
case, strings or numbers as appropriate to the comparison op).  This
prevents Test::More from piercing an object's interface allowing
better blackbox testing.  So if a function starts returning overloaded
objects instead of bare strings your tests won't notice the
difference.  This is good.

However, it does mean that functions like C<is_deeply()> cannot be used to
test the internals of string overloaded objects.  In this case I would
suggest L<Test::Deep> which contains more flexible testing functions for
complex data structures.


=item Threads

Test::More will only be aware of threads if C<use threads> has been done
I<before> Test::More is loaded.  This is ok:

    use threads;
    use Test::More;

This may cause problems:

    use Test::More
    use threads;

5.8.1 and above are supported.  Anything below that has too many bugs.

=back


=head1 HISTORY

This is a case of convergent evolution with Joshua Pritikin's L<Test>
module.  I was largely unaware of its existence when I'd first
written my own C<ok()> routines.  This module exists because I can't
figure out how to easily wedge test names into Test's interface (along
with a few other problems).

The goal here is to have a testing utility that's simple to learn,
quick to use and difficult to trip yourself up with while still
providing more flexibility than the existing Test.pm.  As such, the
names of the most common routines are kept tiny, special cases and
magic side-effects are kept to a minimum.  WYSIWYG.


=head1 SEE ALSO

=head2

=head2 ALTERNATIVES

L<Test2::Suite> is the most recent and modern set of tools for testing.

L<Test::Simple> if all this confuses you and you just want to write
some tests.  You can upgrade to Test::More later (it's forward
compatible).

L<Test::Legacy> tests written with Test.pm, the original testing
module, do not play well with other testing libraries.  Test::Legacy
emulates the Test.pm interface and does play well with others.

=head2 ADDITIONAL LIBRARIES

L<Test::Differences> for more ways to test complex data structures.
And it plays well with Test::More.

L<Test::Class> is like xUnit but more perlish.

L<Test::Deep> gives you more powerful complex data structure testing.

L<Test::Inline> shows the idea of embedded testing.

L<Mock::Quick> The ultimate mocking library. Easily spawn objects defined on
the fly. Can also override, block, or reimplement packages as needed.

L<Test::FixtureBuilder> Quickly define fixture data for unit tests.

=head2 OTHER COMPONENTS

L<Test::Harness> is the test runner and output interpreter for Perl.
It's the thing that powers C<make test> and where the C<prove> utility
comes from.

=head2 BUNDLES

L<Test::Most> Most commonly needed test functions and features.

=head1 AUTHORS

Michael G Schwern E<lt>schwern@pobox.comE<gt> with much inspiration
from Joshua Pritikin's Test module and lots of help from Barrie
Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and
the perl-qa gang.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back


=head1 BUGS

See F<https://github.com/Test-More/test-more/issues> to report and view bugs.


=head1 SOURCE

The source code repository for Test::More can be found at
F<http://github.com/Test-More/test-more/>.


=head1 COPYRIGHT

Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.

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

See F<http://www.perl.com/perl/misc/Artistic.html>

=cut

1;
PK       ! �+��  �    perl5/Test/Builder/Module.pmnu ��6�$        package Test::Builder::Module;

use strict;

use Test::Builder;

require Exporter;
our @ISA = qw(Exporter);

our $VERSION = '1.302183';


=head1 NAME

Test::Builder::Module - Base class for test modules

=head1 SYNOPSIS

  # Emulates Test::Simple
  package Your::Module;

  my $CLASS = __PACKAGE__;

  use parent 'Test::Builder::Module';
  @EXPORT = qw(ok);

  sub ok ($;$) {
      my $tb = $CLASS->builder;
      return $tb->ok(@_);
  }
  
  1;


=head1 DESCRIPTION

This is a superclass for L<Test::Builder>-based modules.  It provides a
handful of common functionality and a method of getting at the underlying
L<Test::Builder> object.


=head2 Importing

Test::Builder::Module is a subclass of L<Exporter> which means your
module is also a subclass of Exporter.  @EXPORT, @EXPORT_OK, etc...
all act normally.

A few methods are provided to do the C<< use Your::Module tests => 23 >> part
for you.

=head3 import

Test::Builder::Module provides an C<import()> method which acts in the
same basic way as L<Test::More>'s, setting the plan and controlling
exporting of functions and variables.  This allows your module to set
the plan independent of L<Test::More>.

All arguments passed to C<import()> are passed onto 
C<< Your::Module->builder->plan() >> with the exception of 
C<< import =>[qw(things to import)] >>.

    use Your::Module import => [qw(this that)], tests => 23;

says to import the functions C<this()> and C<that()> as well as set the plan
to be 23 tests.

C<import()> also sets the C<exported_to()> attribute of your builder to be
the caller of the C<import()> function.

Additional behaviors can be added to your C<import()> method by overriding
C<import_extra()>.

=cut

sub import {
    my($class) = shift;

    Test2::API::test2_load() unless Test2::API::test2_in_preload();

    # Don't run all this when loading ourself.
    return 1 if $class eq 'Test::Builder::Module';

    my $test = $class->builder;

    my $caller = caller;

    $test->exported_to($caller);

    $class->import_extra( \@_ );
    my(@imports) = $class->_strip_imports( \@_ );

    $test->plan(@_);

    local $Exporter::ExportLevel = $Exporter::ExportLevel + 1;
    $class->Exporter::import(@imports);
}

sub _strip_imports {
    my $class = shift;
    my $list  = shift;

    my @imports = ();
    my @other   = ();
    my $idx     = 0;
    while( $idx <= $#{$list} ) {
        my $item = $list->[$idx];

        if( defined $item and $item eq 'import' ) {
            push @imports, @{ $list->[ $idx + 1 ] };
            $idx++;
        }
        else {
            push @other, $item;
        }

        $idx++;
    }

    @$list = @other;

    return @imports;
}

=head3 import_extra

    Your::Module->import_extra(\@import_args);

C<import_extra()> is called by C<import()>.  It provides an opportunity for you
to add behaviors to your module based on its import list.

Any extra arguments which shouldn't be passed on to C<plan()> should be
stripped off by this method.

See L<Test::More> for an example of its use.

B<NOTE> This mechanism is I<VERY ALPHA AND LIKELY TO CHANGE> as it
feels like a bit of an ugly hack in its current form.

=cut

sub import_extra { }

=head2 Builder

Test::Builder::Module provides some methods of getting at the underlying
Test::Builder object.

=head3 builder

  my $builder = Your::Class->builder;

This method returns the L<Test::Builder> object associated with Your::Class.
It is not a constructor so you can call it as often as you like.

This is the preferred way to get the L<Test::Builder> object.  You should
I<not> get it via C<< Test::Builder->new >> as was previously
recommended.

The object returned by C<builder()> may change at runtime so you should
call C<builder()> inside each function rather than store it in a global.

  sub ok {
      my $builder = Your::Class->builder;

      return $builder->ok(@_);
  }


=cut

sub builder {
    return Test::Builder->new;
}

=head1 SEE ALSO

L<< Test2::Manual::Tooling::TestBuilder >> describes the improved
options for writing testing modules provided by L<< Test2 >>.

=cut

1;
PK       ! ��u�9  9    perl5/Test/Builder/TodoDiag.pmnu ��6�$        package Test::Builder::TodoDiag;
use strict;
use warnings;

our $VERSION = '1.302183';

BEGIN { require Test2::Event::Diag; our @ISA = qw(Test2::Event::Diag) }

sub diagnostics { 0 }

sub facet_data {
    my $self = shift;
    my $out = $self->SUPER::facet_data();
    $out->{info}->[0]->{debug} = 0;
    return $out;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test::Builder::TodoDiag - Test::Builder subclass of Test2::Event::Diag

=head1 DESCRIPTION

This is used to encapsulate diag messages created inside TODO.

=head1 SYNOPSIS

You do not need to use this directly.

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! �+w�  �  "  perl5/Test/Builder/Tester/Color.pmnu ��6�$        package Test::Builder::Tester::Color;

use strict;
our $VERSION = '1.302183';

require Test::Builder::Tester;


=head1 NAME

Test::Builder::Tester::Color - turn on colour in Test::Builder::Tester

=head1 SYNOPSIS

   When running a test script

     perl -MTest::Builder::Tester::Color test.t

=head1 DESCRIPTION

Importing this module causes the subroutine color in Test::Builder::Tester
to be called with a true value causing colour highlighting to be turned
on in debug output.

The sole purpose of this module is to enable colour highlighting
from the command line.

=cut

sub import {
    Test::Builder::Tester::color(1);
}

=head1 AUTHOR

Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002.

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

=head1 BUGS

This module will have no effect unless Term::ANSIColor is installed.

=head1 SEE ALSO

L<Test::Builder::Tester>, L<Term::ANSIColor>

=cut

1;
PK       ! �i�J  J    perl5/Test/Builder/Formatter.pmnu ��6�$        package Test::Builder::Formatter;
use strict;
use warnings;

our $VERSION = '1.302183';

BEGIN { require Test2::Formatter::TAP; our @ISA = qw(Test2::Formatter::TAP) }

use Test2::Util::HashBase qw/no_header no_diag/;

BEGIN {
    *OUT_STD = Test2::Formatter::TAP->can('OUT_STD');
    *OUT_ERR = Test2::Formatter::TAP->can('OUT_ERR');

    my $todo = OUT_ERR() + 1;
    *OUT_TODO = sub() { $todo };
}

sub init {
    my $self = shift;
    $self->SUPER::init(@_);
    $self->{+HANDLES}->[OUT_TODO] = $self->{+HANDLES}->[OUT_STD];
}

sub plan_tap {
    my ($self, $f) = @_;

    return if $self->{+NO_HEADER};
    return $self->SUPER::plan_tap($f);
}

sub debug_tap {
    my ($self, $f, $num) = @_;
    return if $self->{+NO_DIAG};
    my @out = $self->SUPER::debug_tap($f, $num);
    $self->redirect(\@out) if @out && ref $f->{about} && defined $f->{about}->{package}
        && $f->{about}->{package} eq 'Test::Builder::TodoDiag';
    return @out;
}

sub info_tap {
    my ($self, $f) = @_;
    return if $self->{+NO_DIAG};
    my @out = $self->SUPER::info_tap($f);
    $self->redirect(\@out) if @out && ref $f->{about} && defined $f->{about}->{package}
        && $f->{about}->{package} eq 'Test::Builder::TodoDiag';
    return @out;
}

sub redirect {
    my ($self, $out) = @_;
    $_->[0] = OUT_TODO for @$out;
}

sub no_subtest_space { 1 }

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test::Builder::Formatter - Test::Builder subclass of Test2::Formatter::TAP

=head1 DESCRIPTION

This is what takes events and turns them into TAP.

=head1 SYNOPSIS

    use Test::Builder; # Loads Test::Builder::Formatter for you

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! Iz2sF  sF    perl5/Test/Builder/Tester.pmnu ��6�$        package Test::Builder::Tester;

use strict;
our $VERSION = '1.302183';

use Test::Builder;
use Symbol;
use Carp;

=head1 NAME

Test::Builder::Tester - test testsuites that have been built with
Test::Builder

=head1 SYNOPSIS

    use Test::Builder::Tester tests => 1;
    use Test::More;

    test_out("not ok 1 - foo");
    test_fail(+1);
    fail("foo");
    test_test("fail works");

=head1 DESCRIPTION

A module that helps you test testing modules that are built with
L<Test::Builder>.

The testing system is designed to be used by performing a three step
process for each test you wish to test.  This process starts with using
C<test_out> and C<test_err> in advance to declare what the testsuite you
are testing will output with L<Test::Builder> to stdout and stderr.

You then can run the test(s) from your test suite that call
L<Test::Builder>.  At this point the output of L<Test::Builder> is
safely captured by L<Test::Builder::Tester> rather than being
interpreted as real test output.

The final stage is to call C<test_test> that will simply compare what you
predeclared to what L<Test::Builder> actually outputted, and report the
results back with a "ok" or "not ok" (with debugging) to the normal
output.

=cut

####
# set up testing
####

my $t = Test::Builder->new;

###
# make us an exporter
###

use Exporter;
our @ISA = qw(Exporter);

our @EXPORT = qw(test_out test_err test_fail test_diag test_test line_num);

sub import {
    my $class = shift;
    my(@plan) = @_;

    my $caller = caller;

    $t->exported_to($caller);
    $t->plan(@plan);

    my @imports = ();
    foreach my $idx ( 0 .. $#plan ) {
        if( $plan[$idx] eq 'import' ) {
            @imports = @{ $plan[ $idx + 1 ] };
            last;
        }
    }

    __PACKAGE__->export_to_level( 1, __PACKAGE__, @imports );
}

###
# set up file handles
###

# create some private file handles
my $output_handle = gensym;
my $error_handle  = gensym;

# and tie them to this package
my $out = tie *$output_handle, "Test::Builder::Tester::Tie", "STDOUT";
my $err = tie *$error_handle,  "Test::Builder::Tester::Tie", "STDERR";

####
# exported functions
####

# for remembering that we're testing and where we're testing at
my $testing = 0;
my $testing_num;
my $original_is_passing;

# remembering where the file handles were originally connected
my $original_output_handle;
my $original_failure_handle;
my $original_todo_handle;
my $original_formatter;

my $original_harness_env;

# function that starts testing and redirects the filehandles for now
sub _start_testing {
    # Hack for things that conditioned on Test-Stream being loaded
    $INC{'Test/Stream.pm'} ||= 'fake' if $INC{'Test/Moose/More.pm'};
    # even if we're running under Test::Harness pretend we're not
    # for now.  This needed so Test::Builder doesn't add extra spaces
    $original_harness_env = $ENV{HARNESS_ACTIVE} || 0;
    $ENV{HARNESS_ACTIVE} = 0;

    my $hub = $t->{Hub} || ($t->{Stack} ? $t->{Stack}->top : Test2::API::test2_stack->top);
    $original_formatter = $hub->format;
    unless ($original_formatter && $original_formatter->isa('Test::Builder::Formatter')) {
        my $fmt = Test::Builder::Formatter->new;
        $hub->format($fmt);
    }

    # remember what the handles were set to
    $original_output_handle  = $t->output();
    $original_failure_handle = $t->failure_output();
    $original_todo_handle    = $t->todo_output();

    # switch out to our own handles
    $t->output($output_handle);
    $t->failure_output($error_handle);
    $t->todo_output($output_handle);

    # clear the expected list
    $out->reset();
    $err->reset();

    # remember that we're testing
    $testing     = 1;
    $testing_num = $t->current_test;
    $t->current_test(0);
    $original_is_passing  = $t->is_passing;
    $t->is_passing(1);

    # look, we shouldn't do the ending stuff
    $t->no_ending(1);
}

=head2 Functions

These are the six methods that are exported as default.

=over 4

=item test_out

=item test_err

Procedures for predeclaring the output that your test suite is
expected to produce until C<test_test> is called.  These procedures
automatically assume that each line terminates with "\n".  So

   test_out("ok 1","ok 2");

is the same as

   test_out("ok 1\nok 2");

which is even the same as

   test_out("ok 1");
   test_out("ok 2");

Once C<test_out> or C<test_err> (or C<test_fail> or C<test_diag>) have
been called, all further output from L<Test::Builder> will be
captured by L<Test::Builder::Tester>.  This means that you will not
be able perform further tests to the normal output in the normal way
until you call C<test_test> (well, unless you manually meddle with the
output filehandles)

=cut

sub test_out {
    # do we need to do any setup?
    _start_testing() unless $testing;

    $out->expect(@_);
}

sub test_err {
    # do we need to do any setup?
    _start_testing() unless $testing;

    $err->expect(@_);
}

=item test_fail

Because the standard failure message that L<Test::Builder> produces
whenever a test fails will be a common occurrence in your test error
output, and because it has changed between Test::Builder versions, rather
than forcing you to call C<test_err> with the string all the time like
so

    test_err("# Failed test ($0 at line ".line_num(+1).")");

C<test_fail> exists as a convenience function that can be called
instead.  It takes one argument, the offset from the current line that
the line that causes the fail is on.

    test_fail(+1);

This means that the example in the synopsis could be rewritten
more simply as:

   test_out("not ok 1 - foo");
   test_fail(+1);
   fail("foo");
   test_test("fail works");

=cut

sub test_fail {
    # do we need to do any setup?
    _start_testing() unless $testing;

    # work out what line we should be on
    my( $package, $filename, $line ) = caller;
    $line = $line + ( shift() || 0 );    # prevent warnings

    # expect that on stderr
    $err->expect("#     Failed test ($filename at line $line)");
}

=item test_diag

As most of the remaining expected output to the error stream will be
created by L<Test::Builder>'s C<diag> function, L<Test::Builder::Tester>
provides a convenience function C<test_diag> that you can use instead of
C<test_err>.

The C<test_diag> function prepends comment hashes and spacing to the
start and newlines to the end of the expected output passed to it and
adds it to the list of expected error output.  So, instead of writing

   test_err("# Couldn't open file");

you can write

   test_diag("Couldn't open file");

Remember that L<Test::Builder>'s diag function will not add newlines to
the end of output and test_diag will. So to check

   Test::Builder->new->diag("foo\n","bar\n");

You would do

  test_diag("foo","bar")

without the newlines.

=cut

sub test_diag {
    # do we need to do any setup?
    _start_testing() unless $testing;

    # expect the same thing, but prepended with "#     "
    local $_;
    $err->expect( map { "# $_" } @_ );
}

=item test_test

Actually performs the output check testing the tests, comparing the
data (with C<eq>) that we have captured from L<Test::Builder> against
what was declared with C<test_out> and C<test_err>.

This takes name/value pairs that effect how the test is run.

=over

=item title (synonym 'name', 'label')

The name of the test that will be displayed after the C<ok> or C<not
ok>.

=item skip_out

Setting this to a true value will cause the test to ignore if the
output sent by the test to the output stream does not match that
declared with C<test_out>.

=item skip_err

Setting this to a true value will cause the test to ignore if the
output sent by the test to the error stream does not match that
declared with C<test_err>.

=back

As a convenience, if only one argument is passed then this argument
is assumed to be the name of the test (as in the above examples.)

Once C<test_test> has been run test output will be redirected back to
the original filehandles that L<Test::Builder> was connected to
(probably STDOUT and STDERR,) meaning any further tests you run
will function normally and cause success/errors for L<Test::Harness>.

=cut

sub test_test {
    # END the hack
    delete $INC{'Test/Stream.pm'} if $INC{'Test/Stream.pm'} && $INC{'Test/Stream.pm'} eq 'fake';
    # decode the arguments as described in the pod
    my $mess;
    my %args;
    if( @_ == 1 ) {
        $mess = shift
    }
    else {
        %args = @_;
        $mess = $args{name} if exists( $args{name} );
        $mess = $args{title} if exists( $args{title} );
        $mess = $args{label} if exists( $args{label} );
    }

    # er, are we testing?
    croak "Not testing.  You must declare output with a test function first."
      unless $testing;


    my $hub = $t->{Hub} || Test2::API::test2_stack->top;
    $hub->format($original_formatter);

    # okay, reconnect the test suite back to the saved handles
    $t->output($original_output_handle);
    $t->failure_output($original_failure_handle);
    $t->todo_output($original_todo_handle);

    # restore the test no, etc, back to the original point
    $t->current_test($testing_num);
    $testing = 0;
    $t->is_passing($original_is_passing);

    # re-enable the original setting of the harness
    $ENV{HARNESS_ACTIVE} = $original_harness_env;

    # check the output we've stashed
    unless( $t->ok( ( $args{skip_out} || $out->check ) &&
                    ( $args{skip_err} || $err->check ), $mess ) 
    )
    {
        # print out the diagnostic information about why this
        # test failed

        local $_;

        $t->diag( map { "$_\n" } $out->complaint )
          unless $args{skip_out} || $out->check;

        $t->diag( map { "$_\n" } $err->complaint )
          unless $args{skip_err} || $err->check;
    }
}

=item line_num

A utility function that returns the line number that the function was
called on.  You can pass it an offset which will be added to the
result.  This is very useful for working out the correct text of
diagnostic functions that contain line numbers.

Essentially this is the same as the C<__LINE__> macro, but the
C<line_num(+3)> idiom is arguably nicer.

=cut

sub line_num {
    my( $package, $filename, $line ) = caller;
    return $line + ( shift() || 0 );    # prevent warnings
}

=back

In addition to the six exported functions there exists one
function that can only be accessed with a fully qualified function
call.

=over 4

=item color

When C<test_test> is called and the output that your tests generate
does not match that which you declared, C<test_test> will print out
debug information showing the two conflicting versions.  As this
output itself is debug information it can be confusing which part of
the output is from C<test_test> and which was the original output from
your original tests.  Also, it may be hard to spot things like
extraneous whitespace at the end of lines that may cause your test to
fail even though the output looks similar.

To assist you C<test_test> can colour the background of the debug
information to disambiguate the different types of output. The debug
output will have its background coloured green and red.  The green
part represents the text which is the same between the executed and
actual output, the red shows which part differs.

The C<color> function determines if colouring should occur or not.
Passing it a true or false value will enable or disable colouring
respectively, and the function called with no argument will return the
current setting.

To enable colouring from the command line, you can use the
L<Text::Builder::Tester::Color> module like so:

   perl -Mlib=Text::Builder::Tester::Color test.t

Or by including the L<Test::Builder::Tester::Color> module directly in
the PERL5LIB.

=cut

my $color;

sub color {
    $color = shift if @_;
    $color;
}

=back

=head1 BUGS

Test::Builder::Tester does not handle plans well. It has never done anything
special with plans. This means that plans from outside Test::Builder::Tester
will effect Test::Builder::Tester, worse plans when using Test::Builder::Tester
will effect overall testing. At this point there are no plans to fix this bug
as people have come to depend on it, and Test::Builder::Tester is now
discouraged in favor of C<Test2::API::intercept()>. See
L<https://github.com/Test-More/test-more/issues/667>

Calls C<< Test::Builder->no_ending >> turning off the ending tests.
This is needed as otherwise it will trip out because we've run more
tests than we strictly should have and it'll register any failures we
had that we were testing for as real failures.

The color function doesn't work unless L<Term::ANSIColor> is
compatible with your terminal. Additionally, L<Win32::Console::ANSI>
must be installed on windows platforms for color output.

Bugs (and requests for new features) can be reported to the author
though GitHub:
L<https://github.com/Test-More/test-more/issues>

=head1 AUTHOR

Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.

Some code taken from L<Test::More> and L<Test::Catch>, written by
Michael G Schwern E<lt>schwern@pobox.comE<gt>.  Hence, those parts
Copyright Micheal G Schwern 2001.  Used and distributed with
permission.

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

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 NOTES

Thanks to Richard Clamp E<lt>richardc@unixbeard.netE<gt> for letting
me use his testing system to try this module out on.

=head1 SEE ALSO

L<Test::Builder>, L<Test::Builder::Tester::Color>, L<Test::More>.

=cut

1;

####################################################################
# Helper class that is used to remember expected and received data

package Test::Builder::Tester::Tie;

##
# add line(s) to be expected

sub expect {
    my $self = shift;

    my @checks = @_;
    foreach my $check (@checks) {
        $check = $self->_account_for_subtest($check);
        $check = $self->_translate_Failed_check($check);
        push @{ $self->{wanted} }, ref $check ? $check : "$check\n";
    }
}

sub _account_for_subtest {
    my( $self, $check ) = @_;

    my $hub = $t->{Stack}->top;
    my $nesting = $hub->isa('Test2::Hub::Subtest') ? $hub->nested : 0;
    return ref($check) ? $check : ('    ' x $nesting) . $check;
}

sub _translate_Failed_check {
    my( $self, $check ) = @_;

    if( $check =~ /\A(.*)#     (Failed .*test) \((.*?) at line (\d+)\)\Z(?!\n)/ ) {
        $check = "/\Q$1\E#\\s+\Q$2\E.*?\\n?.*?\Qat $3\E line \Q$4\E.*\\n?/";
    }

    return $check;
}

##
# return true iff the expected data matches the got data

sub check {
    my $self = shift;

    # turn off warnings as these might be undef
    local $^W = 0;

    my @checks = @{ $self->{wanted} };
    my $got    = $self->{got};
    foreach my $check (@checks) {
        $check = "\Q$check\E" unless( $check =~ s,^/(.*)/$,$1, or ref $check );
        return 0 unless $got =~ s/^$check//;
    }

    return length $got == 0;
}

##
# a complaint message about the inputs not matching (to be
# used for debugging messages)

sub complaint {
    my $self   = shift;
    my $type   = $self->type;
    my $got    = $self->got;
    my $wanted = join '', @{ $self->wanted };

    # are we running in colour mode?
    if(Test::Builder::Tester::color) {
        # get color
        eval { require Term::ANSIColor };
        unless($@) {
            eval { require Win32::Console::ANSI } if 'MSWin32' eq $^O;  # support color on windows platforms

            # colours

            my $green = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_green");
            my $red   = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_red");
            my $reset = Term::ANSIColor::color("reset");

            # work out where the two strings start to differ
            my $char = 0;
            $char++ while substr( $got, $char, 1 ) eq substr( $wanted, $char, 1 );

            # get the start string and the two end strings
            my $start = $green . substr( $wanted, 0, $char );
            my $gotend    = $red . substr( $got,    $char ) . $reset;
            my $wantedend = $red . substr( $wanted, $char ) . $reset;

            # make the start turn green on and off
            $start =~ s/\n/$reset\n$green/g;

            # make the ends turn red on and off
            $gotend    =~ s/\n/$reset\n$red/g;
            $wantedend =~ s/\n/$reset\n$red/g;

            # rebuild the strings
            $got    = $start . $gotend;
            $wanted = $start . $wantedend;
        }
    }

    my @got = split "\n", $got;
    my @wanted = split "\n", $wanted;

    $got = "";
    $wanted = "";

    while (@got || @wanted) {
        my $g = shift @got    || "";
        my $w = shift @wanted || "";
        if ($g ne $w) {
            if($g =~ s/(\s+)$/    |> /g) {
                $g .= ($_ eq ' ' ? '_' : '\t') for split '', $1;
            }
            if($w =~ s/(\s+)$/    |> /g) {
                $w .= ($_ eq ' ' ? '_' : '\t') for split '', $1;
            }
            $g = "> $g";
            $w = "> $w";
        }
        else {
            $g = "  $g";
            $w = "  $w";
        }
        $got = $got ? "$got\n$g" : $g;
        $wanted = $wanted ? "$wanted\n$w" : $w;
    }

    return "$type is:\n" . "$got\nnot:\n$wanted\nas expected";
}

##
# forget all expected and got data

sub reset {
    my $self = shift;
    %$self = (
        type   => $self->{type},
        got    => '',
        wanted => [],
    );
}

sub got {
    my $self = shift;
    return $self->{got};
}

sub wanted {
    my $self = shift;
    return $self->{wanted};
}

sub type {
    my $self = shift;
    return $self->{type};
}

###
# tie interface
###

sub PRINT {
    my $self = shift;
    $self->{got} .= join '', @_;
}

sub TIEHANDLE {
    my( $class, $type ) = @_;

    my $self = bless { type => $type }, $class;

    $self->reset;

    return $self;
}

sub READ     { }
sub READLINE { }
sub GETC     { }
sub FILENO   { }

1;
PK       ! ���H5  H5    perl5/Test/Builder/IO/Scalar.pmnu ��6�$        package Test::Builder::IO::Scalar;


=head1 NAME

Test::Builder::IO::Scalar - A copy of IO::Scalar for Test::Builder

=head1 DESCRIPTION

This is a copy of L<IO::Scalar> which ships with L<Test::Builder> to
support scalar references as filehandles on Perl 5.6.  Newer
versions of Perl simply use C<open()>'s built in support.

L<Test::Builder> can not have dependencies on other modules without
careful consideration, so its simply been copied into the distribution.

=head1 COPYRIGHT and LICENSE

This file came from the "IO-stringy" Perl5 toolkit.

Copyright (c) 1996 by Eryq.  All rights reserved.
Copyright (c) 1999,2001 by ZeeGee Software Inc.  All rights reserved.

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


=cut

# This is copied code, I don't care.
##no critic

use Carp;
use strict;
use vars qw($VERSION @ISA);
use IO::Handle;

use 5.005;

### The package version, both in 1.23 style *and* usable by MakeMaker:
$VERSION = "2.114";

### Inheritance:
@ISA = qw(IO::Handle);

#==============================

=head2 Construction

=over 4

=cut

#------------------------------

=item new [ARGS...]

I<Class method.>
Return a new, unattached scalar handle.
If any arguments are given, they're sent to open().

=cut

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self = bless \do { local *FH }, $class;
    tie *$self, $class, $self;
    $self->open(@_);   ### open on anonymous by default
    $self;
}
sub DESTROY {
    shift->close;
}

#------------------------------

=item open [SCALARREF]

I<Instance method.>
Open the scalar handle on a new scalar, pointed to by SCALARREF.
If no SCALARREF is given, a "private" scalar is created to hold
the file data.

Returns the self object on success, undefined on error.

=cut

sub open {
    my ($self, $sref) = @_;

    ### Sanity:
    defined($sref) or do {my $s = ''; $sref = \$s};
    (ref($sref) eq "SCALAR") or croak "open() needs a ref to a scalar";

    ### Setup:
    *$self->{Pos} = 0;          ### seek position
    *$self->{SR}  = $sref;      ### scalar reference
    $self;
}

#------------------------------

=item opened

I<Instance method.>
Is the scalar handle opened on something?

=cut

sub opened {
    *{shift()}->{SR};
}

#------------------------------

=item close

I<Instance method.>
Disassociate the scalar handle from its underlying scalar.
Done automatically on destroy.

=cut

sub close {
    my $self = shift;
    %{*$self} = ();
    1;
}

=back

=cut


#==============================

=head2 Input and output

=over 4

=cut


#------------------------------

=item flush

I<Instance method.>
No-op, provided for OO compatibility.

=cut

sub flush { "0 but true" }

#------------------------------

=item getc

I<Instance method.>
Return the next character, or undef if none remain.

=cut

sub getc {
    my $self = shift;

    ### Return undef right away if at EOF; else, move pos forward:
    return undef if $self->eof;
    substr(${*$self->{SR}}, *$self->{Pos}++, 1);
}

#------------------------------

=item getline

I<Instance method.>
Return the next line, or undef on end of string.
Can safely be called in an array context.
Currently, lines are delimited by "\n".

=cut

sub getline {
    my $self = shift;

    ### Return undef right away if at EOF:
    return undef if $self->eof;

    ### Get next line:
    my $sr = *$self->{SR};
    my $i  = *$self->{Pos};	        ### Start matching at this point.

    ### Minimal impact implementation!
    ### We do the fast fast thing (no regexps) if using the
    ### classic input record separator.

    ### Case 1: $/ is undef: slurp all...
    if    (!defined($/)) {
	*$self->{Pos} = length $$sr;
        return substr($$sr, $i);
    }

    ### Case 2: $/ is "\n": zoom zoom zoom...
    elsif ($/ eq "\012") {

        ### Seek ahead for "\n"... yes, this really is faster than regexps.
        my $len = length($$sr);
        for (; $i < $len; ++$i) {
           last if ord (substr ($$sr, $i, 1)) == 10;
        }

        ### Extract the line:
        my $line;
        if ($i < $len) {                ### We found a "\n":
            $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos} + 1);
            *$self->{Pos} = $i+1;            ### Remember where we finished up.
        }
        else {                          ### No "\n"; slurp the remainder:
            $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos});
            *$self->{Pos} = $len;
        }
        return $line;
    }

    ### Case 3: $/ is ref to int. Do fixed-size records.
    ###        (Thanks to Dominique Quatravaux.)
    elsif (ref($/)) {
        my $len = length($$sr);
		my $i = ${$/} + 0;
		my $line = substr ($$sr, *$self->{Pos}, $i);
		*$self->{Pos} += $i;
        *$self->{Pos} = $len if (*$self->{Pos} > $len);
		return $line;
    }

    ### Case 4: $/ is either "" (paragraphs) or something weird...
    ###         This is Graham's general-purpose stuff, which might be
    ###         a tad slower than Case 2 for typical data, because
    ###         of the regexps.
    else {
        pos($$sr) = $i;

	### If in paragraph mode, skip leading lines (and update i!):
        length($/) or
	    (($$sr =~ m/\G\n*/g) and ($i = pos($$sr)));

        ### If we see the separator in the buffer ahead...
        if (length($/)
	    ?  $$sr =~ m,\Q$/\E,g          ###   (ordinary sep) TBD: precomp!
            :  $$sr =~ m,\n\n,g            ###   (a paragraph)
            ) {
            *$self->{Pos} = pos $$sr;
            return substr($$sr, $i, *$self->{Pos}-$i);
        }
        ### Else if no separator remains, just slurp the rest:
        else {
            *$self->{Pos} = length $$sr;
            return substr($$sr, $i);
        }
    }
}

#------------------------------

=item getlines

I<Instance method.>
Get all remaining lines.
It will croak() if accidentally called in a scalar context.

=cut

sub getlines {
    my $self = shift;
    wantarray or croak("can't call getlines in scalar context!");
    my ($line, @lines);
    push @lines, $line while (defined($line = $self->getline));
    @lines;
}

#------------------------------

=item print ARGS...

I<Instance method.>
Print ARGS to the underlying scalar.

B<Warning:> this continues to always cause a seek to the end
of the string, but if you perform seek()s and tell()s, it is
still safer to explicitly seek-to-end before subsequent print()s.

=cut

sub print {
    my $self = shift;
    *$self->{Pos} = length(${*$self->{SR}} .= join('', @_) . (defined($\) ? $\ : ""));
    1;
}
sub _unsafe_print {
    my $self = shift;
    my $append = join('', @_) . $\;
    ${*$self->{SR}} .= $append;
    *$self->{Pos}   += length($append);
    1;
}
sub _old_print {
    my $self = shift;
    ${*$self->{SR}} .= join('', @_) . $\;
    *$self->{Pos} = length(${*$self->{SR}});
    1;
}


#------------------------------

=item read BUF, NBYTES, [OFFSET]

I<Instance method.>
Read some bytes from the scalar.
Returns the number of bytes actually read, 0 on end-of-file, undef on error.

=cut

sub read {
    my $self = $_[0];
    my $n    = $_[2];
    my $off  = $_[3] || 0;

    my $read = substr(${*$self->{SR}}, *$self->{Pos}, $n);
    $n = length($read);
    *$self->{Pos} += $n;
    ($off ? substr($_[1], $off) : $_[1]) = $read;
    return $n;
}

#------------------------------

=item write BUF, NBYTES, [OFFSET]

I<Instance method.>
Write some bytes to the scalar.

=cut

sub write {
    my $self = $_[0];
    my $n    = $_[2];
    my $off  = $_[3] || 0;

    my $data = substr($_[1], $off, $n);
    $n = length($data);
    $self->print($data);
    return $n;
}

#------------------------------

=item sysread BUF, LEN, [OFFSET]

I<Instance method.>
Read some bytes from the scalar.
Returns the number of bytes actually read, 0 on end-of-file, undef on error.

=cut

sub sysread {
  my $self = shift;
  $self->read(@_);
}

#------------------------------

=item syswrite BUF, NBYTES, [OFFSET]

I<Instance method.>
Write some bytes to the scalar.

=cut

sub syswrite {
  my $self = shift;
  $self->write(@_);
}

=back

=cut


#==============================

=head2 Seeking/telling and other attributes

=over 4

=cut


#------------------------------

=item autoflush

I<Instance method.>
No-op, provided for OO compatibility.

=cut

sub autoflush {}

#------------------------------

=item binmode

I<Instance method.>
No-op, provided for OO compatibility.

=cut

sub binmode {}

#------------------------------

=item clearerr

I<Instance method.>  Clear the error and EOF flags.  A no-op.

=cut

sub clearerr { 1 }

#------------------------------

=item eof

I<Instance method.>  Are we at end of file?

=cut

sub eof {
    my $self = shift;
    (*$self->{Pos} >= length(${*$self->{SR}}));
}

#------------------------------

=item seek OFFSET, WHENCE

I<Instance method.>  Seek to a given position in the stream.

=cut

sub seek {
    my ($self, $pos, $whence) = @_;
    my $eofpos = length(${*$self->{SR}});

    ### Seek:
    if    ($whence == 0) { *$self->{Pos} = $pos }             ### SEEK_SET
    elsif ($whence == 1) { *$self->{Pos} += $pos }            ### SEEK_CUR
    elsif ($whence == 2) { *$self->{Pos} = $eofpos + $pos}    ### SEEK_END
    else                 { croak "bad seek whence ($whence)" }

    ### Fixup:
    if (*$self->{Pos} < 0)       { *$self->{Pos} = 0 }
    if (*$self->{Pos} > $eofpos) { *$self->{Pos} = $eofpos }
    return 1;
}

#------------------------------

=item sysseek OFFSET, WHENCE

I<Instance method.> Identical to C<seek OFFSET, WHENCE>, I<q.v.>

=cut

sub sysseek {
    my $self = shift;
    $self->seek (@_);
}

#------------------------------

=item tell

I<Instance method.>
Return the current position in the stream, as a numeric offset.

=cut

sub tell { *{shift()}->{Pos} }

#------------------------------

=item  use_RS [YESNO]

I<Instance method.>
B<Deprecated and ignored.>
Obey the current setting of $/, like IO::Handle does?
Default is false in 1.x, but cold-welded true in 2.x and later.

=cut

sub use_RS {
    my ($self, $yesno) = @_;
    carp "use_RS is deprecated and ignored; \$/ is always consulted\n";
 }

#------------------------------

=item setpos POS

I<Instance method.>
Set the current position, using the opaque value returned by C<getpos()>.

=cut

sub setpos { shift->seek($_[0],0) }

#------------------------------

=item getpos

I<Instance method.>
Return the current position in the string, as an opaque object.

=cut

*getpos = \&tell;


#------------------------------

=item sref

I<Instance method.>
Return a reference to the underlying scalar.

=cut

sub sref { *{shift()}->{SR} }


#------------------------------
# Tied handle methods...
#------------------------------

# Conventional tiehandle interface:
sub TIEHANDLE {
    ((defined($_[1]) && UNIVERSAL::isa($_[1], __PACKAGE__))
     ? $_[1]
     : shift->new(@_));
}
sub GETC      { shift->getc(@_) }
sub PRINT     { shift->print(@_) }
sub PRINTF    { shift->print(sprintf(shift, @_)) }
sub READ      { shift->read(@_) }
sub READLINE  { wantarray ? shift->getlines(@_) : shift->getline(@_) }
sub WRITE     { shift->write(@_); }
sub CLOSE     { shift->close(@_); }
sub SEEK      { shift->seek(@_); }
sub TELL      { shift->tell(@_); }
sub EOF       { shift->eof(@_); }
sub FILENO    { -1 }

#------------------------------------------------------------

1;

__END__


=back

=cut


=head1 WARNINGS

Perl's TIEHANDLE spec was incomplete prior to 5.005_57;
it was missing support for C<seek()>, C<tell()>, and C<eof()>.
Attempting to use these functions with an IO::Scalar will not work
prior to 5.005_57. IO::Scalar will not have the relevant methods
invoked; and even worse, this kind of bug can lie dormant for a while.
If you turn warnings on (via C<$^W> or C<perl -w>),
and you see something like this...

    attempt to seek on unopened filehandle

...then you are probably trying to use one of these functions
on an IO::Scalar with an old Perl.  The remedy is to simply
use the OO version; e.g.:

    $SH->seek(0,0);    ### GOOD: will work on any 5.005
    seek($SH,0,0);     ### WARNING: will only work on 5.005_57 and beyond


=head1 VERSION

$Id: Scalar.pm,v 1.6 2005/02/10 21:21:53 dfs Exp $


=head1 AUTHORS

=head2 Primary Maintainer

David F. Skoll (F<dfs@roaringpenguin.com>).

=head2 Principal author

Eryq (F<eryq@zeegee.com>).
President, ZeeGee Software Inc (F<http://www.zeegee.com>).


=head2 Other contributors

The full set of contributors always includes the folks mentioned
in L<IO::Stringy/"CHANGE LOG">.  But just the same, special
thanks to the following individuals for their invaluable contributions
(if I've forgotten or misspelled your name, please email me!):

I<Andy Glew,>
for contributing C<getc()>.

I<Brandon Browning,>
for suggesting C<opened()>.

I<David Richter,>
for finding and fixing the bug in C<PRINTF()>.

I<Eric L. Brine,>
for his offset-using read() and write() implementations.

I<Richard Jones,>
for his patches to massively improve the performance of C<getline()>
and add C<sysread> and C<syswrite>.

I<B. K. Oxley (binkley),>
for stringification and inheritance improvements,
and sundry good ideas.

I<Doug Wilson,>
for the IO::Handle inheritance and automatic tie-ing.


=head1 SEE ALSO

L<IO::String>, which is quite similar but which was designed
more-recently and with an IO::Handle-like interface in mind,
so you could mix OO- and native-filehandle usage without using tied().

I<Note:> as of version 2.x, these classes all work like
their IO::Handle counterparts, so we have comparable
functionality to IO::String.

=cut

PK       ! uB��,9  ,9    perl5/Test/Warnings.pmnu ��6�$        use strict;
use warnings;
package Test::Warnings; # git description: v0.029-2-g97d1c9f
# vim: set ts=8 sts=4 sw=4 tw=115 et :
# ABSTRACT: Test for warnings and the lack of them
# KEYWORDS: testing tests warnings

our $VERSION = '0.030';

use parent 'Exporter';
use Test::Builder;

our @EXPORT_OK = qw(
    allow_warnings allowing_warnings
    had_no_warnings
    warnings warning
);
our %EXPORT_TAGS = ( all => \@EXPORT_OK );

my $warnings_allowed;
my $forbidden_warnings_found;
my $done_testing_called;
my $no_end_test;
my $fail_on_warning;
my $report_warnings;
my @collected_warnings;

sub import
{
    my $class = shift @_;

    my %names; @names{@_} = ();
    # END block will check for this status
    $no_end_test = exists $names{':no_end_test'};
    # __WARN__ handler will check for this status
    $fail_on_warning = exists $names{':fail_on_warning'};
    # Collect and report warnings at the end
    $report_warnings = exists $names{':report_warnings'};

    delete @names{qw(:no_end_test :fail_on_warning :report_warnings)};
    __PACKAGE__->export_to_level(1, $class, keys %names);
}

# for testing this module only!
my $tb;
sub _builder(;$)
{
    if (not @_)
    {
        $tb ||= Test::Builder->new;
        return $tb;
    }

    $tb = shift;
}

my $_orig_warn_handler = $SIG{__WARN__};
$SIG{__WARN__} = sub {
    if ($warnings_allowed)
    {
        Test::Builder->new->note($_[0]);
    }
    else
    {
        $forbidden_warnings_found++;
        push @collected_warnings, $_[0] if $report_warnings;

        # TODO: this doesn't handle blessed coderefs... does anyone care?
        goto &$_orig_warn_handler if $_orig_warn_handler
            and (  (ref $_orig_warn_handler eq 'CODE')
                or ($_orig_warn_handler ne 'DEFAULT'
                    and $_orig_warn_handler ne 'IGNORE'
                    and defined &$_orig_warn_handler));

        if ($_[0] =~ /\n$/) {
            warn $_[0];
        } else {
            require Carp;
            Carp::carp($_[0]);
        }
        _builder->ok(0, 'unexpected warning') if $fail_on_warning;
    }
};

sub warnings(;&)
{
    # if someone manually does warnings->import in the same namespace this is
    # imported into, this sub will be called.  in that case, just return the
    # string "warnings" so it calls the correct method.
    if (!@_) {
        return 'warnings';
    }
    my $code = shift;
    my @warnings;
    local $SIG{__WARN__} = sub {
        push @warnings, shift;
    };
    $code->();
    @warnings;
}

sub warning(&)
{
    my @warnings = &warnings(@_);
    return @warnings == 1 ? $warnings[0] : \@warnings;
}

if (Test::Builder->can('done_testing'))
{
    # monkeypatch Test::Builder::done_testing:
    # check for any forbidden warnings, and record that we have done so
    # so we do not check again via END

    no strict 'refs';
    my $orig = *{'Test::Builder::done_testing'}{CODE};
    no warnings 'redefine';
    *{'Test::Builder::done_testing'} = sub {
        # only do this at the end of all tests, not at the end of a subtest
        my $builder = _builder;
        my $in_subtest_sub = $builder->can('in_subtest');
        if (not $no_end_test
            and not ($in_subtest_sub ? $builder->$in_subtest_sub : $builder->parent))
        {
            local $Test::Builder::Level = $Test::Builder::Level + 3;
            had_no_warnings('no (unexpected) warnings (via done_testing)');
            $done_testing_called = 1;
        }

        $orig->(@_);
    };
}

END {
    if (not $no_end_test
        and not $done_testing_called
        # skip this if there is no plan and no tests have been run (e.g.
        # compilation tests of this module!)
        and (_builder->expected_tests or _builder->current_test > 0)
    )
    {
        local $Test::Builder::Level = $Test::Builder::Level + 1;
        had_no_warnings('no (unexpected) warnings (via END block)');
    }
}

# setter
sub allow_warnings(;$)
{
    $warnings_allowed = @_ || defined $_[0] ? $_[0] : 1;
}

# getter
sub allowing_warnings() { $warnings_allowed }

# call at any time to assert no (unexpected) warnings so far
sub had_no_warnings(;$)
{
    _builder->ok(!$forbidden_warnings_found, shift || 'no (unexpected) warnings');
    if ($report_warnings and $forbidden_warnings_found) {
        _builder->diag("Got the following unexpected warnings:");
        for my $i (1 .. @collected_warnings) {
            _builder->diag("  $i: $collected_warnings[ $i - 1 ]");
        }
    }
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test::Warnings - Test for warnings and the lack of them

=head1 VERSION

version 0.030

=head1 SYNOPSIS

    use Test::More;
    use Test::Warnings;

    pass('yay!');
    done_testing;

emits TAP:

    ok 1 - yay!
    ok 2 - no (unexpected) warnings (via done_testing)
    1..2

and:

    use Test::More tests => 3;
    use Test::Warnings 0.005 ':all';

    pass('yay!');
    like(warning { warn "oh noes!" }, qr/^oh noes/, 'we warned');

emits TAP:

    ok 1 - yay!
    ok 2 - we warned
    ok 3 - no (unexpected) warnings (via END block)
    1..3

=head1 DESCRIPTION

If you've ever tried to use L<Test::NoWarnings> to confirm there are no warnings
generated by your tests, combined with the convenience of C<done_testing> to
not have to declare a
L<test count|Test::More/I love it-when-a-plan-comes-together>,
you'll have discovered that these two features do not play well together,
as the test count will be calculated I<before> the warnings test is run,
resulting in a TAP error. (See C<examples/test_nowarnings.pl> in this
distribution for a demonstration.)

This module is intended to be used as a drop-in replacement for
L<Test::NoWarnings>: it also adds an extra test, but runs this test I<before>
C<done_testing> calculates the test count, rather than after.  It does this by
hooking into C<done_testing> as well as via an C<END> block.  You can declare
a plan, or not, and things will still Just Work.

It is actually equivalent to:

    use Test::NoWarnings 1.04 ':early';

as warnings are still printed normally as they occur.  You are safe, and
enthusiastically encouraged, to perform a global search-replace of the above
with C<use Test::Warnings;> whether or not your tests have a plan.

It can also be used as a replacement for L<Test::Warn>, if you wish to test
the content of expected warnings; read on to find out how.

=head1 FUNCTIONS

The following functions are available for import (not included by default; you
can also get all of them by importing the tag C<:all>):

=head2 C<< allow_warnings([bool]) >> - EXPERIMENTAL - MAY BE REMOVED

When passed a true value, or no value at all, subsequent warnings will not
result in a test failure; when passed a false value, subsequent warnings will
result in a test failure.  Initial value is C<false>.

When warnings are allowed, any warnings will instead be emitted via
L<Test::Builder::note|Test::Builder/Output>.

=head2 C<allowing_warnings> - EXPERIMENTAL - MAY BE REMOVED

Returns whether we are currently allowing warnings (set by C<allow_warnings>
as described above).

=head2 C<< had_no_warnings(<optional test name>) >>

Tests whether there have been any warnings so far, not preceded by an
C<allowing_warnings> call.  It is run
automatically at the end of all tests, but can also be called manually at any
time, as often as desired.

=head2 C<< warnings( { code } ) >>

Given a code block, runs the block and returns a list of all the
(not previously allowed via C<allow_warnings>) warnings issued within.  This
lets you test for the presence of warnings that you not only would I<allow>,
but I<must> be issued.  Testing functions are not provided; given the strings
returned, you can test these yourself using your favourite testing functions,
such as L<Test::More::is|Test::More/is> or L<Test::Deep::cmp_deeply|Test::Deep/cmp_deeply>.

You can use this construct as a replacement for
L<Test::Warn::warnings_are|Test::Warn/warnings_are>:

    is_deeply(
        [ warnings { ... } ],
        [
            'warning message 1',
            'warning message 2',
        ],
        'got expected warnings',
    );

or, to replace L<Test::Warn::warnings_like|Test::Warn/warnings_like>:

    cmp_deeply(
        [ warnings { ... } ],
        bag(    # ordering of messages doesn't matter
            re(qr/warning message 1/),
            re(qr/warning message 2/),
        ),
        'got expected warnings (in any order)',
    );

Warnings generated by this code block are I<NOT> propagated further. However,
since they are returned from this function with their filename and line
numbers intact, you can re-issue them yourself immediately after calling
C<warnings(...)>, if desired.

Note that C<use Test::Warnings 'warnings'> will give you a C<warnings>
subroutine in your namespace (most likely C<main>, if you're writing a test),
so you (or things you load) can't subsequently do C<< warnings->import >> --
it will result in the error: "Not enough arguments for
Test::Warnings::warnings at ..., near "warnings->import"".  To work around
this, either use the fully-qualified form (C<Test::warnings>) or make your
calls to the C<warnings> package first.

=head2 C<< warning( { code } ) >>

Same as C<< warnings( { code } ) >>, except a scalar is always returned - the
single warning produced, if there was one, or an arrayref otherwise -- which
can be more convenient to use than C<warnings()> if you are expecting exactly
one warning.

However, you are advised to capture the result from C<warning()> into a temp
variable so you can dump its value if it doesn't contain what you expect.
e.g. with this test:

    like(
        warning { foo() },
        qr/^this is a warning/,
        'got a warning from foo()',
    );

if you get two warnings (or none) back instead of one, you'll get an
arrayref, which will result in an unhelpful test failure message like:

    #   Failed test 'got a warning from foo()'
    #   at t/mytest.t line 10.
    #                   'ARRAY(0xdeadbeef)'
    #     doesn't match '(?^:^this is a warning)'

So instead, change your test to:

    my $warning = warning { foo() };
    like(
        $warning,
        qr/^this is a warning/,
        'got a warning from foo()',
    ) or diag 'got warning(s): ', explain($warning);

=head1 IMPORT OPTIONS

=head2 C<:all>

Imports all functions listed above

=head2 C<:no_end_test>

Disables the addition of a C<had_no_warnings> test
via C<END> or C<done_testing>

=head2 C<:fail_on_warning>

=for stopwords unexempted

When used, fail immediately when an unexempted warning is generated (as opposed to waiting until
L</had_no_warnings> or C<done_testing> is called).

I recommend you only turn this option on when debugging a test, to see where a surprise warning is coming from,
and rely on the end-of-tests check otherwise.

=head2 C<:report_warnings>

When used, C<had_no_warnings()> will print all the unexempted warning content, in case it had been suppressed
earlier by other captures (such as L<Test::Output/stderr_like> or L<Capture::Tiny/capture>).

=head1 CAVEATS

=for stopwords smartmatch TODO irc

Sometimes new warnings can appear in Perl that should B<not> block
installation -- for example, smartmatch was recently deprecated in
perl 5.17.11, so now any distribution that uses smartmatch and also
tests for warnings cannot be installed under 5.18.0.  You might want to
consider only making warnings fail tests in an author environment -- you can
do this with the L<if> pragma:

    use if $ENV{AUTHOR_TESTING} || $ENV{RELEASE_TESTING}, 'Test::Warnings';

In future versions of this module, when interfaces are added to test the
content of warnings, there will likely be additional sugar available to
indicate that warnings should be checked only in author tests (or TODO when
not in author testing), but will still provide exported subs.  Comments are
enthusiastically solicited - drop me an email, write up an RT ticket, or come
by C<#perl-qa> on irc!

=for stopwords Achtung

B<Achtung!>  This is not a great idea:

    sub warning_like(&$;$) {
        my ($code, $pattern, $name) = @_;
        like( &warning($code), $pattern, $name );
    }

    warning_like( { ... }, qr/foo/, 'foo appears in the warning' );

If the code in the C<{ ... }> is going to warn with a stack trace with the
arguments to each subroutine in its call stack (for example via C<Carp::cluck>),
the test name, "foo appears in the warning" will itself be matched by the
regex (see F<examples/warning_like.t>).  Instead, write this:

  like( warning { ... }, qr/foo/, 'foo appears in the warning' );

=head1 TO DO (or: POSSIBLE FEATURES COMING IN FUTURE RELEASES)

=over

=item * C<< allow_warnings(qr/.../) >> - allow some warnings and not others

=for stopwords subtest subtests

=item * more sophisticated handling in subtests - if we save some state on the
L<Test::Builder> object itself, we can allow warnings in a subtest and then
the state will revert when the subtest ends, as well as check for warnings at
the end of every subtest via C<done_testing>.

=item * sugar for making failures TODO when testing outside an author
environment

=back

=head1 SEE ALSO

=for stopwords YANWT

=over 4

=item *

L<Test::NoWarnings>

=item *

L<Test::FailWarnings>

=item *

L<blogs.perl.org: YANWT (Yet Another No-Warnings Tester)|http://blogs.perl.org/users/ether/2013/03/yanwt-yet-another-no-warnings-tester.html>

=item *

L<strictures> - which makes all warnings fatal in tests, hence lessening the need for special warning testing

=item *

L<Test::Warn>

=item *

L<Test::Fatal>

=back

=head1 SUPPORT

Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=Test-Warnings>
(or L<bug-Test-Warnings@rt.cpan.org|mailto:bug-Test-Warnings@rt.cpan.org>).

There is also a mailing list available for users of this distribution, at
L<http://lists.perl.org/list/perl-qa.html>.

There is also an irc channel available for users of this distribution, at
L<C<#perl> on C<irc.perl.org>|irc://irc.perl.org/#perl-qa>.

I am also usually active on irc, as 'ether' at C<irc.perl.org>.

=head1 AUTHOR

Karen Etheridge <ether@cpan.org>

=head1 CONTRIBUTORS

=for stopwords Graham Knop A. Sinan Unur Leon Timmermans Tina Mueller

=over 4

=item *

Graham Knop <haarg@haarg.org>

=item *

A. Sinan Unur <nanis@cpan.org>

=item *

Leon Timmermans <fawaka@gmail.com>

=item *

Tina Mueller <cpan2@tinita.de>

=back

=head1 COPYRIGHT AND LICENCE

This software is copyright (c) 2013 by Karen Etheridge.

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

=cut
PK       ! �M��E  E    perl5/Test/Alien/Build.pmnu ��6�$        package Test::Alien::Build;

use strict;
use warnings;
use 5.008004;
use Exporter qw( import );
use Path::Tiny qw( path );
use Carp qw( croak );
use Test2::API qw( context run_subtest );
use Capture::Tiny qw( capture_merged );
use Alien::Build::Util qw( _mirror );
use List::Util 1.33 qw( any );
use Alien::Build::Temp;

our @EXPORT = qw(
  alienfile
  alienfile_ok
  alienfile_skip_if_missing_prereqs
  alien_download_ok
  alien_extract_ok
  alien_build_ok
  alien_build_clean
  alien_clean_install
  alien_install_type_is
  alien_checkpoint_ok
  alien_resume_ok
  alien_subtest
  alien_rc
);

# ABSTRACT: Tools for testing Alien::Build + alienfile
our $VERSION = '2.83'; # VERSION


my $build;
my $build_alienfile;
my $build_root;
my $build_targ;

sub alienfile::targ
{
  $build_targ;
}

sub alienfile
{
  my($package, $filename, $line) = caller;
  ($package, $filename, $line) = caller(2) if $package eq __PACKAGE__;
  $filename = path($filename)->absolute;
  my %args = @_ == 0 ? (filename => 'alienfile') : @_ % 2 ? ( source => do { '# line '. $line . ' "' . path($filename)->absolute . qq("\n) . $_[0] }) : @_;

  require alienfile;
  push @alienfile::EXPORT, 'targ' unless any { /^targ$/ } @alienfile::EXPORT;

  my $temp = Alien::Build::Temp->newdir;
  my $get_temp_root = do{
    my $root; # may be undef;
    sub {
      $root ||= Path::Tiny->new($temp);

      if(@_)
      {
        my $path = $root->child(@_);
        $path->mkpath;
        $path;
      }
      else
      {
        return $root;
      }
    };
  };

  if($args{source})
  {
    my $file = $get_temp_root->()->child('alienfile');
    $file->spew_utf8($args{source});
    $args{filename} = $file->stringify;
  }
  else
  {
    unless(defined $args{filename})
    {
      croak "You must specify at least one of filename or source";
    }
    $args{filename} = path($args{filename})->absolute->stringify;
  }

  $args{stage}  ||= $get_temp_root->('stage')->stringify;
  $args{prefix} ||= $get_temp_root->('prefix')->stringify;
  $args{root}   ||= $get_temp_root->('root')->stringify;

  require Alien::Build;

  _alienfile_clear();
  my $out = capture_merged {
    $build_targ = $args{targ};
    $build = Alien::Build->load($args{filename}, root => $args{root});
    $build->set_stage($args{stage});
    $build->set_prefix($args{prefix});
  };

  my $ctx = context();
  $ctx->note($out) if $out;
  $ctx->release;

  $build_alienfile = $args{filename};
  $build_root      = $temp;
  $build
}

sub _alienfile_clear
{
  eval { defined $build_root && -d $build_root && path($build_root)->remove_tree };
  undef $build;
  undef $build_alienfile;
  undef $build_root;
  undef $build_targ;
}


sub alienfile_ok
{
  my $build;
  my $name;
  my $error;

  if(@_ == 1 && ! defined $_[0])
  {
    $build = $_[0];
    $error = 'no alienfile given';
    $name = 'alienfile compiled';
  }
  elsif(@_ == 1 && eval { $_[0]->isa('Alien::Build') })
  {
    $build = $_[0];
    $name = 'alienfile compiled';
  }
  else
  {
    $build = eval { alienfile(@_) };
    $error = $@;
    $name = 'alienfile compiles';
  }

  my $ok = !! $build;

  my $ctx = context();
  $ctx->ok($ok, $name);
  $ctx->diag("error: $error") if $error;
  $ctx->release;

  $build;
}


sub alienfile_skip_if_missing_prereqs
{
  my($phase) = @_;

  if($build)
  {
    eval { $build->load_requires('configure', 1) };
    if(my $error = $@)
    {
      my $reason = "Missing configure prereq";
      if($error =~ /Required (.*) (.*),/)
      {
        $reason .= ": $1 $2";
      }
      my $ctx = context();
      $ctx->plan(0, SKIP => $reason);
      $ctx->release;
      return;
    }
    $phase ||= $build->install_type;
    eval { $build->load_requires($phase, 1) };
    if(my $error = $@)
    {
      my $reason = "Missing $phase prereq";
      if($error =~ /Required (.*) (.*),/)
      {
        $reason .= ": $1 $2";
      }
      my $ctx = context();
      $ctx->plan(0, SKIP => $reason);
      $ctx->release;
      return;
    }
  }
}


sub alien_install_type_is
{
  my($type, $name) = @_;

  croak "invalid install type" unless defined $type && $type =~ /^(system|share)$/;
  $name ||= "alien install type is $type";

  my $ok = 0;
  my @diag;

  if($build)
  {
    my($out, $actual) = capture_merged {
      $build->load_requires('configure');
      $build->install_type;
    };
    if($type eq $actual)
    {
      $ok = 1;
    }
    else
    {
      push @diag, "expected install type of $type, but got $actual";
    }
  }
  else
  {
    push @diag, 'no alienfile'
  }

  my $ctx = context();
  $ctx->ok($ok, $name);
  $ctx->diag($_) for @diag;
  $ctx->release;

  $ok;
}


sub alien_download_ok
{
  my($name) = @_;

  $name ||= 'alien download';

  my $ok;
  my $file;
  my @diag;
  my @note;

  if($build)
  {
    my($out, $error) = capture_merged {
      eval {
        $build->load_requires('configure');
        $build->load_requires($build->install_type);
        $build->download;
      };
      $@;
    };
    if($error)
    {
      $ok = 0;
      push @diag, $out if defined $out;
      push @diag, "extract threw exception: $error";
    }
    else
    {
      $file = $build->install_prop->{download};
      if(-d $file || -f $file)
      {
        $ok = 1;
        push @note, $out if defined $out;
      }
      else
      {
        $ok = 0;
        push @diag, $out if defined $out;
        push @diag, 'no file or directory';
      }
    }
  }
  else
  {
    $ok = 0;
    push @diag, 'no alienfile';
  }

  my $ctx = context();
  $ctx->ok($ok, $name);
  $ctx->note($_) for @note;
  $ctx->diag($_) for @diag;
  $ctx->release;

  $file;
}


sub alien_extract_ok
{
  my($archive, $name) = @_;

  $name ||= $archive ? "alien extraction of $archive" : 'alien extraction';
  my $ok;
  my $dir;
  my @diag;
  my @note;

  if($build)
  {
    my($out, $error);
    ($out, $dir, $error) = capture_merged {
      my $dir = eval {
        $build->load_requires('configure');
        $build->load_requires($build->install_type);
        $build->download;
        $build->extract($archive);
      };
      ($dir, $@);
    };
    if($error)
    {
      $ok = 0;
      push @diag, $out if defined $out;
      push @diag, "extract threw exception: $error";
    }
    else
    {
      if(-d $dir)
      {
        $ok = 1;
        push @note, $out if defined $out;
      }
      else
      {
        $ok = 0;
        push @diag, $out if defined $out;
        push @diag, 'no directory';
      }
    }
  }
  else
  {
    $ok = 0;
    push @diag, 'no alienfile';
  }

  my $ctx = context();
  $ctx->ok($ok, $name);
  $ctx->note($_) for @note;
  $ctx->diag($_) for @diag;
  $ctx->release;

  $dir;
}


my $count = 1;

sub alien_build_ok
{
  my $opt = defined $_[0] && ref($_[0]) eq 'HASH'
    ? shift : { class => 'Alien::Base' };

  my($name) = @_;

  $name ||= 'alien builds okay';
  my $ok;
  my @diag;
  my @note;
  my $alien;

  if($build)
  {
    my($out,$error) = capture_merged {
      eval {
        $build->load_requires('configure');
        $build->load_requires($build->install_type);
        $build->download;
        $build->build;
      };
      $@;
    };
    if($error)
    {
      $ok = 0;
      push @diag, $out if defined $out;
      push @diag, "build threw exception: $error";
    }
    else
    {
      $ok = 1;

      push @note, $out if defined $out;

      require Alien::Base;

      my $prefix = $build->runtime_prop->{prefix};
      my $stage  = $build->install_prop->{stage};
      my %prop   = %{ $build->runtime_prop };

      $prop{distdir} = $prefix;

      _mirror $stage, $prefix;

      my $dist_dir = sub {
        $prefix;
      };

      my $runtime_prop = sub {
        \%prop;
      };

      $alien = sprintf 'Test::Alien::Build::Faux%04d', $count++;
      {
        no strict 'refs';
        @{ "${alien}::ISA" }          = $opt->{class};
        *{ "${alien}::dist_dir" }     = $dist_dir;
        *{ "${alien}::runtime_prop" } = $runtime_prop;
      }
    }
  }
  else
  {
    $ok = 0;
    push @diag, 'no alienfile';
  }

  my $ctx = context();
  $ctx->ok($ok, $name);
  $ctx->diag($_) for @diag;
  $ctx->note($_) for @note;
  $ctx->release;

  $alien;
}


sub alien_build_clean
{
  my $ctx = context();
  if($build_root)
  {
    foreach my $child (path($build_root)->children)
    {
      next if $child->basename eq 'prefix';
      $ctx->note("clean: rm: $child");
      $child->remove_tree;
    }
  }
  else
  {
    $ctx->note("no build to clean");
  }
  $ctx->release;
}


sub alien_clean_install
{
  my($name) = @_;

  $name ||= "run clean_install";

  my $ok;
  my @diag;
  my @note;

  if($build)
  {
    my($out,$error) = capture_merged {
      eval {
        $build->clean_install;
      };
      $@;
    };
    if($error)
    {
      $ok = 0;
      push @diag, $out if defined $out && $out ne '';
      push @diag, "build threw exception: $error";
    }
    else
    {
      $ok = 1;
      push @note, $out if defined $out && $out ne '';
    }
  }
  else
  {
    $ok = 0;
    push @diag, 'no alienfile';
  }

  my $ctx = context();
  $ctx->ok($ok, $name);
  $ctx->diag($_) for @diag;
  $ctx->note($_) for @note;
  $ctx->release;
}


sub alien_checkpoint_ok
{
  my($name) = @_;

  $name ||= "alien checkpoint ok";
  my $ok;
  my @diag;

  if($build)
  {
    eval { $build->checkpoint };
    if($@)
    {
      push @diag, "error in checkpoint: $@";
      $ok = 0;
    }
    else
    {
      $ok = 1;
    }
    undef $build;
  }
  else
  {
    push @diag, "no build to checkpoint";
    $ok = 0;
  }

  my $ctx = context();
  $ctx->ok($ok, $name);
  $ctx->diag($_) for @diag;
  $ctx->release;

  $ok;
}


sub alien_resume_ok
{
  my($name) = @_;

  $name ||= "alien resume ok";
  my $ok;
  my @diag;

  if($build_alienfile && $build_root && !defined $build)
  {
    $build = eval { Alien::Build->resume($build_alienfile, "$build_root/root") };
    if($@)
    {
      push @diag, "error in resume: $@";
      $ok = 0;
    }
    else
    {
      $ok = 1;
    }
  }
  else
  {
    if($build)
    {
      push @diag, "build has not been checkpointed";
    }
    else
    {
      push @diag, "no build to resume";
    }
    $ok = 0;
  }

  my $ctx = context();
  $ctx->ok($ok, $name);
  $ctx->diag($_) for @diag;
  $ctx->release;

  ($ok && $build) || $ok;
}


my $alien_rc_root;

sub alien_rc
{
  my($code) = @_;

  croak "passed in undef rc" unless defined $code;
  croak "looks like you have already defined a rc.pl file" if $ENV{ALIEN_BUILD_RC} ne '-';

  my(undef, $filename, $line) = caller;
  my $code2 = "use strict; use warnings;\n" .
              '# line ' . $line . ' "' . path($filename)->absolute . "\n$code";

  $alien_rc_root ||= Alien::Build::Temp->newdir;

  my $rc = path($alien_rc_root)->child('rc.pl');
  $rc->spew_utf8($code2);
  $ENV{ALIEN_BUILD_RC} = "$rc";
  return 1;
}


sub alien_subtest
{
  my($name, $code, @args) = @_;

  _alienfile_clear;

  my $ctx = context();
  my $pass = run_subtest($name, $code, { buffered => 1 }, @args);
  $ctx->release;

  _alienfile_clear;

  $pass;
}

delete $ENV{$_} for qw( ALIEN_BUILD_LOG ALIEN_BUILD_PRELOAD ALIEN_BUILD_POSTLOAD ALIEN_INSTALL_TYPE PKG_CONFIG_PATH ALIEN_BUILD_PKG_CONFIG );
$ENV{ALIEN_BUILD_RC} = '-';

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test::Alien::Build - Tools for testing Alien::Build + alienfile

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use Test2::V0;
 use Test::Alien::Build;
 
 # returns an instance of Alien::Build.
 my $build = alienfile_ok q{
   use alienfile;
 
   plugin 'My::Plugin' => (
     foo => 1,
     bar => 'string',
     ...
   );
 };
 
 alien_build_ok 'builds okay.';
 
 done_testing;

=head1 DESCRIPTION

This module provides some tools for testing L<Alien::Build> and L<alienfile>.  Outside of L<Alien::Build>
core development, It is probably most useful for L<Alien::Build::Plugin> developers.

This module also unsets a number of L<Alien::Build> specific environment variables, in order to make tests
reproducible even when overrides are set in different environments.  So if you want to test those variables in
various states you should explicitly set them in your test script.  These variables are unset if they defined:
C<ALIEN_BUILD_PRELOAD> C<ALIEN_BUILD_POSTLOAD> C<ALIEN_INSTALL_TYPE>.

=head1 FUNCTIONS

=head2 alienfile

 my $build = alienfile;
 my $build = alienfile q{ use alienfile ... };
 my $build = alienfile filename => 'alienfile';

Create a Alien::Build instance from the given L<alienfile>.  The first two forms are abbreviations.

 my $build = alienfile;
 # is the same as
 my $build = alienfile filename => 'alienfile';

and

 my $build = alienfile q{ use alienfile ... };
 # is the same as
 my $build = alienfile source => q{ use alienfile ... };

Except for the second abbreviated form sets the line number before feeding the source into L<Alien::Build>
so that you will get diagnostics with the correct line numbers.

=over 4

=item source

The source for the alienfile as a string.  You must specify one of C<source> or C<filename>.

=item filename

The filename for the alienfile.  You must specify one of C<source> or C<filename>.

=item root

The build root.

=item stage

The staging area for the build.

=item prefix

The install prefix for the build.

=back

=head2 alienfile_ok

 my $build = alienfile_ok;
 my $build = alienfile_ok q{ use alienfile ... };
 my $build = alienfile_ok filename => 'alienfile';
 my $build = alienfile_ok $build;

Same as C<alienfile> above, except that it runs as a test, and will not throw an exception
on failure (it will return undef instead).

[version 1.49]

As of version 1.49 you can also pass in an already formed instance of L<Alien::Build>.  This
allows you to do something like this:

 subtest 'a subtest' => sub {
   my $build = alienfile q{ use alienfile; ... };
   alienfile_skip_if_missing_prereqs; # skip if alienfile prereqs are missing
   alienfile_ok $build;  # delayed pass/fail for the compile of alienfile
 };

=head2 alienfile_skip_if_missing_prereqs

 alienfile_skip_if_missing_prereqs;
 alienfile_skip_if_missing_prereqs $phase;

Skips the test or subtest if the prereqs for the alienfile are missing.
If C<$phase> is not given, then either C<share> or C<system> will be
detected.

=head2 alien_install_type_is

 alien_install_type_is $type;
 alien_install_type_is $type, $name;

Simple test to see if the install type is what you expect.
C<$type> should be one of C<system> or C<share>.

=head2 alien_download_ok

 my $file = alien_download_ok;
 my $file = alien_download_ok $name;

Makes a download attempt and test that a file or directory results.  Returns
the file or directory if successful.  Returns C<undef> otherwise.

=head2 alien_extract_ok

 my $dir = alien_extract_ok;
 my $dir = alien_extract_ok $archive;
 my $dir = alien_extract_ok $archive, $name;
 my $dir = alien_extract_ok undef, $name;

Makes an extraction attempt and test that a directory results.  Returns
the directory if successful.  Returns C<undef> otherwise.

=head2 alien_build_ok

 my $alien = alien_build_ok;
 my $alien = alien_build_ok $name;
 my $alien = alien_build_ok { class => $class };
 my $alien = alien_build_ok { class => $class }, $name;

Runs the download and build stages.  Passes if the build succeeds.  Returns an instance
of L<Alien::Base> which can be passed into C<alien_ok> from L<Test::Alien>.  Returns
C<undef> if the test fails.

Options

=over 4

=item class

The base class to use for your alien.  This is L<Alien::Base> by default.  Should
be a subclass of L<Alien::Base>, or at least adhere to its API.

=back

=head2 alien_build_clean

 alien_build_clean;

Removes all files with the current build, except for the runtime prefix.
This helps test that the final install won't depend on the build files.

=head2 alien_clean_install

 alien_clean_install;

Runs C<$build-E<gt>clean_install>, and verifies it did not crash.

=head2 alien_checkpoint_ok

 alien_checkpoint_ok;
 alien_checkpoint_ok $test_name;

Test the checkpoint of a build.

=head2 alien_resume_ok

 alien_resume_ok;
 alien_resume_ok $test_name;

Test a resume a checkpointed build.

=head2 alien_rc

 alien_rc $code;

Creates C<rc.pl> file in a temp directory and sets ALIEN_BUILD_RC.  Useful for testing
plugins that should be called from C<~/.alienbuild/rc.pl>.  Note that because of the
nature of how the C<~/.alienbuild/rc.pl> file works, you can only use this once!

=head2 alien_subtest

 alien_subtest $test_name => sub {
   ...
 };

Clear the build object and clear the build object before and after the subtest.

=head1 SEE ALSO

=over 4

=item L<Alien>

=item L<alienfile>

=item L<Alien::Build>

=item L<Test::Alien>

=back

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! �KHp  p    perl5/Test/Alien/Synthetic.pmnu ��6�$        package Test::Alien::Synthetic;

use strict;
use warnings;
use 5.008004;
use Test2::API qw( context );

# ABSTRACT: A mock alien object for testing
our $VERSION = '2.83'; # VERSION


sub _def ($) { my($val) = @_; defined $val ? $val : '' }

sub cflags       { _def shift->{cflags}             }
sub libs         { _def shift->{libs}               }
sub dynamic_libs { @{ shift->{dynamic_libs} || [] } }

sub runtime_prop
{
  my($self) = @_;
  defined $self->{runtime_prop}
    ? $self->{runtime_prop}
    : {};
}

sub cflags_static
{
  my($self) = @_;
  defined $self->{cflags_static}
    ? $self->{cflags_static}
    : $self->cflags;
}

sub libs_static
{
  my($self) = @_;
  defined $self->{libs_static}
    ? $self->{libs_static}
    : $self->libs;
}

sub bin_dir
{
  my $dir = shift->{bin_dir};
  defined $dir && -d $dir ? ($dir) : ();
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test::Alien::Synthetic - A mock alien object for testing

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use Test2::V0;
 use Test::Alien;
 
 my $alien = synthetic {
   cflags => '-I/foo/bar/include',
   libs   => '-L/foo/bar/lib -lbaz',
 };
 
 alien_ok $alien;
 
 done_testing;

=head1 DESCRIPTION

This class is used to model a synthetic L<Alien>
class that implements the minimum L<Alien::Base>
interface needed by L<Test::Alien>.

It can be useful if you have a non-L<Alien::Base>
based L<Alien> distribution that you need to test.

B<NOTE>: The name of this class may move in the
future, so do not refer to this class name directly.
Instead create instances of this class using the
L<Test::Alien#synthetic> function.

=head1 ATTRIBUTES

=head2 cflags

String containing the compiler flags

=head2 cflags_static

String containing the static compiler flags

=head2 libs

String containing the linker and library flags

=head2 libs_static

String containing the static linker and library flags

=head2 dynamic_libs

List reference containing the dynamic libraries.

=head2 bin_dir

Tool binary directory.

=head2 runtime_prop

Runtime properties.

=head1 EXAMPLE

Here is a complete example using L<Alien::Libarchive> which is a non-L<Alien::Base>
based L<Alien> distribution.

 use strict;
 use warnings;
 use Test2::V0;
 use Test::Alien;
 use Alien::Libarchive;
 
 my $real = Alien::Libarchive->new;
 my $alien = synthetic {
   cflags       => scalar $real->cflags,
   libs         => scalar $real->libs,
   dynamic_libs => [$real->dlls],
 };
 
 alien_ok $alien;
 
 xs_ok do { local $/; <DATA> }, with_subtest {
   my($module) = @_;
   my $ptr = $module->archive_read_new;
   like $ptr, qr{^[0-9]+$};
   $module->archive_read_free($ptr);
 };
 
 ffi_ok { symbols => [qw( archive_read_new )] }, with_subtest {
   my($ffi) = @_;
   my $new  = $ffi->function(archive_read_new => [] => 'opaque');
   my $free = $ffi->function(archive_read_close => ['opaque'] => 'void');
   my $ptr = $new->();
   like $ptr, qr{^[0-9]+$};
   $free->($ptr);
 };
 
 done_testing;
 
 __DATA__
 
 #include "EXTERN.h"
 #include "perl.h"
 #include "XSUB.h"
 #include <archive.h>
 
 MODULE = TA_MODULE PACKAGE = TA_MODULE
 
 void *archive_read_new(class);
     const char *class;
   CODE:
     RETVAL = (void*) archive_read_new();
   OUTPUT:
     RETVAL
 
 void archive_read_free(class, ptr);
     const char *class;
     void *ptr;
   CODE:
     archive_read_free(ptr);

=head1 SEE ALSO

=over 4

=item L<Test::Alien>

=back

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! Z�_�  �    perl5/Test/Alien/CanPlatypus.pmnu ��6�$        package Test::Alien::CanPlatypus;

use strict;
use warnings;
use 5.008004;
use Test2::API qw( context );

# ABSTRACT: Skip a test file unless FFI::Platypus is available
our $VERSION = '2.83'; # VERSION


sub skip
{
  eval { require FFI::Platypus; 1 } ? undef : 'This test requires FFI::Platypus.';
}

sub import
{
  my $skip = __PACKAGE__->skip;
  return unless defined $skip;

  my $ctx = context();
  $ctx->plan(0, SKIP => $skip);
  $ctx->release;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test::Alien::CanPlatypus - Skip a test file unless FFI::Platypus is available

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use Test::Alien::CanPlatypus;

=head1 DESCRIPTION

This is just a L<Test2> plugin that requires that L<FFI::Platypus>
be available.  Otherwise the test will be skipped.

=head1 SEE ALSO

=over 4

=item L<Test::Alien>

=item L<FFI::Platypus>

=back

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! ���<      perl5/Test/Alien/Diag.pmnu ��6�$        package Test::Alien::Diag;

use strict;
use warnings;
use 5.008004;
use Test2::API qw( context );
use Exporter qw( import );

our @EXPORT = qw( alien_diag );
our @EXPORT_OK = @EXPORT;

# ABSTRACT: Print out standard diagnostic for Aliens in the test step.
our $VERSION = '2.83'; # VERSION


my @default_scalar_properties = qw(
  cflags cflags_static libs libs_static version install_type
);

my @default_list_properties = qw(
  dynamic_libs bin_dir
);

sub alien_diag ($@)
{
  my $ctx = context();

  my %options = defined $_[-1] && ref($_[-1]) eq 'HASH' ?  %{ pop @_ } : ();

  my @extra_properties      = @{ delete $options{properties}      || [] };
  my @extra_list_properties = @{ delete $options{list_properties} || [] };

  my $max = 0;
  foreach my $alien (@_)
  {
    foreach my $name (@default_scalar_properties, @default_list_properties, @extra_properties, @extra_list_properties)
    {
      if(eval { $alien->can($name) })
      {
        my $str = "$alien->$name";
        if(length($str) > $max)
        {
          $max = length($str);
        }
      }
    }
  }


  $ctx->diag('');

  if(%options)
  {
    my @extra = sort keys %options;
    $ctx->diag("warning: unknown option@{[ @extra > 1 ? 's' : '' ]} for alien_diag: @extra");
    $ctx->diag("(you should check for typos or maybe upgrade to a newer version of Alien::Build)");
  }


  foreach my $alien (@_) {
    $ctx->diag('') for 1..2;

    my $found = 0;

    foreach my $name (sort(@default_scalar_properties, @extra_properties))
    {
      if(eval { $alien->can($name) })
      {
        $found++;
        my $value = $alien->$name;
        $value = '[undef]' unless defined $value;
        $ctx->diag(sprintf "%-${max}s = %s", "$alien->$name", $value);
      }
    }

    foreach my $name (sort(@default_list_properties, @extra_list_properties))
    {
      if(eval { $alien->can($name) })
      {
        $found++;
        my @list = eval { $alien->$name };
        next if $@;
        $ctx->diag(sprintf "%-${max}s = %s", "$alien->$name", $_) for @list;
      }
    }

    $ctx->diag("no diagnostics found for $alien") unless $found;
  }

  $ctx->diag('') for 1..2;

  $ctx->release;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test::Alien::Diag - Print out standard diagnostic for Aliens in the test step.

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use Test2::V0;
 use Test::Alien::Diag qw( alien_diag );

=head1 DESCRIPTION

This module provides an C<alien_diag> method that prints out diagnostics useful for
cpantesters and other bug reports that gives a quick summary of the important settings
like C<clfags> and C<libs>.

=head1 FUNCTIONS

=head2 alien_diag

 alien_diag @aliens;

prints out diagnostics for each given alien.  Each alien must be the class
name of an alien.

[version 2.68]

 alien_diag @aliens, \%options;

Starting with L<Alien::Build> 2.68, you can provide an option hash to adjust the
behavior of C<alien_diag>.  Valid options are:

=over 4

=item properties

Additional properties to display in the diagnostic.  Useful when you have an L<Alien>
with custom properties defined in the subclass.

=item list_properties

Additional properties that are returned as a list to display in the diagnostic.  Useful
when you have an L<Alien> with customer properties that return a list.

=back

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! �қd  d    perl5/Test/Alien/Run.pmnu ��6�$        package Test::Alien::Run;

use strict;
use warnings;
use 5.008004;
use Test2::API qw( context );

# ABSTRACT: Run object
our $VERSION = '2.83'; # VERSION


sub out    { shift->{out} }
sub err    { shift->{err} }
sub exit   { shift->{exit} }
sub signal { shift->{sig} }


sub success
{
  my($self, $message) = @_;
  $message ||= 'command succeeded';
  my $ok = $self->exit == 0 && $self->signal == 0;
  $ok = 0 if $self->{fail};

  my $ctx = context();
  $ctx->ok($ok, $message);
  unless($ok)
  {
    $ctx->diag("  command exited with @{[ $self->exit   ]}") if $self->exit;
    $ctx->diag("  command killed with @{[ $self->signal ]}") if $self->signal;
    $ctx->diag("  @{[ $self->{fail} ]}") if $self->{fail};
  }
  $ctx->release;
  $self;
}


sub exit_is
{
  my($self, $exit, $message) = @_;

  $message ||= "command exited with value $exit";
  my $ok = $self->exit == $exit;

  my $ctx = context();
  $ctx->ok($ok, $message);
  $ctx->diag("  actual exit value was: @{[ $self->exit ]}") unless $ok;
  $ctx->release;
  $self;
}


sub exit_isnt
{
  my($self, $exit, $message) = @_;

  $message ||= "command exited with value not $exit";
  my $ok = $self->exit != $exit;

  my $ctx = context();
  $ctx->ok($ok, $message);
  $ctx->diag("  actual exit value was: @{[ $self->exit ]}") unless $ok;
  $ctx->release;
  $self;
}


sub _like
{
  my($self, $regex, $source, $not, $message) = @_;

  my $ok = $self->{$source} =~ $regex;
  $ok = !$ok if $not;

  my $ctx = context();
  $ctx->ok($ok, $message);
  unless($ok)
  {
    $ctx->diag("  $source:");
    $ctx->diag("    $_") for split /\r?\n/, $self->{$source};
    $ctx->diag($not ? '  matches:' : '  does not match:');
    $ctx->diag("    $regex");
  }
  $ctx->release;

  $self;
}

sub out_like
{
  my($self, $regex, $message) = @_;
  $message ||= "output matches $regex";
  $self->_like($regex, 'out', 0, $message);
}


sub out_unlike
{
  my($self, $regex, $message) = @_;
  $message ||= "output does not match $regex";
  $self->_like($regex, 'out', 1, $message);
}


sub err_like
{
  my($self, $regex, $message) = @_;
  $message ||= "standard error matches $regex";
  $self->_like($regex, 'err', 0, $message);
}


sub err_unlike
{
  my($self, $regex, $message) = @_;
  $message ||= "standard error does not match $regex";
  $self->_like($regex, 'err', 1, $message);
}


sub note
{
  my($self) = @_;
  my $ctx = context();
  $ctx->note("[cmd]");
  $ctx->note("  @{$self->{cmd}}");
  if($self->out ne '')
  {
    $ctx->note("[out]");
    $ctx->note("  $_") for split /\r?\n/, $self->out;
  }
  if($self->err ne '')
  {
    $ctx->note("[err]");
    $ctx->note("  $_") for split /\r?\n/, $self->err;
  }
  $ctx->release;
  $self;
}


sub diag
{
  my($self) = @_;
  my $ctx = context();
  $ctx->diag("[cmd]");
  $ctx->diag("  @{$self->{cmd}}");
  if($self->out ne '')
  {
    $ctx->diag("[out]");
    $ctx->diag("  $_") for split /\r?\n/, $self->out;
  }
  if($self->err ne '')
  {
    $ctx->diag("[err]");
    $ctx->diag("  $_") for split /\r?\n/, $self->err;
  }
  $ctx->release;
  $self;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test::Alien::Run - Run object

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use Test2::V0;
 use Test::Alien;
 
 run_ok([ $^X, -e => 'print "some output"; exit 22'])
   ->exit_is(22)
   ->out_like(qr{some});

=head1 DESCRIPTION

This class stores information about a process run as performed by
L<Test::Alien#run_ok>.  That function is the I<ONLY> way to create
an instance of this class.

=head1 ATTRIBUTES

=head2 out

 my $str = $run->out;

The standard output from the run.

=head2 err

 my $str = $run->err;

The standard error from the run.

=head2 exit

 my $int = $run->exit;

The exit value of the run.

=head2 signal

 my $int = $run->signal;

The signal that killed the run, or zero if the process was terminated normally.

=head1 METHODS

These methods return the run object itself, so they can be chained,
as in the synopsis above.

=head2 success

 $run->success;
 $run->success($message);

Passes if the process terminated normally with an exit value of 0.

=head2 exit_is

 $run->exit_is($exit);
 $run->exit_is($exit, $message);

Passes if the process terminated with the given exit value.

=head2 exit_isnt

 $run->exit_isnt($exit);
 $run->exit_isnt($exit, $message);

Passes if the process terminated with an exit value of anything
but the given value.

=head2 out_like

 $run->out_like($regex);
 $run->out_like($regex, $message);

Passes if the output of the run matches the given pattern.

=head2 out_unlike

 $run->out_unlike($regex);
 $run->out_unlike($regex, $message);

Passes if the output of the run does not match the given pattern.

=head2 err_like

 $run->err_like($regex);
 $run->err_like($regex, $message);

Passes if the standard error of the run matches the given pattern.

=head2 err_unlike

 $run->err_unlike($regex);
 $run->err_unlike($regex, $message);

Passes if the standard error of the run does not match the given pattern.

=head2 note

 $run->note;

Send the output and standard error as test note.

=head2 diag

 $run->diag;

Send the output and standard error as test diagnostic.

=head1 SEE ALSO

=over 4

=item L<Test::Alien>

=back

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! t6F�  �    perl5/Test/Alien/CanCompile.pmnu ��6�$        package Test::Alien::CanCompile;

use strict;
use warnings;
use 5.008004;
use Test2::API qw( context );

# ABSTRACT: Skip a test file unless a C compiler is available
our $VERSION = '2.83'; # VERSION


sub skip
{
  require ExtUtils::CBuilder;
  ExtUtils::CBuilder->new->have_compiler ? undef : 'This test requires a compiler.';
}

sub import
{
  my $skip = __PACKAGE__->skip;
  return unless defined $skip;

  my $ctx = context();
  $ctx->plan(0, SKIP => $skip);
  $ctx->release;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test::Alien::CanCompile - Skip a test file unless a C compiler is available

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use Test::Alien::CanCompile;

=head1 DESCRIPTION

This is just a L<Test2> plugin that requires that a compiler
be available.  Otherwise the test will be skipped.

=head1 SEE ALSO

=over 4

=item L<Test::Alien>

=back

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! �<,P�/  �/    perl5/Authen/NTLM.pmnu ��6�$        #!/usr/local/bin/perl

package Authen::NTLM;
use strict;
use Authen::NTLM::DES;
use Authen::NTLM::MD4;
use MIME::Base64;
use Digest::HMAC_MD5;

use vars qw($VERSION @ISA @EXPORT);
require Exporter;

=head1 NAME

Authen::NTLM - An NTLM authentication module

=head1 SYNOPSIS

    use Mail::IMAPClient;
    use Authen::NTLM;
    my $imap = Mail::IMAPClient->new(Server=>'imaphost');
    ntlm_user($username);
    ntlm_password($password);
    $imap->authenticate("NTLM", Authen::NTLM::ntlm);
    :
    $imap->logout;
    ntlm_reset;
    :

or

    ntlmv2(1);
    ntlm_user($username);
    ntlm_host($host);
    ntlm_password($password);
    :

or

    my $ntlm = Authen::NTLM-> new(
        host     => $host,
        user     => $username,
        domain   => $domain,
        password => $password,
        version  => 1,
    );
    $ntlm-> challenge;
    :
    $ntlm-> challenge($challenge);


=head1 DESCRIPTION

    This module provides methods to use NTLM authentication.  It can
    be used as an authenticate method with the Mail::IMAPClient module
    to perform the challenge/response mechanism for NTLM connections
    or it can be used on its own for NTLM authentication with other
    protocols (eg. HTTP).

    The implementation is a direct port of the code from F<fetchmail>
    which, itself, has based its NTLM implementation on F<samba>.  As
    such, this code is not especially efficient, however it will still
    take a fraction of a second to negotiate a login on a PII which is
    likely to be good enough for most situations.

=head2 FUNCTIONS

=over 4

=item ntlm_domain()

    Set the domain to use in the NTLM authentication messages.
    Returns the new domain.  Without an argument, this function
    returns the current domain entry.

=item ntlm_user()

    Set the username to use in the NTLM authentication messages.
    Returns the new username.  Without an argument, this function
    returns the current username entry.

=item ntlm_password()

    Set the password to use in the NTLM authentication messages.
    Returns the new password.  Without an argument, this function
    returns the current password entry.

=item ntlm_reset()

    Resets the NTLM challenge/response state machine so that the next
    call to C<ntlm()> will produce an initial connect message.

=item ntlm()

    Generate a reply to a challenge.  The NTLM protocol involves an
    initial empty challenge from the server requiring a message
    response containing the username and domain (which may be empty).
    The first call to C<ntlm()> generates this first message ignoring
    any arguments.

    The second time it is called, it is assumed that the argument is
    the challenge string sent from the server.  This will contain 8
    bytes of data which are used in the DES functions to generate the
    response authentication strings.  The result of the call is the
    final authentication string.

    If C<ntlm_reset()> is called, then the next call to C<ntlm()> will
    start the process again allowing multiple authentications within
    an application.

=item ntlmv2()

    Use NTLM v2 authentication.

=back

=head2 OBJECT API

=over

=item new %options

Creates an object that accepts the following options: C<user>, C<host>,
C<domain>, C<password>, C<version>.

=item challenge [$challenge]

If C<$challenge> is not supplied, first-stage challenge string is generated.
Otherwise, the third-stage challenge is generated, where C<$challenge> is
assumed to be extracted from the second stage of NTLM exchange. The result of
the call is the final authentication string.

=back

=head1 AUTHOR

    David (Buzz) Bussenschutt <davidbuzz@gmail.com> - current maintainer
    Dmitry Karasik <dmitry@karasik.eu.org> - nice ntlmv2 patch, OO extensions.
    Andrew Hobson <ahobson@infloop.com> - initial ntlmv2 code
    Mark Bush <Mark.Bush@bushnet.demon.co.uk> - perl port
    Eric S. Raymond - author of fetchmail
    Andrew Tridgell and Jeremy Allison for SMB/Netbios code

=head1 SEE ALSO

L<perl>, L<Mail::IMAPClient>, L<LWP::Authen::Ntlm> 

=head1 HISTORY

    1.09 - fix CPAN ticket # 70703
    1.08 - fix CPAN ticket # 39925
    1.07 - not publicly released
    1.06 - relicense as GPL+ or Artistic
    1.05 - add OO interface by Dmitry Karasik
    1.04 - implementation of NTLMv2 by Andrew Hobson/Dmitry Karasik 
    1.03 - fixes long-standing 1 line bug L<http://rt.cpan.org/Public/Bug/Display.html?id=9521> - released by David Bussenschutt 9th Aug 2007 
    1.02 - released by Mark Bush 29th Oct 2001

=cut

$VERSION = "1.09";
@ISA = qw(Exporter);
@EXPORT = qw(ntlm ntlm_domain ntlm_user ntlm_password ntlm_reset ntlm_host ntlmv2);

my $domain = "";
my $user = "";
my $password = "";

my $str_hdr = "vvV";
my $hdr_len = 8;
my $ident = "NTLMSSP";

my $msg1_f = 0x0000b207;
my $msg1 = "Z8VV";
my $msg1_hlen = 16 + ($hdr_len*2);

my $msg2 = "Z8Va${hdr_len}Va8a8a${hdr_len}";
my $msg2_hlen = 12 + $hdr_len + 20 + $hdr_len;

my $msg3 = "Z8V";
my $msg3_tl = "V";
my $msg3_hlen = 12 + ($hdr_len*6) + 4;

my $state = 0;

my $host = "";
my $ntlm_v2 = 0;
my $ntlm_v2_msg3_flags = 0x88205;


# Domain Name supplied on negotiate
use constant NTLMSSP_NEGOTIATE_OEM_DOMAIN_SUPPLIED      => 0x00001000;
# Workstation Name supplied on negotiate
use constant NTLMSSP_NEGOTIATE_OEM_WORKSTATION_SUPPLIED => 0x00002000;
# Try to use NTLMv2
use constant NTLMSSP_NEGOTIATE_NTLM2                    => 0x00080000;


# Object API

sub new
{
   my ( $class, %opt) = @_;
   for (qw(domain user password host)) {
      $opt{$_} = "" unless defined $opt{$_};
   }
   $opt{version} ||= 1;
   return bless { %opt }, $class;
}

sub challenge
{
   my ( $self, $challenge) = @_;
   $state = defined $challenge;
   ($user,$domain,$password,$host) = @{$self}{qw(user domain password host)};
   $ntlm_v2 = ($self-> {version} eq '2') ? 1 : 0;
   return ntlm($challenge);
}

eval "sub $_ { \$#_ ? \$_[0]->{$_} = \$_[1] : \$_[0]->{$_} }"
   for qw(user domain password host version);

# Function API

sub ntlm_domain
{
  if (@_)
  {
    $domain = shift;
  }
  return $domain;
}

sub ntlm_user
{
  if (@_)
  {
    $user = shift;
  }
  return $user;
}

sub ntlm_password
{
  if (@_)
  {
    $password = shift;
  }
  return $password;
}

sub ntlm_reset
{
  $state = 0;
}

sub ntlmv2
{
  if (@_) {
    $ntlm_v2 = shift;
  }
  return $ntlm_v2;
}

sub ntlm_host {
  if (@_) {
    $host = shift;
  }
  return $host;
}

sub ntlm
{
  my ($challenge) = @_;

  my ($flags, $user_hdr, $domain_hdr,
      $u_off, $d_off, $c_info, $lmResp, $ntResp, $lm_hdr,
      $nt_hdr, $wks_hdr, $session_hdr, $lm_off, $nt_off,
      $wks_off, $s_off, $u_user, $msg1_host, $host_hdr, $u_host);
  my $response;
  if ($state)
  {

    $challenge =~ s/^\s*//;
    $challenge = decode_base64($challenge);
    $c_info = &decode_challenge($challenge);
    $u_user = &unicode($user);
    if (!$ntlm_v2) {
      $domain = substr($challenge, $c_info->{domain}{offset}, $c_info->{domain}{len}); 
      $lmResp = &lmEncrypt($c_info->{data});
      $ntResp = &ntEncrypt($c_info->{data});
      $flags = pack($msg3_tl, $c_info->{flags});
	 }
	 elsif ($ntlm_v2 eq '1') {
      $lmResp = &lmv2Encrypt($c_info->{data});
      $ntResp = &ntv2Encrypt($c_info->{data}, $c_info->{target_data});
      $flags = pack($msg3_tl, $ntlm_v2_msg3_flags);
	 }
    else {
      $domain = &unicode($domain);#substr($challenge, $c_info->{domain}{offset}, $c_info->{domain}{len}); 
      $lmResp = &lmEncrypt($c_info->{data});
      $ntResp = &ntEncrypt($c_info->{data});
      $flags = pack($msg3_tl, $c_info->{flags});
    }
    $u_host = &unicode(($host ? $host : $user));
    $response = pack($msg3, $ident, 3);

    $lm_off = $msg3_hlen;
    $nt_off = $lm_off + length($lmResp);
    $d_off = $nt_off + length($ntResp);
    $u_off = $d_off + length($domain);
    $wks_off = $u_off + length($u_user);
    $s_off = $wks_off + length($u_host);
    $lm_hdr = &hdr($lmResp, $msg3_hlen, $lm_off);
    $nt_hdr = &hdr($ntResp, $msg3_hlen, $nt_off);
    $domain_hdr = &hdr($domain, $msg3_hlen, $d_off);
    $user_hdr = &hdr($u_user, $msg3_hlen, $u_off);
    $wks_hdr = &hdr($u_host, $msg3_hlen, $wks_off);
    $session_hdr = &hdr("", $msg3_hlen, $s_off);
    $response .= $lm_hdr . $nt_hdr . $domain_hdr . $user_hdr .
                 $wks_hdr . $session_hdr . $flags .
		 $lmResp . $ntResp . $domain . $u_user . $u_host;
  }
  else # first response;
  {
    my $f = $msg1_f;
    if (!length $domain) {
      $f &= ~NTLMSSP_NEGOTIATE_OEM_DOMAIN_SUPPLIED;
    }
    $msg1_host = $user;
    if ($ntlm_v2 and $ntlm_v2 eq '1') {
      $f &= ~NTLMSSP_NEGOTIATE_OEM_WORKSTATION_SUPPLIED;
      $f |= NTLMSSP_NEGOTIATE_NTLM2;
      $msg1_host = "";
    }

    $response = pack($msg1, $ident, 1, $f);
    $u_off = $msg1_hlen;
    $d_off = $u_off + length($msg1_host);
    $host_hdr = &hdr($msg1_host, $msg1_hlen, $u_off);
    $domain_hdr = &hdr($domain, $msg1_hlen, $d_off);
    $response .= $host_hdr . $domain_hdr . $msg1_host . $domain;
    $state = 1;
  }
  return encode_base64($response, "");
}

sub hdr
{
  my ($string, $h_len, $offset) = @_;

  my ($res, $len);
  $len = length($string);
  if ($string)
  {
    $res = pack($str_hdr, $len, $len, $offset);
  }
  else
  {
    $res = pack($str_hdr, 0, 0, $offset - $h_len);
  }
  return $res;
}

sub decode_challenge
{
  my ($challenge) = @_;

  my $res;
  my (@res, @hdr);
  my $original = $challenge;

  $res->{buffer} = $msg2_hlen < length $challenge
  ? substr($challenge, $msg2_hlen) : '';
  $challenge = substr($challenge, 0, $msg2_hlen);
  @res = unpack($msg2, $challenge);
  $res->{ident} = $res[0];
  $res->{type} = $res[1];
  @hdr = unpack($str_hdr, $res[2]);
  $res->{domain}{len} = $hdr[0];
  $res->{domain}{maxlen} = $hdr[1];
  $res->{domain}{offset} = $hdr[2];
  $res->{flags} = $res[3];
  $res->{data} = $res[4];
  $res->{reserved} = $res[5];
  $res->{empty_hdr} = $res[6];
  @hdr = unpack($str_hdr, $res[6]);
  $res->{target}{len} = $hdr[0];
  $res->{target}{maxlen} = $hdr[1];
  $res->{target}{offset} = $hdr[2];
  $res->{target_data} = substr($original, $hdr[2], $hdr[1]);

  return $res;
}

sub unicode
{
  my ($string) = @_;
  my ($reply, $c, $z) = ('');

  $z = sprintf "%c", 0;
  foreach $c (split //, $string)
  {
    $reply .= $c . $z;
  }
  return $reply;
}

sub NTunicode
{
  my ($string) = @_;
  my ($reply, $c);

  foreach $c (map {ord($_)} split(//, $string))
  {
    $reply .= pack("v", $c);
  }
  return $reply;
}

sub lmEncrypt
{
  my ($data) = @_;

  my $p14 = substr($password, 0, 14);
  $p14 =~ tr/a-z/A-Z/;
  $p14 .= "\0"x(14-length($p14));
  my $p21 = E_P16($p14);
  $p21 .= "\0"x(21-length($p21));
  my $p24 = E_P24($p21, $data);
  return $p24;
}

sub ntEncrypt
{
  my ($data) = @_;

  my $p21 = &E_md4hash;
  $p21 .= "\0"x(21-length($p21));
  my $p24 = E_P24($p21, $data);
  return $p24;
}

sub E_md4hash
{
  my $wpwd = &NTunicode($password);
  my $p16 = mdfour($wpwd);
  return $p16;
}

sub lmv2Encrypt {
  my ($data) = @_;

  my $u_pass = &unicode($password);
  my $ntlm_hash = mdfour($u_pass);

  my $u_user = &unicode("\U$user\E");
  my $u_domain = &unicode("$domain");
  my $concat = $u_user . $u_domain;

  my $hmac = Digest::HMAC_MD5->new($ntlm_hash);
  $hmac->add($concat);
  my $ntlm_v2_hash = $hmac->digest;

  # Firefox seems to use this as its random challenge
  my $random_challenge = "\0" x 8;

  my $concat2 = $data . $random_challenge;

  $hmac = Digest::HMAC_MD5->new($ntlm_v2_hash);
  $hmac->add(substr($data, 0, 8) . $random_challenge);
  my $r = $hmac->digest . $random_challenge;

  return $r;
}

sub ntv2Encrypt {
  my ($data, $target) = @_;

  my $u_pass = &unicode($password);
  my $ntlm_hash = mdfour($u_pass);

  my $u_user = &unicode("\U$user\E");
  my $u_domain = &unicode("$domain");
  my $concat = $u_user . $u_domain;

  my $hmac = Digest::HMAC_MD5->new($ntlm_hash);
  $hmac->add($concat);
  my $ntlm_v2_hash = $hmac->digest;

  my $zero_long = "\000" x 4;
  my $sig = pack("H8", "01010000");
  my $time = pack("VV", (time + 11644473600) + 10000000);
  my $rand = "\0" x 8;
  my $blob = $sig . $zero_long . $time . $rand . $zero_long .
      $target . $zero_long;

  $concat = $data . $blob;

  $hmac = Digest::HMAC_MD5->new($ntlm_v2_hash);
  $hmac->add($concat);

  my $d = $hmac->digest;

  my $r = $d . $blob;

  return $r;
}

1;
PK       ! ,c�+�  �    perl5/Authen/NTLM/MD4.pmnu ��6�$        #!/usr/local/bin/perl
#
# This is a partial implentation of the MD4 checksum code.
#
# NOTE
#
# The function &add() in this module is required as we need to be
# able to add 32bit integers ignoring overflow.  The C code this is
# based on does this because it uses the underlying hardware to
# perform the required addition however we need to be more careful
# as Perl will overflow an int and produce a result of 0xffffffff
# which is not very useful.  The &add() function splits its arguments
# into two shorts and adds these carrying overflow from the low short
# to the high short and ignoring carry from the high short.  Not
# exactly efficient, but it works and is fast enough for the purposes
# of this implementation
#

package Authen::NTLM::MD4;

use vars qw($VERSION @ISA @EXPORT);
require Exporter;

$VERSION = "1.02";
@ISA = qw(Exporter);
@EXPORT = qw(mdfour);

my ($A, $B, $C, $D);
my (@X, $M);

sub mdfour
{
  my ($in) = @_;

  my ($i, $pos);
  my $len = length($in);
  my $b = $len * 8;
  $in .= "\0"x128;
  $A = 0x67452301;
  $B = 0xefcdab89;
  $C = 0x98badcfe;
  $D = 0x10325476;
  $pos = 0;
  while ($len > 64)
  {
    &copy64(substr($in, $pos, 64));
    &mdfour64;
    $pos += 64;
    $len -= 64;
  }
  my $buf = substr($in, $pos, $len);
  $buf .= sprintf "%c", 0x80;
  if ($len <= 55)
  {
    $buf .= "\0"x(55-$len);
    $buf .= pack("V", $b);
    $buf .= "\0"x4;
    &copy64($buf);
    &mdfour64;
  }
  else
  {
    $buf .= "\0"x(120-$len);
    $buf .= pack("V", $b);
    $buf .= "\0"x4;
    &copy64(substr($buf, 0, 64));
    &mdfour64;
    &copy64(substr($buf, 64, 64));
    &mdfour64;
  }
  my $out = pack("VVVV", $A, $B, $C, $D);
  return $out;
}

sub F
{
  my ($X, $Y, $Z) = @_;
  my $res = ($X&$Y) | ((~$X)&$Z);
  return $res;
}

sub G
{
  my ($X, $Y, $Z) = @_;

  return ($X&$Y) | ($X&$Z) | ($Y&$Z);
}

sub H
{
  my ($X, $Y, $Z) = @_;

  return $X^$Y^$Z;
}

sub lshift
{
  my ($x, $s) = @_;

  $x &= 0xffffffff;
  return (($x<<$s)&0xffffffff) | ($x>>(32-$s));
}

sub ROUND1
{
  my ($a, $b, $c, $d, $k, $s) = @_;
  my $e = &add($a, &F($b, $c, $d), $X[$k]);
  return &lshift($e, $s);
}

sub ROUND2
{
  my ($a, $b, $c, $d, $k, $s) = @_;

  my $e = &add($a, &G($b, $c, $d), $X[$k], 0x5a827999);
  return &lshift($e, $s);
}

sub ROUND3
{
  my ($a, $b, $c, $d, $k, $s) = @_;

  my $e = &add($a, &H($b, $c, $d), $X[$k], 0x6ed9eba1);
  return &lshift($e, $s);
}

sub mdfour64
{
  my ($i, $AA, $BB, $CC, $DD);
  @X = unpack("N16", $M);
  $AA = $A;
  $BB = $B;
  $CC = $C;
  $DD = $D;

  $A = &ROUND1($A,$B,$C,$D, 0, 3); $D = &ROUND1($D,$A,$B,$C, 1, 7);
  $C = &ROUND1($C,$D,$A,$B, 2,11); $B = &ROUND1($B,$C,$D,$A, 3,19);
  $A = &ROUND1($A,$B,$C,$D, 4, 3); $D = &ROUND1($D,$A,$B,$C, 5, 7);
  $C = &ROUND1($C,$D,$A,$B, 6,11); $B = &ROUND1($B,$C,$D,$A, 7,19);
  $A = &ROUND1($A,$B,$C,$D, 8, 3); $D = &ROUND1($D,$A,$B,$C, 9, 7);
  $C = &ROUND1($C,$D,$A,$B,10,11); $B = &ROUND1($B,$C,$D,$A,11,19);
  $A = &ROUND1($A,$B,$C,$D,12, 3); $D = &ROUND1($D,$A,$B,$C,13, 7);
  $C = &ROUND1($C,$D,$A,$B,14,11); $B = &ROUND1($B,$C,$D,$A,15,19);

  $A = &ROUND2($A,$B,$C,$D, 0, 3); $D = &ROUND2($D,$A,$B,$C, 4, 5);
  $C = &ROUND2($C,$D,$A,$B, 8, 9); $B = &ROUND2($B,$C,$D,$A,12,13);
  $A = &ROUND2($A,$B,$C,$D, 1, 3); $D = &ROUND2($D,$A,$B,$C, 5, 5);
  $C = &ROUND2($C,$D,$A,$B, 9, 9); $B = &ROUND2($B,$C,$D,$A,13,13);
  $A = &ROUND2($A,$B,$C,$D, 2, 3); $D = &ROUND2($D,$A,$B,$C, 6, 5);
  $C = &ROUND2($C,$D,$A,$B,10, 9); $B = &ROUND2($B,$C,$D,$A,14,13);
  $A = &ROUND2($A,$B,$C,$D, 3, 3); $D = &ROUND2($D,$A,$B,$C, 7, 5);
  $C = &ROUND2($C,$D,$A,$B,11, 9); $B = &ROUND2($B,$C,$D,$A,15,13);

  $A = &ROUND3($A,$B,$C,$D, 0, 3); $D = &ROUND3($D,$A,$B,$C, 8, 9);
  $C = &ROUND3($C,$D,$A,$B, 4,11); $B = &ROUND3($B,$C,$D,$A,12,15);
  $A = &ROUND3($A,$B,$C,$D, 2, 3); $D = &ROUND3($D,$A,$B,$C,10, 9);
  $C = &ROUND3($C,$D,$A,$B, 6,11); $B = &ROUND3($B,$C,$D,$A,14,15);
  $A = &ROUND3($A,$B,$C,$D, 1, 3); $D = &ROUND3($D,$A,$B,$C, 9, 9);
  $C = &ROUND3($C,$D,$A,$B, 5,11); $B = &ROUND3($B,$C,$D,$A,13,15);
  $A = &ROUND3($A,$B,$C,$D, 3, 3); $D = &ROUND3($D,$A,$B,$C,11, 9);
  $C = &ROUND3($C,$D,$A,$B, 7,11); $B = &ROUND3($B,$C,$D,$A,15,15);

  $A = &add($A, $AA); $B = &add($B, $BB);
  $C = &add($C, $CC); $D = &add($D, $DD);
  $A &= 0xffffffff; $B &= 0xffffffff;
  $C &= 0xffffffff; $D &= 0xffffffff;
  map {$_ = 0} @X;
}

sub copy64
{
  my ($in) = @_;

  $M = pack("V16", unpack("N16", $in));
}

# see note at top of this file about this function
sub add
{
  my (@nums) = @_;
  my ($r_low, $r_high, $n_low, $l_high);
  my $num;
  $r_low = $r_high = 0;
  foreach $num (@nums)
  {
    $n_low = $num & 0xffff;
    $n_high = ($num&0xffff0000)>>16;
    $r_low += $n_low;
    ($r_low&0xf0000) && $r_high++;
    $r_low &= 0xffff;
    $r_high += $n_high;
    $r_high &= 0xffff;
  }
  return ($r_high<<16)|$r_low;
}

1;
PK       ! +�rM[  [    perl5/Authen/NTLM/DES.pmnu ��6�$        #!/usr/local/bin/perl
#
# This is an implementation of part of the DES specification.  According
# to the code this is ported from, this code does NOT enable 2-way
# encryption and is, hence, not a cypher and does not appear to come
# under any export restrictions on such.
#
package Authen::NTLM::DES;

use vars qw($VERSION @ISA @EXPORT);
require Exporter;

$VERSION = "1.02";
@ISA = qw(Exporter);
@EXPORT = qw(E_P16 E_P24);

my ($loop, $loop2);
$loop = 0;
$loop2 = 0;

my $perm1 = [57, 49, 41, 33, 25, 17, 9,
             1, 58, 50, 42, 34, 26, 18,
	     10, 2, 59, 51, 43, 35, 27,
	     19, 11, 3, 60, 52, 44, 36,
	     63, 55, 47, 39, 31, 23, 15,
	     7, 62, 54, 46, 38, 30, 22,
	     14, 6, 61, 53, 45, 37, 29,
	     21, 13, 5, 28, 20, 12, 4];
my $perm2 = [14, 17, 11, 24, 1, 5,
             3, 28, 15, 6, 21, 10,
	     23, 19, 12, 4, 26, 8,
	     16, 7, 27, 20, 13, 2,
	     41, 52, 31, 37, 47, 55,
	     30, 40, 51, 45, 33, 48,
	     44, 49, 39, 56, 34, 53,
	     46, 42, 50, 36, 29, 32];
my $perm3 = [58, 50, 42, 34, 26, 18, 10, 2,
             60, 52, 44, 36, 28, 20, 12, 4,
	     62, 54, 46, 38, 30, 22, 14, 6,
	     64, 56, 48, 40, 32, 24, 16, 8,
	     57, 49, 41, 33, 25, 17, 9, 1,
	     59, 51, 43, 35, 27, 19, 11, 3,
	     61, 53, 45, 37, 29, 21, 13, 5,
	     63, 55, 47, 39, 31, 23, 15, 7];
my $perm4 = [32, 1, 2, 3, 4, 5,
             4, 5, 6, 7, 8, 9,
	     8, 9, 10, 11, 12, 13,
	     12, 13, 14, 15, 16, 17,
	     16, 17, 18, 19, 20, 21,
	     20, 21, 22, 23, 24, 25,
	     24, 25, 26, 27, 28, 29,
	     28, 29, 30, 31, 32, 1];
my $perm5 = [16, 7, 20, 21, 29, 12, 28, 17,
             1, 15, 23, 26, 5, 18, 31, 10,
	     2, 8, 24, 14, 32, 27, 3, 9,
	     19, 13, 30, 6, 22, 11, 4, 25];
my $perm6 = [40, 8, 48, 16, 56, 24, 64, 32,
             39, 7, 47, 15, 55, 23, 63, 31,
	     38, 6, 46, 14, 54, 22, 62, 30,
	     37, 5, 45, 13, 53, 21, 61, 29,
	     36, 4, 44, 12, 52, 20, 60, 28,
	     35, 3, 43, 11, 51, 19, 59, 27,
	     34, 2, 42, 10, 50, 18, 58, 26,
	     33, 1, 41,  9, 49, 17, 57, 25];
my $sc = [1, 1, 2, 2, 2, 2, 2, 2, 1, 2, 2, 2, 2, 2, 2, 1];
my $sbox = [
[
[14, 4, 13, 1, 2, 15, 11, 8, 3, 10, 6, 12, 5, 9, 0, 7],
[0, 15, 7, 4, 14, 2, 13, 1, 10, 6, 12, 11, 9, 5, 3, 8],
[4, 1, 14, 8, 13, 6, 2, 11, 15, 12, 9, 7, 3, 10, 5, 0],
[15, 12, 8, 2, 4, 9, 1, 7, 5, 11, 3, 14, 10, 0, 6, 13]
],
[
[15, 1, 8, 14, 6, 11, 3, 4, 9, 7, 2, 13, 12, 0, 5, 10],
[3, 13, 4, 7, 15, 2, 8, 14, 12, 0, 1, 10, 6, 9, 11, 5],
[0, 14, 7, 11, 10, 4, 13, 1, 5, 8, 12, 6, 9, 3, 2, 15],
[13, 8, 10, 1, 3, 15, 4, 2, 11, 6, 7, 12, 0, 5, 14, 9]
],
[
[10, 0, 9, 14, 6, 3, 15, 5, 1, 13, 12, 7, 11, 4, 2, 8],
[13, 7, 0, 9, 3, 4, 6, 10, 2, 8, 5, 14, 12, 11, 15, 1],
[13, 6, 4, 9, 8, 15, 3, 0, 11, 1, 2, 12, 5, 10, 14, 7],
[1, 10, 13, 0, 6, 9, 8, 7, 4, 15, 14, 3, 11, 5, 2, 12]
],
[
[7, 13, 14, 3, 0, 6, 9, 10, 1, 2, 8, 5, 11, 12, 4, 15],
[13, 8, 11, 5, 6, 15, 0, 3, 4, 7, 2, 12, 1, 10, 14, 9],
[10, 6, 9, 0, 12, 11, 7, 13, 15, 1, 3, 14, 5, 2, 8, 4],
[3, 15, 0, 6, 10, 1, 13, 8, 9, 4, 5, 11, 12, 7, 2, 14]
],
[
[2,12,4,1,7,10,11,6,8,5,3,15,13,0,14,9],
[14,11,2,12,4,7,13,1,5,0,15,10,3,9,8,6],
[4,2,1,11,10,13,7,8,15,9,12,5,6,3,0,14],
[11,8,12,7,1,14,2,13,6,15,0,9,10,4,5,3]
],
[
[12,1,10,15,9,2,6,8,0,13,3,4,14,7,5,11],
[10,15,4,2,7,12,9,5,6,1,13,14,0,11,3,8],
[9,14,15,5,2,8,12,3,7,0,4,10,1,13,11,6],
[4,3,2,12,9,5,15,10,11,14,1,7,6,0,8,13]
],
[
[4,11,2,14,15,0,8,13,3,12,9,7,5,10,6,1],
[13,0,11,7,4,9,1,10,14,3,5,12,2,15,8,6],
[1,4,11,13,12,3,7,14,10,15,6,8,0,5,9,2],
[6,11,13,8,1,4,10,7,9,5,0,15,14,2,3,12]
],
[
[13,2,8,4,6,15,11,1,10,9,3,14,5,0,12,7],
[1,15,13,8,10,3,7,4,12,5,6,11,0,14,9,2],
[7,11,4,1,9,12,14,2,0,6,10,13,15,3,5,8],
[2,1,14,7,4,10,8,13,15,12,9,0,3,5,6,11]
]
];

sub E_P16
{
  my ($p14) = @_;
  my $sp8 = [0x4b, 0x47, 0x53, 0x21, 0x40, 0x23, 0x24, 0x25];

  my $p7 = substr($p14, 0, 7);
  my $p16 = smbhash($sp8, $p7);
  $p7 = substr($p14, 7, 7);
  $p16 .= smbhash($sp8, $p7);
  return $p16;
}

sub E_P24
{
  my ($p21, $c8_str) = @_;
  my @c8 = map {ord($_)} split(//, $c8_str);
  my $p24 = smbhash(\@c8, substr($p21, 0, 7));
  $p24 .= smbhash(\@c8, substr($p21, 7, 7));
  $p24 .= smbhash(\@c8, substr($p21, 14, 7));
}

sub permute
{
  my ($out, $in, $p, $n) = @_;
  my $i;

  foreach $i (0..($n-1))
  {
    $out->[$i] = $in->[$p->[$i]-1];
  }
}

sub lshift
{
  my ($d, $count, $n) = @_;
  my (@out, $i);

  foreach $i (0..($n-1))
  {
    $out[$i] = $d->[($i+$count)%$n];
  }
  foreach $i (0..($n-1))
  {
    $d->[$i] = $out[$i];
  }
}

sub xor
{
  my ($out, $in1, $in2, $n) = @_;
  my $i;

  foreach $i (0..($n-1))
  {
    $out->[$i] = $in1->[$i]^$in2->[$i];
  }
}

sub dohash
{
  my ($out, $in, $key) = @_;
  my ($i, $j, $k, @pk1, @c, @d, @cd,
      @ki, @pd1, @l, @r, @rl);

  &permute(\@pk1, $key, $perm1, 56);

  foreach $i (0..27)
  {
    $c[$i] = $pk1[$i];
    $d[$i] = $pk1[$i+28];
  }
  foreach $i (0..15)
  {
    my @array;
    &lshift(\@c, $sc->[$i], 28);
    &lshift(\@d, $sc->[$i], 28);
    @cd = (@c, @d);
    &permute(\@array, \@cd, $perm2, 48);
    $ki[$i] = \@array;
  }
  &permute(\@pd1, $in, $perm3, 64);

  foreach $j (0..31)
  {
    $l[$j] = $pd1[$j];
    $r[$j] = $pd1[$j+32];
  }

  foreach $i (0..15)
  {
    local (@er, @erk, @b, @cb, @pcb, @r2);
    permute(\@er, \@r, $perm4, 48);
    &xor(\@erk, \@er, $ki[$i], 48);
    foreach $j (0..7)
    {
      foreach $k (0..5)
      {
	$b[$j][$k] = $erk[$j*6+$k];
      }
    }
    foreach $j (0..7)
    {
      local ($m, $n);
      $m = ($b[$j][0]<<1) | $b[$j][5];
      $n = ($b[$j][1]<<3) | ($b[$j][2]<<2) | ($b[$j][3]<<1) | $b[$j][4];
      foreach $k (0..3)
      {
	$b[$j][$k] = ($sbox->[$j][$m][$n] & (1<<(3-$k)))? 1: 0;
      }
    }
    foreach $j (0..7)
    {
      foreach $k (0..3)
      {
	$cb[$j*4+$k] = $b[$j][$k];
      }
    }
    &permute(\@pcb, \@cb, $perm5, 32);
    &xor(\@r2, \@l, \@pcb, 32);
    foreach $j (0..31)
    {
      $l[$j] = $r[$j];
      $r[$j] = $r2[$j];
    }
  }
  @rl = (@r, @l);
  &permute($out, \@rl, $perm6, 64);
}

sub str_to_key
{
  my ($str) = @_;
  my $i;
  my @key;
  my $out;
  my @str = map {ord($_)} split(//, $str);
  $key[0] = $str[0]>>1;
  $key[1] = (($str[0]&0x01)<<6) | ($str[1]>>2);
  $key[2] = (($str[1]&0x03)<<5) | ($str[2]>>3);
  $key[3] = (($str[2]&0x07)<<4) | ($str[3]>>4);
  $key[4] = (($str[3]&0x0f)<<3) | ($str[4]>>5);
  $key[5] = (($str[4]&0x1f)<<2) | ($str[5]>>6);
  $key[6] = (($str[5]&0x3f)<<1) | ($str[6]>>7);
  $key[7] = $str[6]&0x7f;
  foreach $i (0..7)
  {
    $key[$i] = 0xff&($key[$i]<<1);
  }
  return \@key;
}

sub smbhash
{
  my ($in, $key) = @_;

  my $key2 = &str_to_key($key);
  my ($i, $div, $mod, @in, @outb, @inb, @keyb, @out);
  foreach $i (0..63)
  {
    $div = int($i/8); $mod = $i%8;
    $inb[$i] = ($in->[$div] & (1<<(7-($mod))))? 1: 0;
    $keyb[$i] = ($key2->[$div] & (1<<(7-($mod))))? 1: 0;
    $outb[$i] = 0;
  }
  &dohash(\@outb, \@inb, \@keyb);
  foreach $i (0..7)
  {
    $out[$i] = 0;
  }
  foreach $i (0..63)
  {
    $out[int($i/8)] |= (1<<(7-($i%8))) if ($outb[$i]);
  }
  my $out = pack("C8", @out);
  return $out;
}

1;
PK       ! 0���Q4  Q4    perl5/HTTP/Status.pmnu ��6�$        package HTTP::Status;

use strict;
use warnings;

our $VERSION = '6.26';

require 5.002;   # because we use prototypes

use base 'Exporter';
our @EXPORT = qw(is_info is_success is_redirect is_error status_message);
our @EXPORT_OK = qw(is_client_error is_server_error is_cacheable_by_default);

# Note also addition of mnemonics to @EXPORT below

# Unmarked codes are from RFC 7231 (2017-12-20)
# See also:
# https://www.iana.org/assignments/http-status-codes/http-status-codes.xhtml

my %StatusCode = (
    100 => 'Continue',
    101 => 'Switching Protocols',
    102 => 'Processing',                      # RFC 2518: WebDAV
    103 => 'Early Hints',                     # RFC 8297: Indicating Hints
#   104 .. 199
    200 => 'OK',
    201 => 'Created',
    202 => 'Accepted',
    203 => 'Non-Authoritative Information',
    204 => 'No Content',
    205 => 'Reset Content',
    206 => 'Partial Content',                 # RFC 7233: Range Requests
    207 => 'Multi-Status',                    # RFC 4918: WebDAV
    208 => 'Already Reported',                # RFC 5842: WebDAV bindings
#   209 .. 225
    226 => 'IM Used',                         # RFC 3229: Delta encoding
#   227 .. 299
    300 => 'Multiple Choices',
    301 => 'Moved Permanently',
    302 => 'Found',
    303 => 'See Other',
    304 => 'Not Modified',                    # RFC 7232: Conditional Request
    305 => 'Use Proxy',
    307 => 'Temporary Redirect',
    308 => 'Permanent Redirect',              # RFC 7528: Permanent Redirect
#   309 .. 399
    400 => 'Bad Request',
    401 => 'Unauthorized',                    # RFC 7235: Authentication
    402 => 'Payment Required',
    403 => 'Forbidden',
    404 => 'Not Found',
    405 => 'Method Not Allowed',
    406 => 'Not Acceptable',
    407 => 'Proxy Authentication Required',   # RFC 7235: Authentication
    408 => 'Request Timeout',
    409 => 'Conflict',
    410 => 'Gone',
    411 => 'Length Required',
    412 => 'Precondition Failed',             # RFC 7232: Conditional Request
    413 => 'Payload Too Large',
    414 => 'URI Too Long',
    415 => 'Unsupported Media Type',
    416 => 'Range Not Satisfiable',           # RFC 7233: Range Requests
    417 => 'Expectation Failed',
#   418 .. 420
    421 => 'Misdirected Request',             # RFC 7540: HTTP/2
    422 => 'Unprocessable Entity',            # RFC 4918: WebDAV
    423 => 'Locked',                          # RFC 4918: WebDAV
    424 => 'Failed Dependency',               # RFC 4918: WebDAV
    425 => 'Too Early',                       # RFC 8470: Using Early Data in HTTP
    426 => 'Upgrade Required',
#   427
    428 => 'Precondition Required',           # RFC 6585: Additional Codes
    429 => 'Too Many Requests',               # RFC 6585: Additional Codes
#   430
    431 => 'Request Header Fields Too Large', # RFC 6585: Additional Codes
#   432 .. 450
    451 => 'Unavailable For Legal Reasons',   # RFC 7725: Legal Obstacles
#   452 .. 499
    500 => 'Internal Server Error',
    501 => 'Not Implemented',
    502 => 'Bad Gateway',
    503 => 'Service Unavailable',
    504 => 'Gateway Timeout',
    505 => 'HTTP Version Not Supported',
    506 => 'Variant Also Negotiates',         # RFC 2295: Transparant Ngttn
    507 => 'Insufficient Storage',            # RFC 4918: WebDAV
    508 => 'Loop Detected',                   # RFC 5842: WebDAV bindings
#   509
    510 => 'Not Extended',                    # RFC 2774: Extension Framework
    511 => 'Network Authentication Required', # RFC 6585: Additional Codes
);

# keep some unofficial codes that used to be in this distribution
%StatusCode = (
    %StatusCode,
    418 => 'I\'m a teapot',                   # RFC 2324: HTCPC/1.0  1-april
    449 => 'Retry with',                      #           microsoft
    509 => 'Bandwidth Limit Exceeded',        #           Apache / cPanel
);

my $mnemonicCode = '';
my ($code, $message);
while (($code, $message) = each %StatusCode) {
    # create mnemonic subroutines
    $message =~ s/I'm/I am/;
    $message =~ tr/a-z \-/A-Z__/;
    $mnemonicCode .= "sub HTTP_$message () { $code }\n";
    $mnemonicCode .= "*RC_$message = \\&HTTP_$message;\n";  # legacy
    $mnemonicCode .= "push(\@EXPORT_OK, 'HTTP_$message');\n";
    $mnemonicCode .= "push(\@EXPORT, 'RC_$message');\n";
}
eval $mnemonicCode; # only one eval for speed
die if $@;

# backwards compatibility
*RC_MOVED_TEMPORARILY = \&RC_FOUND;  # 302 was renamed in the standard
push(@EXPORT, "RC_MOVED_TEMPORARILY");

*RC_REQUEST_ENTITY_TOO_LARGE = \&RC_PAYLOAD_TOO_LARGE;
push(@EXPORT, "RC_REQUEST_ENTITY_TOO_LARGE");

*RC_REQUEST_URI_TOO_LARGE = \&RC_URI_TOO_LONG;
push(@EXPORT, "RC_REQUEST_URI_TOO_LARGE");

*RC_REQUEST_RANGE_NOT_SATISFIABLE = \&RC_RANGE_NOT_SATISFIABLE;
push(@EXPORT, "RC_REQUEST_RANGE_NOT_SATISFIABLE");

*RC_NO_CODE = \&RC_TOO_EARLY;
push(@EXPORT, "RC_NO_CODE");

*RC_UNORDERED_COLLECTION = \&RC_TOO_EARLY;
push(@EXPORT, "RC_UNORDERED_COLLECTION");

*HTTP_REQUEST_ENTITY_TOO_LARGE = \&HTTP_PAYLOAD_TOO_LARGE;
push(@EXPORT_OK, "HTTP_REQUEST_ENTITY_TOO_LARGE");

*HTTP_REQUEST_URI_TOO_LARGE = \&HTTP_URI_TOO_LONG;
push(@EXPORT_OK, "HTTP_REQUEST_URI_TOO_LARGE");

*HTTP_REQUEST_RANGE_NOT_SATISFIABLE = \&HTTP_RANGE_NOT_SATISFIABLE;
push(@EXPORT_OK, "HTTP_REQUEST_RANGE_NOT_SATISFIABLE");

*HTTP_NO_CODE = \&HTTP_TOO_EARLY;
push(@EXPORT_OK, "HTTP_NO_CODE");

*HTTP_UNORDERED_COLLECTION = \&HTTP_TOO_EARLY;
push(@EXPORT_OK, "HTTP_UNORDERED_COLLECTION");

our %EXPORT_TAGS = (
   constants => [grep /^HTTP_/, @EXPORT_OK],
   is => [grep /^is_/, @EXPORT, @EXPORT_OK],
);


sub status_message  ($) { $StatusCode{$_[0]}; }

sub is_info                 ($) { $_[0] && $_[0] >= 100 && $_[0] < 200; }
sub is_success              ($) { $_[0] && $_[0] >= 200 && $_[0] < 300; }
sub is_redirect             ($) { $_[0] && $_[0] >= 300 && $_[0] < 400; }
sub is_error                ($) { $_[0] && $_[0] >= 400 && $_[0] < 600; }
sub is_client_error         ($) { $_[0] && $_[0] >= 400 && $_[0] < 500; }
sub is_server_error         ($) { $_[0] && $_[0] >= 500 && $_[0] < 600; }
sub is_cacheable_by_default ($) { $_[0] && ( $_[0] == 200 # OK
                                          || $_[0] == 203 # Non-Authoritative Information
                                          || $_[0] == 204 # No Content
                                          || $_[0] == 206 # Not Acceptable
                                          || $_[0] == 300 # Multiple Choices
                                          || $_[0] == 301 # Moved Permanently
                                          || $_[0] == 404 # Not Found
                                          || $_[0] == 405 # Method Not Allowed
                                          || $_[0] == 410 # Gone
                                          || $_[0] == 414 # Request-URI Too Large
                                          || $_[0] == 451 # Unavailable For Legal Reasons
                                          || $_[0] == 501 # Not Implemented
                                            );
}

1;

=pod

=encoding UTF-8

=head1 NAME

HTTP::Status - HTTP Status code processing

=head1 VERSION

version 6.26

=head1 SYNOPSIS

 use HTTP::Status qw(:constants :is status_message);

 if ($rc != HTTP_OK) {
     print status_message($rc), "\n";
 }

 if (is_success($rc)) { ... }
 if (is_error($rc)) { ... }
 if (is_redirect($rc)) { ... }

=head1 DESCRIPTION

I<HTTP::Status> is a library of routines for defining and
classifying HTTP status codes for libwww-perl.  Status codes are
used to encode the overall outcome of an HTTP response message.  Codes
correspond to those defined in RFC 2616 and RFC 2518.

=head1 CONSTANTS

The following constant functions can be used as mnemonic status code
names.  None of these are exported by default.  Use the C<:constants>
tag to import them all.

   HTTP_CONTINUE                        (100)
   HTTP_SWITCHING_PROTOCOLS             (101)
   HTTP_PROCESSING                      (102)
   HTTP_EARLY_HINTS                     (103)

   HTTP_OK                              (200)
   HTTP_CREATED                         (201)
   HTTP_ACCEPTED                        (202)
   HTTP_NON_AUTHORITATIVE_INFORMATION   (203)
   HTTP_NO_CONTENT                      (204)
   HTTP_RESET_CONTENT                   (205)
   HTTP_PARTIAL_CONTENT                 (206)
   HTTP_MULTI_STATUS                    (207)
   HTTP_ALREADY_REPORTED                (208)

   HTTP_IM_USED                         (226)

   HTTP_MULTIPLE_CHOICES                (300)
   HTTP_MOVED_PERMANENTLY               (301)
   HTTP_FOUND                           (302)
   HTTP_SEE_OTHER                       (303)
   HTTP_NOT_MODIFIED                    (304)
   HTTP_USE_PROXY                       (305)
   HTTP_TEMPORARY_REDIRECT              (307)
   HTTP_PERMANENT_REDIRECT              (308)

   HTTP_BAD_REQUEST                     (400)
   HTTP_UNAUTHORIZED                    (401)
   HTTP_PAYMENT_REQUIRED                (402)
   HTTP_FORBIDDEN                       (403)
   HTTP_NOT_FOUND                       (404)
   HTTP_METHOD_NOT_ALLOWED              (405)
   HTTP_NOT_ACCEPTABLE                  (406)
   HTTP_PROXY_AUTHENTICATION_REQUIRED   (407)
   HTTP_REQUEST_TIMEOUT                 (408)
   HTTP_CONFLICT                        (409)
   HTTP_GONE                            (410)
   HTTP_LENGTH_REQUIRED                 (411)
   HTTP_PRECONDITION_FAILED             (412)
   HTTP_PAYLOAD_TOO_LARGE               (413)
   HTTP_URI_TOO_LONG                    (414)
   HTTP_UNSUPPORTED_MEDIA_TYPE          (415)
   HTTP_RANGE_NOT_SATISFIABLE           (416)
   HTTP_EXPECTATION_FAILED              (417)
   HTTP_MISDIRECTED REQUEST             (421)
   HTTP_UNPROCESSABLE_ENTITY            (422)
   HTTP_LOCKED                          (423)
   HTTP_FAILED_DEPENDENCY               (424)
   HTTP_TOO_EARLY                       (425)
   HTTP_UPGRADE_REQUIRED                (426)
   HTTP_PRECONDITION_REQUIRED           (428)
   HTTP_TOO_MANY_REQUESTS               (429)
   HTTP_REQUEST_HEADER_FIELDS_TOO_LARGE (431)
   HTTP_UNAVAILABLE_FOR_LEGAL_REASONS   (451)

   HTTP_INTERNAL_SERVER_ERROR           (500)
   HTTP_NOT_IMPLEMENTED                 (501)
   HTTP_BAD_GATEWAY                     (502)
   HTTP_SERVICE_UNAVAILABLE             (503)
   HTTP_GATEWAY_TIMEOUT                 (504)
   HTTP_HTTP_VERSION_NOT_SUPPORTED      (505)
   HTTP_VARIANT_ALSO_NEGOTIATES         (506)
   HTTP_INSUFFICIENT_STORAGE            (507)
   HTTP_LOOP_DETECTED                   (508)
   HTTP_NOT_EXTENDED                    (510)
   HTTP_NETWORK_AUTHENTICATION_REQUIRED (511)

=head1 FUNCTIONS

The following additional functions are provided.  Most of them are
exported by default.  The C<:is> import tag can be used to import all
the classification functions.

=over 4

=item status_message( $code )

The status_message() function will translate status codes to human
readable strings. The string is the same as found in the constant
names above. If the $code is not registered in the L<list of IANA HTTP Status
Codes|https://www.iana.org/assignments/http-status-codes/http-status-codes.xhtml>
then C<undef> is returned. 

=item is_info( $code )

Return TRUE if C<$code> is an I<Informational> status code (1xx).  This
class of status code indicates a provisional response which can't have
any content.

=item is_success( $code )

Return TRUE if C<$code> is a I<Successful> status code (2xx).

=item is_redirect( $code )

Return TRUE if C<$code> is a I<Redirection> status code (3xx). This class of
status code indicates that further action needs to be taken by the
user agent in order to fulfill the request.

=item is_error( $code )

Return TRUE if C<$code> is an I<Error> status code (4xx or 5xx).  The function
returns TRUE for both client and server error status codes.

=item is_client_error( $code )

Return TRUE if C<$code> is a I<Client Error> status code (4xx). This class
of status code is intended for cases in which the client seems to have
erred.

This function is B<not> exported by default.

=item is_server_error( $code )

Return TRUE if C<$code> is a I<Server Error> status code (5xx). This class
of status codes is intended for cases in which the server is aware
that it has erred or is incapable of performing the request.

This function is B<not> exported by default.

=item is_cacheable_by_default( $code )

Return TRUE if C<$code> indicates that a response is cacheable by default, and
it can be reused by a cache with heuristic expiration. All other status codes
are not cacheable by default. See L<RFC 7231 - HTTP/1.1 Semantics and Content,
Section 6.1. Overview of Status Codes|https://tools.ietf.org/html/rfc7231#section-6.1>.

This function is B<not> exported by default.

=back

=head1 SEE ALSO

L<IANA HTTP Status Codes|https://www.iana.org/assignments/http-status-codes/http-status-codes.xhtml>

=head1 BUGS

For legacy reasons all the C<HTTP_> constants are exported by default
with the prefix C<RC_>.  It's recommended to use explicit imports and
the C<:constants> tag instead of relying on this.

=head1 AUTHOR

Gisle Aas <gisle@activestate.com>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 1994 by Gisle Aas.

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

=cut

__END__


#ABSTRACT: HTTP Status code processing
PK       ! ��Ѥ�"  �"    perl5/HTTP/Request.pmnu ��6�$        package HTTP::Request;

use strict;
use warnings;

our $VERSION = '6.26';

use base 'HTTP::Message';

sub new
{
    my($class, $method, $uri, $header, $content) = @_;
    my $self = $class->SUPER::new($header, $content);
    $self->method($method);
    $self->uri($uri);
    $self;
}


sub parse
{
    my($class, $str) = @_;
    Carp::carp('Undefined argument to parse()') if $^W && ! defined $str;
    my $request_line;
    if (defined $str && $str =~ s/^(.*)\n//) {
	$request_line = $1;
    }
    else {
	$request_line = $str;
	$str = "";
    }

    my $self = $class->SUPER::parse($str);
    if (defined $request_line) {
        my($method, $uri, $protocol) = split(' ', $request_line);
        $self->method($method);
        $self->uri($uri) if defined($uri);
        $self->protocol($protocol) if $protocol;
    }
    $self;
}


sub clone
{
    my $self = shift;
    my $clone = bless $self->SUPER::clone, ref($self);
    $clone->method($self->method);
    $clone->uri($self->uri);
    $clone;
}


sub method
{
    shift->_elem('_method', @_);
}


sub uri
{
    my $self = shift;
    my $old = $self->{'_uri'};
    if (@_) {
	my $uri = shift;
	if (!defined $uri) {
	    # that's ok
	}
	elsif (ref $uri) {
	    Carp::croak("A URI can't be a " . ref($uri) . " reference")
		if ref($uri) eq 'HASH' or ref($uri) eq 'ARRAY';
	    Carp::croak("Can't use a " . ref($uri) . " object as a URI")
		unless $uri->can('scheme') && $uri->can('canonical');
	    $uri = $uri->clone;
	    unless ($HTTP::URI_CLASS eq "URI") {
		# Argh!! Hate this... old LWP legacy!
		eval { local $SIG{__DIE__}; $uri = $uri->abs; };
		die $@ if $@ && $@ !~ /Missing base argument/;
	    }
	}
	else {
	    $uri = $HTTP::URI_CLASS->new($uri);
	}
	$self->{'_uri'} = $uri;
        delete $self->{'_uri_canonical'};
    }
    $old;
}

*url = \&uri;  # legacy

sub uri_canonical
{
    my $self = shift;

    my $uri = $self->{_uri};

    if (defined (my $canon = $self->{_uri_canonical})) {
        # early bailout if these are the exact same string; try to use
        # the cheapest comparison method possible
        return $canon if $$canon eq $$uri;
    }

    # otherwise we need to refresh the memoized value
    $self->{_uri_canonical} = $uri->canonical;
}


sub accept_decodable
{
    my $self = shift;
    $self->header("Accept-Encoding", scalar($self->decodable));
}

sub as_string
{
    my $self = shift;
    my($eol) = @_;
    $eol = "\n" unless defined $eol;

    my $req_line = $self->method || "-";
    my $uri = $self->uri;
    $uri = (defined $uri) ? $uri->as_string : "-";
    $req_line .= " $uri";
    my $proto = $self->protocol;
    $req_line .= " $proto" if $proto;

    return join($eol, $req_line, $self->SUPER::as_string(@_));
}

sub dump
{
    my $self = shift;
    my @pre = ($self->method || "-", $self->uri || "-");
    if (my $prot = $self->protocol) {
	push(@pre, $prot);
    }

    return $self->SUPER::dump(
        preheader => join(" ", @pre),
	@_,
    );
}


1;

=pod

=encoding UTF-8

=head1 NAME

HTTP::Request - HTTP style request message

=head1 VERSION

version 6.26

=head1 SYNOPSIS

 require HTTP::Request;
 $request = HTTP::Request->new(GET => 'http://www.example.com/');

and usually used like this:

 $ua = LWP::UserAgent->new;
 $response = $ua->request($request);

=head1 DESCRIPTION

C<HTTP::Request> is a class encapsulating HTTP style requests,
consisting of a request line, some headers, and a content body. Note
that the LWP library uses HTTP style requests even for non-HTTP
protocols.  Instances of this class are usually passed to the
request() method of an C<LWP::UserAgent> object.

C<HTTP::Request> is a subclass of C<HTTP::Message> and therefore
inherits its methods.  The following additional methods are available:

=over 4

=item $r = HTTP::Request->new( $method, $uri )

=item $r = HTTP::Request->new( $method, $uri, $header )

=item $r = HTTP::Request->new( $method, $uri, $header, $content )

Constructs a new C<HTTP::Request> object describing a request on the
object $uri using method $method.  The $method argument must be a
string.  The $uri argument can be either a string, or a reference to a
C<URI> object.  The optional $header argument should be a reference to
an C<HTTP::Headers> object or a plain array reference of key/value
pairs.  The optional $content argument should be a string of bytes.

=item $r = HTTP::Request->parse( $str )

This constructs a new request object by parsing the given string.

=item $r->method

=item $r->method( $val )

This is used to get/set the method attribute.  The method should be a
short string like "GET", "HEAD", "PUT", "PATCH" or "POST".

=item $r->uri

=item $r->uri( $val )

This is used to get/set the uri attribute.  The $val can be a
reference to a URI object or a plain string.  If a string is given,
then it should be parsable as an absolute URI.

=item $r->header( $field )

=item $r->header( $field => $value )

This is used to get/set header values and it is inherited from
C<HTTP::Headers> via C<HTTP::Message>.  See L<HTTP::Headers> for
details and other similar methods that can be used to access the
headers.

=item $r->accept_decodable

This will set the C<Accept-Encoding> header to the list of encodings
that decoded_content() can decode.

=item $r->content

=item $r->content( $bytes )

This is used to get/set the content and it is inherited from the
C<HTTP::Message> base class.  See L<HTTP::Message> for details and
other methods that can be used to access the content.

Note that the content should be a string of bytes.  Strings in perl
can contain characters outside the range of a byte.  The C<Encode>
module can be used to turn such strings into a string of bytes.

=item $r->as_string

=item $r->as_string( $eol )

Method returning a textual representation of the request.

=back

=head1 EXAMPLES

Creating requests to be sent with L<LWP::UserAgent> or others can be easy. Here
are a few examples.

=head2 Simple POST

Here, we'll create a simple POST request that could be used to send JSON data
to an endpoint.

    #!/usr/bin/env perl

    use strict;
    use warnings;

    use HTTP::Request ();
    use JSON::MaybeXS qw(encode_json);

    my $url = 'https://www.example.com/api/user/123';
    my $header = ['Content-Type' => 'application/json; charset=UTF-8'];
    my $data = {foo => 'bar', baz => 'quux'};
    my $encoded_data = encode_json($data);

    my $r = HTTP::Request->new('POST', $url, $header, $encoded_data);
    # at this point, we could send it via LWP::UserAgent
    # my $ua = LWP::UserAgent->new();
    # my $res = $ua->request($r);

=head2 Batch POST Request

Some services, like Google, allow multiple requests to be sent in one batch.
L<https://developers.google.com/drive/v3/web/batch> for example. Using the
C<add_part> method from L<HTTP::Message> makes this simple.

    #!/usr/bin/env perl

    use strict;
    use warnings;

    use HTTP::Request ();
    use JSON::MaybeXS qw(encode_json);

    my $auth_token = 'auth_token';
    my $batch_url = 'https://www.googleapis.com/batch';
    my $url = 'https://www.googleapis.com/drive/v3/files/fileId/permissions?fields=id';
    my $url_no_email = 'https://www.googleapis.com/drive/v3/files/fileId/permissions?fields=id&sendNotificationEmail=false';

    # generate a JSON post request for one of the batch entries
    my $req1 = build_json_request($url, {
        emailAddress => 'example@appsrocks.com',
        role => "writer",
        type => "user",
    });

    # generate a JSON post request for one of the batch entries
    my $req2 = build_json_request($url_no_email, {
        domain => "appsrocks.com",
        role => "reader",
        type => "domain",
    });

    # generate a multipart request to send all of the other requests
    my $r = HTTP::Request->new('POST', $batch_url, [
        'Accept-Encoding' => 'gzip',
        # if we don't provide a boundary here, HTTP::Message will generate
        # one for us. We could use UUID::uuid() here if we wanted.
        'Content-Type' => 'multipart/mixed; boundary=END_OF_PART'
    ]);

    # add the two POST requests to the main request
    $r->add_part($req1, $req2);
    # at this point, we could send it via LWP::UserAgent
    # my $ua = LWP::UserAgent->new();
    # my $res = $ua->request($r);
    exit();

    sub build_json_request {
        my ($url, $href) = @_;
        my $header = ['Authorization' => "Bearer $auth_token", 'Content-Type' => 'application/json; charset=UTF-8'];
        return HTTP::Request->new('POST', $url, $header, encode_json($href));
    }

=head1 SEE ALSO

L<HTTP::Headers>, L<HTTP::Message>, L<HTTP::Request::Common>,
L<HTTP::Response>

=head1 AUTHOR

Gisle Aas <gisle@activestate.com>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 1994 by Gisle Aas.

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

=cut

__END__


#ABSTRACT: HTTP style request message
PK       ! #�kx  x    perl5/HTTP/Message.pmnu ��6�$        package HTTP::Message;

use strict;
use warnings;

our $VERSION = '6.26';

require HTTP::Headers;
require Carp;

my $CRLF = "\015\012";   # "\r\n" is not portable
unless ($HTTP::URI_CLASS) {
    if ($ENV{PERL_HTTP_URI_CLASS}
    &&  $ENV{PERL_HTTP_URI_CLASS} =~ /^([\w:]+)$/) {
        $HTTP::URI_CLASS = $1;
    } else {
        $HTTP::URI_CLASS = "URI";
    }
}
eval "require $HTTP::URI_CLASS"; die $@ if $@;

*_utf8_downgrade = defined(&utf8::downgrade) ?
    sub {
        utf8::downgrade($_[0], 1) or
            Carp::croak("HTTP::Message content must be bytes")
    }
    :
    sub {
    };

sub new
{
    my($class, $header, $content) = @_;
    if (defined $header) {
	Carp::croak("Bad header argument") unless ref $header;
        if (ref($header) eq "ARRAY") {
	    $header = HTTP::Headers->new(@$header);
	}
	else {
	    $header = $header->clone;
	}
    }
    else {
	$header = HTTP::Headers->new;
    }
    if (defined $content) {
        _utf8_downgrade($content);
    }
    else {
        $content = '';
    }

    bless {
	'_headers' => $header,
	'_content' => $content,
    }, $class;
}


sub parse
{
    my($class, $str) = @_;

    my @hdr;
    while (1) {
	if ($str =~ s/^([^\s:]+)[ \t]*: ?(.*)\n?//) {
	    push(@hdr, $1, $2);
	    $hdr[-1] =~ s/\r\z//;
	}
	elsif (@hdr && $str =~ s/^([ \t].*)\n?//) {
	    $hdr[-1] .= "\n$1";
	    $hdr[-1] =~ s/\r\z//;
	}
	else {
	    $str =~ s/^\r?\n//;
	    last;
	}
    }
    local $HTTP::Headers::TRANSLATE_UNDERSCORE;
    new($class, \@hdr, $str);
}


sub clone
{
    my $self  = shift;
    my $clone = HTTP::Message->new($self->headers,
				   $self->content);
    $clone->protocol($self->protocol);
    $clone;
}


sub clear {
    my $self = shift;
    $self->{_headers}->clear;
    $self->content("");
    delete $self->{_parts};
    return;
}


sub protocol {
    shift->_elem('_protocol',  @_);
}

sub headers {
    my $self = shift;

    # recalculation of _content might change headers, so we
    # need to force it now
    $self->_content unless exists $self->{_content};

    $self->{_headers};
}

sub headers_as_string {
    shift->headers->as_string(@_);
}


sub content  {

    my $self = $_[0];
    if (defined(wantarray)) {
	$self->_content unless exists $self->{_content};
	my $old = $self->{_content};
	$old = $$old if ref($old) eq "SCALAR";
	&_set_content if @_ > 1;
	return $old;
    }

    if (@_ > 1) {
	&_set_content;
    }
    else {
	Carp::carp("Useless content call in void context") if $^W;
    }
}


sub _set_content {
    my $self = $_[0];
    _utf8_downgrade($_[1]);
    if (!ref($_[1]) && ref($self->{_content}) eq "SCALAR") {
	${$self->{_content}} = defined( $_[1] ) ? $_[1] : '';
    }
    else {
	die "Can't set content to be a scalar reference" if ref($_[1]) eq "SCALAR";
	$self->{_content} = defined( $_[1] ) ? $_[1] : '';
	delete $self->{_content_ref};
    }
    delete $self->{_parts} unless $_[2];
}


sub add_content
{
    my $self = shift;
    $self->_content unless exists $self->{_content};
    my $chunkref = \$_[0];
    $chunkref = $$chunkref if ref($$chunkref);  # legacy

    _utf8_downgrade($$chunkref);

    my $ref = ref($self->{_content});
    if (!$ref) {
	$self->{_content} .= $$chunkref;
    }
    elsif ($ref eq "SCALAR") {
	${$self->{_content}} .= $$chunkref;
    }
    else {
	Carp::croak("Can't append to $ref content");
    }
    delete $self->{_parts};
}

sub add_content_utf8 {
    my($self, $buf)  = @_;
    utf8::upgrade($buf);
    utf8::encode($buf);
    $self->add_content($buf);
}

sub content_ref
{
    my $self = shift;
    $self->_content unless exists $self->{_content};
    delete $self->{_parts};
    my $old = \$self->{_content};
    my $old_cref = $self->{_content_ref};
    if (@_) {
	my $new = shift;
	Carp::croak("Setting content_ref to a non-ref") unless ref($new);
	delete $self->{_content};  # avoid modifying $$old
	$self->{_content} = $new;
	$self->{_content_ref}++;
    }
    $old = $$old if $old_cref;
    return $old;
}


sub content_charset
{
    my $self = shift;
    if (my $charset = $self->content_type_charset) {
	return $charset;
    }

    # time to start guessing
    my $cref = $self->decoded_content(ref => 1, charset => "none");

    # Unicode BOM
    for ($$cref) {
	return "UTF-8"     if /^\xEF\xBB\xBF/;
	return "UTF-32LE" if /^\xFF\xFE\x00\x00/;
	return "UTF-32BE" if /^\x00\x00\xFE\xFF/;
	return "UTF-16LE" if /^\xFF\xFE/;
	return "UTF-16BE" if /^\xFE\xFF/;
    }

    if ($self->content_is_xml) {
	# http://www.w3.org/TR/2006/REC-xml-20060816/#sec-guessing
	# XML entity not accompanied by external encoding information and not
	# in UTF-8 or UTF-16 encoding must begin with an XML encoding declaration,
	# in which the first characters must be '<?xml'
	for ($$cref) {
	    return "UTF-32BE" if /^\x00\x00\x00</;
	    return "UTF-32LE" if /^<\x00\x00\x00/;
	    return "UTF-16BE" if /^(?:\x00\s)*\x00</;
	    return "UTF-16LE" if /^(?:\s\x00)*<\x00/;
	    if (/^\s*(<\?xml[^\x00]*?\?>)/) {
		if ($1 =~ /\sencoding\s*=\s*(["'])(.*?)\1/) {
		    my $enc = $2;
		    $enc =~ s/^\s+//; $enc =~ s/\s+\z//;
		    return $enc if $enc;
		}
	    }
	}
	return "UTF-8";
    }
    elsif ($self->content_is_html) {
	# look for <META charset="..."> or <META content="...">
	# http://dev.w3.org/html5/spec/Overview.html#determining-the-character-encoding
	require IO::HTML;
	# Use relaxed search to match previous versions of HTTP::Message:
	my $encoding = IO::HTML::find_charset_in($$cref, { encoding    => 1,
	                                                   need_pragma => 0 });
	return $encoding->mime_name if $encoding;
    }
    elsif ($self->content_type eq "application/json") {
	for ($$cref) {
	    # RFC 4627, ch 3
	    return "UTF-32BE" if /^\x00\x00\x00./s;
	    return "UTF-32LE" if /^.\x00\x00\x00/s;
	    return "UTF-16BE" if /^\x00.\x00./s;
	    return "UTF-16LE" if /^.\x00.\x00/s;
	    return "UTF-8";
	}
    }
    if ($self->content_type =~ /^text\//) {
	for ($$cref) {
	    if (length) {
		return "US-ASCII" unless /[\x80-\xFF]/;
		require Encode;
		eval {
		    Encode::decode_utf8($_, Encode::FB_CROAK() | Encode::LEAVE_SRC());
		};
		return "UTF-8" unless $@;
		return "ISO-8859-1";
	    }
	}
    }

    return undef;
}


sub decoded_content
{
    my($self, %opt) = @_;
    my $content_ref;
    my $content_ref_iscopy;

    eval {
	$content_ref = $self->content_ref;
	die "Can't decode ref content" if ref($content_ref) ne "SCALAR";

	if (my $h = $self->header("Content-Encoding")) {
	    $h =~ s/^\s+//;
	    $h =~ s/\s+$//;
	    for my $ce (reverse split(/\s*,\s*/, lc($h))) {
		next unless $ce;
		next if $ce eq "identity" || $ce eq "none";
		if ($ce eq "gzip" || $ce eq "x-gzip") {
		    require IO::Uncompress::Gunzip;
		    my $output;
		    IO::Uncompress::Gunzip::gunzip($content_ref, \$output, Transparent => 0)
			or die "Can't gunzip content: $IO::Uncompress::Gunzip::GunzipError";
		    $content_ref = \$output;
		    $content_ref_iscopy++;
		}
		elsif ($ce eq "x-bzip2" or $ce eq "bzip2") {
		    require IO::Uncompress::Bunzip2;
		    my $output;
		    IO::Uncompress::Bunzip2::bunzip2($content_ref, \$output, Transparent => 0)
			or die "Can't bunzip content: $IO::Uncompress::Bunzip2::Bunzip2Error";
		    $content_ref = \$output;
		    $content_ref_iscopy++;
		}
		elsif ($ce eq "deflate") {
		    require IO::Uncompress::Inflate;
		    my $output;
		    my $status = IO::Uncompress::Inflate::inflate($content_ref, \$output, Transparent => 0);
		    my $error = $IO::Uncompress::Inflate::InflateError;
		    unless ($status) {
			# "Content-Encoding: deflate" is supposed to mean the
			# "zlib" format of RFC 1950, but Microsoft got that
			# wrong, so some servers sends the raw compressed
			# "deflate" data.  This tries to inflate this format.
			$output = undef;
			require IO::Uncompress::RawInflate;
			unless (IO::Uncompress::RawInflate::rawinflate($content_ref, \$output)) {
			    $self->push_header("Client-Warning" =>
				"Could not raw inflate content: $IO::Uncompress::RawInflate::RawInflateError");
			    $output = undef;
			}
		    }
		    die "Can't inflate content: $error" unless defined $output;
		    $content_ref = \$output;
		    $content_ref_iscopy++;
		}
		elsif ($ce eq "compress" || $ce eq "x-compress") {
		    die "Can't uncompress content";
		}
		elsif ($ce eq "base64") {  # not really C-T-E, but should be harmless
		    require MIME::Base64;
		    $content_ref = \MIME::Base64::decode($$content_ref);
		    $content_ref_iscopy++;
		}
		elsif ($ce eq "quoted-printable") { # not really C-T-E, but should be harmless
		    require MIME::QuotedPrint;
		    $content_ref = \MIME::QuotedPrint::decode($$content_ref);
		    $content_ref_iscopy++;
		}
		else {
		    die "Don't know how to decode Content-Encoding '$ce'";
		}
	    }
	}

	if ($self->content_is_text || (my $is_xml = $self->content_is_xml)) {
	    my $charset = lc(
	        $opt{charset} ||
		$self->content_type_charset ||
		$opt{default_charset} ||
		$self->content_charset ||
		"ISO-8859-1"
	    );
	    if ($charset eq "none") {
		# leave it as is
	    }
	    elsif ($charset eq "us-ascii" || $charset eq "iso-8859-1") {
		if ($$content_ref =~ /[^\x00-\x7F]/ && defined &utf8::upgrade) {
		    unless ($content_ref_iscopy) {
			my $copy = $$content_ref;
			$content_ref = \$copy;
			$content_ref_iscopy++;
		    }
		    utf8::upgrade($$content_ref);
		}
	    }
	    else {
		require Encode;
		eval {
		    $content_ref = \Encode::decode($charset, $$content_ref,
			 ($opt{charset_strict} ? Encode::FB_CROAK() : 0) | Encode::LEAVE_SRC());
		};
		if ($@) {
		    my $retried;
		    if ($@ =~ /^Unknown encoding/) {
			my $alt_charset = lc($opt{alt_charset} || "");
			if ($alt_charset && $charset ne $alt_charset) {
			    # Retry decoding with the alternative charset
			    $content_ref = \Encode::decode($alt_charset, $$content_ref,
				 ($opt{charset_strict} ? Encode::FB_CROAK() : 0) | Encode::LEAVE_SRC())
			        unless $alt_charset eq "none";
			    $retried++;
			}
		    }
		    die unless $retried;
		}
		die "Encode::decode() returned undef improperly" unless defined $$content_ref;
		if ($is_xml) {
		    # Get rid of the XML encoding declaration if present
		    $$content_ref =~ s/^\x{FEFF}//;
		    if ($$content_ref =~ /^(\s*<\?xml[^\x00]*?\?>)/) {
			substr($$content_ref, 0, length($1)) =~ s/\sencoding\s*=\s*(["']).*?\1//;
		    }
		}
	    }
	}
    };
    if ($@) {
	Carp::croak($@) if $opt{raise_error};
	return undef;
    }

    return $opt{ref} ? $content_ref : $$content_ref;
}


sub decodable
{
    # should match the Content-Encoding values that decoded_content can deal with
    my $self = shift;
    my @enc;
    local $@;
    # XXX preferably we should determine if the modules are available without loading
    # them here
    eval {
        require IO::Uncompress::Gunzip;
        push(@enc, "gzip", "x-gzip");
    };
    eval {
        require IO::Uncompress::Inflate;
        require IO::Uncompress::RawInflate;
        push(@enc, "deflate");
    };
    eval {
        require IO::Uncompress::Bunzip2;
        push(@enc, "x-bzip2", "bzip2");
    };
    # we don't care about announcing the 'identity', 'base64' and
    # 'quoted-printable' stuff
    return wantarray ? @enc : join(", ", @enc);
}


sub decode
{
    my $self = shift;
    return 1 unless $self->header("Content-Encoding");
    if (defined(my $content = $self->decoded_content(charset => "none"))) {
	$self->remove_header("Content-Encoding", "Content-Length", "Content-MD5");
	$self->content($content);
	return 1;
    }
    return 0;
}


sub encode
{
    my($self, @enc) = @_;

    Carp::croak("Can't encode multipart/* messages") if $self->content_type =~ m,^multipart/,;
    Carp::croak("Can't encode message/* messages") if $self->content_type =~ m,^message/,;

    return 1 unless @enc;  # nothing to do

    my $content = $self->content;
    for my $encoding (@enc) {
	if ($encoding eq "identity" || $encoding eq "none") {
	    # nothing to do
	}
	elsif ($encoding eq "base64") {
	    require MIME::Base64;
	    $content = MIME::Base64::encode($content);
	}
	elsif ($encoding eq "gzip" || $encoding eq "x-gzip") {
	    require IO::Compress::Gzip;
	    my $output;
	    IO::Compress::Gzip::gzip(\$content, \$output, Minimal => 1)
		or die "Can't gzip content: $IO::Compress::Gzip::GzipError";
	    $content = $output;
	}
	elsif ($encoding eq "deflate") {
	    require IO::Compress::Deflate;
	    my $output;
	    IO::Compress::Deflate::deflate(\$content, \$output)
		or die "Can't deflate content: $IO::Compress::Deflate::DeflateError";
	    $content = $output;
	}
	elsif ($encoding eq "x-bzip2" || $encoding eq "bzip2") {
	    require IO::Compress::Bzip2;
	    my $output;
	    IO::Compress::Bzip2::bzip2(\$content, \$output)
		or die "Can't bzip2 content: $IO::Compress::Bzip2::Bzip2Error";
	    $content = $output;
	}
	elsif ($encoding eq "rot13") {  # for the fun of it
	    $content =~ tr/A-Za-z/N-ZA-Mn-za-m/;
	}
	else {
	    return 0;
	}
    }
    my $h = $self->header("Content-Encoding");
    unshift(@enc, $h) if $h;
    $self->header("Content-Encoding", join(", ", @enc));
    $self->remove_header("Content-Length", "Content-MD5");
    $self->content($content);
    return 1;
}


sub as_string
{
    my($self, $eol) = @_;
    $eol = "\n" unless defined $eol;

    # The calculation of content might update the headers
    # so we need to do that first.
    my $content = $self->content;

    return join("", $self->{'_headers'}->as_string($eol),
		    $eol,
		    $content,
		    (@_ == 1 && length($content) &&
		     $content !~ /\n\z/) ? "\n" : "",
		);
}


sub dump
{
    my($self, %opt) = @_;
    my $content = $self->content;
    my $chopped = 0;
    if (!ref($content)) {
	my $maxlen = $opt{maxlength};
	$maxlen = 512 unless defined($maxlen);
	if ($maxlen && length($content) > $maxlen * 1.1 + 3) {
	    $chopped = length($content) - $maxlen;
	    $content = substr($content, 0, $maxlen) . "...";
	}

	$content =~ s/\\/\\\\/g;
	$content =~ s/\t/\\t/g;
	$content =~ s/\r/\\r/g;

	# no need for 3 digits in escape for these
	$content =~ s/([\0-\11\13-\037])(?!\d)/sprintf('\\%o',ord($1))/eg;

	$content =~ s/([\0-\11\13-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg;
	$content =~ s/([^\12\040-\176])/sprintf('\\x{%X}',ord($1))/eg;

	# remaining whitespace
	$content =~ s/( +)\n/("\\40" x length($1)) . "\n"/eg;
	$content =~ s/(\n+)\n/("\\n" x length($1)) . "\n"/eg;
	$content =~ s/\n\z/\\n/;

	my $no_content = $opt{no_content};
	$no_content = "(no content)" unless defined $no_content;
	if ($content eq $no_content) {
	    # escape our $no_content marker
	    $content =~ s/^(.)/sprintf('\\x%02X',ord($1))/eg;
	}
	elsif ($content eq "") {
	    $content = $no_content;
	}
    }

    my @dump;
    push(@dump, $opt{preheader}) if $opt{preheader};
    push(@dump, $self->{_headers}->as_string, $content);
    push(@dump, "(+ $chopped more bytes not shown)") if $chopped;

    my $dump = join("\n", @dump, "");
    $dump =~ s/^/$opt{prefix}/gm if $opt{prefix};

    print $dump unless defined wantarray;
    return $dump;
}

# allow subclasses to override what will handle individual parts
sub _part_class {
    return __PACKAGE__;
}

sub parts {
    my $self = shift;
    if (defined(wantarray) && (!exists $self->{_parts} || ref($self->{_content}) eq "SCALAR")) {
	$self->_parts;
    }
    my $old = $self->{_parts};
    if (@_) {
	my @parts = map { ref($_) eq 'ARRAY' ? @$_ : $_ } @_;
	my $ct = $self->content_type || "";
	if ($ct =~ m,^message/,) {
	    Carp::croak("Only one part allowed for $ct content")
		if @parts > 1;
	}
	elsif ($ct !~ m,^multipart/,) {
	    $self->remove_content_headers;
	    $self->content_type("multipart/mixed");
	}
	$self->{_parts} = \@parts;
	_stale_content($self);
    }
    return @$old if wantarray;
    return $old->[0];
}

sub add_part {
    my $self = shift;
    if (($self->content_type || "") !~ m,^multipart/,) {
	my $p = $self->_part_class->new(
	    $self->remove_content_headers,
	    $self->content(""),
	);
	$self->content_type("multipart/mixed");
	$self->{_parts} = [];
        if ($p->headers->header_field_names || $p->content ne "") {
            push(@{$self->{_parts}}, $p);
        }
    }
    elsif (!exists $self->{_parts} || ref($self->{_content}) eq "SCALAR") {
	$self->_parts;
    }

    push(@{$self->{_parts}}, @_);
    _stale_content($self);
    return;
}

sub _stale_content {
    my $self = shift;
    if (ref($self->{_content}) eq "SCALAR") {
	# must recalculate now
	$self->_content;
    }
    else {
	# just invalidate cache
	delete $self->{_content};
	delete $self->{_content_ref};
    }
}


# delegate all other method calls to the headers object.
our $AUTOLOAD;
sub AUTOLOAD
{
    my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);

    # We create the function here so that it will not need to be
    # autoloaded the next time.
    no strict 'refs';
    *$method = sub { local $Carp::Internal{+__PACKAGE__} = 1; shift->headers->$method(@_) };
    goto &$method;
}


sub DESTROY {}  # avoid AUTOLOADing it


# Private method to access members in %$self
sub _elem
{
    my $self = shift;
    my $elem = shift;
    my $old = $self->{$elem};
    $self->{$elem} = $_[0] if @_;
    return $old;
}


# Create private _parts attribute from current _content
sub _parts {
    my $self = shift;
    my $ct = $self->content_type;
    if ($ct =~ m,^multipart/,) {
	require HTTP::Headers::Util;
	my @h = HTTP::Headers::Util::split_header_words($self->header("Content-Type"));
	die "Assert" unless @h;
	my %h = @{$h[0]};
	if (defined(my $b = $h{boundary})) {
	    my $str = $self->content;
	    $str =~ s/\r?\n--\Q$b\E--.*//s;
	    if ($str =~ s/(^|.*?\r?\n)--\Q$b\E\r?\n//s) {
		$self->{_parts} = [map $self->_part_class->parse($_),
				   split(/\r?\n--\Q$b\E\r?\n/, $str)]
	    }
	}
    }
    elsif ($ct eq "message/http") {
	require HTTP::Request;
	require HTTP::Response;
	my $content = $self->content;
	my $class = ($content =~ m,^(HTTP/.*)\n,) ?
	    "HTTP::Response" : "HTTP::Request";
	$self->{_parts} = [$class->parse($content)];
    }
    elsif ($ct =~ m,^message/,) {
	$self->{_parts} = [ $self->_part_class->parse($self->content) ];
    }

    $self->{_parts} ||= [];
}


# Create private _content attribute from current _parts
sub _content {
    my $self = shift;
    my $ct = $self->{_headers}->header("Content-Type") || "multipart/mixed";
    if ($ct =~ m,^\s*message/,i) {
	_set_content($self, $self->{_parts}[0]->as_string($CRLF), 1);
	return;
    }

    require HTTP::Headers::Util;
    my @v = HTTP::Headers::Util::split_header_words($ct);
    Carp::carp("Multiple Content-Type headers") if @v > 1;
    @v = @{$v[0]};

    my $boundary;
    my $boundary_index;
    for (my @tmp = @v; @tmp;) {
	my($k, $v) = splice(@tmp, 0, 2);
	if ($k eq "boundary") {
	    $boundary = $v;
	    $boundary_index = @v - @tmp - 1;
	    last;
	}
    }

    my @parts = map $_->as_string($CRLF), @{$self->{_parts}};

    my $bno = 0;
    $boundary = _boundary() unless defined $boundary;
 CHECK_BOUNDARY:
    {
	for (@parts) {
	    if (index($_, $boundary) >= 0) {
		# must have a better boundary
		$boundary = _boundary(++$bno);
		redo CHECK_BOUNDARY;
	    }
	}
    }

    if ($boundary_index) {
	$v[$boundary_index] = $boundary;
    }
    else {
	push(@v, boundary => $boundary);
    }

    $ct = HTTP::Headers::Util::join_header_words(@v);
    $self->{_headers}->header("Content-Type", $ct);

    _set_content($self, "--$boundary$CRLF" .
	                join("$CRLF--$boundary$CRLF", @parts) .
			"$CRLF--$boundary--$CRLF",
                        1);
}


sub _boundary
{
    my $size = shift || return "xYzZY";
    require MIME::Base64;
    my $b = MIME::Base64::encode(join("", map chr(rand(256)), 1..$size*3), "");
    $b =~ s/[\W]/X/g;  # ensure alnum only
    $b;
}


1;

=pod

=encoding UTF-8

=head1 NAME

HTTP::Message - HTTP style message (base class)

=head1 VERSION

version 6.26

=head1 SYNOPSIS

 use base 'HTTP::Message';

=head1 DESCRIPTION

An C<HTTP::Message> object contains some headers and a content body.
The following methods are available:

=over 4

=item $mess = HTTP::Message->new

=item $mess = HTTP::Message->new( $headers )

=item $mess = HTTP::Message->new( $headers, $content )

This constructs a new message object.  Normally you would want
construct C<HTTP::Request> or C<HTTP::Response> objects instead.

The optional $header argument should be a reference to an
C<HTTP::Headers> object or a plain array reference of key/value pairs.
If an C<HTTP::Headers> object is provided then a copy of it will be
embedded into the constructed message, i.e. it will not be owned and
can be modified afterwards without affecting the message.

The optional $content argument should be a string of bytes.

=item $mess = HTTP::Message->parse( $str )

This constructs a new message object by parsing the given string.

=item $mess->headers

Returns the embedded C<HTTP::Headers> object.

=item $mess->headers_as_string

=item $mess->headers_as_string( $eol )

Call the as_string() method for the headers in the
message.  This will be the same as

    $mess->headers->as_string

but it will make your program a whole character shorter :-)

=item $mess->content

=item $mess->content( $bytes )

The content() method sets the raw content if an argument is given.  If no
argument is given the content is not touched.  In either case the
original raw content is returned.

If the C<undef> argument is given, the content is reset to its default value,
which is an empty string.

Note that the content should be a string of bytes.  Strings in perl
can contain characters outside the range of a byte.  The C<Encode>
module can be used to turn such strings into a string of bytes.

=item $mess->add_content( $bytes )

The add_content() methods appends more data bytes to the end of the
current content buffer.

=item $mess->add_content_utf8( $string )

The add_content_utf8() method appends the UTF-8 bytes representing the
string to the end of the current content buffer.

=item $mess->content_ref

=item $mess->content_ref( \$bytes )

The content_ref() method will return a reference to content buffer string.
It can be more efficient to access the content this way if the content
is huge, and it can even be used for direct manipulation of the content,
for instance:

  ${$res->content_ref} =~ s/\bfoo\b/bar/g;

This example would modify the content buffer in-place.

If an argument is passed it will setup the content to reference some
external source.  The content() and add_content() methods
will automatically dereference scalar references passed this way.  For
other references content() will return the reference itself and
add_content() will refuse to do anything.

=item $mess->content_charset

This returns the charset used by the content in the message.  The
charset is either found as the charset attribute of the
C<Content-Type> header or by guessing.

See L<http://www.w3.org/TR/REC-html40/charset.html#spec-char-encoding>
for details about how charset is determined.

=item $mess->decoded_content( %options )

Returns the content with any C<Content-Encoding> undone and for textual content
the raw content encoded to Perl's Unicode strings.  If the C<Content-Encoding>
or C<charset> of the message is unknown this method will fail by returning
C<undef>.

The following options can be specified.

=over

=item C<charset>

This override the charset parameter for text content.  The value
C<none> can used to suppress decoding of the charset.

=item C<default_charset>

This override the default charset guessed by content_charset() or
if that fails "ISO-8859-1".

=item C<alt_charset>

If decoding fails because the charset specified in the Content-Type header
isn't recognized by Perl's Encode module, then try decoding using this charset
instead of failing.  The C<alt_charset> might be specified as C<none> to simply
return the string without any decoding of charset as alternative.

=item C<charset_strict>

Abort decoding if malformed characters is found in the content.  By
default you get the substitution character ("\x{FFFD}") in place of
malformed characters.

=item C<raise_error>

If TRUE then raise an exception if not able to decode content.  Reason
might be that the specified C<Content-Encoding> or C<charset> is not
supported.  If this option is FALSE, then decoded_content() will return
C<undef> on errors, but will still set $@.

=item C<ref>

If TRUE then a reference to decoded content is returned.  This might
be more efficient in cases where the decoded content is identical to
the raw content as no data copying is required in this case.

=back

=item $mess->decodable

=item HTTP::Message::decodable()

This returns the encoding identifiers that decoded_content() can
process.  In scalar context returns a comma separated string of
identifiers.

This value is suitable for initializing the C<Accept-Encoding> request
header field.

=item $mess->decode

This method tries to replace the content of the message with the
decoded version and removes the C<Content-Encoding> header.  Returns
TRUE if successful and FALSE if not.

If the message does not have a C<Content-Encoding> header this method
does nothing and returns TRUE.

Note that the content of the message is still bytes after this method
has been called and you still need to call decoded_content() if you
want to process its content as a string.

=item $mess->encode( $encoding, ... )

Apply the given encodings to the content of the message.  Returns TRUE
if successful. The "identity" (non-)encoding is always supported; other
currently supported encodings, subject to availability of required
additional modules, are "gzip", "deflate", "x-bzip2" and "base64".

A successful call to this function will set the C<Content-Encoding>
header.

Note that C<multipart/*> or C<message/*> messages can't be encoded and
this method will croak if you try.

=item $mess->parts

=item $mess->parts( @parts )

=item $mess->parts( \@parts )

Messages can be composite, i.e. contain other messages.  The composite
messages have a content type of C<multipart/*> or C<message/*>.  This
method give access to the contained messages.

The argumentless form will return a list of C<HTTP::Message> objects.
If the content type of $msg is not C<multipart/*> or C<message/*> then
this will return the empty list.  In scalar context only the first
object is returned.  The returned message parts should be regarded as
read-only (future versions of this library might make it possible
to modify the parent by modifying the parts).

If the content type of $msg is C<message/*> then there will only be
one part returned.

If the content type is C<message/http>, then the return value will be
either an C<HTTP::Request> or an C<HTTP::Response> object.

If a @parts argument is given, then the content of the message will be
modified. The array reference form is provided so that an empty list
can be provided.  The @parts array should contain C<HTTP::Message>
objects.  The @parts objects are owned by $mess after this call and
should not be modified or made part of other messages.

When updating the message with this method and the old content type of
$mess is not C<multipart/*> or C<message/*>, then the content type is
set to C<multipart/mixed> and all other content headers are cleared.

This method will croak if the content type is C<message/*> and more
than one part is provided.

=item $mess->add_part( $part )

This will add a part to a message.  The $part argument should be
another C<HTTP::Message> object.  If the previous content type of
$mess is not C<multipart/*> then the old content (together with all
content headers) will be made part #1 and the content type made
C<multipart/mixed> before the new part is added.  The $part object is
owned by $mess after this call and should not be modified or made part
of other messages.

There is no return value.

=item $mess->clear

Will clear the headers and set the content to the empty string.  There
is no return value

=item $mess->protocol

=item $mess->protocol( $proto )

Sets the HTTP protocol used for the message.  The protocol() is a string
like C<HTTP/1.0> or C<HTTP/1.1>.

=item $mess->clone

Returns a copy of the message object.

=item $mess->as_string

=item $mess->as_string( $eol )

Returns the message formatted as a single string.

The optional $eol parameter specifies the line ending sequence to use.
The default is "\n".  If no $eol is given then as_string will ensure
that the returned string is newline terminated (even when the message
content is not).  No extra newline is appended if an explicit $eol is
passed.

=item $mess->dump( %opt )

Returns the message formatted as a string.  In void context print the string.

This differs from C<< $mess->as_string >> in that it escapes the bytes
of the content so that it's safe to print them and it limits how much
content to print.  The escapes syntax used is the same as for Perl's
double quoted strings.  If there is no content the string "(no
content)" is shown in its place.

Options to influence the output can be passed as key/value pairs. The
following options are recognized:

=over

=item maxlength => $num

How much of the content to show.  The default is 512.  Set this to 0
for unlimited.

If the content is longer then the string is chopped at the limit and
the string "...\n(### more bytes not shown)" appended.

=item no_content => $str

Replaces the "(no content)" marker.

=item prefix => $str

A string that will be prefixed to each line of the dump.

=back

=back

All methods unknown to C<HTTP::Message> itself are delegated to the
C<HTTP::Headers> object that is part of every message.  This allows
convenient access to these methods.  Refer to L<HTTP::Headers> for
details of these methods:

    $mess->header( $field => $val )
    $mess->push_header( $field => $val )
    $mess->init_header( $field => $val )
    $mess->remove_header( $field )
    $mess->remove_content_headers
    $mess->header_field_names
    $mess->scan( \&doit )

    $mess->date
    $mess->expires
    $mess->if_modified_since
    $mess->if_unmodified_since
    $mess->last_modified
    $mess->content_type
    $mess->content_encoding
    $mess->content_length
    $mess->content_language
    $mess->title
    $mess->user_agent
    $mess->server
    $mess->from
    $mess->referer
    $mess->www_authenticate
    $mess->authorization
    $mess->proxy_authorization
    $mess->authorization_basic
    $mess->proxy_authorization_basic

=head1 AUTHOR

Gisle Aas <gisle@activestate.com>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 1994 by Gisle Aas.

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

=cut

__END__


#ABSTRACT: HTTP style message (base class)

PK       ! ��Pd�-  �-    perl5/HTTP/Config.pmnu ��6�$        package HTTP::Config;

use strict;
use warnings;

our $VERSION = '6.26';

use URI;

sub new {
    my $class = shift;
    return bless [], $class;
}

sub entries {
    my $self = shift;
    @$self;
}

sub empty {
    my $self = shift;
    not @$self;
}

sub add {
    if (@_ == 2) {
        my $self = shift;
        push(@$self, shift);
        return;
    }
    my($self, %spec) = @_;
    push(@$self, \%spec);
    return;
}

sub find2 {
    my($self, %spec) = @_;
    my @found;
    my @rest;
 ITEM:
    for my $item (@$self) {
        for my $k (keys %spec) {
            no warnings 'uninitialized';
            if (!exists $item->{$k} || $spec{$k} ne $item->{$k}) {
                push(@rest, $item);
                next ITEM;
            }
        }
        push(@found, $item);
    }
    return \@found unless wantarray;
    return \@found, \@rest;
}

sub find {
    my $self = shift;
    my $f = $self->find2(@_);
    return @$f if wantarray;
    return $f->[0];
}

sub remove {
    my($self, %spec) = @_;
    my($removed, $rest) = $self->find2(%spec);
    @$self = @$rest if @$removed;
    return @$removed;
}

my %MATCH = (
    m_scheme => sub {
        my($v, $uri) = @_;
        return $uri->_scheme eq $v;  # URI known to be canonical
    },
    m_secure => sub {
        my($v, $uri) = @_;
        my $secure = $uri->can("secure") ? $uri->secure : $uri->_scheme eq "https";
        return $secure == !!$v;
    },
    m_host_port => sub {
        my($v, $uri) = @_;
        return unless $uri->can("host_port");
        return $uri->host_port eq $v, 7;
    },
    m_host => sub {
        my($v, $uri) = @_;
        return unless $uri->can("host");
        return $uri->host eq $v, 6;
    },
    m_port => sub {
        my($v, $uri) = @_;
        return unless $uri->can("port");
        return $uri->port eq $v;
    },
    m_domain => sub {
        my($v, $uri) = @_;
        return unless $uri->can("host");
        my $h = $uri->host;
        $h = "$h.local" unless $h =~ /\./;
        $v = ".$v" unless $v =~ /^\./;
        return length($v), 5 if substr($h, -length($v)) eq $v;
        return 0;
    },
    m_path => sub {
        my($v, $uri) = @_;
        return unless $uri->can("path");
        return $uri->path eq $v, 4;
    },
    m_path_prefix => sub {
        my($v, $uri) = @_;
        return unless $uri->can("path");
        my $path = $uri->path;
        my $len = length($v);
        return $len, 3 if $path eq $v;
        return 0 if length($path) <= $len;
        $v .= "/" unless $v =~ m,/\z,,;
        return $len, 3 if substr($path, 0, length($v)) eq $v;
        return 0;
    },
    m_path_match => sub {
        my($v, $uri) = @_;
        return unless $uri->can("path");
        return $uri->path =~ $v;
    },
    m_uri__ => sub {
        my($v, $k, $uri) = @_;
        return unless $uri->can($k);
        return 1 unless defined $v;
        return $uri->$k eq $v;
    },
    m_method => sub {
        my($v, $uri, $request) = @_;
        return $request && $request->method eq $v;
    },
    m_proxy => sub {
        my($v, $uri, $request) = @_;
        return $request && ($request->{proxy} || "") eq $v;
    },
    m_code => sub {
        my($v, $uri, $request, $response) = @_;
        $v =~ s/xx\z//;
        return unless $response;
        return length($v), 2 if substr($response->code, 0, length($v)) eq $v;
    },
    m_media_type => sub {  # for request too??
        my($v, $uri, $request, $response) = @_;
        return unless $response;
        return 1, 1 if $v eq "*/*";
        my $ct = $response->content_type;
        return 2, 1 if $v =~ s,/\*\z,, && $ct =~ m,^\Q$v\E/,;
        return 3, 1 if $v eq "html" && $response->content_is_html;
        return 4, 1 if $v eq "xhtml" && $response->content_is_xhtml;
        return 10, 1 if $v eq $ct;
        return 0;
    },
    m_header__ => sub {
        my($v, $k, $uri, $request, $response) = @_;
        return unless $request;
        return 1 if $request->header($k) eq $v;
        return 1 if $response && $response->header($k) eq $v;
        return 0;
    },
    m_response_attr__ => sub {
        my($v, $k, $uri, $request, $response) = @_;
        return unless $response;
        return 1 if !defined($v) && exists $response->{$k};
        return 0 unless exists $response->{$k};
        return 1 if $response->{$k} eq $v;
        return 0;
    },
);

sub matching {
    my $self = shift;
    if (@_ == 1) {
        if ($_[0]->can("request")) {
            unshift(@_, $_[0]->request);
            unshift(@_, undef) unless defined $_[0];
        }
        unshift(@_, $_[0]->uri_canonical) if $_[0] && $_[0]->can("uri_canonical");
    }
    my($uri, $request, $response) = @_;
    $uri = URI->new($uri) unless ref($uri);

    my @m;
 ITEM:
    for my $item (@$self) {
        my $order;
        for my $ikey (keys %$item) {
            my $mkey = $ikey;
            my $k;
            $k = $1 if $mkey =~ s/__(.*)/__/;
            if (my $m = $MATCH{$mkey}) {
                #print "$ikey $mkey\n";
                my($c, $o);
                my @arg = (
                    defined($k) ? $k : (),
                    $uri, $request, $response
                );
                my $v = $item->{$ikey};
                $v = [$v] unless ref($v) eq "ARRAY";
                for (@$v) {
                    ($c, $o) = $m->($_, @arg);
                    #print "  - $_ ==> $c $o\n";
                    last if $c;
                }
                next ITEM unless $c;
                $order->[$o || 0] += $c;
            }
        }
        $order->[7] ||= 0;
        $item->{_order} = join(".", reverse map sprintf("%03d", $_ || 0), @$order);
        push(@m, $item);
    }
    @m = sort { $b->{_order} cmp $a->{_order} } @m;
    delete $_->{_order} for @m;
    return @m if wantarray;
    return $m[0];
}

sub add_item {
    my $self = shift;
    my $item = shift;
    return $self->add(item => $item, @_);
}

sub remove_items {
    my $self = shift;
    return map $_->{item}, $self->remove(@_);
}

sub matching_items {
    my $self = shift;
    return map $_->{item}, $self->matching(@_);
}

1;

=pod

=encoding UTF-8

=head1 NAME

HTTP::Config - Configuration for request and response objects

=head1 VERSION

version 6.26

=head1 SYNOPSIS

 use HTTP::Config;
 my $c = HTTP::Config->new;
 $c->add(m_domain => ".example.com", m_scheme => "http", verbose => 1);
 
 use HTTP::Request;
 my $request = HTTP::Request->new(GET => "http://www.example.com");
 
 if (my @m = $c->matching($request)) {
    print "Yadayada\n" if $m[0]->{verbose};
 }

=head1 DESCRIPTION

An C<HTTP::Config> object is a list of entries that
can be matched against request or request/response pairs.  Its
purpose is to hold configuration data that can be looked up given a
request or response object.

Each configuration entry is a hash.  Some keys specify matching to
occur against attributes of request/response objects.  Other keys can
be used to hold user data.

The following methods are provided:

=over 4

=item $conf = HTTP::Config->new

Constructs a new empty C<HTTP::Config> object and returns it.

=item $conf->entries

Returns the list of entries in the configuration object.
In scalar context returns the number of entries.

=item $conf->empty

Return true if there are no entries in the configuration object.
This is just a shorthand for C<< not $conf->entries >>.

=item $conf->add( %matchspec, %other )

=item $conf->add( \%entry )

Adds a new entry to the configuration.
You can either pass separate key/value pairs or a hash reference.

=item $conf->remove( %spec )

Removes (and returns) the entries that have matches for all the key/value pairs in %spec.
If %spec is empty this will match all entries; so it will empty the configuration object.

=item $conf->matching( $uri, $request, $response )

=item $conf->matching( $uri )

=item $conf->matching( $request )

=item $conf->matching( $response )

Returns the entries that match the given $uri, $request and $response triplet.

If called with a single $request object then the $uri is obtained by calling its 'uri_canonical' method.
If called with a single $response object, then the request object is obtained by calling its 'request' method;
and then the $uri is obtained as if a single $request was provided.

The entries are returned with the most specific matches first.
In scalar context returns the most specific match or C<undef> in none match.

=item $conf->add_item( $item, %matchspec )

=item $conf->remove_items( %spec )

=item $conf->matching_items( $uri, $request, $response )

Wrappers that hides the entries themselves.

=back

=head2 Matching

The following keys on a configuration entry specify matching.  For all
of these you can provide an array of values instead of a single value.
The entry matches if at least one of the values in the array matches.

Entries that require match against a response object attribute will never match
unless a response object was provided.

=over

=item m_scheme => $scheme

Matches if the URI uses the specified scheme; e.g. "http".

=item m_secure => $bool

If $bool is TRUE; matches if the URI uses a secure scheme.  If $bool
is FALSE; matches if the URI does not use a secure scheme.  An example
of a secure scheme is "https".

=item m_host_port => "$hostname:$port"

Matches if the URI's host_port method return the specified value.

=item m_host => $hostname

Matches if the URI's host method returns the specified value.

=item m_port => $port

Matches if the URI's port method returns the specified value.

=item m_domain => ".$domain"

Matches if the URI's host method return a value that within the given
domain.  The hostname "www.example.com" will for instance match the
domain ".com".

=item m_path => $path

Matches if the URI's path method returns the specified value.

=item m_path_prefix => $path

Matches if the URI's path is the specified path or has the specified
path as prefix.

=item m_path_match => $Regexp

Matches if the regular expression matches the URI's path.  Eg. qr/\.html$/.

=item m_method => $method

Matches if the request method matches the specified value. Eg. "GET" or "POST".

=item m_code => $digit

=item m_code => $status_code

Matches if the response status code matches.  If a single digit is
specified; matches for all response status codes beginning with that digit.

=item m_proxy => $url

Matches if the request is to be sent to the given Proxy server.

=item m_media_type => "*/*"

=item m_media_type => "text/*"

=item m_media_type => "html"

=item m_media_type => "xhtml"

=item m_media_type => "text/html"

Matches if the response media type matches.

With a value of "html" matches if $response->content_is_html returns TRUE.
With a value of "xhtml" matches if $response->content_is_xhtml returns TRUE.

=item m_uri__I<$method> => undef

Matches if the URI object provides the method.

=item m_uri__I<$method> => $string

Matches if the URI's $method method returns the given value.

=item m_header__I<$field> => $string

Matches if either the request or the response have a header $field with the given value.

=item m_response_attr__I<$key> => undef

=item m_response_attr__I<$key> => $string

Matches if the response object has that key, or the entry has the given value.

=back

=head1 SEE ALSO

L<URI>, L<HTTP::Request>, L<HTTP::Response>

=head1 AUTHOR

Gisle Aas <gisle@activestate.com>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 1994 by Gisle Aas.

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

=cut

__END__


#ABSTRACT: Configuration for request and response objects

PK       ! ި��  �    perl5/HTTP/Headers/Util.pmnu ��6�$        package HTTP::Headers::Util;

use strict;
use warnings;

our $VERSION = '6.26';

use base 'Exporter';

our @EXPORT_OK=qw(split_header_words _split_header_words join_header_words);


sub split_header_words {
    my @res = &_split_header_words;
    for my $arr (@res) {
	for (my $i = @$arr - 2; $i >= 0; $i -= 2) {
	    $arr->[$i] = lc($arr->[$i]);
	}
    }
    return @res;
}

sub _split_header_words
{
    my(@val) = @_;
    my @res;
    for (@val) {
	my @cur;
	while (length) {
	    if (s/^\s*(=*[^\s=;,]+)//) {  # 'token' or parameter 'attribute'
		push(@cur, $1);
		# a quoted value
		if (s/^\s*=\s*\"([^\"\\]*(?:\\.[^\"\\]*)*)\"//) {
		    my $val = $1;
		    $val =~ s/\\(.)/$1/g;
		    push(@cur, $val);
		# some unquoted value
		}
		elsif (s/^\s*=\s*([^;,\s]*)//) {
		    my $val = $1;
		    $val =~ s/\s+$//;
		    push(@cur, $val);
		# no value, a lone token
		}
		else {
		    push(@cur, undef);
		}
	    }
	    elsif (s/^\s*,//) {
		push(@res, [@cur]) if @cur;
		@cur = ();
	    }
	    elsif (s/^\s*;// || s/^\s+//) {
		# continue
	    }
	    else {
		die "This should not happen: '$_'";
	    }
	}
	push(@res, \@cur) if @cur;
    }
    @res;
}


sub join_header_words
{
    @_ = ([@_]) if @_ && !ref($_[0]);
    my @res;
    for (@_) {
	my @cur = @$_;
	my @attr;
	while (@cur) {
	    my $k = shift @cur;
	    my $v = shift @cur;
	    if (defined $v) {
		if ($v =~ /[\x00-\x20()<>@,;:\\\"\/\[\]?={}\x7F-\xFF]/ || !length($v)) {
		    $v =~ s/([\"\\])/\\$1/g;  # escape " and \
		    $k .= qq(="$v");
		}
		else {
		    # token
		    $k .= "=$v";
		}
	    }
	    push(@attr, $k);
	}
	push(@res, join("; ", @attr)) if @attr;
    }
    join(", ", @res);
}


1;

=pod

=encoding UTF-8

=head1 NAME

HTTP::Headers::Util - Header value parsing utility functions

=head1 VERSION

version 6.26

=head1 SYNOPSIS

  use HTTP::Headers::Util qw(split_header_words);
  @values = split_header_words($h->header("Content-Type"));

=head1 DESCRIPTION

This module provides a few functions that helps parsing and
construction of valid HTTP header values.  None of the functions are
exported by default.

The following functions are available:

=over 4

=item split_header_words( @header_values )

This function will parse the header values given as argument into a
list of anonymous arrays containing key/value pairs.  The function
knows how to deal with ",", ";" and "=" as well as quoted values after
"=".  A list of space separated tokens are parsed as if they were
separated by ";".

If the @header_values passed as argument contains multiple values,
then they are treated as if they were a single value separated by
comma ",".

This means that this function is useful for parsing header fields that
follow this syntax (BNF as from the HTTP/1.1 specification, but we relax
the requirement for tokens).

  headers           = #header
  header            = (token | parameter) *( [";"] (token | parameter))

  token             = 1*<any CHAR except CTLs or separators>
  separators        = "(" | ")" | "<" | ">" | "@"
                    | "," | ";" | ":" | "\" | <">
                    | "/" | "[" | "]" | "?" | "="
                    | "{" | "}" | SP | HT

  quoted-string     = ( <"> *(qdtext | quoted-pair ) <"> )
  qdtext            = <any TEXT except <">>
  quoted-pair       = "\" CHAR

  parameter         = attribute "=" value
  attribute         = token
  value             = token | quoted-string

Each I<header> is represented by an anonymous array of key/value
pairs.  The keys will be all be forced to lower case.
The value for a simple token (not part of a parameter) is C<undef>.
Syntactically incorrect headers will not necessarily be parsed as you
would want.

This is easier to describe with some examples:

   split_header_words('foo="bar"; port="80,81"; DISCARD, BAR=baz');
   split_header_words('text/html; charset="iso-8859-1"');
   split_header_words('Basic realm="\\"foo\\\\bar\\""');

will return

   [foo=>'bar', port=>'80,81', discard=> undef], [bar=>'baz' ]
   ['text/html' => undef, charset => 'iso-8859-1']
   [basic => undef, realm => "\"foo\\bar\""]

If you don't want the function to convert tokens and attribute keys to
lower case you can call it as C<_split_header_words> instead (with a
leading underscore).

=item join_header_words( @arrays )

This will do the opposite of the conversion done by split_header_words().
It takes a list of anonymous arrays as arguments (or a list of
key/value pairs) and produces a single header value.  Attribute values
are quoted if needed.

Example:

   join_header_words(["text/plain" => undef, charset => "iso-8859/1"]);
   join_header_words("text/plain" => undef, charset => "iso-8859/1");

will both return the string:

   text/plain; charset="iso-8859/1"

=back

=head1 AUTHOR

Gisle Aas <gisle@activestate.com>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 1994 by Gisle Aas.

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

=cut

__END__


#ABSTRACT: Header value parsing utility functions

PK       ! ��+~�	  �	    perl5/HTTP/Headers/ETag.pmnu ��6�$        package HTTP::Headers::ETag;

use strict;
use warnings;

our $VERSION = '6.26';

require HTTP::Date;

require HTTP::Headers;
package
    HTTP::Headers;

sub _etags
{
    my $self = shift;
    my $header = shift;
    my @old = _split_etag_list($self->_header($header));
    if (@_) {
	$self->_header($header => join(", ", _split_etag_list(@_)));
    }
    wantarray ? @old : join(", ", @old);
}

sub etag          { shift->_etags("ETag", @_); }
sub if_match      { shift->_etags("If-Match", @_); }
sub if_none_match { shift->_etags("If-None-Match", @_); }

sub if_range {
    # Either a date or an entity-tag
    my $self = shift;
    my @old = $self->_header("If-Range");
    if (@_) {
	my $new = shift;
	if (!defined $new) {
	    $self->remove_header("If-Range");
	}
	elsif ($new =~ /^\d+$/) {
	    $self->_date_header("If-Range", $new);
	}
	else {
	    $self->_etags("If-Range", $new);
	}
    }
    return unless defined(wantarray);
    for (@old) {
	my $t = HTTP::Date::str2time($_);
	$_ = $t if $t;
    }
    wantarray ? @old : join(", ", @old);
}


# Split a list of entity tag values.  The return value is a list
# consisting of one element per entity tag.  Suitable for parsing
# headers like C<If-Match>, C<If-None-Match>.  You might even want to
# use it on C<ETag> and C<If-Range> entity tag values, because it will
# normalize them to the common form.
#
#  entity-tag	  = [ weak ] opaque-tag
#  weak		  = "W/"
#  opaque-tag	  = quoted-string


sub _split_etag_list
{
    my(@val) = @_;
    my @res;
    for (@val) {
        while (length) {
            my $weak = "";
	    $weak = "W/" if s,^\s*[wW]/,,;
            my $etag = "";
	    if (s/^\s*(\"[^\"\\]*(?:\\.[^\"\\]*)*\")//) {
		push(@res, "$weak$1");
            }
            elsif (s/^\s*,//) {
                push(@res, qq(W/"")) if $weak;
            }
            elsif (s/^\s*([^,\s]+)//) {
                $etag = $1;
		$etag =~ s/([\"\\])/\\$1/g;
	        push(@res, qq($weak"$etag"));
            }
            elsif (s/^\s+// || !length) {
                push(@res, qq(W/"")) if $weak;
            }
            else {
	 	die "This should not happen: '$_'";
            }
        }
   }
   @res;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

HTTP::Headers::ETag

=head1 VERSION

version 6.26

=head1 AUTHOR

Gisle Aas <gisle@activestate.com>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 1994 by Gisle Aas.

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

=cut
PK       ! �PT.	  .	    perl5/HTTP/Headers/Auth.pmnu ��6�$        package HTTP::Headers::Auth;

use strict;
use warnings;

our $VERSION = '6.26';

use HTTP::Headers;

package
    HTTP::Headers;

BEGIN {
    # we provide a new (and better) implementations below
    undef(&www_authenticate);
    undef(&proxy_authenticate);
}

require HTTP::Headers::Util;

sub _parse_authenticate
{
    my @ret;
    for (HTTP::Headers::Util::split_header_words(@_)) {
	if (!defined($_->[1])) {
	    # this is a new auth scheme
	    push(@ret, shift(@$_) => {});
	    shift @$_;
	}
	if (@ret) {
	    # this a new parameter pair for the last auth scheme
	    while (@$_) {
		my $k = shift @$_;
		my $v = shift @$_;
	        $ret[-1]{$k} = $v;
	    }
	}
	else {
	    # something wrong, parameter pair without any scheme seen
	    # IGNORE
	}
    }
    @ret;
}

sub _authenticate
{
    my $self = shift;
    my $header = shift;
    my @old = $self->_header($header);
    if (@_) {
	$self->remove_header($header);
	my @new = @_;
	while (@new) {
	    my $a_scheme = shift(@new);
	    if ($a_scheme =~ /\s/) {
		# assume complete valid value, pass it through
		$self->push_header($header, $a_scheme);
	    }
	    else {
		my @param;
		if (@new) {
		    my $p = $new[0];
		    if (ref($p) eq "ARRAY") {
			@param = @$p;
			shift(@new);
		    }
		    elsif (ref($p) eq "HASH") {
			@param = %$p;
			shift(@new);
		    }
		}
		my $val = ucfirst(lc($a_scheme));
		if (@param) {
		    my $sep = " ";
		    while (@param) {
			my $k = shift @param;
			my $v = shift @param;
			if ($v =~ /[^0-9a-zA-Z]/ || lc($k) eq "realm") {
			    # must quote the value
			    $v =~ s,([\\\"]),\\$1,g;
			    $v = qq("$v");
			}
			$val .= "$sep$k=$v";
			$sep = ", ";
		    }
		}
		$self->push_header($header, $val);
	    }
	}
    }
    return unless defined wantarray;
    wantarray ? _parse_authenticate(@old) : join(", ", @old);
}


sub www_authenticate    { shift->_authenticate("WWW-Authenticate", @_)   }
sub proxy_authenticate  { shift->_authenticate("Proxy-Authenticate", @_) }

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

HTTP::Headers::Auth

=head1 VERSION

version 6.26

=head1 AUTHOR

Gisle Aas <gisle@activestate.com>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 1994 by Gisle Aas.

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

=cut
PK       ! ��
RB?  B?    perl5/HTTP/Request/Common.pmnu ��6�$        package HTTP::Request::Common;

use strict;
use warnings;

our $VERSION = '6.26';

our $DYNAMIC_FILE_UPLOAD ||= 0;  # make it defined (don't know why)

use Exporter 5.57 'import';

our @EXPORT =qw(GET HEAD PUT PATCH POST OPTIONS);
our @EXPORT_OK = qw($DYNAMIC_FILE_UPLOAD DELETE);

require HTTP::Request;
use Carp();

my $CRLF = "\015\012";   # "\r\n" is not portable

sub GET  { _simple_req('GET',  @_); }
sub HEAD { _simple_req('HEAD', @_); }
sub DELETE { _simple_req('DELETE', @_); }
sub PATCH { request_type_with_data('PATCH', @_); }
sub POST { request_type_with_data('POST', @_); }
sub PUT { request_type_with_data('PUT', @_); }
sub OPTIONS { request_type_with_data('OPTIONS', @_); }

sub request_type_with_data
{
    my $type = shift;
    my $url  = shift;
    my $req = HTTP::Request->new($type => $url);
    my $content;
    $content = shift if @_ and ref $_[0];
    my($k, $v);
    while (($k,$v) = splice(@_, 0, 2)) {
	if (lc($k) eq 'content') {
	    $content = $v;
	}
	else {
	    $req->push_header($k, $v);
	}
    }
    my $ct = $req->header('Content-Type');
    unless ($ct) {
	$ct = 'application/x-www-form-urlencoded';
    }
    elsif ($ct eq 'form-data') {
	$ct = 'multipart/form-data';
    }

    if (ref $content) {
	if ($ct =~ m,^multipart/form-data\s*(;|$),i) {
	    require HTTP::Headers::Util;
	    my @v = HTTP::Headers::Util::split_header_words($ct);
	    Carp::carp("Multiple Content-Type headers") if @v > 1;
	    @v = @{$v[0]};

	    my $boundary;
	    my $boundary_index;
	    for (my @tmp = @v; @tmp;) {
		my($k, $v) = splice(@tmp, 0, 2);
		if ($k eq "boundary") {
		    $boundary = $v;
		    $boundary_index = @v - @tmp - 1;
		    last;
		}
	    }

	    ($content, $boundary) = form_data($content, $boundary, $req);

	    if ($boundary_index) {
		$v[$boundary_index] = $boundary;
	    }
	    else {
		push(@v, boundary => $boundary);
	    }

	    $ct = HTTP::Headers::Util::join_header_words(@v);
	}
	else {
	    # We use a temporary URI object to format
	    # the application/x-www-form-urlencoded content.
	    require URI;
	    my $url = URI->new('http:');
	    $url->query_form(ref($content) eq "HASH" ? %$content : @$content);
	    $content = $url->query;

	    # HTML/4.01 says that line breaks are represented as "CR LF" pairs (i.e., `%0D%0A')
	    $content =~ s/(?<!%0D)%0A/%0D%0A/g if defined($content);
	}
    }

    $req->header('Content-Type' => $ct);  # might be redundant
    if (defined($content)) {
	$req->header('Content-Length' =>
		     length($content)) unless ref($content);
	$req->content($content);
    }
    else {
        $req->header('Content-Length' => 0);
    }
    $req;
}


sub _simple_req
{
    my($method, $url) = splice(@_, 0, 2);
    my $req = HTTP::Request->new($method => $url);
    my($k, $v);
    my $content;
    while (($k,$v) = splice(@_, 0, 2)) {
	if (lc($k) eq 'content') {
	    $req->add_content($v);
            $content++;
	}
	else {
	    $req->push_header($k, $v);
	}
    }
    if ($content && !defined($req->header("Content-Length"))) {
        $req->header("Content-Length", length(${$req->content_ref}));
    }
    $req;
}


sub form_data   # RFC1867
{
    my($data, $boundary, $req) = @_;
    my @data = ref($data) eq "HASH" ? %$data : @$data;  # copy
    my $fhparts;
    my @parts;
    while (my ($k,$v) = splice(@data, 0, 2)) {
	if (!ref($v)) {
	    $k =~ s/([\\\"])/\\$1/g;  # escape quotes and backslashes
            no warnings 'uninitialized';
	    push(@parts,
		 qq(Content-Disposition: form-data; name="$k"$CRLF$CRLF$v));
	}
	else {
	    my($file, $usename, @headers) = @$v;
	    unless (defined $usename) {
		$usename = $file;
		$usename =~ s,.*/,, if defined($usename);
	    }
            $k =~ s/([\\\"])/\\$1/g;
	    my $disp = qq(form-data; name="$k");
            if (defined($usename) and length($usename)) {
                $usename =~ s/([\\\"])/\\$1/g;
                $disp .= qq(; filename="$usename");
            }
	    my $content = "";
	    my $h = HTTP::Headers->new(@headers);
	    if ($file) {
		open(my $fh, "<", $file) or Carp::croak("Can't open file $file: $!");
		binmode($fh);
		if ($DYNAMIC_FILE_UPLOAD) {
		    # will read file later, close it now in order to
                    # not accumulate to many open file handles
                    close($fh);
		    $content = \$file;
		}
		else {
		    local($/) = undef; # slurp files
		    $content = <$fh>;
		    close($fh);
		}
		unless ($h->header("Content-Type")) {
		    require LWP::MediaTypes;
		    LWP::MediaTypes::guess_media_type($file, $h);
		}
	    }
	    if ($h->header("Content-Disposition")) {
		# just to get it sorted first
		$disp = $h->header("Content-Disposition");
		$h->remove_header("Content-Disposition");
	    }
	    if ($h->header("Content")) {
		$content = $h->header("Content");
		$h->remove_header("Content");
	    }
	    my $head = join($CRLF, "Content-Disposition: $disp",
			           $h->as_string($CRLF),
			           "");
	    if (ref $content) {
		push(@parts, [$head, $$content]);
		$fhparts++;
	    }
	    else {
		push(@parts, $head . $content);
	    }
	}
    }
    return ("", "none") unless @parts;

    my $content;
    if ($fhparts) {
	$boundary = boundary(10) # hopefully enough randomness
	    unless $boundary;

	# add the boundaries to the @parts array
	for (1..@parts-1) {
	    splice(@parts, $_*2-1, 0, "$CRLF--$boundary$CRLF");
	}
	unshift(@parts, "--$boundary$CRLF");
	push(@parts, "$CRLF--$boundary--$CRLF");

	# See if we can generate Content-Length header
	my $length = 0;
	for (@parts) {
	    if (ref $_) {
	 	my ($head, $f) = @$_;
		my $file_size;
		unless ( -f $f && ($file_size = -s _) ) {
		    # The file is either a dynamic file like /dev/audio
		    # or perhaps a file in the /proc file system where
		    # stat may return a 0 size even though reading it
		    # will produce data.  So we cannot make
		    # a Content-Length header.
		    undef $length;
		    last;
		}
	    	$length += $file_size + length $head;
	    }
	    else {
		$length += length;
	    }
        }
        $length && $req->header('Content-Length' => $length);

	# set up a closure that will return content piecemeal
	$content = sub {
	    for (;;) {
		unless (@parts) {
		    defined $length && $length != 0 &&
		    	Carp::croak "length of data sent did not match calculated Content-Length header.  Probably because uploaded file changed in size during transfer.";
		    return;
		}
		my $p = shift @parts;
		unless (ref $p) {
		    $p .= shift @parts while @parts && !ref($parts[0]);
		    defined $length && ($length -= length $p);
		    return $p;
		}
		my($buf, $fh) = @$p;
                unless (ref($fh)) {
                    my $file = $fh;
                    undef($fh);
                    open($fh, "<", $file) || Carp::croak("Can't open file $file: $!");
                    binmode($fh);
                }
		my $buflength = length $buf;
		my $n = read($fh, $buf, 2048, $buflength);
		if ($n) {
		    $buflength += $n;
		    unshift(@parts, ["", $fh]);
		}
		else {
		    close($fh);
		}
		if ($buflength) {
		    defined $length && ($length -= $buflength);
		    return $buf
	    	}
	    }
	};

    }
    else {
	$boundary = boundary() unless $boundary;

	my $bno = 0;
      CHECK_BOUNDARY:
	{
	    for (@parts) {
		if (index($_, $boundary) >= 0) {
		    # must have a better boundary
		    $boundary = boundary(++$bno);
		    redo CHECK_BOUNDARY;
		}
	    }
	    last;
	}
	$content = "--$boundary$CRLF" .
	           join("$CRLF--$boundary$CRLF", @parts) .
		   "$CRLF--$boundary--$CRLF";
    }

    wantarray ? ($content, $boundary) : $content;
}


sub boundary
{
    my $size = shift || return "xYzZY";
    require MIME::Base64;
    my $b = MIME::Base64::encode(join("", map chr(rand(256)), 1..$size*3), "");
    $b =~ s/[\W]/X/g;  # ensure alnum only
    $b;
}

1;

=pod

=encoding UTF-8

=head1 NAME

HTTP::Request::Common - Construct common HTTP::Request objects

=head1 VERSION

version 6.26

=head1 SYNOPSIS

  use HTTP::Request::Common;
  $ua = LWP::UserAgent->new;
  $ua->request(GET 'http://www.sn.no/');
  $ua->request(POST 'http://somewhere/foo', [foo => bar, bar => foo]);
  $ua->request(PATCH 'http://somewhere/foo', [foo => bar, bar => foo]);
  $ua->request(PUT 'http://somewhere/foo', [foo => bar, bar => foo]);
  $ua->request(OPTIONS 'http://somewhere/foo', [foo => bar, bar => foo]);

=head1 DESCRIPTION

This module provides functions that return newly created C<HTTP::Request>
objects.  These functions are usually more convenient to use than the
standard C<HTTP::Request> constructor for the most common requests.

Note that L<LWP::UserAgent> has several convenience methods, including
C<get>, C<head>, C<delete>, C<post> and C<put>.

The following functions are provided:

=over 4

=item GET $url

=item GET $url, Header => Value,...

The C<GET> function returns an L<HTTP::Request> object initialized with
the "GET" method and the specified URL.  It is roughly equivalent to the
following call

  HTTP::Request->new(
     GET => $url,
     HTTP::Headers->new(Header => Value,...),
  )

but is less cluttered.  What is different is that a header named
C<Content> will initialize the content part of the request instead of
setting a header field.  Note that GET requests should normally not
have a content, so this hack makes more sense for the C<PUT>, C<PATCH>
 and C<POST> functions described below.

The C<get(...)> method of L<LWP::UserAgent> exists as a shortcut for
C<< $ua->request(GET ...) >>.

=item HEAD $url

=item HEAD $url, Header => Value,...

Like GET() but the method in the request is "HEAD".

The C<head(...)>  method of L<LWP::UserAgent> exists as a shortcut for
C<< $ua->request(HEAD ...) >>.

=item DELETE $url

=item DELETE $url, Header => Value,...

Like C<GET> but the method in the request is C<DELETE>.  This function
is not exported by default.

=item PATCH $url

=item PATCH $url, Header => Value,...

=item PATCH $url, $form_ref, Header => Value,...

=item PATCH $url, Header => Value,..., Content => $form_ref

=item PATCH $url, Header => Value,..., Content => $content

The same as C<POST> below, but the method in the request is C<PATCH>.

=item PUT $url

=item PUT $url, Header => Value,...

=item PUT $url, $form_ref, Header => Value,...

=item PUT $url, Header => Value,..., Content => $form_ref

=item PUT $url, Header => Value,..., Content => $content

The same as C<POST> below, but the method in the request is C<PUT>

=item OPTIONS $url

=item OPTIONS $url, Header => Value,...

=item OPTIONS $url, $form_ref, Header => Value,...

=item OPTIONS $url, Header => Value,..., Content => $form_ref

=item OPTIONS $url, Header => Value,..., Content => $content

The same as C<POST> below, but the method in the request is C<OPTIONS>

=item POST $url

=item POST $url, Header => Value,...

=item POST $url, $form_ref, Header => Value,...

=item POST $url, Header => Value,..., Content => $form_ref

=item POST $url, Header => Value,..., Content => $content

C<POST>, C<PATCH> and C<PUT> all work with the same parameters.

  %data = ( title => 'something', body => something else' );
  $ua = LWP::UserAgent->new();
  $request = HTTP::Request::Common::POST( $url, [ %data ] );
  $response = $ua->request($request);

They take a second optional array or hash reference
parameter C<$form_ref>.  The content can also be specified
directly using the C<Content> pseudo-header, and you may also provide
the C<$form_ref> this way.

The C<Content> pseudo-header steals a bit of the header field namespace as
there is no way to directly specify a header that is actually called
"Content".  If you really need this you must update the request
returned in a separate statement.

The C<$form_ref> argument can be used to pass key/value pairs for the
form content.  By default we will initialize a request using the
C<application/x-www-form-urlencoded> content type.  This means that
you can emulate an HTML E<lt>form> POSTing like this:

  POST 'http://www.perl.org/survey.cgi',
       [ name   => 'Gisle Aas',
         email  => 'gisle@aas.no',
         gender => 'M',
         born   => '1964',
         perc   => '3%',
       ];

This will create an L<HTTP::Request> object that looks like this:

  POST http://www.perl.org/survey.cgi
  Content-Length: 66
  Content-Type: application/x-www-form-urlencoded

  name=Gisle%20Aas&email=gisle%40aas.no&gender=M&born=1964&perc=3%25

Multivalued form fields can be specified by either repeating the field
name or by passing the value as an array reference.

The POST method also supports the C<multipart/form-data> content used
for I<Form-based File Upload> as specified in RFC 1867.  You trigger
this content format by specifying a content type of C<'form-data'> as
one of the request headers.  If one of the values in the C<$form_ref> is
an array reference, then it is treated as a file part specification
with the following interpretation:

  [ $file, $filename, Header => Value... ]
  [ undef, $filename, Header => Value,..., Content => $content ]

The first value in the array ($file) is the name of a file to open.
This file will be read and its content placed in the request.  The
routine will croak if the file can't be opened.  Use an C<undef> as
$file value if you want to specify the content directly with a
C<Content> header.  The $filename is the filename to report in the
request.  If this value is undefined, then the basename of the $file
will be used.  You can specify an empty string as $filename if you
want to suppress sending the filename when you provide a $file value.

If a $file is provided by no C<Content-Type> header, then C<Content-Type>
and C<Content-Encoding> will be filled in automatically with the values
returned by C<LWP::MediaTypes::guess_media_type()>

Sending my F<~/.profile> to the survey used as example above can be
achieved by this:

  POST 'http://www.perl.org/survey.cgi',
       Content_Type => 'form-data',
       Content      => [ name  => 'Gisle Aas',
                         email => 'gisle@aas.no',
                         gender => 'M',
                         born   => '1964',
                         init   => ["$ENV{HOME}/.profile"],
                       ]

This will create an L<HTTP::Request> object that almost looks this (the
boundary and the content of your F<~/.profile> is likely to be
different):

  POST http://www.perl.org/survey.cgi
  Content-Length: 388
  Content-Type: multipart/form-data; boundary="6G+f"

  --6G+f
  Content-Disposition: form-data; name="name"

  Gisle Aas
  --6G+f
  Content-Disposition: form-data; name="email"

  gisle@aas.no
  --6G+f
  Content-Disposition: form-data; name="gender"

  M
  --6G+f
  Content-Disposition: form-data; name="born"

  1964
  --6G+f
  Content-Disposition: form-data; name="init"; filename=".profile"
  Content-Type: text/plain

  PATH=/local/perl/bin:$PATH
  export PATH

  --6G+f--

If you set the C<$DYNAMIC_FILE_UPLOAD> variable (exportable) to some TRUE
value, then you get back a request object with a subroutine closure as
the content attribute.  This subroutine will read the content of any
files on demand and return it in suitable chunks.  This allow you to
upload arbitrary big files without using lots of memory.  You can even
upload infinite files like F</dev/audio> if you wish; however, if
the file is not a plain file, there will be no C<Content-Length> header
defined for the request.  Not all servers (or server
applications) like this.  Also, if the file(s) change in size between
the time the C<Content-Length> is calculated and the time that the last
chunk is delivered, the subroutine will C<Croak>.

The C<post(...)>  method of L<LWP::UserAgent> exists as a shortcut for
C<< $ua->request(POST ...) >>.

=back

=head1 SEE ALSO

L<HTTP::Request>, L<LWP::UserAgent>

Also, there are some examples in L<HTTP::Request/"EXAMPLES"> that you might
find useful. For example, batch requests are explained there.

=head1 AUTHOR

Gisle Aas <gisle@activestate.com>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 1994 by Gisle Aas.

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

=cut

__END__


#ABSTRACT: Construct common HTTP::Request objects
PK       ! �b�SB  B    perl5/HTTP/Response.pmnu ��6�$        package HTTP::Response;

use strict;
use warnings;

our $VERSION = '6.26';

use base 'HTTP::Message';

use HTTP::Status ();


sub new
{
    my($class, $rc, $msg, $header, $content) = @_;
    my $self = $class->SUPER::new($header, $content);
    $self->code($rc);
    $self->message($msg);
    $self;
}


sub parse
{
    my($class, $str) = @_;
    Carp::carp('Undefined argument to parse()') if $^W && ! defined $str;
    my $status_line;
    if (defined $str && $str =~ s/^(.*)\n//) {
	$status_line = $1;
    }
    else {
	$status_line = $str;
	$str = "";
    }

    $status_line =~ s/\r\z// if defined $status_line;

    my $self = $class->SUPER::parse($str);
    if (defined $status_line) {
        my($protocol, $code, $message);
        if ($status_line =~ /^\d{3} /) {
           # Looks like a response created by HTTP::Response->new
           ($code, $message) = split(' ', $status_line, 2);
        } else {
           ($protocol, $code, $message) = split(' ', $status_line, 3);
        }
        $self->protocol($protocol) if $protocol;
        $self->code($code) if defined($code);
        $self->message($message) if defined($message);
    }
    $self;
}


sub clone
{
    my $self = shift;
    my $clone = bless $self->SUPER::clone, ref($self);
    $clone->code($self->code);
    $clone->message($self->message);
    $clone->request($self->request->clone) if $self->request;
    # we don't clone previous
    $clone;
}


sub code      { shift->_elem('_rc',      @_); }
sub message   { shift->_elem('_msg',     @_); }
sub previous  { shift->_elem('_previous',@_); }
sub request   { shift->_elem('_request', @_); }


sub status_line
{
    my $self = shift;
    my $code = $self->{'_rc'}  || "000";
    my $mess = $self->{'_msg'} || HTTP::Status::status_message($code) || "Unknown code";
    return "$code $mess";
}


sub base
{
    my $self = shift;
    my $base = (
	$self->header('Content-Base'),        # used to be HTTP/1.1
	$self->header('Content-Location'),    # HTTP/1.1
	$self->header('Base'),                # HTTP/1.0
    )[0];
    if ($base && $base =~ /^$URI::scheme_re:/o) {
	# already absolute
	return $HTTP::URI_CLASS->new($base);
    }

    my $req = $self->request;
    if ($req) {
        # if $base is undef here, the return value is effectively
        # just a copy of $self->request->uri.
        return $HTTP::URI_CLASS->new_abs($base, $req->uri);
    }

    # can't find an absolute base
    return undef;
}


sub redirects {
    my $self = shift;
    my @r;
    my $r = $self;
    while (my $p = $r->previous) {
        push(@r, $p);
        $r = $p;
    }
    return @r unless wantarray;
    return reverse @r;
}


sub filename
{
    my $self = shift;
    my $file;

    my $cd = $self->header('Content-Disposition');
    if ($cd) {
	require HTTP::Headers::Util;
	if (my @cd = HTTP::Headers::Util::split_header_words($cd)) {
	    my ($disposition, undef, %cd_param) = @{$cd[-1]};
	    $file = $cd_param{filename};

	    # RFC 2047 encoded?
	    if ($file && $file =~ /^=\?(.+?)\?(.+?)\?(.+)\?=$/) {
		my $charset = $1;
		my $encoding = uc($2);
		my $encfile = $3;

		if ($encoding eq 'Q' || $encoding eq 'B') {
		    local($SIG{__DIE__});
		    eval {
			if ($encoding eq 'Q') {
			    $encfile =~ s/_/ /g;
			    require MIME::QuotedPrint;
			    $encfile = MIME::QuotedPrint::decode($encfile);
			}
			else { # $encoding eq 'B'
			    require MIME::Base64;
			    $encfile = MIME::Base64::decode($encfile);
			}

			require Encode;
			require Encode::Locale;
			Encode::from_to($encfile, $charset, "locale_fs");
		    };

		    $file = $encfile unless $@;
		}
	    }
	}
    }

    unless (defined($file) && length($file)) {
	my $uri;
	if (my $cl = $self->header('Content-Location')) {
	    $uri = URI->new($cl);
	}
	elsif (my $request = $self->request) {
	    $uri = $request->uri;
	}

	if ($uri) {
	    $file = ($uri->path_segments)[-1];
	}
    }

    if ($file) {
	$file =~ s,.*[\\/],,;  # basename
    }

    if ($file && !length($file)) {
	$file = undef;
    }

    $file;
}


sub as_string
{
    my $self = shift;
    my($eol) = @_;
    $eol = "\n" unless defined $eol;

    my $status_line = $self->status_line;
    my $proto = $self->protocol;
    $status_line = "$proto $status_line" if $proto;

    return join($eol, $status_line, $self->SUPER::as_string(@_));
}


sub dump
{
    my $self = shift;

    my $status_line = $self->status_line;
    my $proto = $self->protocol;
    $status_line = "$proto $status_line" if $proto;

    return $self->SUPER::dump(
	preheader => $status_line,
        @_,
    );
}


sub is_info     { HTTP::Status::is_info     (shift->{'_rc'}); }
sub is_success  { HTTP::Status::is_success  (shift->{'_rc'}); }
sub is_redirect { HTTP::Status::is_redirect (shift->{'_rc'}); }
sub is_error    { HTTP::Status::is_error    (shift->{'_rc'}); }
sub is_client_error { HTTP::Status::is_client_error (shift->{'_rc'}); }
sub is_server_error { HTTP::Status::is_server_error (shift->{'_rc'}); }


sub error_as_HTML
{
    my $self = shift;
    my $title = 'An Error Occurred';
    my $body  = $self->status_line;
    $body =~ s/&/&amp;/g;
    $body =~ s/</&lt;/g;
    return <<EOM;
<html>
<head><title>$title</title></head>
<body>
<h1>$title</h1>
<p>$body</p>
</body>
</html>
EOM
}


sub current_age
{
    my $self = shift;
    my $time = shift;

    # Implementation of RFC 2616 section 13.2.3
    # (age calculations)
    my $response_time = $self->client_date;
    my $date = $self->date;

    my $age = 0;
    if ($response_time && $date) {
	$age = $response_time - $date;  # apparent_age
	$age = 0 if $age < 0;
    }

    my $age_v = $self->header('Age');
    if ($age_v && $age_v > $age) {
	$age = $age_v;   # corrected_received_age
    }

    if ($response_time) {
	my $request = $self->request;
	if ($request) {
	    my $request_time = $request->date;
	    if ($request_time && $request_time < $response_time) {
		# Add response_delay to age to get 'corrected_initial_age'
		$age += $response_time - $request_time;
	    }
	}
	$age += ($time || time) - $response_time;
    }
    return $age;
}


sub freshness_lifetime
{
    my($self, %opt) = @_;

    # First look for the Cache-Control: max-age=n header
    for my $cc ($self->header('Cache-Control')) {
	for my $cc_dir (split(/\s*,\s*/, $cc)) {
	    return $1 if $cc_dir =~ /^max-age\s*=\s*(\d+)/i;
	}
    }

    # Next possibility is to look at the "Expires" header
    my $date = $self->date || $self->client_date || $opt{time} || time;
    if (my $expires = $self->expires) {
	return $expires - $date;
    }

    # Must apply heuristic expiration
    return undef if exists $opt{heuristic_expiry} && !$opt{heuristic_expiry};

    # Default heuristic expiration parameters
    $opt{h_min} ||= 60;
    $opt{h_max} ||= 24 * 3600;
    $opt{h_lastmod_fraction} ||= 0.10; # 10% since last-mod suggested by RFC2616
    $opt{h_default} ||= 3600;

    # Should give a warning if more than 24 hours according to
    # RFC 2616 section 13.2.4.  Here we just make this the default
    # maximum value.

    if (my $last_modified = $self->last_modified) {
	my $h_exp = ($date - $last_modified) * $opt{h_lastmod_fraction};
	return $opt{h_min} if $h_exp < $opt{h_min};
	return $opt{h_max} if $h_exp > $opt{h_max};
	return $h_exp;
    }

    # default when all else fails
    return $opt{h_min} if $opt{h_min} > $opt{h_default};
    return $opt{h_default};
}


sub is_fresh
{
    my($self, %opt) = @_;
    $opt{time} ||= time;
    my $f = $self->freshness_lifetime(%opt);
    return undef unless defined($f);
    return $f > $self->current_age($opt{time});
}


sub fresh_until
{
    my($self, %opt) = @_;
    $opt{time} ||= time;
    my $f = $self->freshness_lifetime(%opt);
    return undef unless defined($f);
    return $f - $self->current_age($opt{time}) + $opt{time};
}

1;

=pod

=encoding UTF-8

=head1 NAME

HTTP::Response - HTTP style response message

=head1 VERSION

version 6.26

=head1 SYNOPSIS

Response objects are returned by the request() method of the C<LWP::UserAgent>:

    # ...
    $response = $ua->request($request);
    if ($response->is_success) {
        print $response->decoded_content;
    }
    else {
        print STDERR $response->status_line, "\n";
    }

=head1 DESCRIPTION

The C<HTTP::Response> class encapsulates HTTP style responses.  A
response consists of a response line, some headers, and a content
body. Note that the LWP library uses HTTP style responses even for
non-HTTP protocol schemes.  Instances of this class are usually
created and returned by the request() method of an C<LWP::UserAgent>
object.

C<HTTP::Response> is a subclass of C<HTTP::Message> and therefore
inherits its methods.  The following additional methods are available:

=over 4

=item $r = HTTP::Response->new( $code )

=item $r = HTTP::Response->new( $code, $msg )

=item $r = HTTP::Response->new( $code, $msg, $header )

=item $r = HTTP::Response->new( $code, $msg, $header, $content )

Constructs a new C<HTTP::Response> object describing a response with
response code $code and optional message $msg.  The optional $header
argument should be a reference to an C<HTTP::Headers> object or a
plain array reference of key/value pairs.  The optional $content
argument should be a string of bytes.  The meanings of these arguments are
described below.

=item $r = HTTP::Response->parse( $str )

This constructs a new response object by parsing the given string.

=item $r->code

=item $r->code( $code )

This is used to get/set the code attribute.  The code is a 3 digit
number that encode the overall outcome of an HTTP response.  The
C<HTTP::Status> module provide constants that provide mnemonic names
for the code attribute.

=item $r->message

=item $r->message( $message )

This is used to get/set the message attribute.  The message is a short
human readable single line string that explains the response code.

=item $r->header( $field )

=item $r->header( $field => $value )

This is used to get/set header values and it is inherited from
C<HTTP::Headers> via C<HTTP::Message>.  See L<HTTP::Headers> for
details and other similar methods that can be used to access the
headers.

=item $r->content

=item $r->content( $bytes )

This is used to get/set the raw content and it is inherited from the
C<HTTP::Message> base class.  See L<HTTP::Message> for details and
other methods that can be used to access the content.

=item $r->decoded_content( %options )

This will return the content after any C<Content-Encoding> and
charsets have been decoded.  See L<HTTP::Message> for details.

=item $r->request

=item $r->request( $request )

This is used to get/set the request attribute.  The request attribute
is a reference to the request that caused this response.  It does
not have to be the same request passed to the $ua->request() method,
because there might have been redirects and authorization retries in
between.

=item $r->previous

=item $r->previous( $response )

This is used to get/set the previous attribute.  The previous
attribute is used to link together chains of responses.  You get
chains of responses if the first response is redirect or unauthorized.
The value is C<undef> if this is the first response in a chain.

Note that the method $r->redirects is provided as a more convenient
way to access the response chain.

=item $r->status_line

Returns the string "E<lt>code> E<lt>message>".  If the message attribute
is not set then the official name of E<lt>code> (see L<HTTP::Status>)
is substituted.

=item $r->base

Returns the base URI for this response.  The return value will be a
reference to a URI object.

The base URI is obtained from one the following sources (in priority
order):

=over 4

=item 1.

Embedded in the document content, for instance <BASE HREF="...">
in HTML documents.

=item 2.

A "Content-Base:" or a "Content-Location:" header in the response.

For backwards compatibility with older HTTP implementations we will
also look for the "Base:" header.

=item 3.

The URI used to request this response. This might not be the original
URI that was passed to $ua->request() method, because we might have
received some redirect responses first.

=back

If none of these sources provide an absolute URI, undef is returned.

When the LWP protocol modules produce the HTTP::Response object, then any base
URI embedded in the document (step 1) will already have initialized the
"Content-Base:" header. (See L<LWP::UserAgent/parse_head>).  This means that
this method only performs the last 2 steps (the content is not always available
either).

=item $r->filename

Returns a filename for this response.  Note that doing sanity checks
on the returned filename (eg. removing characters that cannot be used
on the target filesystem where the filename would be used, and
laundering it for security purposes) are the caller's responsibility;
the only related thing done by this method is that it makes a simple
attempt to return a plain filename with no preceding path segments.

The filename is obtained from one the following sources (in priority
order):

=over 4

=item 1.

A "Content-Disposition:" header in the response.  Proper decoding of
RFC 2047 encoded filenames requires the C<MIME::QuotedPrint> (for "Q"
encoding), C<MIME::Base64> (for "B" encoding), and C<Encode> modules.

=item 2.

A "Content-Location:" header in the response.

=item 3.

The URI used to request this response. This might not be the original
URI that was passed to $ua->request() method, because we might have
received some redirect responses first.

=back

If a filename cannot be derived from any of these sources, undef is
returned.

=item $r->as_string

=item $r->as_string( $eol )

Returns a textual representation of the response.

=item $r->is_info

=item $r->is_success

=item $r->is_redirect

=item $r->is_error

=item $r->is_client_error

=item $r->is_server_error

These methods indicate if the response was informational, successful, a
redirection, or an error.  See L<HTTP::Status> for the meaning of these.

=item $r->error_as_HTML

Returns a string containing a complete HTML document indicating what
error occurred.  This method should only be called when $r->is_error
is TRUE.

=item $r->redirects

Returns the list of redirect responses that lead up to this response
by following the $r->previous chain.  The list order is oldest first.

In scalar context return the number of redirect responses leading up
to this one.

=item $r->current_age

Calculates the "current age" of the response as specified by RFC 2616
section 13.2.3.  The age of a response is the time since it was sent
by the origin server.  The returned value is a number representing the
age in seconds.

=item $r->freshness_lifetime( %opt )

Calculates the "freshness lifetime" of the response as specified by
RFC 2616 section 13.2.4.  The "freshness lifetime" is the length of
time between the generation of a response and its expiration time.
The returned value is the number of seconds until expiry.

If the response does not contain an "Expires" or a "Cache-Control"
header, then this function will apply some simple heuristic based on
the "Last-Modified" header to determine a suitable lifetime.  The
following options might be passed to control the heuristics:

=over

=item heuristic_expiry => $bool

If passed as a FALSE value, don't apply heuristics and just return
C<undef> when "Expires" or "Cache-Control" is lacking.

=item h_lastmod_fraction => $num

This number represent the fraction of the difference since the
"Last-Modified" timestamp to make the expiry time.  The default is
C<0.10>, the suggested typical setting of 10% in RFC 2616.

=item h_min => $sec

This is the lower limit of the heuristic expiry age to use.  The
default is C<60> (1 minute).

=item h_max => $sec

This is the upper limit of the heuristic expiry age to use.  The
default is C<86400> (24 hours).

=item h_default => $sec

This is the expiry age to use when nothing else applies.  The default
is C<3600> (1 hour) or "h_min" if greater.

=back

=item $r->is_fresh( %opt )

Returns TRUE if the response is fresh, based on the values of
freshness_lifetime() and current_age().  If the response is no longer
fresh, then it has to be re-fetched or re-validated by the origin
server.

Options might be passed to control expiry heuristics, see the
description of freshness_lifetime().

=item $r->fresh_until( %opt )

Returns the time (seconds since epoch) when this entity is no longer fresh.

Options might be passed to control expiry heuristics, see the
description of freshness_lifetime().

=back

=head1 SEE ALSO

L<HTTP::Headers>, L<HTTP::Message>, L<HTTP::Status>, L<HTTP::Request>

=head1 AUTHOR

Gisle Aas <gisle@activestate.com>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 1994 by Gisle Aas.

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

=cut

__END__


#ABSTRACT: HTTP style response message

PK       ! ��L= =   perl5/HTTP/Tiny.pmnu ��6�$        # vim: ts=4 sts=4 sw=4 et:
package HTTP::Tiny;
use strict;
use warnings;
# ABSTRACT: A small, simple, correct HTTP/1.1 client

our $VERSION = '0.088';

sub _croak { require Carp; Carp::croak(@_) }

#pod =method new
#pod
#pod     $http = HTTP::Tiny->new( %attributes );
#pod
#pod This constructor returns a new HTTP::Tiny object.  Valid attributes include:
#pod
#pod =for :list
#pod * C<agent> — A user-agent string (defaults to 'HTTP-Tiny/$VERSION'). If
#pod   C<agent> — ends in a space character, the default user-agent string is
#pod   appended.
#pod * C<cookie_jar> — An instance of L<HTTP::CookieJar> — or equivalent class
#pod   that supports the C<add> and C<cookie_header> methods
#pod * C<default_headers> — A hashref of default headers to apply to requests
#pod * C<local_address> — The local IP address to bind to
#pod * C<keep_alive> — Whether to reuse the last connection (if for the same
#pod   scheme, host and port) (defaults to 1)
#pod * C<max_redirect> — Maximum number of redirects allowed (defaults to 5)
#pod * C<max_size> — Maximum response size in bytes (only when not using a data
#pod   callback).  If defined, requests with responses larger than this will return
#pod   a 599 status code.
#pod * C<http_proxy> — URL of a proxy server to use for HTTP connections
#pod   (default is C<$ENV{http_proxy}> — if set)
#pod * C<https_proxy> — URL of a proxy server to use for HTTPS connections
#pod   (default is C<$ENV{https_proxy}> — if set)
#pod * C<proxy> — URL of a generic proxy server for both HTTP and HTTPS
#pod   connections (default is C<$ENV{all_proxy}> — if set)
#pod * C<no_proxy> — List of domain suffixes that should not be proxied.  Must
#pod   be a comma-separated string or an array reference. (default is
#pod   C<$ENV{no_proxy}> —)
#pod * C<timeout> — Request timeout in seconds (default is 60) If a socket open,
#pod   read or write takes longer than the timeout, the request response status code
#pod   will be 599.
#pod * C<verify_SSL> — A boolean that indicates whether to validate the TLS/SSL
#pod   certificate of an C<https> — connection (default is true). Changed from false
#pod   to true in version 0.083.
#pod * C<SSL_options> — A hashref of C<SSL_*> — options to pass through to
#pod   L<IO::Socket::SSL>
#pod * C<$ENV{PERL_HTTP_TINY_SSL_INSECURE_BY_DEFAULT}> - Changes the default
#pod   certificate verification behavior to not check server identity if set to 1.
#pod   Only effective if C<verify_SSL> is not set. Added in version 0.083.
#pod
#pod
#pod An accessor/mutator method exists for each attribute.
#pod
#pod Passing an explicit C<undef> for C<proxy>, C<http_proxy> or C<https_proxy> will
#pod prevent getting the corresponding proxies from the environment.
#pod
#pod Errors during request execution will result in a pseudo-HTTP status code of 599
#pod and a reason of "Internal Exception". The content field in the response will
#pod contain the text of the error.
#pod
#pod The C<keep_alive> parameter enables a persistent connection, but only to a
#pod single destination scheme, host and port.  If any connection-relevant
#pod attributes are modified via accessor, or if the process ID or thread ID change,
#pod the persistent connection will be dropped.  If you want persistent connections
#pod across multiple destinations, use multiple HTTP::Tiny objects.
#pod
#pod See L</SSL SUPPORT> for more on the C<verify_SSL> and C<SSL_options> attributes.
#pod
#pod =cut

my @attributes;
BEGIN {
    @attributes = qw(
        cookie_jar default_headers http_proxy https_proxy keep_alive
        local_address max_redirect max_size proxy no_proxy
        SSL_options verify_SSL
    );
    my %persist_ok = map {; $_ => 1 } qw(
        cookie_jar default_headers max_redirect max_size
    );
    no strict 'refs';
    no warnings 'uninitialized';
    for my $accessor ( @attributes ) {
        *{$accessor} = sub {
            @_ > 1
                ? do {
                    delete $_[0]->{handle} if !$persist_ok{$accessor} && $_[1] ne $_[0]->{$accessor};
                    $_[0]->{$accessor} = $_[1]
                }
                : $_[0]->{$accessor};
        };
    }
}

sub agent {
    my($self, $agent) = @_;
    if( @_ > 1 ){
        $self->{agent} =
            (defined $agent && $agent =~ / $/) ? $agent . $self->_agent : $agent;
    }
    return $self->{agent};
}

sub timeout {
    my ($self, $timeout) = @_;
    if ( @_ > 1 ) {
        $self->{timeout} = $timeout;
        if ($self->{handle}) {
            $self->{handle}->timeout($timeout);
        }
    }
    return $self->{timeout};
}

sub new {
    my($class, %args) = @_;

    # Support lower case verify_ssl argument, but only if verify_SSL is not
    # true.
    if ( exists $args{verify_ssl} ) {
        $args{verify_SSL}  ||= $args{verify_ssl};
    }

    my $self = {
        max_redirect => 5,
        timeout      => defined $args{timeout} ? $args{timeout} : 60,
        keep_alive   => 1,
        verify_SSL   => defined $args{verify_SSL} ? $args{verify_SSL} : _verify_SSL_default(),
        no_proxy     => $ENV{no_proxy},
    };

    bless $self, $class;

    $class->_validate_cookie_jar( $args{cookie_jar} ) if $args{cookie_jar};

    for my $key ( @attributes ) {
        $self->{$key} = $args{$key} if exists $args{$key}
    }

    $self->agent( exists $args{agent} ? $args{agent} : $class->_agent );

    $self->_set_proxies;

    return $self;
}

sub _verify_SSL_default {
    my ($self) = @_;
    # Check if insecure default certificate verification behaviour has been
    # changed by the user by setting PERL_HTTP_TINY_SSL_INSECURE_BY_DEFAULT=1
    return (($ENV{PERL_HTTP_TINY_SSL_INSECURE_BY_DEFAULT} || '') eq '1') ? 0 : 1;
}

sub _set_proxies {
    my ($self) = @_;

    # get proxies from %ENV only if not provided; explicit undef will disable
    # getting proxies from the environment

    # generic proxy
    if (! exists $self->{proxy} ) {
        $self->{proxy} = $ENV{all_proxy} || $ENV{ALL_PROXY};
    }

    if ( defined $self->{proxy} ) {
        $self->_split_proxy( 'generic proxy' => $self->{proxy} ); # validate
    }
    else {
        delete $self->{proxy};
    }

    # http proxy
    if (! exists $self->{http_proxy} ) {
        # under CGI, bypass HTTP_PROXY as request sets it from Proxy header
        local $ENV{HTTP_PROXY} = ($ENV{CGI_HTTP_PROXY} || "") if $ENV{REQUEST_METHOD};
        $self->{http_proxy} = $ENV{http_proxy} || $ENV{HTTP_PROXY} || $self->{proxy};
    }

    if ( defined $self->{http_proxy} ) {
        $self->_split_proxy( http_proxy => $self->{http_proxy} ); # validate
        $self->{_has_proxy}{http} = 1;
    }
    else {
        delete $self->{http_proxy};
    }

    # https proxy
    if (! exists $self->{https_proxy} ) {
        $self->{https_proxy} = $ENV{https_proxy} || $ENV{HTTPS_PROXY} || $self->{proxy};
    }

    if ( $self->{https_proxy} ) {
        $self->_split_proxy( https_proxy => $self->{https_proxy} ); # validate
        $self->{_has_proxy}{https} = 1;
    }
    else {
        delete $self->{https_proxy};
    }

    # Split no_proxy to array reference if not provided as such
    unless ( ref $self->{no_proxy} eq 'ARRAY' ) {
        $self->{no_proxy} =
            (defined $self->{no_proxy}) ? [ split /\s*,\s*/, $self->{no_proxy} ] : [];
    }

    return;
}

#pod =method get|head|put|post|patch|delete
#pod
#pod     $response = $http->get($url);
#pod     $response = $http->get($url, \%options);
#pod     $response = $http->head($url);
#pod
#pod These methods are shorthand for calling C<request()> for the given method.  The
#pod URL must have unsafe characters escaped and international domain names encoded.
#pod See C<request()> for valid options and a description of the response.
#pod
#pod The C<success> field of the response will be true if the status code is 2XX.
#pod
#pod =cut

for my $sub_name ( qw/get head put post patch delete/ ) {
    my $req_method = uc $sub_name;
    no strict 'refs';
    eval <<"HERE"; ## no critic
    sub $sub_name {
        my (\$self, \$url, \$args) = \@_;
        \@_ == 2 || (\@_ == 3 && ref \$args eq 'HASH')
        or _croak(q/Usage: \$http->$sub_name(URL, [HASHREF])/ . "\n");
        return \$self->request('$req_method', \$url, \$args || {});
    }
HERE
}

#pod =method post_form
#pod
#pod     $response = $http->post_form($url, $form_data);
#pod     $response = $http->post_form($url, $form_data, \%options);
#pod
#pod This method executes a C<POST> request and sends the key/value pairs from a
#pod form data hash or array reference to the given URL with a C<content-type> of
#pod C<application/x-www-form-urlencoded>.  If data is provided as an array
#pod reference, the order is preserved; if provided as a hash reference, the terms
#pod are sorted on key and value for consistency.  See documentation for the
#pod C<www_form_urlencode> method for details on the encoding.
#pod
#pod The URL must have unsafe characters escaped and international domain names
#pod encoded.  See C<request()> for valid options and a description of the response.
#pod Any C<content-type> header or content in the options hashref will be ignored.
#pod
#pod The C<success> field of the response will be true if the status code is 2XX.
#pod
#pod =cut

sub post_form {
    my ($self, $url, $data, $args) = @_;
    (@_ == 3 || @_ == 4 && ref $args eq 'HASH')
        or _croak(q/Usage: $http->post_form(URL, DATAREF, [HASHREF])/ . "\n");

    my $headers = {};
    while ( my ($key, $value) = each %{$args->{headers} || {}} ) {
        $headers->{lc $key} = $value;
    }

    return $self->request('POST', $url, {
            # Any existing 'headers' key in $args will be overridden with a
            # normalized version below.
            %$args,
            content => $self->www_form_urlencode($data),
            headers => {
                %$headers,
                'content-type' => 'application/x-www-form-urlencoded'
            },
        }
    );
}

#pod =method mirror
#pod
#pod     $response = $http->mirror($url, $file, \%options)
#pod     if ( $response->{success} ) {
#pod         print "$file is up to date\n";
#pod     }
#pod
#pod Executes a C<GET> request for the URL and saves the response body to the file
#pod name provided.  The URL must have unsafe characters escaped and international
#pod domain names encoded.  If the file already exists, the request will include an
#pod C<If-Modified-Since> header with the modification timestamp of the file.  You
#pod may specify a different C<If-Modified-Since> header yourself in the C<<
#pod $options->{headers} >> hash.
#pod
#pod The C<success> field of the response will be true if the status code is 2XX
#pod or if the status code is 304 (unmodified).
#pod
#pod If the file was modified and the server response includes a properly
#pod formatted C<Last-Modified> header, the file modification time will
#pod be updated accordingly.
#pod
#pod =cut

sub mirror {
    my ($self, $url, $file, $args) = @_;
    @_ == 3 || (@_ == 4 && ref $args eq 'HASH')
      or _croak(q/Usage: $http->mirror(URL, FILE, [HASHREF])/ . "\n");

    if ( exists $args->{headers} ) {
        my $headers = {};
        while ( my ($key, $value) = each %{$args->{headers} || {}} ) {
            $headers->{lc $key} = $value;
        }
        $args->{headers} = $headers;
    }

    if ( -e $file and my $mtime = (stat($file))[9] ) {
        $args->{headers}{'if-modified-since'} ||= $self->_http_date($mtime);
    }
    my $tempfile = $file . int(rand(2**31));

    require Fcntl;
    sysopen my $fh, $tempfile, Fcntl::O_CREAT()|Fcntl::O_EXCL()|Fcntl::O_WRONLY()
       or _croak(qq/Error: Could not create temporary file $tempfile for downloading: $!\n/);
    binmode $fh;
    $args->{data_callback} = sub { print {$fh} $_[0] };
    my $response = $self->request('GET', $url, $args);
    close $fh
        or _croak(qq/Error: Caught error closing temporary file $tempfile: $!\n/);

    if ( $response->{success} ) {
        rename $tempfile, $file
            or _croak(qq/Error replacing $file with $tempfile: $!\n/);
        my $lm = $response->{headers}{'last-modified'};
        if ( $lm and my $mtime = $self->_parse_http_date($lm) ) {
            utime $mtime, $mtime, $file;
        }
    }
    $response->{success} ||= $response->{status} eq '304';
    unlink $tempfile;
    return $response;
}

#pod =method request
#pod
#pod     $response = $http->request($method, $url);
#pod     $response = $http->request($method, $url, \%options);
#pod
#pod Executes an HTTP request of the given method type ('GET', 'HEAD', 'POST',
#pod 'PUT', etc.) on the given URL.  The URL must have unsafe characters escaped and
#pod international domain names encoded.
#pod
#pod B<NOTE>: Method names are B<case-sensitive> per the HTTP/1.1 specification.
#pod Don't use C<get> when you really want C<GET>.  See L<LIMITATIONS> for
#pod how this applies to redirection.
#pod
#pod If the URL includes a "user:password" stanza, they will be used for Basic-style
#pod authorization headers.  (Authorization headers will not be included in a
#pod redirected request.) For example:
#pod
#pod     $http->request('GET', 'http://Aladdin:open sesame@example.com/');
#pod
#pod If the "user:password" stanza contains reserved characters, they must
#pod be percent-escaped:
#pod
#pod     $http->request('GET', 'http://john%40example.com:password@example.com/');
#pod
#pod A hashref of options may be appended to modify the request.
#pod
#pod Valid options are:
#pod
#pod =for :list
#pod * C<headers> —
#pod     A hashref containing headers to include with the request.  If the value for
#pod     a header is an array reference, the header will be output multiple times with
#pod     each value in the array.  These headers over-write any default headers.
#pod * C<content> —
#pod     A scalar to include as the body of the request OR a code reference
#pod     that will be called iteratively to produce the body of the request
#pod * C<trailer_callback> —
#pod     A code reference that will be called if it exists to provide a hashref
#pod     of trailing headers (only used with chunked transfer-encoding)
#pod * C<data_callback> —
#pod     A code reference that will be called for each chunks of the response
#pod     body received.
#pod * C<peer> —
#pod     Override host resolution and force all connections to go only to a
#pod     specific peer address, regardless of the URL of the request.  This will
#pod     include any redirections!  This options should be used with extreme
#pod     caution (e.g. debugging or very special circumstances). It can be given as
#pod     either a scalar or a code reference that will receive the hostname and
#pod     whose response will be taken as the address.
#pod
#pod The C<Host> header is generated from the URL in accordance with RFC 2616.  It
#pod is a fatal error to specify C<Host> in the C<headers> option.  Other headers
#pod may be ignored or overwritten if necessary for transport compliance.
#pod
#pod If the C<content> option is a code reference, it will be called iteratively
#pod to provide the content body of the request.  It should return the empty
#pod string or undef when the iterator is exhausted.
#pod
#pod If the C<content> option is the empty string, no C<content-type> or
#pod C<content-length> headers will be generated.
#pod
#pod If the C<data_callback> option is provided, it will be called iteratively until
#pod the entire response body is received.  The first argument will be a string
#pod containing a chunk of the response body, the second argument will be the
#pod in-progress response hash reference, as described below.  (This allows
#pod customizing the action of the callback based on the C<status> or C<headers>
#pod received prior to the content body.)
#pod
#pod Content data in the request/response is handled as "raw bytes".  Any
#pod encoding/decoding (with associated headers) are the responsibility of the
#pod caller.
#pod
#pod The C<request> method returns a hashref containing the response.  The hashref
#pod will have the following keys:
#pod
#pod =for :list
#pod * C<success> —
#pod     Boolean indicating whether the operation returned a 2XX status code
#pod * C<url> —
#pod     URL that provided the response. This is the URL of the request unless
#pod     there were redirections, in which case it is the last URL queried
#pod     in a redirection chain
#pod * C<status> —
#pod     The HTTP status code of the response
#pod * C<reason> —
#pod     The response phrase returned by the server
#pod * C<content> —
#pod     The body of the response.  If the response does not have any content
#pod     or if a data callback is provided to consume the response body,
#pod     this will be the empty string
#pod * C<headers> —
#pod     A hashref of header fields.  All header field names will be normalized
#pod     to be lower case. If a header is repeated, the value will be an arrayref;
#pod     it will otherwise be a scalar string containing the value
#pod * C<protocol> -
#pod     If this field exists, it is the protocol of the response
#pod     such as HTTP/1.0 or HTTP/1.1
#pod * C<redirects>
#pod     If this field exists, it is an arrayref of response hash references from
#pod     redirects in the same order that redirections occurred.  If it does
#pod     not exist, then no redirections occurred.
#pod
#pod On an error during the execution of the request, the C<status> field will
#pod contain 599, and the C<content> field will contain the text of the error.
#pod
#pod =cut

my %idempotent = map { $_ => 1 } qw/GET HEAD PUT DELETE OPTIONS TRACE/;

sub request {
    my ($self, $method, $url, $args) = @_;
    @_ == 3 || (@_ == 4 && ref $args eq 'HASH')
      or _croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/ . "\n");
    $args ||= {}; # we keep some state in this during _request

    # RFC 2616 Section 8.1.4 mandates a single retry on broken socket
    my $response;
    for ( 0 .. 1 ) {
        $response = eval { $self->_request($method, $url, $args) };
        last unless $@ && $idempotent{$method}
            && $@ =~ m{^(?:Socket closed|Unexpected end|SSL read error)};
    }

    if (my $e = $@) {
        # maybe we got a response hash thrown from somewhere deep
        if ( ref $e eq 'HASH' && exists $e->{status} ) {
            $e->{redirects} = delete $args->{_redirects} if @{ $args->{_redirects} || []};
            return $e;
        }

        # otherwise, stringify it
        $e = "$e";
        $response = {
            url     => $url,
            success => q{},
            status  => 599,
            reason  => 'Internal Exception',
            content => $e,
            headers => {
                'content-type'   => 'text/plain',
                'content-length' => length $e,
            },
            ( @{$args->{_redirects} || []} ? (redirects => delete $args->{_redirects}) : () ),
        };
    }
    return $response;
}

#pod =method www_form_urlencode
#pod
#pod     $params = $http->www_form_urlencode( $data );
#pod     $response = $http->get("http://example.com/query?$params");
#pod
#pod This method converts the key/value pairs from a data hash or array reference
#pod into a C<x-www-form-urlencoded> string.  The keys and values from the data
#pod reference will be UTF-8 encoded and escaped per RFC 3986.  If a value is an
#pod array reference, the key will be repeated with each of the values of the array
#pod reference.  If data is provided as a hash reference, the key/value pairs in the
#pod resulting string will be sorted by key and value for consistent ordering.
#pod
#pod =cut

sub www_form_urlencode {
    my ($self, $data) = @_;
    (@_ == 2 && ref $data)
        or _croak(q/Usage: $http->www_form_urlencode(DATAREF)/ . "\n");
    (ref $data eq 'HASH' || ref $data eq 'ARRAY')
        or _croak("form data must be a hash or array reference\n");

    my @params = ref $data eq 'HASH' ? %$data : @$data;
    @params % 2 == 0
        or _croak("form data reference must have an even number of terms\n");

    my @terms;
    while( @params ) {
        my ($key, $value) = splice(@params, 0, 2);
        _croak("form data keys must not be undef")
            if !defined($key);
        if ( ref $value eq 'ARRAY' ) {
            unshift @params, map { $key => $_ } @$value;
        }
        else {
            push @terms, join("=", map { $self->_uri_escape($_) } $key, $value);
        }
    }

    return join("&", (ref $data eq 'ARRAY') ? (@terms) : (sort @terms) );
}

#pod =method can_ssl
#pod
#pod     $ok         = HTTP::Tiny->can_ssl;
#pod     ($ok, $why) = HTTP::Tiny->can_ssl;
#pod     ($ok, $why) = $http->can_ssl;
#pod
#pod Indicates if SSL support is available.  When called as a class object, it
#pod checks for the correct version of L<Net::SSLeay> and L<IO::Socket::SSL>.
#pod When called as an object methods, if C<SSL_verify> is true or if C<SSL_verify_mode>
#pod is set in C<SSL_options>, it checks that a CA file is available.
#pod
#pod In scalar context, returns a boolean indicating if SSL is available.
#pod In list context, returns the boolean and a (possibly multi-line) string of
#pod errors indicating why SSL isn't available.
#pod
#pod =cut

sub can_ssl {
    my ($self) = @_;

    my($ok, $reason) = (1, '');

    # Need IO::Socket::SSL 1.42 for SSL_create_ctx_callback
    local @INC = @INC;
    pop @INC if $INC[-1] eq '.';
    unless (eval {require IO::Socket::SSL; IO::Socket::SSL->VERSION(1.42)}) {
        $ok = 0;
        $reason .= qq/IO::Socket::SSL 1.42 must be installed for https support\n/;
    }

    # Need Net::SSLeay 1.49 for MODE_AUTO_RETRY
    unless (eval {require Net::SSLeay; Net::SSLeay->VERSION(1.49)}) {
        $ok = 0;
        $reason .= qq/Net::SSLeay 1.49 must be installed for https support\n/;
    }

    # If an object, check that SSL config lets us get a CA if necessary
    if ( ref($self) && ( $self->{verify_SSL} || $self->{SSL_options}{SSL_verify_mode} ) ) {
        my $handle = HTTP::Tiny::Handle->new(
            SSL_options => $self->{SSL_options},
            verify_SSL  => $self->{verify_SSL},
        );
        unless ( eval { $handle->_find_CA_file; 1 } ) {
            $ok = 0;
            $reason .= "$@";
        }
    }

    wantarray ? ($ok, $reason) : $ok;
}

#pod =method connected
#pod
#pod     $host = $http->connected;
#pod     ($host, $port) = $http->connected;
#pod
#pod Indicates if a connection to a peer is being kept alive, per the C<keep_alive>
#pod option.
#pod
#pod In scalar context, returns the peer host and port, joined with a colon, or
#pod C<undef> (if no peer is connected).
#pod In list context, returns the peer host and port or an empty list (if no peer
#pod is connected).
#pod
#pod B<Note>: This method cannot reliably be used to discover whether the remote
#pod host has closed its end of the socket.
#pod
#pod =cut

sub connected {
    my ($self) = @_;

    if ( $self->{handle} ) {
        return $self->{handle}->connected;
    }
    return;
}

#--------------------------------------------------------------------------#
# private methods
#--------------------------------------------------------------------------#

my %DefaultPort = (
    http => 80,
    https => 443,
);

sub _agent {
    my $class = ref($_[0]) || $_[0];
    (my $default_agent = $class) =~ s{::}{-}g;
    my $version = $class->VERSION;
    $default_agent .= "/$version" if defined $version;
    return $default_agent;
}

sub _request {
    my ($self, $method, $url, $args) = @_;

    my ($scheme, $host, $port, $path_query, $auth) = $self->_split_url($url);

    if ($scheme ne 'http' && $scheme ne 'https') {
      die(qq/Unsupported URL scheme '$scheme'\n/);
    }

    my $request = {
        method    => $method,
        scheme    => $scheme,
        host      => $host,
        port      => $port,
        host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"),
        uri       => $path_query,
        headers   => {},
    };

    my $peer = $args->{peer} || $host;

    # Allow 'peer' to be a coderef.
    if ('CODE' eq ref $peer) {
        $peer = $peer->($host);
    }

    # We remove the cached handle so it is not reused in the case of redirect.
    # If all is well, it will be recached at the end of _request.  We only
    # reuse for the same scheme, host and port
    my $handle = delete $self->{handle};
    if ( $handle ) {
        unless ( $handle->can_reuse( $scheme, $host, $port, $peer ) ) {
            $handle->close;
            undef $handle;
        }
    }
    $handle ||= $self->_open_handle( $request, $scheme, $host, $port, $peer );

    $self->_prepare_headers_and_cb($request, $args, $url, $auth);
    $handle->write_request($request);

    my $response;
    do { $response = $handle->read_response_header }
        until (substr($response->{status},0,1) ne '1');

    $self->_update_cookie_jar( $url, $response ) if $self->{cookie_jar};
    my @redir_args = $self->_maybe_redirect($request, $response, $args);

    my $known_message_length;
    if ($method eq 'HEAD' || $response->{status} =~ /^[23]04/) {
        # response has no message body
        $known_message_length = 1;
    }
    else {
        # Ignore any data callbacks during redirection.
        my $cb_args = @redir_args ? +{} : $args;
        my $data_cb = $self->_prepare_data_cb($response, $cb_args);
        $known_message_length = $handle->read_body($data_cb, $response);
    }

    if ( $self->{keep_alive}
        && $handle->connected
        && $known_message_length
        && $response->{protocol} eq 'HTTP/1.1'
        && ($response->{headers}{connection} || '') ne 'close'
    ) {
        $self->{handle} = $handle;
    }
    else {
        $handle->close;
    }

    $response->{success} = substr( $response->{status}, 0, 1 ) eq '2';
    $response->{url} = $url;

    # Push the current response onto the stack of redirects if redirecting.
    if (@redir_args) {
        push @{$args->{_redirects}}, $response;
        return $self->_request(@redir_args, $args);
    }

    # Copy the stack of redirects into the response before returning.
    $response->{redirects} = delete $args->{_redirects}
      if @{$args->{_redirects}};
    return $response;
}

sub _open_handle {
    my ($self, $request, $scheme, $host, $port, $peer) = @_;

    my $handle  = HTTP::Tiny::Handle->new(
        timeout         => $self->{timeout},
        SSL_options     => $self->{SSL_options},
        verify_SSL      => $self->{verify_SSL},
        local_address   => $self->{local_address},
        keep_alive      => $self->{keep_alive}
    );

    if ($self->{_has_proxy}{$scheme} && ! grep { $host =~ /\Q$_\E$/ } @{$self->{no_proxy}}) {
        return $self->_proxy_connect( $request, $handle );
    }
    else {
        return $handle->connect($scheme, $host, $port, $peer);
    }
}

sub _proxy_connect {
    my ($self, $request, $handle) = @_;

    my @proxy_vars;
    if ( $request->{scheme} eq 'https' ) {
        _croak(qq{No https_proxy defined}) unless $self->{https_proxy};
        @proxy_vars = $self->_split_proxy( https_proxy => $self->{https_proxy} );
        if ( $proxy_vars[0] eq 'https' ) {
            _croak(qq{Can't proxy https over https: $request->{uri} via $self->{https_proxy}});
        }
    }
    else {
        _croak(qq{No http_proxy defined}) unless $self->{http_proxy};
        @proxy_vars = $self->_split_proxy( http_proxy => $self->{http_proxy} );
    }

    my ($p_scheme, $p_host, $p_port, $p_auth) = @proxy_vars;

    if ( length $p_auth && ! defined $request->{headers}{'proxy-authorization'} ) {
        $self->_add_basic_auth_header( $request, 'proxy-authorization' => $p_auth );
    }

    $handle->connect($p_scheme, $p_host, $p_port, $p_host);

    if ($request->{scheme} eq 'https') {
        $self->_create_proxy_tunnel( $request, $handle );
    }
    else {
        # non-tunneled proxy requires absolute URI
        $request->{uri} = "$request->{scheme}://$request->{host_port}$request->{uri}";
    }

    return $handle;
}

sub _split_proxy {
    my ($self, $type, $proxy) = @_;

    my ($scheme, $host, $port, $path_query, $auth) = eval { $self->_split_url($proxy) };

    unless(
        defined($scheme) && length($scheme) && length($host) && length($port)
        && $path_query eq '/'
    ) {
        _croak(qq{$type URL must be in format http[s]://[auth@]<host>:<port>/\n});
    }

    return ($scheme, $host, $port, $auth);
}

sub _create_proxy_tunnel {
    my ($self, $request, $handle) = @_;

    $handle->_assert_ssl;

    my $agent = exists($request->{headers}{'user-agent'})
        ? $request->{headers}{'user-agent'} : $self->{agent};

    my $connect_request = {
        method    => 'CONNECT',
        uri       => "$request->{host}:$request->{port}",
        headers   => {
            host => "$request->{host}:$request->{port}",
            'user-agent' => $agent,
        }
    };

    if ( $request->{headers}{'proxy-authorization'} ) {
        $connect_request->{headers}{'proxy-authorization'} =
            delete $request->{headers}{'proxy-authorization'};
    }

    $handle->write_request($connect_request);
    my $response;
    do { $response = $handle->read_response_header }
        until (substr($response->{status},0,1) ne '1');

    # if CONNECT failed, throw the response so it will be
    # returned from the original request() method;
    unless (substr($response->{status},0,1) eq '2') {
        die $response;
    }

    # tunnel established, so start SSL handshake
    $handle->start_ssl( $request->{host} );

    return;
}

sub _prepare_headers_and_cb {
    my ($self, $request, $args, $url, $auth) = @_;

    for ($self->{default_headers}, $args->{headers}) {
        next unless defined;
        while (my ($k, $v) = each %$_) {
            $request->{headers}{lc $k} = $v;
            $request->{header_case}{lc $k} = $k;
        }
    }

    if (exists $request->{headers}{'host'}) {
        die(qq/The 'Host' header must not be provided as header option\n/);
    }

    $request->{headers}{'host'}         = $request->{host_port};
    $request->{headers}{'user-agent'} ||= $self->{agent};
    $request->{headers}{'connection'}   = "close"
        unless $self->{keep_alive};

    # Some servers error on an empty-body PUT/POST without a content-length
    if ( $request->{method} eq 'PUT' || $request->{method} eq 'POST' ) {
        if (!defined($args->{content}) || !length($args->{content}) ) {
            $request->{headers}{'content-length'} = 0;
        }
    }

    if ( defined $args->{content} ) {
        if ( ref $args->{content} eq 'CODE' ) {
            if ( exists $request->{'content-length'} && $request->{'content-length'} == 0 ) {
                $request->{cb} = sub { "" };
            }
            else {
                $request->{headers}{'content-type'} ||= "application/octet-stream";
                $request->{headers}{'transfer-encoding'} = 'chunked'
                  unless exists $request->{headers}{'content-length'}
                  || $request->{headers}{'transfer-encoding'};
                $request->{cb} = $args->{content};
            }
        }
        elsif ( length $args->{content} ) {
            my $content = $args->{content};
            if ( $] ge '5.008' ) {
                utf8::downgrade($content, 1)
                    or die(qq/Wide character in request message body\n/);
            }
            $request->{headers}{'content-type'} ||= "application/octet-stream";
            $request->{headers}{'content-length'} = length $content
              unless $request->{headers}{'content-length'}
                  || $request->{headers}{'transfer-encoding'};
            $request->{cb} = sub { substr $content, 0, length $content, '' };
        }
        $request->{trailer_cb} = $args->{trailer_callback}
            if ref $args->{trailer_callback} eq 'CODE';
    }

    ### If we have a cookie jar, then maybe add relevant cookies
    if ( $self->{cookie_jar} ) {
        my $cookies = $self->cookie_jar->cookie_header( $url );
        $request->{headers}{cookie} = $cookies if length $cookies;
    }

    # if we have Basic auth parameters, add them
    if ( length $auth && ! defined $request->{headers}{authorization} ) {
        $self->_add_basic_auth_header( $request, 'authorization' => $auth );
    }

    return;
}

sub _add_basic_auth_header {
    my ($self, $request, $header, $auth) = @_;
    require MIME::Base64;
    $request->{headers}{$header} =
        "Basic " . MIME::Base64::encode_base64($auth, "");
    return;
}

sub _prepare_data_cb {
    my ($self, $response, $args) = @_;
    my $data_cb = $args->{data_callback};
    $response->{content} = '';

    if (!$data_cb || $response->{status} !~ /^2/) {
        if (defined $self->{max_size}) {
            $data_cb = sub {
                $_[1]->{content} .= $_[0];
                die(qq/Size of response body exceeds the maximum allowed of $self->{max_size}\n/)
                  if length $_[1]->{content} > $self->{max_size};
            };
        }
        else {
            $data_cb = sub { $_[1]->{content} .= $_[0] };
        }
    }
    return $data_cb;
}

sub _update_cookie_jar {
    my ($self, $url, $response) = @_;

    my $cookies = $response->{headers}->{'set-cookie'};
    return unless defined $cookies;

    my @cookies = ref $cookies ? @$cookies : $cookies;

    $self->cookie_jar->add( $url, $_ ) for @cookies;

    return;
}

sub _validate_cookie_jar {
    my ($class, $jar) = @_;

    # duck typing
    for my $method ( qw/add cookie_header/ ) {
        _croak(qq/Cookie jar must provide the '$method' method\n/)
            unless ref($jar) && ref($jar)->can($method);
    }

    return;
}

sub _maybe_redirect {
    my ($self, $request, $response, $args) = @_;
    my $headers = $response->{headers};
    my ($status, $method) = ($response->{status}, $request->{method});
    $args->{_redirects} ||= [];

    if (($status eq '303' or ($status =~ /^30[1278]/ && $method =~ /^GET|HEAD$/))
        and $headers->{location}
        and @{$args->{_redirects}} < $self->{max_redirect}
    ) {
        my $location = ($headers->{location} =~ /^\//)
            ? "$request->{scheme}://$request->{host_port}$headers->{location}"
            : $headers->{location} ;
        return (($status eq '303' ? 'GET' : $method), $location);
    }
    return;
}

sub _split_url {
    my $url = pop;

    # URI regex adapted from the URI module
    my ($scheme, $host, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)>
      or die(qq/Cannot parse URL: '$url'\n/);

    $scheme     = lc $scheme;
    $path_query = "/$path_query" unless $path_query =~ m<\A/>;

    my $auth = '';
    if ( (my $i = index $host, '@') != -1 ) {
        # user:pass@host
        $auth = substr $host, 0, $i, ''; # take up to the @ for auth
        substr $host, 0, 1, '';          # knock the @ off the host

        # userinfo might be percent escaped, so recover real auth info
        $auth =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
    }
    my $port = $host =~ s/:(\d*)\z// && length $1 ? $1
             : $scheme eq 'http'                  ? 80
             : $scheme eq 'https'                 ? 443
             : undef;

    return ($scheme, (length $host ? lc $host : "localhost") , $port, $path_query, $auth);
}

# Date conversions adapted from HTTP::Date
my $DoW = "Sun|Mon|Tue|Wed|Thu|Fri|Sat";
my $MoY = "Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec";
sub _http_date {
    my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($_[1]);
    return sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT",
        substr($DoW,$wday*4,3),
        $mday, substr($MoY,$mon*4,3), $year+1900,
        $hour, $min, $sec
    );
}

sub _parse_http_date {
    my ($self, $str) = @_;
    require Time::Local;
    my @tl_parts;
    if ($str =~ /^[SMTWF][a-z]+, +(\d{1,2}) ($MoY) +(\d\d\d\d) +(\d\d):(\d\d):(\d\d) +GMT$/) {
        @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
    }
    elsif ($str =~ /^[SMTWF][a-z]+, +(\d\d)-($MoY)-(\d{2,4}) +(\d\d):(\d\d):(\d\d) +GMT$/ ) {
        @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
    }
    elsif ($str =~ /^[SMTWF][a-z]+ +($MoY) +(\d{1,2}) +(\d\d):(\d\d):(\d\d) +(?:[^0-9]+ +)?(\d\d\d\d)$/ ) {
        @tl_parts = ($5, $4, $3, $2, (index($MoY,$1)/4), $6);
    }
    return eval {
        my $t = @tl_parts ? Time::Local::timegm(@tl_parts) : -1;
        $t < 0 ? undef : $t;
    };
}

# URI escaping adapted from URI::Escape
# c.f. http://www.w3.org/TR/html4/interact/forms.html#h-17.13.4.1
# perl 5.6 ready UTF-8 encoding adapted from JSON::PP
my %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255;
$escapes{' '}="+";
my $unsafe_char = qr/[^A-Za-z0-9\-\._~]/;

sub _uri_escape {
    my ($self, $str) = @_;
    return "" if !defined $str;
    if ( $] ge '5.008' ) {
        utf8::encode($str);
    }
    else {
        $str = pack("U*", unpack("C*", $str)) # UTF-8 encode a byte string
            if ( length $str == do { use bytes; length $str } );
        $str = pack("C*", unpack("C*", $str)); # clear UTF-8 flag
    }
    $str =~ s/($unsafe_char)/$escapes{$1}/g;
    return $str;
}

package
    HTTP::Tiny::Handle; # hide from PAUSE/indexers
use strict;
use warnings;

use Errno      qw[EINTR EPIPE];
use IO::Socket qw[SOCK_STREAM];
use Socket     qw[SOL_SOCKET SO_KEEPALIVE];

# PERL_HTTP_TINY_IPV4_ONLY is a private environment variable to force old
# behavior if someone is unable to boostrap CPAN from a new perl install; it is
# not intended for general, per-client use and may be removed in the future
my $SOCKET_CLASS =
    $ENV{PERL_HTTP_TINY_IPV4_ONLY} ? 'IO::Socket::INET' :
    eval { require IO::Socket::IP; IO::Socket::IP->VERSION(0.32) } ? 'IO::Socket::IP' :
    'IO::Socket::INET';

sub BUFSIZE () { 32768 } ## no critic

my $Printable = sub {
    local $_ = shift;
    s/\r/\\r/g;
    s/\n/\\n/g;
    s/\t/\\t/g;
    s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
    $_;
};

my $Token = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
my $Field_Content = qr/[[:print:]]+ (?: [\x20\x09]+ [[:print:]]+ )*/x;

sub new {
    my ($class, %args) = @_;
    return bless {
        rbuf             => '',
        timeout          => 60,
        max_line_size    => 16384,
        max_header_lines => 64,
        verify_SSL       => HTTP::Tiny::_verify_SSL_default(),
        SSL_options      => {},
        %args
    }, $class;
}

sub timeout {
    my ($self, $timeout) = @_;
    if ( @_ > 1 ) {
        $self->{timeout} = $timeout;
        if ( $self->{fh} && $self->{fh}->can('timeout') ) {
            $self->{fh}->timeout($timeout);
        }
    }
    return $self->{timeout};
}

sub connect {
    @_ == 5 || die(q/Usage: $handle->connect(scheme, host, port, peer)/ . "\n");
    my ($self, $scheme, $host, $port, $peer) = @_;

    if ( $scheme eq 'https' ) {
        $self->_assert_ssl;
    }

    $self->{fh} = $SOCKET_CLASS->new(
        PeerHost  => $peer,
        PeerPort  => $port,
        $self->{local_address} ?
            ( LocalAddr => $self->{local_address} ) : (),
        Proto     => 'tcp',
        Type      => SOCK_STREAM,
        Timeout   => $self->{timeout},
    ) or die(qq/Could not connect to '$host:$port': $@\n/);

    binmode($self->{fh})
      or die(qq/Could not binmode() socket: '$!'\n/);

    if ( $self->{keep_alive} ) {
        unless ( defined( $self->{fh}->setsockopt( SOL_SOCKET, SO_KEEPALIVE, 1 ) ) ) {
            CORE::close($self->{fh});
            die(qq/Could not set SO_KEEPALIVE on socket: '$!'\n/);
        }
    }

    $self->start_ssl($host) if $scheme eq 'https';

    $self->{scheme} = $scheme;
    $self->{host} = $host;
    $self->{peer} = $peer;
    $self->{port} = $port;
    $self->{pid} = $$;
    $self->{tid} = _get_tid();

    return $self;
}

sub connected {
    my ($self) = @_;
    if ( $self->{fh} && $self->{fh}->connected ) {
        return wantarray
          ? ( $self->{fh}->peerhost, $self->{fh}->peerport )
          : join( ':', $self->{fh}->peerhost, $self->{fh}->peerport );
    }
    return;
}

sub start_ssl {
    my ($self, $host) = @_;

    # As this might be used via CONNECT after an SSL session
    # to a proxy, we shut down any existing SSL before attempting
    # the handshake
    if ( ref($self->{fh}) eq 'IO::Socket::SSL' ) {
        unless ( $self->{fh}->stop_SSL ) {
            my $ssl_err = IO::Socket::SSL->errstr;
            die(qq/Error halting prior SSL connection: $ssl_err/);
        }
    }

    my $ssl_args = $self->_ssl_args($host);
    IO::Socket::SSL->start_SSL(
        $self->{fh},
        %$ssl_args,
        SSL_create_ctx_callback => sub {
            my $ctx = shift;
            Net::SSLeay::CTX_set_mode($ctx, Net::SSLeay::MODE_AUTO_RETRY());
        },
    );

    unless ( ref($self->{fh}) eq 'IO::Socket::SSL' ) {
        my $ssl_err = IO::Socket::SSL->errstr;
        die(qq/SSL connection failed for $host: $ssl_err\n/);
    }
}

sub close {
    @_ == 1 || die(q/Usage: $handle->close()/ . "\n");
    my ($self) = @_;
    CORE::close($self->{fh})
      or die(qq/Could not close socket: '$!'\n/);
}

sub write {
    @_ == 2 || die(q/Usage: $handle->write(buf)/ . "\n");
    my ($self, $buf) = @_;

    if ( $] ge '5.008' ) {
        utf8::downgrade($buf, 1)
            or die(qq/Wide character in write()\n/);
    }

    my $len = length $buf;
    my $off = 0;

    local $SIG{PIPE} = 'IGNORE';

    while () {
        $self->can_write
          or die(qq/Timed out while waiting for socket to become ready for writing\n/);
        my $r = syswrite($self->{fh}, $buf, $len, $off);
        if (defined $r) {
            $len -= $r;
            $off += $r;
            last unless $len > 0;
        }
        elsif ($! == EPIPE) {
            die(qq/Socket closed by remote server: $!\n/);
        }
        elsif ($! != EINTR) {
            if ($self->{fh}->can('errstr')){
                my $err = $self->{fh}->errstr();
                die (qq/Could not write to SSL socket: '$err'\n /);
            }
            else {
                die(qq/Could not write to socket: '$!'\n/);
            }

        }
    }
    return $off;
}

sub read {
    @_ == 2 || @_ == 3 || die(q/Usage: $handle->read(len [, allow_partial])/ . "\n");
    my ($self, $len, $allow_partial) = @_;

    my $buf  = '';
    my $got = length $self->{rbuf};

    if ($got) {
        my $take = ($got < $len) ? $got : $len;
        $buf  = substr($self->{rbuf}, 0, $take, '');
        $len -= $take;
    }

    # Ignore SIGPIPE because SSL reads can result in writes that might error.
    # See "Expecting exactly the same behavior as plain sockets" in
    # https://metacpan.org/dist/IO-Socket-SSL/view/lib/IO/Socket/SSL.pod#Common-Usage-Errors
    local $SIG{PIPE} = 'IGNORE';

    while ($len > 0) {
        $self->can_read
          or die(q/Timed out while waiting for socket to become ready for reading/ . "\n");
        my $r = sysread($self->{fh}, $buf, $len, length $buf);
        if (defined $r) {
            last unless $r;
            $len -= $r;
        }
        elsif ($! != EINTR) {
            if ($self->{fh}->can('errstr')){
                my $err = $self->{fh}->errstr();
                die (qq/Could not read from SSL socket: '$err'\n /);
            }
            else {
                die(qq/Could not read from socket: '$!'\n/);
            }
        }
    }
    if ($len && !$allow_partial) {
        die(qq/Unexpected end of stream\n/);
    }
    return $buf;
}

sub readline {
    @_ == 1 || die(q/Usage: $handle->readline()/ . "\n");
    my ($self) = @_;

    while () {
        if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
            return $1;
        }
        if (length $self->{rbuf} >= $self->{max_line_size}) {
            die(qq/Line size exceeds the maximum allowed size of $self->{max_line_size}\n/);
        }
        $self->can_read
          or die(qq/Timed out while waiting for socket to become ready for reading\n/);
        my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
        if (defined $r) {
            last unless $r;
        }
        elsif ($! != EINTR) {
            if ($self->{fh}->can('errstr')){
                my $err = $self->{fh}->errstr();
                die (qq/Could not read from SSL socket: '$err'\n /);
            }
            else {
                die(qq/Could not read from socket: '$!'\n/);
            }
        }
    }
    die(qq/Unexpected end of stream while looking for line\n/);
}

sub read_header_lines {
    @_ == 1 || @_ == 2 || die(q/Usage: $handle->read_header_lines([headers])/ . "\n");
    my ($self, $headers) = @_;
    $headers ||= {};
    my $lines   = 0;
    my $val;

    while () {
         my $line = $self->readline;

         if (++$lines >= $self->{max_header_lines}) {
             die(qq/Header lines exceeds maximum number allowed of $self->{max_header_lines}\n/);
         }
         elsif ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
             my ($field_name) = lc $1;
             if (exists $headers->{$field_name}) {
                 for ($headers->{$field_name}) {
                     $_ = [$_] unless ref $_ eq "ARRAY";
                     push @$_, $2;
                     $val = \$_->[-1];
                 }
             }
             else {
                 $val = \($headers->{$field_name} = $2);
             }
         }
         elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
             $val
               or die(qq/Unexpected header continuation line\n/);
             next unless length $1;
             $$val .= ' ' if length $$val;
             $$val .= $1;
         }
         elsif ($line =~ /\A \x0D?\x0A \z/x) {
            last;
         }
         else {
            die(q/Malformed header line: / . $Printable->($line) . "\n");
         }
    }
    return $headers;
}

sub write_request {
    @_ == 2 || die(q/Usage: $handle->write_request(request)/ . "\n");
    my($self, $request) = @_;
    $self->write_request_header(@{$request}{qw/method uri headers header_case/});
    $self->write_body($request) if $request->{cb};
    return;
}

# Standard request header names/case from HTTP/1.1 RFCs
my @rfc_request_headers = qw(
  Accept Accept-Charset Accept-Encoding Accept-Language Authorization
  Cache-Control Connection Content-Length Expect From Host
  If-Match If-Modified-Since If-None-Match If-Range If-Unmodified-Since
  Max-Forwards Pragma Proxy-Authorization Range Referer TE Trailer
  Transfer-Encoding Upgrade User-Agent Via
);

my @other_request_headers = qw(
  Content-Encoding Content-MD5 Content-Type Cookie DNT Date Origin
  X-XSS-Protection
);

my %HeaderCase = map { lc($_) => $_ } @rfc_request_headers, @other_request_headers;

# to avoid multiple small writes and hence nagle, you can pass the method line or anything else to
# combine writes.
sub write_header_lines {
    (@_ >= 2 && @_ <= 4 && ref $_[1] eq 'HASH') || die(q/Usage: $handle->write_header_lines(headers, [header_case, prefix])/ . "\n");
    my($self, $headers, $header_case, $prefix_data) = @_;
    $header_case ||= {};

    my $buf = (defined $prefix_data ? $prefix_data : '');

    # Per RFC, control fields should be listed first
    my %seen;
    for my $k ( qw/host cache-control expect max-forwards pragma range te/ ) {
        next unless exists $headers->{$k};
        $seen{$k}++;
        my $field_name = $HeaderCase{$k};
        my $v = $headers->{$k};
        for (ref $v eq 'ARRAY' ? @$v : $v) {
            $_ = '' unless defined $_;
            $buf .= "$field_name: $_\x0D\x0A";
        }
    }

    # Other headers sent in arbitrary order
    while (my ($k, $v) = each %$headers) {
        my $field_name = lc $k;
        next if $seen{$field_name};
        if (exists $HeaderCase{$field_name}) {
            $field_name = $HeaderCase{$field_name};
        }
        else {
            if (exists $header_case->{$field_name}) {
                $field_name = $header_case->{$field_name};
            }
            else {
                $field_name =~ s/\b(\w)/\u$1/g;
            }
            $field_name =~ /\A $Token+ \z/xo
              or die(q/Invalid HTTP header field name: / . $Printable->($field_name) . "\n");
            $HeaderCase{lc $field_name} = $field_name;
        }
        for (ref $v eq 'ARRAY' ? @$v : $v) {
            # unwrap a field value if pre-wrapped by user
            s/\x0D?\x0A\s+/ /g;
            die(qq/Invalid HTTP header field value ($field_name): / . $Printable->($_). "\n")
              unless $_ eq '' || /\A $Field_Content \z/xo;
            $_ = '' unless defined $_;
            $buf .= "$field_name: $_\x0D\x0A";
        }
    }
    $buf .= "\x0D\x0A";
    return $self->write($buf);
}

# return value indicates whether message length was defined; this is generally
# true unless there was no content-length header and we just read until EOF.
# Other message length errors are thrown as exceptions
sub read_body {
    @_ == 3 || die(q/Usage: $handle->read_body(callback, response)/ . "\n");
    my ($self, $cb, $response) = @_;
    my $te = $response->{headers}{'transfer-encoding'} || '';
    my $chunked = grep { /chunked/i } ( ref $te eq 'ARRAY' ? @$te : $te ) ;
    return $chunked
        ? $self->read_chunked_body($cb, $response)
        : $self->read_content_body($cb, $response);
}

sub write_body {
    @_ == 2 || die(q/Usage: $handle->write_body(request)/ . "\n");
    my ($self, $request) = @_;
    if (exists $request->{headers}{'content-length'}) {
        return unless $request->{headers}{'content-length'};
        return $self->write_content_body($request);
    }
    else {
        return $self->write_chunked_body($request);
    }
}

sub read_content_body {
    @_ == 3 || @_ == 4 || die(q/Usage: $handle->read_content_body(callback, response, [read_length])/ . "\n");
    my ($self, $cb, $response, $content_length) = @_;
    $content_length ||= $response->{headers}{'content-length'};

    if ( defined $content_length ) {
        my $len = $content_length;
        while ($len > 0) {
            my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
            $cb->($self->read($read, 0), $response);
            $len -= $read;
        }
        return length($self->{rbuf}) == 0;
    }

    my $chunk;
    $cb->($chunk, $response) while length( $chunk = $self->read(BUFSIZE, 1) );

    return;
}

sub write_content_body {
    @_ == 2 || die(q/Usage: $handle->write_content_body(request)/ . "\n");
    my ($self, $request) = @_;

    my ($len, $content_length) = (0, $request->{headers}{'content-length'});
    while () {
        my $data = $request->{cb}->();

        defined $data && length $data
          or last;

        if ( $] ge '5.008' ) {
            utf8::downgrade($data, 1)
                or die(qq/Wide character in write_content()\n/);
        }

        $len += $self->write($data);
    }

    $len == $content_length
      or die(qq/Content-Length mismatch (got: $len expected: $content_length)\n/);

    return $len;
}

sub read_chunked_body {
    @_ == 3 || die(q/Usage: $handle->read_chunked_body(callback, $response)/ . "\n");
    my ($self, $cb, $response) = @_;

    while () {
        my $head = $self->readline;

        $head =~ /\A ([A-Fa-f0-9]+)/x
          or die(q/Malformed chunk head: / . $Printable->($head) . "\n");

        my $len = hex($1)
          or last;

        $self->read_content_body($cb, $response, $len);

        $self->read(2) eq "\x0D\x0A"
          or die(qq/Malformed chunk: missing CRLF after chunk data\n/);
    }
    $self->read_header_lines($response->{headers});
    return 1;
}

sub write_chunked_body {
    @_ == 2 || die(q/Usage: $handle->write_chunked_body(request)/ . "\n");
    my ($self, $request) = @_;

    my $len = 0;
    while () {
        my $data = $request->{cb}->();

        defined $data && length $data
          or last;

        if ( $] ge '5.008' ) {
            utf8::downgrade($data, 1)
                or die(qq/Wide character in write_chunked_body()\n/);
        }

        $len += length $data;

        my $chunk  = sprintf '%X', length $data;
           $chunk .= "\x0D\x0A";
           $chunk .= $data;
           $chunk .= "\x0D\x0A";

        $self->write($chunk);
    }
    $self->write("0\x0D\x0A");
    if ( ref $request->{trailer_cb} eq 'CODE' ) {
        $self->write_header_lines($request->{trailer_cb}->())
    }
    else {
        $self->write("\x0D\x0A");
    }
    return $len;
}

sub read_response_header {
    @_ == 1 || die(q/Usage: $handle->read_response_header()/ . "\n");
    my ($self) = @_;

    my $line = $self->readline;

    $line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) (?: [\x09\x20]+ ([^\x0D\x0A]*) )? \x0D?\x0A/x
      or die(q/Malformed Status-Line: / . $Printable->($line). "\n");

    my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
    $reason = "" unless defined $reason;

    die (qq/Unsupported HTTP protocol: $protocol\n/)
        unless $version =~ /0*1\.0*[01]/;

    return {
        status       => $status,
        reason       => $reason,
        headers      => $self->read_header_lines,
        protocol     => $protocol,
    };
}

sub write_request_header {
    @_ == 5 || die(q/Usage: $handle->write_request_header(method, request_uri, headers, header_case)/ . "\n");
    my ($self, $method, $request_uri, $headers, $header_case) = @_;

    return $self->write_header_lines($headers, $header_case, "$method $request_uri HTTP/1.1\x0D\x0A");
}

sub _do_timeout {
    my ($self, $type, $timeout) = @_;
    $timeout = $self->{timeout}
        unless defined $timeout && $timeout >= 0;

    my $fd = fileno $self->{fh};
    defined $fd && $fd >= 0
      or die(qq/select(2): 'Bad file descriptor'\n/);

    my $initial = time;
    my $pending = $timeout;
    my $nfound;

    vec(my $fdset = '', $fd, 1) = 1;

    while () {
        $nfound = ($type eq 'read')
            ? select($fdset, undef, undef, $pending)
            : select(undef, $fdset, undef, $pending) ;
        if ($nfound == -1) {
            $! == EINTR
              or die(qq/select(2): '$!'\n/);
            redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
            $nfound = 0;
        }
        last;
    }
    $! = 0;
    return $nfound;
}

sub can_read {
    @_ == 1 || @_ == 2 || die(q/Usage: $handle->can_read([timeout])/ . "\n");
    my $self = shift;
    if ( ref($self->{fh}) eq 'IO::Socket::SSL' ) {
        return 1 if $self->{fh}->pending;
    }
    return $self->_do_timeout('read', @_)
}

sub can_write {
    @_ == 1 || @_ == 2 || die(q/Usage: $handle->can_write([timeout])/ . "\n");
    my $self = shift;
    return $self->_do_timeout('write', @_)
}

sub _assert_ssl {
    my($ok, $reason) = HTTP::Tiny->can_ssl();
    die $reason unless $ok;
}

sub can_reuse {
    my ($self,$scheme,$host,$port,$peer) = @_;
    return 0 if
        $self->{pid} != $$
        || $self->{tid} != _get_tid()
        || length($self->{rbuf})
        || $scheme ne $self->{scheme}
        || $host ne $self->{host}
        || $port ne $self->{port}
        || $peer ne $self->{peer}
        || eval { $self->can_read(0) }
        || $@ ;
        return 1;
}

# Try to find a CA bundle to validate the SSL cert,
# prefer Mozilla::CA or fallback to a system file
sub _find_CA_file {
    my $self = shift();

    my $ca_file =
      defined( $self->{SSL_options}->{SSL_ca_file} )
      ? $self->{SSL_options}->{SSL_ca_file}
      : $ENV{SSL_CERT_FILE};

    if ( defined $ca_file ) {
        unless ( -r $ca_file ) {
            die qq/SSL_ca_file '$ca_file' not found or not readable\n/;
        }
        return $ca_file;
    }

    local @INC = @INC;
    pop @INC if $INC[-1] eq '.';
    return Mozilla::CA::SSL_ca_file()
        if eval { require Mozilla::CA; 1 };

    # cert list copied from golang src/crypto/x509/root_unix.go
    foreach my $ca_bundle (
        "/etc/ssl/certs/ca-certificates.crt",     # Debian/Ubuntu/Gentoo etc.
        "/etc/pki/tls/certs/ca-bundle.crt",       # Fedora/RHEL
        "/etc/ssl/ca-bundle.pem",                 # OpenSUSE
        "/etc/openssl/certs/ca-certificates.crt", # NetBSD
        "/etc/ssl/cert.pem",                      # OpenBSD
        "/usr/local/share/certs/ca-root-nss.crt", # FreeBSD/DragonFly
        "/etc/pki/tls/cacert.pem",                # OpenELEC
        "/etc/certs/ca-certificates.crt",         # Solaris 11.2+
    ) {
        return $ca_bundle if -e $ca_bundle;
    }

    die qq/Couldn't find a CA bundle with which to verify the SSL certificate.\n/
      . qq/Try installing Mozilla::CA from CPAN\n/;
}

# for thread safety, we need to know thread id if threads are loaded
sub _get_tid {
    no warnings 'reserved'; # for 'threads'
    return threads->can("tid") ? threads->tid : 0;
}

sub _ssl_args {
    my ($self, $host) = @_;

    my %ssl_args;

    # This test reimplements IO::Socket::SSL::can_client_sni(), which wasn't
    # added until IO::Socket::SSL 1.84
    if ( Net::SSLeay::OPENSSL_VERSION_NUMBER() >= 0x01000000 ) {
        $ssl_args{SSL_hostname} = $host,          # Sane SNI support
    }

    if ($self->{verify_SSL}) {
        $ssl_args{SSL_verifycn_scheme}  = 'http'; # enable CN validation
        $ssl_args{SSL_verifycn_name}    = $host;  # set validation hostname
        $ssl_args{SSL_verify_mode}      = 0x01;   # enable cert validation
        $ssl_args{SSL_ca_file}          = $self->_find_CA_file;
    }
    else {
        $ssl_args{SSL_verifycn_scheme}  = 'none'; # disable CN validation
        $ssl_args{SSL_verify_mode}      = 0x00;   # disable cert validation
    }

    # user options override settings from verify_SSL
    for my $k ( keys %{$self->{SSL_options}} ) {
        $ssl_args{$k} = $self->{SSL_options}{$k} if $k =~ m/^SSL_/;
    }

    return \%ssl_args;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

HTTP::Tiny - A small, simple, correct HTTP/1.1 client

=head1 VERSION

version 0.088

=head1 SYNOPSIS

    use HTTP::Tiny;

    my $response = HTTP::Tiny->new->get('http://example.com/');

    die "Failed!\n" unless $response->{success};

    print "$response->{status} $response->{reason}\n";

    while (my ($k, $v) = each %{$response->{headers}}) {
        for (ref $v eq 'ARRAY' ? @$v : $v) {
            print "$k: $_\n";
        }
    }

    print $response->{content} if length $response->{content};

=head1 DESCRIPTION

This is a very simple HTTP/1.1 client, designed for doing simple
requests without the overhead of a large framework like L<LWP::UserAgent>.

It is more correct and more complete than L<HTTP::Lite>.  It supports
proxies and redirection.  It also correctly resumes after EINTR.

If L<IO::Socket::IP> 0.25 or later is installed, HTTP::Tiny will use it instead
of L<IO::Socket::INET> for transparent support for both IPv4 and IPv6.

Cookie support requires L<HTTP::CookieJar> or an equivalent class.

=head1 METHODS

=head2 new

    $http = HTTP::Tiny->new( %attributes );

This constructor returns a new HTTP::Tiny object.  Valid attributes include:

=over 4

=item *

C<agent> — A user-agent string (defaults to 'HTTP-Tiny/$VERSION'). If C<agent> — ends in a space character, the default user-agent string is appended.

=item *

C<cookie_jar> — An instance of L<HTTP::CookieJar> — or equivalent class that supports the C<add> and C<cookie_header> methods

=item *

C<default_headers> — A hashref of default headers to apply to requests

=item *

C<local_address> — The local IP address to bind to

=item *

C<keep_alive> — Whether to reuse the last connection (if for the same scheme, host and port) (defaults to 1)

=item *

C<max_redirect> — Maximum number of redirects allowed (defaults to 5)

=item *

C<max_size> — Maximum response size in bytes (only when not using a data callback).  If defined, requests with responses larger than this will return a 599 status code.

=item *

C<http_proxy> — URL of a proxy server to use for HTTP connections (default is C<$ENV{http_proxy}> — if set)

=item *

C<https_proxy> — URL of a proxy server to use for HTTPS connections (default is C<$ENV{https_proxy}> — if set)

=item *

C<proxy> — URL of a generic proxy server for both HTTP and HTTPS connections (default is C<$ENV{all_proxy}> — if set)

=item *

C<no_proxy> — List of domain suffixes that should not be proxied.  Must be a comma-separated string or an array reference. (default is C<$ENV{no_proxy}> —)

=item *

C<timeout> — Request timeout in seconds (default is 60) If a socket open, read or write takes longer than the timeout, the request response status code will be 599.

=item *

C<verify_SSL> — A boolean that indicates whether to validate the TLS/SSL certificate of an C<https> — connection (default is true). Changed from false to true in version 0.083.

=item *

C<SSL_options> — A hashref of C<SSL_*> — options to pass through to L<IO::Socket::SSL>

=item *

C<$ENV{PERL_HTTP_TINY_SSL_INSECURE_BY_DEFAULT}> - Changes the default certificate verification behavior to not check server identity if set to 1. Only effective if C<verify_SSL> is not set. Added in version 0.083.

=back

An accessor/mutator method exists for each attribute.

Passing an explicit C<undef> for C<proxy>, C<http_proxy> or C<https_proxy> will
prevent getting the corresponding proxies from the environment.

Errors during request execution will result in a pseudo-HTTP status code of 599
and a reason of "Internal Exception". The content field in the response will
contain the text of the error.

The C<keep_alive> parameter enables a persistent connection, but only to a
single destination scheme, host and port.  If any connection-relevant
attributes are modified via accessor, or if the process ID or thread ID change,
the persistent connection will be dropped.  If you want persistent connections
across multiple destinations, use multiple HTTP::Tiny objects.

See L</SSL SUPPORT> for more on the C<verify_SSL> and C<SSL_options> attributes.

=head2 get|head|put|post|patch|delete

    $response = $http->get($url);
    $response = $http->get($url, \%options);
    $response = $http->head($url);

These methods are shorthand for calling C<request()> for the given method.  The
URL must have unsafe characters escaped and international domain names encoded.
See C<request()> for valid options and a description of the response.

The C<success> field of the response will be true if the status code is 2XX.

=head2 post_form

    $response = $http->post_form($url, $form_data);
    $response = $http->post_form($url, $form_data, \%options);

This method executes a C<POST> request and sends the key/value pairs from a
form data hash or array reference to the given URL with a C<content-type> of
C<application/x-www-form-urlencoded>.  If data is provided as an array
reference, the order is preserved; if provided as a hash reference, the terms
are sorted on key and value for consistency.  See documentation for the
C<www_form_urlencode> method for details on the encoding.

The URL must have unsafe characters escaped and international domain names
encoded.  See C<request()> for valid options and a description of the response.
Any C<content-type> header or content in the options hashref will be ignored.

The C<success> field of the response will be true if the status code is 2XX.

=head2 mirror

    $response = $http->mirror($url, $file, \%options)
    if ( $response->{success} ) {
        print "$file is up to date\n";
    }

Executes a C<GET> request for the URL and saves the response body to the file
name provided.  The URL must have unsafe characters escaped and international
domain names encoded.  If the file already exists, the request will include an
C<If-Modified-Since> header with the modification timestamp of the file.  You
may specify a different C<If-Modified-Since> header yourself in the C<<
$options->{headers} >> hash.

The C<success> field of the response will be true if the status code is 2XX
or if the status code is 304 (unmodified).

If the file was modified and the server response includes a properly
formatted C<Last-Modified> header, the file modification time will
be updated accordingly.

=head2 request

    $response = $http->request($method, $url);
    $response = $http->request($method, $url, \%options);

Executes an HTTP request of the given method type ('GET', 'HEAD', 'POST',
'PUT', etc.) on the given URL.  The URL must have unsafe characters escaped and
international domain names encoded.

B<NOTE>: Method names are B<case-sensitive> per the HTTP/1.1 specification.
Don't use C<get> when you really want C<GET>.  See L<LIMITATIONS> for
how this applies to redirection.

If the URL includes a "user:password" stanza, they will be used for Basic-style
authorization headers.  (Authorization headers will not be included in a
redirected request.) For example:

    $http->request('GET', 'http://Aladdin:open sesame@example.com/');

If the "user:password" stanza contains reserved characters, they must
be percent-escaped:

    $http->request('GET', 'http://john%40example.com:password@example.com/');

A hashref of options may be appended to modify the request.

Valid options are:

=over 4

=item *

C<headers> — A hashref containing headers to include with the request.  If the value for a header is an array reference, the header will be output multiple times with each value in the array.  These headers over-write any default headers.

=item *

C<content> — A scalar to include as the body of the request OR a code reference that will be called iteratively to produce the body of the request

=item *

C<trailer_callback> — A code reference that will be called if it exists to provide a hashref of trailing headers (only used with chunked transfer-encoding)

=item *

C<data_callback> — A code reference that will be called for each chunks of the response body received.

=item *

C<peer> — Override host resolution and force all connections to go only to a specific peer address, regardless of the URL of the request.  This will include any redirections!  This options should be used with extreme caution (e.g. debugging or very special circumstances). It can be given as either a scalar or a code reference that will receive the hostname and whose response will be taken as the address.

=back

The C<Host> header is generated from the URL in accordance with RFC 2616.  It
is a fatal error to specify C<Host> in the C<headers> option.  Other headers
may be ignored or overwritten if necessary for transport compliance.

If the C<content> option is a code reference, it will be called iteratively
to provide the content body of the request.  It should return the empty
string or undef when the iterator is exhausted.

If the C<content> option is the empty string, no C<content-type> or
C<content-length> headers will be generated.

If the C<data_callback> option is provided, it will be called iteratively until
the entire response body is received.  The first argument will be a string
containing a chunk of the response body, the second argument will be the
in-progress response hash reference, as described below.  (This allows
customizing the action of the callback based on the C<status> or C<headers>
received prior to the content body.)

Content data in the request/response is handled as "raw bytes".  Any
encoding/decoding (with associated headers) are the responsibility of the
caller.

The C<request> method returns a hashref containing the response.  The hashref
will have the following keys:

=over 4

=item *

C<success> — Boolean indicating whether the operation returned a 2XX status code

=item *

C<url> — URL that provided the response. This is the URL of the request unless there were redirections, in which case it is the last URL queried in a redirection chain

=item *

C<status> — The HTTP status code of the response

=item *

C<reason> — The response phrase returned by the server

=item *

C<content> — The body of the response.  If the response does not have any content or if a data callback is provided to consume the response body, this will be the empty string

=item *

C<headers> — A hashref of header fields.  All header field names will be normalized to be lower case. If a header is repeated, the value will be an arrayref; it will otherwise be a scalar string containing the value

=item *

C<protocol> - If this field exists, it is the protocol of the response such as HTTP/1.0 or HTTP/1.1

=item *

C<redirects> If this field exists, it is an arrayref of response hash references from redirects in the same order that redirections occurred.  If it does not exist, then no redirections occurred.

=back

On an error during the execution of the request, the C<status> field will
contain 599, and the C<content> field will contain the text of the error.

=head2 www_form_urlencode

    $params = $http->www_form_urlencode( $data );
    $response = $http->get("http://example.com/query?$params");

This method converts the key/value pairs from a data hash or array reference
into a C<x-www-form-urlencoded> string.  The keys and values from the data
reference will be UTF-8 encoded and escaped per RFC 3986.  If a value is an
array reference, the key will be repeated with each of the values of the array
reference.  If data is provided as a hash reference, the key/value pairs in the
resulting string will be sorted by key and value for consistent ordering.

=head2 can_ssl

    $ok         = HTTP::Tiny->can_ssl;
    ($ok, $why) = HTTP::Tiny->can_ssl;
    ($ok, $why) = $http->can_ssl;

Indicates if SSL support is available.  When called as a class object, it
checks for the correct version of L<Net::SSLeay> and L<IO::Socket::SSL>.
When called as an object methods, if C<SSL_verify> is true or if C<SSL_verify_mode>
is set in C<SSL_options>, it checks that a CA file is available.

In scalar context, returns a boolean indicating if SSL is available.
In list context, returns the boolean and a (possibly multi-line) string of
errors indicating why SSL isn't available.

=head2 connected

    $host = $http->connected;
    ($host, $port) = $http->connected;

Indicates if a connection to a peer is being kept alive, per the C<keep_alive>
option.

In scalar context, returns the peer host and port, joined with a colon, or
C<undef> (if no peer is connected).
In list context, returns the peer host and port or an empty list (if no peer
is connected).

B<Note>: This method cannot reliably be used to discover whether the remote
host has closed its end of the socket.

=for Pod::Coverage SSL_options
agent
cookie_jar
default_headers
http_proxy
https_proxy
keep_alive
local_address
max_redirect
max_size
no_proxy
proxy
timeout
verify_SSL

=head1 TLS/SSL SUPPORT

Direct C<https> connections are supported only if L<IO::Socket::SSL> 1.56 or
greater and L<Net::SSLeay> 1.49 or greater are installed. An error will occur
if new enough versions of these modules are not installed or if the TLS
encryption fails. You can also use C<HTTP::Tiny::can_ssl()> utility function
that returns boolean to see if the required modules are installed.

An C<https> connection may be made via an C<http> proxy that supports the CONNECT
command (i.e. RFC 2817).  You may not proxy C<https> via a proxy that itself
requires C<https> to communicate.

TLS/SSL provides two distinct capabilities:

=over 4

=item *

Encrypted communication channel

=item *

Verification of server identity

=back

B<By default, HTTP::Tiny verifies server identity>.

This was changed in version 0.083 due to security concerns. The previous default
behavior can be enabled by setting C<$ENV{PERL_HTTP_TINY_SSL_INSECURE_BY_DEFAULT}>
to 1.

Verification is done by checking that that the TLS/SSL connection has a valid
certificate corresponding to the host name of the connection and that the
certificate has been verified by a CA. Assuming you trust the CA, this will
protect against L<machine-in-the-middle
attacks|http://en.wikipedia.org/wiki/Machine-in-the-middle_attack>.

Certificate verification requires a file containing trusted CA certificates.

If the environment variable C<SSL_CERT_FILE> is present, HTTP::Tiny
will try to find a CA certificate file in that location.

If the L<Mozilla::CA> module is installed, HTTP::Tiny will use the CA file
included with it as a source of trusted CA's.

If that module is not available, then HTTP::Tiny will search several
system-specific default locations for a CA certificate file:

=over 4

=item *

/etc/ssl/certs/ca-certificates.crt

=item *

/etc/pki/tls/certs/ca-bundle.crt

=item *

/etc/ssl/ca-bundle.pem

=item *

/etc/openssl/certs/ca-certificates.crt

=item *

/etc/ssl/cert.pem

=item *

/usr/local/share/certs/ca-root-nss.crt

=item *

/etc/pki/tls/cacert.pem

=item *

/etc/certs/ca-certificates.crt

=back

An error will be occur if C<verify_SSL> is true and no CA certificate file
is available.

If you desire complete control over TLS/SSL connections, the C<SSL_options>
attribute lets you provide a hash reference that will be passed through to
C<IO::Socket::SSL::start_SSL()>, overriding any options set by HTTP::Tiny. For
example, to provide your own trusted CA file:

    SSL_options => {
        SSL_ca_file => $file_path,
    }

The C<SSL_options> attribute could also be used for such things as providing a
client certificate for authentication to a server or controlling the choice of
cipher used for the TLS/SSL connection. See L<IO::Socket::SSL> documentation for
details.

=head1 PROXY SUPPORT

HTTP::Tiny can proxy both C<http> and C<https> requests.  Only Basic proxy
authorization is supported and it must be provided as part of the proxy URL:
C<http://user:pass@proxy.example.com/>.

HTTP::Tiny supports the following proxy environment variables:

=over 4

=item *

http_proxy or HTTP_PROXY

=item *

https_proxy or HTTPS_PROXY

=item *

all_proxy or ALL_PROXY

=back

If the C<REQUEST_METHOD> environment variable is set, then this might be a CGI
process and C<HTTP_PROXY> would be set from the C<Proxy:> header, which is a
security risk.  If C<REQUEST_METHOD> is set, C<HTTP_PROXY> (the upper case
variant only) is ignored, but C<CGI_HTTP_PROXY> is considered instead.

Tunnelling C<https> over an C<http> proxy using the CONNECT method is
supported.  If your proxy uses C<https> itself, you can not tunnel C<https>
over it.

Be warned that proxying an C<https> connection opens you to the risk of a
man-in-the-middle attack by the proxy server.

The C<no_proxy> environment variable is supported in the format of a
comma-separated list of domain extensions proxy should not be used for.

Proxy arguments passed to C<new> will override their corresponding
environment variables.

=head1 LIMITATIONS

HTTP::Tiny is I<conditionally compliant> with the
L<HTTP/1.1 specifications|http://www.w3.org/Protocols/>:

=over 4

=item *

"Message Syntax and Routing" [RFC7230]

=item *

"Semantics and Content" [RFC7231]

=item *

"Conditional Requests" [RFC7232]

=item *

"Range Requests" [RFC7233]

=item *

"Caching" [RFC7234]

=item *

"Authentication" [RFC7235]

=back

It attempts to meet all "MUST" requirements of the specification, but does not
implement all "SHOULD" requirements.  (Note: it was developed against the
earlier RFC 2616 specification and may not yet meet the revised RFC 7230-7235
spec.) Additionally, HTTP::Tiny supports the C<PATCH> method of RFC 5789.

Some particular limitations of note include:

=over

=item *

HTTP::Tiny focuses on correct transport.  Users are responsible for ensuring
that user-defined headers and content are compliant with the HTTP/1.1
specification.

=item *

Users must ensure that URLs are properly escaped for unsafe characters and that
international domain names are properly encoded to ASCII. See L<URI::Escape>,
L<URI::_punycode> and L<Net::IDN::Encode>.

=item *

Redirection is very strict against the specification.  Redirection is only
automatic for response codes 301, 302, 307 and 308 if the request method is
'GET' or 'HEAD'.  Response code 303 is always converted into a 'GET'
redirection, as mandated by the specification.  There is no automatic support
for status 305 ("Use proxy") redirections.

=item *

There is no provision for delaying a request body using an C<Expect> header.
Unexpected C<1XX> responses are silently ignored as per the specification.

=item *

Only 'chunked' C<Transfer-Encoding> is supported.

=item *

There is no support for a Request-URI of '*' for the 'OPTIONS' request.

=item *

Headers mentioned in the RFCs and some other, well-known headers are
generated with their canonical case.  Other headers are sent in the
case provided by the user.  Except for control headers (which are sent first),
headers are sent in arbitrary order.

=back

Despite the limitations listed above, HTTP::Tiny is considered
feature-complete.  New feature requests should be directed to
L<HTTP::Tiny::UA>.

=head1 SEE ALSO

=over 4

=item *

L<HTTP::Tiny::UA> - Higher level UA features for HTTP::Tiny

=item *

L<HTTP::Thin> - HTTP::Tiny wrapper with L<HTTP::Request>/L<HTTP::Response> compatibility

=item *

L<HTTP::Tiny::Mech> - Wrap L<WWW::Mechanize> instance in HTTP::Tiny compatible interface

=item *

L<IO::Socket::IP> - Required for IPv6 support

=item *

L<IO::Socket::SSL> - Required for SSL support

=item *

L<LWP::UserAgent> - If HTTP::Tiny isn't enough for you, this is the "standard" way to do things

=item *

L<Mozilla::CA> - Required if you want to validate SSL certificates

=item *

L<Net::SSLeay> - Required for SSL support

=back

=for :stopwords cpan testmatrix url bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan

=head1 SUPPORT

=head2 Bugs / Feature Requests

Please report any bugs or feature requests through the issue tracker
at L<https://github.com/Perl-Toolchain-Gang/HTTP-Tiny/issues>.
You will be notified automatically of any progress on your issue.

=head2 Source Code

This is open source software.  The code repository is available for
public review and contribution under the terms of the license.

L<https://github.com/Perl-Toolchain-Gang/HTTP-Tiny>

  git clone https://github.com/Perl-Toolchain-Gang/HTTP-Tiny.git

=head1 AUTHORS

=over 4

=item *

Christian Hansen <chansen@cpan.org>

=item *

David Golden <dagolden@cpan.org>

=back

=head1 CONTRIBUTORS

=for stopwords Alan Gardner Alessandro Ghedini A. Sinan Unur Brad Gilbert brian m. carlson Chris Nehren Weyl Claes Jakobsson Clinton Gormley Craig Berry David Golden Mitchell Dean Pearce Edward Zborowski Felipe Gasper Graham Knop Greg Kennedy James E Keenan Raspass Jeremy Mates Jess Robinson Karen Etheridge Lukas Eklund Martin J. Evans Martin-Louis Bright Matthew Horsfall Michael R. Davis Mike Doherty Nicolas Rochelemagne Olaf Alders Olivier Mengué Petr Písař sanjay-cpu Serguei Trouchelle Shoichi Kaji SkyMarshal Sören Kornetzki Steve Grazzini Stig Palmquist Syohei YOSHIDA Tatsuhiko Miyagawa Tom Hukins Tony Cook Xavier Guimard

=over 4

=item *

Alan Gardner <gardner@pythian.com>

=item *

Alessandro Ghedini <al3xbio@gmail.com>

=item *

A. Sinan Unur <nanis@cpan.org>

=item *

Brad Gilbert <bgills@cpan.org>

=item *

brian m. carlson <sandals@crustytoothpaste.net>

=item *

Chris Nehren <apeiron@cpan.org>

=item *

Chris Weyl <cweyl@alumni.drew.edu>

=item *

Claes Jakobsson <claes@surfar.nu>

=item *

Clinton Gormley <clint@traveljury.com>

=item *

Craig A. Berry <craigberry@mac.com>

=item *

Craig Berry <cberry@cpan.org>

=item *

David Golden <xdg@xdg.me>

=item *

David Mitchell <davem@iabyn.com>

=item *

Dean Pearce <pearce@pythian.com>

=item *

Edward Zborowski <ed@rubensteintech.com>

=item *

Felipe Gasper <felipe@felipegasper.com>

=item *

Graham Knop <haarg@haarg.org>

=item *

Greg Kennedy <kennedy.greg@gmail.com>

=item *

James E Keenan <jkeenan@cpan.org>

=item *

James Raspass <jraspass@gmail.com>

=item *

Jeremy Mates <jmates@cpan.org>

=item *

Jess Robinson <castaway@desert-island.me.uk>

=item *

Karen Etheridge <ether@cpan.org>

=item *

Lukas Eklund <leklund@gmail.com>

=item *

Martin J. Evans <mjegh@ntlworld.com>

=item *

Martin-Louis Bright <mlbright@gmail.com>

=item *

Matthew Horsfall <wolfsage@gmail.com>

=item *

Michael R. Davis <mrdvt92@users.noreply.github.com>

=item *

Mike Doherty <doherty@cpan.org>

=item *

Nicolas Rochelemagne <rochelemagne@cpanel.net>

=item *

Olaf Alders <olaf@wundersolutions.com>

=item *

Olivier Mengué <dolmen@cpan.org>

=item *

Petr Písař <ppisar@redhat.com>

=item *

sanjay-cpu <snjkmr32@gmail.com>

=item *

Serguei Trouchelle <stro@cpan.org>

=item *

Shoichi Kaji <skaji@cpan.org>

=item *

SkyMarshal <skymarshal1729@gmail.com>

=item *

Sören Kornetzki <soeren.kornetzki@delti.com>

=item *

Steve Grazzini <steve.grazzini@grantstreet.com>

=item *

Stig Palmquist <git@stig.io>

=item *

Syohei YOSHIDA <syohex@gmail.com>

=item *

Tatsuhiko Miyagawa <miyagawa@bulknews.net>

=item *

Tom Hukins <tom@eborcom.com>

=item *

Tony Cook <tony@develop-help.com>

=item *

Xavier Guimard <yadd@debian.org>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2023 by Christian Hansen.

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

=cut
PK       ! ��?dBb  Bb    perl5/HTTP/Headers.pmnu ��6�$        package HTTP::Headers;

use strict;
use warnings;

our $VERSION = '6.26';

use Carp ();

# The $TRANSLATE_UNDERSCORE variable controls whether '_' can be used
# as a replacement for '-' in header field names.
our $TRANSLATE_UNDERSCORE = 1 unless defined $TRANSLATE_UNDERSCORE;

# "Good Practice" order of HTTP message headers:
#    - General-Headers
#    - Request-Headers
#    - Response-Headers
#    - Entity-Headers

my @general_headers = qw(
    Cache-Control Connection Date Pragma Trailer Transfer-Encoding Upgrade
    Via Warning
);

my @request_headers = qw(
    Accept Accept-Charset Accept-Encoding Accept-Language
    Authorization Expect From Host
    If-Match If-Modified-Since If-None-Match If-Range If-Unmodified-Since
    Max-Forwards Proxy-Authorization Range Referer TE User-Agent
);

my @response_headers = qw(
    Accept-Ranges Age ETag Location Proxy-Authenticate Retry-After Server
    Vary WWW-Authenticate
);

my @entity_headers = qw(
    Allow Content-Encoding Content-Language Content-Length Content-Location
    Content-MD5 Content-Range Content-Type Expires Last-Modified
);

my %entity_header = map { lc($_) => 1 } @entity_headers;

my @header_order = (
    @general_headers,
    @request_headers,
    @response_headers,
    @entity_headers,
);

# Make alternative representations of @header_order.  This is used
# for sorting and case matching.
my %header_order;
my %standard_case;

{
    my $i = 0;
    for (@header_order) {
	my $lc = lc $_;
	$header_order{$lc} = ++$i;
	$standard_case{$lc} = $_;
    }
}


sub new
{
    my($class) = shift;
    my $self = bless {}, $class;
    $self->header(@_) if @_; # set up initial headers
    $self;
}


sub header
{
    my $self = shift;
    Carp::croak('Usage: $h->header($field, ...)') unless @_;
    my(@old);
    my %seen;
    while (@_) {
	my $field = shift;
        my $op = @_ ? ($seen{lc($field)}++ ? 'PUSH' : 'SET') : 'GET';
	@old = $self->_header($field, shift, $op);
    }
    return @old if wantarray;
    return $old[0] if @old <= 1;
    join(", ", @old);
}

sub clear
{
    my $self = shift;
    %$self = ();
}


sub push_header
{
    my $self = shift;
    return $self->_header(@_, 'PUSH_H') if @_ == 2;
    while (@_) {
	$self->_header(splice(@_, 0, 2), 'PUSH_H');
    }
}


sub init_header
{
    Carp::croak('Usage: $h->init_header($field, $val)') if @_ != 3;
    shift->_header(@_, 'INIT');
}


sub remove_header
{
    my($self, @fields) = @_;
    my $field;
    my @values;
    foreach $field (@fields) {
	$field =~ tr/_/-/ if $field !~ /^:/ && $TRANSLATE_UNDERSCORE;
	my $v = delete $self->{lc $field};
	push(@values, ref($v) eq 'ARRAY' ? @$v : $v) if defined $v;
    }
    return @values;
}

sub remove_content_headers
{
    my $self = shift;
    unless (defined(wantarray)) {
	# fast branch that does not create return object
	delete @$self{grep $entity_header{$_} || /^content-/, keys %$self};
	return;
    }

    my $c = ref($self)->new;
    for my $f (grep $entity_header{$_} || /^content-/, keys %$self) {
	$c->{$f} = delete $self->{$f};
    }
    if (exists $self->{'::std_case'}) {
	$c->{'::std_case'} = $self->{'::std_case'};
    }
    $c;
}


sub _header
{
    my($self, $field, $val, $op) = @_;

    Carp::croak("Illegal field name '$field'")
        if rindex($field, ':') > 1 || !length($field);

    unless ($field =~ /^:/) {
	$field =~ tr/_/-/ if $TRANSLATE_UNDERSCORE;
	my $old = $field;
	$field = lc $field;
	unless($standard_case{$field} || $self->{'::std_case'}{$field}) {
	    # generate a %std_case entry for this field
	    $old =~ s/\b(\w)/\u$1/g;
	    $self->{'::std_case'}{$field} = $old;
	}
    }

    $op ||= defined($val) ? 'SET' : 'GET';
    if ($op eq 'PUSH_H') {
	# Like PUSH but where we don't care about the return value
	if (exists $self->{$field}) {
	    my $h = $self->{$field};
	    if (ref($h) eq 'ARRAY') {
		push(@$h, ref($val) eq "ARRAY" ? @$val : $val);
	    }
	    else {
		$self->{$field} = [$h, ref($val) eq "ARRAY" ? @$val : $val]
	    }
	    return;
	}
	$self->{$field} = $val;
	return;
    }

    my $h = $self->{$field};
    my @old = ref($h) eq 'ARRAY' ? @$h : (defined($h) ? ($h) : ());

    unless ($op eq 'GET' || ($op eq 'INIT' && @old)) {
	if (defined($val)) {
	    my @new = ($op eq 'PUSH') ? @old : ();
	    if (ref($val) ne 'ARRAY') {
		push(@new, $val);
	    }
	    else {
		push(@new, @$val);
	    }
	    $self->{$field} = @new > 1 ? \@new : $new[0];
	}
	elsif ($op ne 'PUSH') {
	    delete $self->{$field};
	}
    }
    @old;
}


sub _sorted_field_names
{
    my $self = shift;
    return [ sort {
        ($header_order{$a} || 999) <=> ($header_order{$b} || 999) ||
         $a cmp $b
    } grep !/^::/, keys %$self ];
}


sub header_field_names {
    my $self = shift;
    return map $standard_case{$_} || $self->{'::std_case'}{$_} || $_, @{ $self->_sorted_field_names },
	if wantarray;
    return grep !/^::/, keys %$self;
}


sub scan
{
    my($self, $sub) = @_;
    my $key;
    for $key (@{ $self->_sorted_field_names }) {
	my $vals = $self->{$key};
	if (ref($vals) eq 'ARRAY') {
	    my $val;
	    for $val (@$vals) {
		$sub->($standard_case{$key} || $self->{'::std_case'}{$key} || $key, $val);
	    }
	}
	else {
	    $sub->($standard_case{$key} || $self->{'::std_case'}{$key} || $key, $vals);
	}
    }
}

sub flatten {
	my($self)=@_;

	(
		map {
			my $k = $_;
			map {
				( $k => $_ )
			} $self->header($_);
		} $self->header_field_names
	);
}

sub as_string
{
    my($self, $endl) = @_;
    $endl = "\n" unless defined $endl;

    my @result = ();
    for my $key (@{ $self->_sorted_field_names }) {
	next if index($key, '_') == 0;
	my $vals = $self->{$key};
	if ( ref($vals) eq 'ARRAY' ) {
	    for my $val (@$vals) {
		$val = '' if not defined $val;
		my $field = $standard_case{$key} || $self->{'::std_case'}{$key} || $key;
		$field =~ s/^://;
		if ( index($val, "\n") >= 0 ) {
		    $val = _process_newline($val, $endl);
		}
		push @result, $field . ': ' . $val;
	    }
	}
	else {
	    $vals = '' if not defined $vals;
	    my $field = $standard_case{$key} || $self->{'::std_case'}{$key} || $key;
	    $field =~ s/^://;
	    if ( index($vals, "\n") >= 0 ) {
		$vals = _process_newline($vals, $endl);
	    }
	    push @result, $field . ': ' . $vals;
	}
    }

    join($endl, @result, '');
}

sub _process_newline {
    local $_ = shift;
    my $endl = shift;
    # must handle header values with embedded newlines with care
    s/\s+$//;        # trailing newlines and space must go
    s/\n(\x0d?\n)+/\n/g;     # no empty lines
    s/\n([^\040\t])/\n $1/g; # initial space for continuation
    s/\n/$endl/g;    # substitute with requested line ending
    $_;
}


if (eval { require Clone; 1 }) {
    *clone = \&Clone::clone;
} else {
    *clone = sub {
	my $self = shift;
	my $clone = HTTP::Headers->new;
	$self->scan(sub { $clone->push_header(@_);} );
	$clone;
    };
}


sub _date_header
{
    require HTTP::Date;
    my($self, $header, $time) = @_;
    my($old) = $self->_header($header);
    if (defined $time) {
	$self->_header($header, HTTP::Date::time2str($time));
    }
    $old =~ s/;.*// if defined($old);
    HTTP::Date::str2time($old);
}


sub date                { shift->_date_header('Date',                @_); }
sub expires             { shift->_date_header('Expires',             @_); }
sub if_modified_since   { shift->_date_header('If-Modified-Since',   @_); }
sub if_unmodified_since { shift->_date_header('If-Unmodified-Since', @_); }
sub last_modified       { shift->_date_header('Last-Modified',       @_); }

# This is used as a private LWP extension.  The Client-Date header is
# added as a timestamp to a response when it has been received.
sub client_date         { shift->_date_header('Client-Date',         @_); }

# The retry_after field is dual format (can also be a expressed as
# number of seconds from now), so we don't provide an easy way to
# access it until we have know how both these interfaces can be
# addressed.  One possibility is to return a negative value for
# relative seconds and a positive value for epoch based time values.
#sub retry_after       { shift->_date_header('Retry-After',       @_); }

sub content_type      {
    my $self = shift;
    my $ct = $self->{'content-type'};
    $self->{'content-type'} = shift if @_;
    $ct = $ct->[0] if ref($ct) eq 'ARRAY';
    return '' unless defined($ct) && length($ct);
    my @ct = split(/;\s*/, $ct, 2);
    for ($ct[0]) {
	s/\s+//g;
	$_ = lc($_);
    }
    wantarray ? @ct : $ct[0];
}

sub content_type_charset {
    my $self = shift;
    require HTTP::Headers::Util;
    my $h = $self->{'content-type'};
    $h = $h->[0] if ref($h);
    $h = "" unless defined $h;
    my @v = HTTP::Headers::Util::split_header_words($h);
    if (@v) {
	my($ct, undef, %ct_param) = @{$v[0]};
	my $charset = $ct_param{charset};
	if ($ct) {
	    $ct = lc($ct);
	    $ct =~ s/\s+//;
	}
	if ($charset) {
	    $charset = uc($charset);
	    $charset =~ s/^\s+//;  $charset =~ s/\s+\z//;
	    undef($charset) if $charset eq "";
	}
	return $ct, $charset if wantarray;
	return $charset;
    }
    return undef, undef if wantarray;
    return undef;
}

sub content_is_text {
    my $self = shift;
    return $self->content_type =~ m,^text/,;
}

sub content_is_html {
    my $self = shift;
    return $self->content_type eq 'text/html' || $self->content_is_xhtml;
}

sub content_is_xhtml {
    my $ct = shift->content_type;
    return $ct eq "application/xhtml+xml" ||
           $ct eq "application/vnd.wap.xhtml+xml";
}

sub content_is_xml {
    my $ct = shift->content_type;
    return 1 if $ct eq "text/xml";
    return 1 if $ct eq "application/xml";
    return 1 if $ct =~ /\+xml$/;
    return 0;
}

sub referer           {
    my $self = shift;
    if (@_ && $_[0] =~ /#/) {
	# Strip fragment per RFC 2616, section 14.36.
	my $uri = shift;
	if (ref($uri)) {
	    $uri = $uri->clone;
	    $uri->fragment(undef);
	}
	else {
	    $uri =~ s/\#.*//;
	}
	unshift @_, $uri;
    }
    ($self->_header('Referer', @_))[0];
}
*referrer = \&referer;  # on tchrist's request

sub title             { (shift->_header('Title',            @_))[0] }
sub content_encoding  { (shift->_header('Content-Encoding', @_))[0] }
sub content_language  { (shift->_header('Content-Language', @_))[0] }
sub content_length    { (shift->_header('Content-Length',   @_))[0] }

sub user_agent        { (shift->_header('User-Agent',       @_))[0] }
sub server            { (shift->_header('Server',           @_))[0] }

sub from              { (shift->_header('From',             @_))[0] }
sub warning           { (shift->_header('Warning',          @_))[0] }

sub www_authenticate  { (shift->_header('WWW-Authenticate', @_))[0] }
sub authorization     { (shift->_header('Authorization',    @_))[0] }

sub proxy_authenticate  { (shift->_header('Proxy-Authenticate',  @_))[0] }
sub proxy_authorization { (shift->_header('Proxy-Authorization', @_))[0] }

sub authorization_basic       { shift->_basic_auth("Authorization",       @_) }
sub proxy_authorization_basic { shift->_basic_auth("Proxy-Authorization", @_) }

sub _basic_auth {
    require MIME::Base64;
    my($self, $h, $user, $passwd) = @_;
    my($old) = $self->_header($h);
    if (defined $user) {
	Carp::croak("Basic authorization user name can't contain ':'")
	  if $user =~ /:/;
	$passwd = '' unless defined $passwd;
	$self->_header($h => 'Basic ' .
                             MIME::Base64::encode("$user:$passwd", ''));
    }
    if (defined $old && $old =~ s/^\s*Basic\s+//) {
	my $val = MIME::Base64::decode($old);
	return $val unless wantarray;
	return split(/:/, $val, 2);
    }
    return;
}


1;

=pod

=encoding UTF-8

=head1 NAME

HTTP::Headers - Class encapsulating HTTP Message headers

=head1 VERSION

version 6.26

=head1 SYNOPSIS

 require HTTP::Headers;
 $h = HTTP::Headers->new;

 $h->header('Content-Type' => 'text/plain');  # set
 $ct = $h->header('Content-Type');            # get
 $h->remove_header('Content-Type');           # delete

=head1 DESCRIPTION

The C<HTTP::Headers> class encapsulates HTTP-style message headers.
The headers consist of attribute-value pairs also called fields, which
may be repeated, and which are printed in a particular order.  The
field names are cases insensitive.

Instances of this class are usually created as member variables of the
C<HTTP::Request> and C<HTTP::Response> classes, internal to the
library.

The following methods are available:

=over 4

=item $h = HTTP::Headers->new

Constructs a new C<HTTP::Headers> object.  You might pass some initial
attribute-value pairs as parameters to the constructor.  I<E.g.>:

 $h = HTTP::Headers->new(
       Date         => 'Thu, 03 Feb 1994 00:00:00 GMT',
       Content_Type => 'text/html; version=3.2',
       Content_Base => 'http://www.perl.org/');

The constructor arguments are passed to the C<header> method which is
described below.

=item $h->clone

Returns a copy of this C<HTTP::Headers> object.

=item $h->header( $field )

=item $h->header( $field => $value )

=item $h->header( $f1 => $v1, $f2 => $v2, ... )

Get or set the value of one or more header fields.  The header field
name ($field) is not case sensitive.  To make the life easier for perl
users who wants to avoid quoting before the => operator, you can use
'_' as a replacement for '-' in header names.

The header() method accepts multiple ($field => $value) pairs, which
means that you can update several fields with a single invocation.

The $value argument may be a plain string or a reference to an array
of strings for a multi-valued field. If the $value is provided as
C<undef> then the field is removed.  If the $value is not given, then
that header field will remain unchanged. In addition to being a string,
$value may be something that stringifies.

The old value (or values) of the last of the header fields is returned.
If no such field exists C<undef> will be returned.

A multi-valued field will be returned as separate values in list
context and will be concatenated with ", " as separator in scalar
context.  The HTTP spec (RFC 2616) promises that joining multiple
values in this way will not change the semantic of a header field, but
in practice there are cases like old-style Netscape cookies (see
L<HTTP::Cookies>) where "," is used as part of the syntax of a single
field value.

Examples:

 $header->header(MIME_Version => '1.0',
		 User_Agent   => 'My-Web-Client/0.01');
 $header->header(Accept => "text/html, text/plain, image/*");
 $header->header(Accept => [qw(text/html text/plain image/*)]);
 @accepts = $header->header('Accept');  # get multiple values
 $accepts = $header->header('Accept');  # get values as a single string

=item $h->push_header( $field => $value )

=item $h->push_header( $f1 => $v1, $f2 => $v2, ... )

Add a new field value for the specified header field.  Previous values
for the same field are retained.

As for the header() method, the field name ($field) is not case
sensitive and '_' can be used as a replacement for '-'.

The $value argument may be a scalar or a reference to a list of
scalars.

 $header->push_header(Accept => 'image/jpeg');
 $header->push_header(Accept => [map "image/$_", qw(gif png tiff)]);

=item $h->init_header( $field => $value )

Set the specified header to the given value, but only if no previous
value for that field is set.

The header field name ($field) is not case sensitive and '_'
can be used as a replacement for '-'.

The $value argument may be a scalar or a reference to a list of
scalars.

=item $h->remove_header( $field, ... )

This function removes the header fields with the specified names.

The header field names ($field) are not case sensitive and '_'
can be used as a replacement for '-'.

The return value is the values of the fields removed.  In scalar
context the number of fields removed is returned.

Note that if you pass in multiple field names then it is generally not
possible to tell which of the returned values belonged to which field.

=item $h->remove_content_headers

This will remove all the header fields used to describe the content of
a message.  All header field names prefixed with C<Content-> fall
into this category, as well as C<Allow>, C<Expires> and
C<Last-Modified>.  RFC 2616 denotes these fields as I<Entity Header
Fields>.

The return value is a new C<HTTP::Headers> object that contains the
removed headers only.

=item $h->clear

This will remove all header fields.

=item $h->header_field_names

Returns the list of distinct names for the fields present in the
header.  The field names have case as suggested by HTTP spec, and the
names are returned in the recommended "Good Practice" order.

In scalar context return the number of distinct field names.

=item $h->scan( \&process_header_field )

Apply a subroutine to each header field in turn.  The callback routine
is called with two parameters; the name of the field and a single
value (a string).  If a header field is multi-valued, then the
routine is called once for each value.  The field name passed to the
callback routine has case as suggested by HTTP spec, and the headers
will be visited in the recommended "Good Practice" order.

Any return values of the callback routine are ignored.  The loop can
be broken by raising an exception (C<die>), but the caller of scan()
would have to trap the exception itself.

=item $h->flatten()

Returns the list of pairs of keys and values.

=item $h->as_string

=item $h->as_string( $eol )

Return the header fields as a formatted MIME header.  Since it
internally uses the C<scan> method to build the string, the result
will use case as suggested by HTTP spec, and it will follow
recommended "Good Practice" of ordering the header fields.  Long header
values are not folded.

The optional $eol parameter specifies the line ending sequence to
use.  The default is "\n".  Embedded "\n" characters in header field
values will be substituted with this line ending sequence.

=back

=head1 CONVENIENCE METHODS

The most frequently used headers can also be accessed through the
following convenience methods.  Most of these methods can both be used to read
and to set the value of a header.  The header value is set if you pass
an argument to the method.  The old header value is always returned.
If the given header did not exist then C<undef> is returned.

Methods that deal with dates/times always convert their value to system
time (seconds since Jan 1, 1970) and they also expect this kind of
value when the header value is set.

=over 4

=item $h->date

This header represents the date and time at which the message was
originated. I<E.g.>:

  $h->date(time);  # set current date

=item $h->expires

This header gives the date and time after which the entity should be
considered stale.

=item $h->if_modified_since

=item $h->if_unmodified_since

These header fields are used to make a request conditional.  If the requested
resource has (or has not) been modified since the time specified in this field,
then the server will return a C<304 Not Modified> response instead of
the document itself.

=item $h->last_modified

This header indicates the date and time at which the resource was last
modified. I<E.g.>:

  # check if document is more than 1 hour old
  if (my $last_mod = $h->last_modified) {
      if ($last_mod < time - 60*60) {
	  ...
      }
  }

=item $h->content_type

The Content-Type header field indicates the media type of the message
content. I<E.g.>:

  $h->content_type('text/html');

The value returned will be converted to lower case, and potential
parameters will be chopped off and returned as a separate value if in
an array context.  If there is no such header field, then the empty
string is returned.  This makes it safe to do the following:

  if ($h->content_type eq 'text/html') {
     # we enter this place even if the real header value happens to
     # be 'TEXT/HTML; version=3.0'
     ...
  }

=item $h->content_type_charset

Returns the upper-cased charset specified in the Content-Type header.  In list
context return the lower-cased bare content type followed by the upper-cased
charset.  Both values will be C<undef> if not specified in the header.

=item $h->content_is_text

Returns TRUE if the Content-Type header field indicate that the
content is textual.

=item $h->content_is_html

Returns TRUE if the Content-Type header field indicate that the
content is some kind of HTML (including XHTML).  This method can't be
used to set Content-Type.

=item $h->content_is_xhtml

Returns TRUE if the Content-Type header field indicate that the
content is XHTML.  This method can't be used to set Content-Type.

=item $h->content_is_xml

Returns TRUE if the Content-Type header field indicate that the
content is XML.  This method can't be used to set Content-Type.

=item $h->content_encoding

The Content-Encoding header field is used as a modifier to the
media type.  When present, its value indicates what additional
encoding mechanism has been applied to the resource.

=item $h->content_length

A decimal number indicating the size in bytes of the message content.

=item $h->content_language

The natural language(s) of the intended audience for the message
content.  The value is one or more language tags as defined by RFC
1766.  Eg. "no" for some kind of Norwegian and "en-US" for English the
way it is written in the US.

=item $h->title

The title of the document.  In libwww-perl this header will be
initialized automatically from the E<lt>TITLE>...E<lt>/TITLE> element
of HTML documents.  I<This header is no longer part of the HTTP
standard.>

=item $h->user_agent

This header field is used in request messages and contains information
about the user agent originating the request.  I<E.g.>:

  $h->user_agent('Mozilla/5.0 (compatible; MSIE 7.0; Windows NT 6.0)');

=item $h->server

The server header field contains information about the software being
used by the originating server program handling the request.

=item $h->from

This header should contain an Internet e-mail address for the human
user who controls the requesting user agent.  The address should be
machine-usable, as defined by RFC822.  E.g.:

  $h->from('King Kong <king@kong.com>');

I<This header is no longer part of the HTTP standard.>

=item $h->referer

Used to specify the address (URI) of the document from which the
requested resource address was obtained.

The "Free On-line Dictionary of Computing" as this to say about the
word I<referer>:

     <World-Wide Web> A misspelling of "referrer" which
     somehow made it into the {HTTP} standard.  A given {web
     page}'s referer (sic) is the {URL} of whatever web page
     contains the link that the user followed to the current
     page.  Most browsers pass this information as part of a
     request.

     (1998-10-19)

By popular demand C<referrer> exists as an alias for this method so you
can avoid this misspelling in your programs and still send the right
thing on the wire.

When setting the referrer, this method removes the fragment from the
given URI if it is present, as mandated by RFC2616.  Note that
the removal does I<not> happen automatically if using the header(),
push_header() or init_header() methods to set the referrer.

=item $h->www_authenticate

This header must be included as part of a C<401 Unauthorized> response.
The field value consist of a challenge that indicates the
authentication scheme and parameters applicable to the requested URI.

=item $h->proxy_authenticate

This header must be included in a C<407 Proxy Authentication Required>
response.

=item $h->authorization

=item $h->proxy_authorization

A user agent that wishes to authenticate itself with a server or a
proxy, may do so by including these headers.

=item $h->authorization_basic

This method is used to get or set an authorization header that use the
"Basic Authentication Scheme".  In array context it will return two
values; the user name and the password.  In scalar context it will
return I<"uname:password"> as a single string value.

When used to set the header value, it expects two arguments.  I<E.g.>:

  $h->authorization_basic($uname, $password);

The method will croak if the $uname contains a colon ':'.

=item $h->proxy_authorization_basic

Same as authorization_basic() but will set the "Proxy-Authorization"
header instead.

=back

=head1 NON-CANONICALIZED FIELD NAMES

The header field name spelling is normally canonicalized including the
'_' to '-' translation.  There are some application where this is not
appropriate.  Prefixing field names with ':' allow you to force a
specific spelling.  For example if you really want a header field name
to show up as C<foo_bar> instead of "Foo-Bar", you might set it like
this:

  $h->header(":foo_bar" => 1);

These field names are returned with the ':' intact for
$h->header_field_names and the $h->scan callback, but the colons do
not show in $h->as_string.

=head1 AUTHOR

Gisle Aas <gisle@activestate.com>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 1994 by Gisle Aas.

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

=cut

__END__


#ABSTRACT: Class encapsulating HTTP Message headers

PK       ! 	���� ��   perl5/Expect.pmnu �7��m        # -*-cperl-*-
# This module is copyrighted as per the usual perl legalese:
# Copyright (c) 1997 Austin Schutz.
# expect() interface & functionality enhancements (c) 1999 Roland Giersig.
#
# All rights reserved. This program is free software; you can
# redistribute it and/or modify it under the same terms as Perl
# itself.
#
# Don't blame/flame me if you bust your stuff.
# Austin Schutz <ASchutz@users.sourceforge.net>
#
# This module now is maintained by
# Dave Jacoby <jacoby@cpan.org>
#

use 5.006;

package Expect;
use strict;
use warnings;

use IO::Pty 1.11; # We need make_slave_controlling_terminal()
use IO::Tty;

use POSIX qw(:sys_wait_h :unistd_h); # For WNOHANG and isatty
use Fcntl qw(:DEFAULT);              # For checking file handle settings.
use Carp qw(cluck croak carp confess);
use IO::Handle ();
use Exporter   qw(import);
use Errno;
use Scalar::Util qw/ looks_like_number /;

# This is necessary to make routines within Expect work.

@Expect::ISA    = qw(IO::Pty);
@Expect::EXPORT = qw(expect exp_continue exp_continue_timeout);

BEGIN {
	$Expect::VERSION = '1.38';

	# These are defaults which may be changed per object, or set as
	# the user wishes.
	# This will be unset, since the default behavior differs between
	# spawned processes and initialized filehandles.
	#  $Expect::Log_Stdout = 1;
	$Expect::Log_Group          = 1;
	$Expect::Debug              = 0;
	$Expect::Exp_Max_Accum      = 0; # unlimited
	$Expect::Exp_Internal       = 0;
	$Expect::IgnoreEintr        = 0;
	$Expect::Manual_Stty        = 0;
	$Expect::Multiline_Matching = 1;
	$Expect::Do_Soft_Close      = 0;
	@Expect::Before_List        = ();
	@Expect::After_List         = ();
	%Expect::Spawned_PIDs       = ();
}

sub version {
	my ($version) = @_;

	warn "Version $version is later than $Expect::VERSION. It may not be supported"
		if ( defined($version) && ( $version > $Expect::VERSION ) );

	die "Versions before 1.03 are not supported in this release"
		if ( ( defined($version) ) && ( $version < 1.03 ) );
	return $Expect::VERSION;
}

sub new {
	my ($class, @args) = @_;

	$class = ref($class) if ref($class); # so we can be called as $exp->new()

	# Create the pty which we will use to pass process info.
	my ($self) = IO::Pty->new;
	die "$class: Could not assign a pty" unless $self;
	bless $self => $class;
	$self->autoflush(1);

	# This is defined here since the default is different for
	# initialized handles as opposed to spawned processes.
	${*$self}{exp_Log_Stdout} = 1;
	$self->_init_vars();

	if (@args) {

		# we got add'l parms, so pass them to spawn
		return $self->spawn(@args);
	}
	return $self;
}

sub timeout {
    my $self = shift;
    ${*$self}{expect_timeout} = shift if @_;
    return ${*$self}{expect_timeout};
}

sub spawn {
	my ($class, @cmd) = @_;
	# spawn is passed command line args.

	my $self;

	if ( ref($class) ) {
		$self = $class;
	} else {
		$self = $class->new();
	}

	croak "Cannot reuse an object with an already spawned command"
		if exists ${*$self}{"exp_Command"};
	${*$self}{"exp_Command"} = \@cmd;

	# set up pipe to detect childs exec error
	pipe( FROM_CHILD,  TO_PARENT ) or die "Cannot open pipe: $!";
	pipe( FROM_PARENT, TO_CHILD )  or die "Cannot open pipe: $!";
	TO_PARENT->autoflush(1);
	TO_CHILD->autoflush(1);
	eval { fcntl( TO_PARENT, Fcntl::F_SETFD, Fcntl::FD_CLOEXEC ); };

	my $pid = fork;

	unless ( defined($pid) ) {
		warn "Cannot fork: $!" if $^W;
		return;
	}

	if ($pid) {

		# parent
		my $errno;
		${*$self}{exp_Pid} = $pid;
		close TO_PARENT;
		close FROM_PARENT;
		$self->close_slave();
		$self->set_raw() if $self->raw_pty and isatty($self);
		close TO_CHILD; # so child gets EOF and can go ahead

		# now wait for child exec (eof due to close-on-exit) or exec error
		my $errstatus = sysread( FROM_CHILD, $errno, 256 );
		die "Cannot sync with child: $!" if not defined $errstatus;
		close FROM_CHILD;
		if ($errstatus) {
			$! = $errno + 0;
			warn "Cannot exec(@cmd): $!\n" if $^W;
			return;
		}
	} else {

		# child
		close FROM_CHILD;
		close TO_CHILD;

		$self->make_slave_controlling_terminal();
		my $slv = $self->slave()
			or die "Cannot get slave: $!";

		$slv->set_raw() if $self->raw_pty;
		close($self);

		# wait for parent before we detach
		my $buffer;
		my $errstatus = sysread( FROM_PARENT, $buffer, 256 );
		die "Cannot sync with parent: $!" if not defined $errstatus;
		close FROM_PARENT;

		close(STDIN);
		open( STDIN, "<&" . $slv->fileno() )
			or die "Couldn't reopen STDIN for reading, $!\n";
		close(STDOUT);
		open( STDOUT, ">&" . $slv->fileno() )
			or die "Couldn't reopen STDOUT for writing, $!\n";
		close(STDERR);
		open( STDERR, ">&" . $slv->fileno() )
			or die "Couldn't reopen STDERR for writing, $!\n";

		{ exec(@cmd) };
		print TO_PARENT $! + 0;
		die "Cannot exec(@cmd): $!\n";
	}

	# This is sort of for code compatibility, and to make debugging a little
	# easier. By code compatibility I mean that previously the process's
	# handle was referenced by $process{Pty_Handle} instead of just $process.
	# This is almost like 'naming' the handle to the process.
	# I think this also reflects Tcl Expect-like behavior.
	${*$self}{exp_Pty_Handle} = "spawn id(" . $self->fileno() . ")";
	if ( ( ${*$self}{"exp_Debug"} ) or ( ${*$self}{"exp_Exp_Internal"} ) ) {
		cluck(
			"Spawned '@cmd'\r\n",
			"\t${*$self}{exp_Pty_Handle}\r\n",
			"\tPid: ${*$self}{exp_Pid}\r\n",
			"\tTty: " . $self->SUPER::ttyname() . "\r\n",
		);
	}
	$Expect::Spawned_PIDs{ ${*$self}{exp_Pid} } = undef;
	return $self;
}

sub exp_init {
	my ($class, $self) = @_;

	# take a filehandle, for use later with expect() or interconnect() .
	# All the functions are written for reading from a tty, so if the naming
	# scheme looks odd, that's why.
	bless $self, $class;
	croak "exp_init not passed a file object, stopped"
		unless defined( $self->fileno() );
	$self->autoflush(1);

	# Define standard variables.. debug states, etc.
	$self->_init_vars();

	# Turn of logging. By default we don't want crap from a file to get spewed
	# on screen as we read it.
	${*$self}{exp_Log_Stdout} = 0;
	${*$self}{exp_Pty_Handle} = "handle id(" . $self->fileno() . ")";
	${*$self}{exp_Pty_Handle} = "STDIN" if $self->fileno() == fileno(STDIN);
	print STDERR "Initialized ${*$self}{exp_Pty_Handle}.'\r\n"
		if ${*$self}{"exp_Debug"};
	return $self;
}

# make an alias
*init = \&exp_init;

######################################################################
# We're happy OOP people. No direct access to stuff.
# For standard read-writeable parameters, we define some autoload magic...
my %Writeable_Vars = (
	debug                        => 'exp_Debug',
	exp_internal                 => 'exp_Exp_Internal',
	do_soft_close                => 'exp_Do_Soft_Close',
	max_accum                    => 'exp_Max_Accum',
	match_max                    => 'exp_Max_Accum',
	notransfer                   => 'exp_NoTransfer',
	log_stdout                   => 'exp_Log_Stdout',
	log_user                     => 'exp_Log_Stdout',
	log_group                    => 'exp_Log_Group',
	manual_stty                  => 'exp_Manual_Stty',
	restart_timeout_upon_receive => 'exp_Continue',
	raw_pty                      => 'exp_Raw_Pty',
);
my %Readable_Vars = (
	pid              => 'exp_Pid',
	exp_pid          => 'exp_Pid',
	exp_match_number => 'exp_Match_Number',
	match_number     => 'exp_Match_Number',
	exp_error        => 'exp_Error',
	error            => 'exp_Error',
	exp_command      => 'exp_Command',
	command          => 'exp_Command',
	exp_match        => 'exp_Match',
	match            => 'exp_Match',
	exp_matchlist    => 'exp_Matchlist',
	matchlist        => 'exp_Matchlist',
	exp_before       => 'exp_Before',
	before           => 'exp_Before',
	exp_after        => 'exp_After',
	after            => 'exp_After',
	exp_exitstatus   => 'exp_Exit',
	exitstatus       => 'exp_Exit',
	exp_pty_handle   => 'exp_Pty_Handle',
	pty_handle       => 'exp_Pty_Handle',
	exp_logfile      => 'exp_Log_File',
	logfile          => 'exp_Log_File',
	%Writeable_Vars,
);

sub AUTOLOAD {
	my ($self, @args) = @_;

	my $type = ref($self)
		or croak "$self is not an object";

	use vars qw($AUTOLOAD);
	my $name = $AUTOLOAD;
	$name =~ s/.*:://; # strip fully-qualified portion

	unless ( exists $Readable_Vars{$name} ) {
		croak "ERROR: cannot find method `$name' in class $type";
	}
	my $varname = $Readable_Vars{$name};
	my $tmp;
	$tmp = ${*$self}{$varname} if exists ${*$self}{$varname};

	if (@args) {
		if ( exists $Writeable_Vars{$name} ) {
			my $ref = ref($tmp);
			if ( $ref eq 'ARRAY' ) {
				${*$self}{$varname} = [@args];
			} elsif ( $ref eq 'HASH' ) {
				${*$self}{$varname} = {@args};
			} else {
				${*$self}{$varname} = shift @args;
			}
		} else {
			carp "Trying to set read-only variable `$name'"
				if $^W;
		}
	}

	my $ref = ref($tmp);
	return ( wantarray ? @{$tmp} : $tmp ) if ( $ref eq 'ARRAY' );
	return ( wantarray ? %{$tmp} : $tmp ) if ( $ref eq 'HASH' );
	return $tmp;
}

######################################################################

sub set_seq {
	my ( $self, $escape_sequence, $function, $params, @args ) = @_;

	# Set an escape sequence/function combo for a read handle for interconnect.
	# Ex: $read_handle->set_seq('',\&function,\@parameters);
	${ ${*$self}{exp_Function} }{$escape_sequence} = $function;
	if ( ( !defined($function) ) || ( $function eq 'undef' ) ) {
		${ ${*$self}{exp_Function} }{$escape_sequence} = \&_undef;
	}
	${ ${*$self}{exp_Parameters} }{$escape_sequence} = $params;

	# This'll be a joy to execute. :)
	if ( ${*$self}{"exp_Debug"} ) {
		print STDERR "Escape seq. '" . $escape_sequence;
		print STDERR "' function for ${*$self}{exp_Pty_Handle} set to '";
		print STDERR ${ ${*$self}{exp_Function} }{$escape_sequence};
		print STDERR "(" . join( ',', @args ) . ")'\r\n";
	}
}

sub set_group {
	my ($self, @args) = @_;

	# Make sure we can read from the read handle
	if ( !defined( $args[0] ) ) {
		if ( defined( ${*$self}{exp_Listen_Group} ) ) {
			return @{ ${*$self}{exp_Listen_Group} };
		} else {

			# Refrain from referencing an undef
			return;
		}
	}
	@{ ${*$self}{exp_Listen_Group} } = ();
	if ( $self->_get_mode() !~ 'r' ) {
		warn(
			"Attempting to set a handle group on ${*$self}{exp_Pty_Handle}, ",
			"a non-readable handle!\r\n"
		);
	}
	while ( my $write_handle = shift @args ) {
		if ( $write_handle->_get_mode() !~ 'w' ) {
			warn(
				"Attempting to set a non-writeable listen handle ",
				"${*$write_handle}{exp_Pty_handle} for ",
				"${*$self}{exp_Pty_Handle}!\r\n"
			);
		}
		push( @{ ${*$self}{exp_Listen_Group} }, $write_handle );
	}
}

sub log_file {
	my ($self, $file, $mode)  = @_;
	$mode ||= "a";

	return ( ${*$self}{exp_Log_File} )
		if @_ < 2; # we got no param, return filehandle
	# $e->log_file(undef) is an acceptable call hence we need to check the number of parameters here

	if ( ${*$self}{exp_Log_File} and ref( ${*$self}{exp_Log_File} ) ne 'CODE' ) {
		close( ${*$self}{exp_Log_File} );
	}
	${*$self}{exp_Log_File} = undef;
	return if ( not $file );
	my $fh = $file;
	if ( not ref($file) ) {

		# it's a filename
		$fh = IO::File->new( $file, $mode )
			or croak "Cannot open logfile $file: $!";
	}
	if ( ref($file) ne 'CODE' ) {
		croak "Given logfile doesn't have a 'print' method"
			if not $fh->can("print");
		$fh->autoflush(1); # so logfile is up to date
	}

	${*$self}{exp_Log_File} = $fh;

	return $fh;
}

# I'm going to leave this here in case I might need to change something.
# Previously this was calling `stty`, in a most bastardized manner.
sub exp_stty {
	my ($self) = shift;
	my ($mode) = "@_";

	return unless defined $mode;
	if ( not defined $INC{"IO/Stty.pm"} ) {
		carp "IO::Stty not installed, cannot change mode";
		return;
	}

	if ( ${*$self}{"exp_Debug"} ) {
		print STDERR "Setting ${*$self}{exp_Pty_Handle} to tty mode '$mode'\r\n";
	}
	unless ( POSIX::isatty($self) ) {
		if ( ${*$self}{"exp_Debug"} or $^W ) {
			warn "${*$self}{exp_Pty_Handle} is not a tty. Not changing mode";
		}
		return ''; # No undef to avoid warnings elsewhere.
	}
	IO::Stty::stty( $self, split( /\s/, $mode ) );
}

*stty = \&exp_stty;

# If we want to clear the buffer. Otherwise Accum will grow during send_slow
# etc. and contain the remainder after matches.
sub clear_accum {
	my ($self) = @_;
	return $self->set_accum('');
}

sub set_accum {
	my ($self, $accum) = @_;

	my $old_accum = ${*$self}{exp_Accum};
	${*$self}{exp_Accum} = $accum;

	# return the contents of the accumulator.
	return $old_accum;
}
sub get_accum {
	my ($self) = @_;
	return ${*$self}{exp_Accum};
}

######################################################################
# define constants for pattern subs
sub exp_continue         {"exp_continue"}
sub exp_continue_timeout {"exp_continue_timeout"}

######################################################################
# Expect on multiple objects at once.
#
# Call as Expect::expect($timeout, -i => \@exp_list, @patternlist,
#                       -i => $exp, @pattern_list, ...);
# or $exp->expect($timeout, @patternlist, -i => \@exp_list, @patternlist,
#                 -i => $exp, @pattern_list, ...);
#
# Patterns are arrays that consist of
#   [ $pattern_type, $pattern, $sub, @subparms ]
#
#   Optional $pattern_type is '-re' (RegExp, default) or '-ex' (exact);
#
#   $sub is optional CODE ref, which is called as &{$sub}($exp, @subparms)
#     if pattern matched; may return exp_continue or exp_continue_timeout.
#
# Old-style syntax (pure pattern strings with optional type)  also supported.
#

sub expect {
	my $self;

	print STDERR ("expect(@_) called...\n") if $Expect::Debug;
	if ( defined( $_[0] ) ) {
		if ( ref( $_[0] ) and $_[0]->isa('Expect') ) {
			$self = shift;
		} elsif ( $_[0] eq 'Expect' ) {
			shift; # or as Expect->expect
		}
	}
	croak "expect(): not enough arguments, should be expect(timeout, [patterns...])"
		if @_ < 1;
	my $timeout;
	if ( looks_like_number($_[0]) or not defined $_[0] ) {
		$timeout = shift;
		}
	else {
		$timeout = $self->timeout; 
		}
	my $timeout_hook = undef;

	my @object_list;
	my %patterns;

	my @pattern_list;
	my @timeout_list;
	my $curr_list;

	if ($self) {
		$curr_list = [$self];
	} else {

		# called directly, so first parameter must be '-i' to establish
		# object list.
		$curr_list = [];
		croak
			"expect(): ERROR: if called directly (not as \$obj->expect(...), but as Expect::expect(...), first parameter MUST be '-i' to set an object (list) for the patterns to work on."
			if ( $_[0] ne '-i' );
	}

	# Let's make a list of patterns wanting to be evaled as regexps.
	my $parm;
	my $parm_nr = 1;
	while ( defined( $parm = shift ) ) {
		print STDERR ("expect(): handling param '$parm'...\n")
			if $Expect::Debug;
		if ( ref($parm) ) {
			if ( ref($parm) eq 'Regexp' ) {
                push @pattern_list, [ $parm_nr, '-re', $parm, undef ];
            }
			elsif ( ref($parm) eq 'ARRAY' ) {
			# if ( ref($parm) eq 'ARRAY' ) {
				my $err = _add_patterns_to_list(
					\@pattern_list, \@timeout_list,
					$parm_nr,       $parm
				);
				carp(
					"expect(): Warning: multiple `timeout' patterns (",
					scalar(@timeout_list), ").\r\n"
				) if @timeout_list > 1;
				$timeout_hook = $timeout_list[-1] if $timeout_list[-1];
				croak $err if $err;
				$parm_nr++;
			} else {
				croak("expect(): Unknown pattern ref $parm");
			}
		} else {

			# not a ref, is an option or raw pattern
			if ( substr( $parm, 0, 1 ) eq '-' ) {

				# it's an option
				print STDERR ("expect(): handling option '$parm'...\n")
					if $Expect::Debug;
				if ( $parm eq '-i' ) {

					# first add collected patterns to object list
					if ( scalar(@$curr_list) ) {
						push @object_list, $curr_list
							if not exists $patterns{"$curr_list"};
						push @{ $patterns{"$curr_list"} }, @pattern_list;
						@pattern_list = ();
					}

					# now put parm(s) into current object list
					if ( ref( $_[0] ) eq 'ARRAY' ) {
						$curr_list = shift;
					} else {
						$curr_list = [shift];
					}
				} elsif ( $parm eq '-re'
					or $parm eq '-ex' )
				{
					if ( ref( $_[1] ) eq 'CODE' ) {
						push @pattern_list, [ $parm_nr, $parm, shift, shift ];
					} else {
						push @pattern_list, [ $parm_nr, $parm, shift, undef ];
					}
					$parm_nr++;
				} else {
					croak("Unknown option $parm");
				}
			} else {

				# a plain pattern, check if it is followed by a CODE ref
				if ( ref( $_[0] ) eq 'CODE' ) {
					if ( $parm eq 'timeout' ) {
						push @timeout_list, shift;
						carp(
							"expect(): Warning: multiple `timeout' patterns (",
							scalar(@timeout_list),
							").\r\n"
						) if @timeout_list > 1;
						$timeout_hook = $timeout_list[-1] if $timeout_list[-1];
					} elsif ( $parm eq 'eof' ) {
						push @pattern_list, [ $parm_nr, "-$parm", undef, shift ];
					} else {
						push @pattern_list, [ $parm_nr, '-ex', $parm, shift ];
					}
				} else {
					print STDERR ("expect(): exact match '$parm'...\n")
						if $Expect::Debug;
					push @pattern_list, [ $parm_nr, '-ex', $parm, undef ];
				}
				$parm_nr++;
			}
		}
	}

	# add rest of collected patterns to object list
	carp "expect(): Empty object list" unless $curr_list;
	push @object_list, $curr_list if not exists $patterns{"$curr_list"};
	push @{ $patterns{"$curr_list"} }, @pattern_list;

	my $debug    = $self ? ${*$self}{exp_Debug}        : $Expect::Debug;
	my $internal = $self ? ${*$self}{exp_Exp_Internal} : $Expect::Exp_Internal;

	# now start matching...

	if (@Expect::Before_List) {
		print STDERR ("Starting BEFORE pattern matching...\r\n")
			if ( $debug or $internal );
		_multi_expect( 0, undef, @Expect::Before_List );
	}

	cluck("Starting EXPECT pattern matching...\r\n")
		if ( $debug or $internal );
	my @ret;
	@ret = _multi_expect(
		$timeout, $timeout_hook,
		map { [ $_, @{ $patterns{"$_"} } ] } @object_list
	);

	if (@Expect::After_List) {
		print STDERR ("Starting AFTER pattern matching...\r\n")
			if ( $debug or $internal );
		_multi_expect( 0, undef, @Expect::After_List );
	}

	return wantarray ? @ret : $ret[0];
}

######################################################################
# the real workhorse
#
sub _multi_expect {
	my ($timeout, $timeout_hook, @params) = @_;

	if ($timeout_hook) {
		croak "Unknown timeout_hook type $timeout_hook"
			unless ( ref($timeout_hook) eq 'CODE'
			or ref($timeout_hook) eq 'ARRAY' );
	}

	foreach my $pat (@params) {
		my @patterns = @{$pat}[ 1 .. $#{$pat} ];
		foreach my $exp ( @{ $pat->[0] } ) {
			${*$exp}{exp_New_Data} = 1; # first round we always try to match
			if ( exists ${*$exp}{"exp_Max_Accum"}
				and ${*$exp}{"exp_Max_Accum"} )
			{
				${*$exp}{exp_Accum} = $exp->_trim_length(
					${*$exp}{exp_Accum},
					${*$exp}{exp_Max_Accum}
				);
			}
			print STDERR (
				"${*$exp}{exp_Pty_Handle}: beginning expect.\r\n",
				"\tTimeout: ",
				( defined($timeout) ? $timeout : "unlimited" ),
				" seconds.\r\n",
				"\tCurrent time: " . localtime() . "\r\n",
			) if $Expect::Debug;

			# What are we expecting? What do you expect? :-)
			if ( ${*$exp}{exp_Exp_Internal} ) {
				print STDERR "${*$exp}{exp_Pty_Handle}: list of patterns:\r\n";
				foreach my $pattern (@patterns) {
					print STDERR (
						'  ',
						defined( $pattern->[0] )
						? '#' . $pattern->[0] . ': '
						: '',
						$pattern->[1],
						" `",
						_make_readable( $pattern->[2] ),
						"'\r\n"
					);
				}
				print STDERR "\r\n";
			}
		}
	}

	my $successful_pattern;
	my $exp_matched;
	my $err;
	my $before;
	my $after;
	my $match;
	my @matchlist;

	# Set the last loop time to now for time comparisons at end of loop.
	my $start_loop_time = time();
	my $exp_cont        = 1;

	READLOOP:
	while ($exp_cont) {
		$exp_cont = 1;
		$err      = "";
		my $rmask     = '';
		my $time_left = undef;
		if ( defined $timeout ) {
			$time_left = $timeout - ( time() - $start_loop_time );
			$time_left = 0 if $time_left < 0;
		}

		$exp_matched = undef;

		# Test for a match first so we can test the current Accum w/out
		# worrying about an EOF.

		foreach my $pat (@params) {
			my @patterns = @{$pat}[ 1 .. $#{$pat} ];
			foreach my $exp ( @{ $pat->[0] } ) {

				# build mask for select in next section...
				my $fn = $exp->fileno();
				vec( $rmask, $fn, 1 ) = 1 if defined $fn;

				next unless ${*$exp}{exp_New_Data};

				# clear error status
				${*$exp}{exp_Error} = undef;
				${*$exp}{exp_After}        = undef;
				${*$exp}{exp_Match_Number} = undef;
				${*$exp}{exp_Match}        = undef;

				# This could be huge. We should attempt to do something
				# about this.  Because the output is used for debugging
				# I'm of the opinion that showing smaller amounts if the
				# total is huge should be ok.
				# Thus the 'trim_length'
				print STDERR (
					"\r\n${*$exp}{exp_Pty_Handle}: Does `",
					$exp->_trim_length( _make_readable( ${*$exp}{exp_Accum} ) ),
					"'\r\nmatch:\r\n"
				) if ${*$exp}{exp_Exp_Internal};

				# we don't keep the parameter number anymore
				# (clashes with before & after), instead the parameter number is
				# stored inside the pattern; we keep the pattern ref
				# and look up the number later.
				foreach my $pattern (@patterns) {
					print STDERR (
						"  pattern",
						defined( $pattern->[0] ) ? ' #' . $pattern->[0] : '',
						": ",
						$pattern->[1],
						" `",
						_make_readable( $pattern->[2] ),
						"'? "
					) if ( ${*$exp}{exp_Exp_Internal} );

					# Matching exactly
					if ( $pattern->[1] eq '-ex' ) {
						my $match_index =
							index( ${*$exp}{exp_Accum}, $pattern->[2] );

						# We matched if $match_index > -1
						if ( $match_index > -1 ) {
							$before =
								substr( ${*$exp}{exp_Accum}, 0, $match_index );
							$match = substr(
								${*$exp}{exp_Accum},
								$match_index, length( $pattern->[2] )
							);
							$after = substr(
								${*$exp}{exp_Accum},
								$match_index + length( $pattern->[2] )
							);
							${*$exp}{exp_Before}       = $before;
							${*$exp}{exp_Match}        = $match;
							${*$exp}{exp_After}        = $after;
							${*$exp}{exp_Match_Number} = $pattern->[0];
							$exp_matched = $exp;
						}
					} elsif ( $pattern->[1] eq '-re' ) {

						if ($Expect::Multiline_Matching) {
							@matchlist =
								( ${*$exp}{exp_Accum}  =~ m/($pattern->[2])/m);
						} else {
							@matchlist =
								( ${*$exp}{exp_Accum} =~ m/($pattern->[2])/);
						}
						if (@matchlist) {

							# Matching regexp
							$match  = shift @matchlist;
							my $start = index ${*$exp}{exp_Accum}, $match;
							die 'The match could not be found' if $start == -1;
							$before = substr ${*$exp}{exp_Accum}, 0, $start;
							$after = substr ${*$exp}{exp_Accum}, $start + length($match);

							${*$exp}{exp_Before} = $before;
							${*$exp}{exp_Match}  = $match;
							${*$exp}{exp_After}  = $after;
							#pop @matchlist; # remove kludged empty bracket from end
							@{ ${*$exp}{exp_Matchlist} } = @matchlist;
							${*$exp}{exp_Match_Number} = $pattern->[0];
							$exp_matched = $exp;
						}
					} else {

						# 'timeout' or 'eof'
					}

					if ($exp_matched) {
						${*$exp}{exp_Accum} = $after
							unless ${*$exp}{exp_NoTransfer};
						print STDERR "YES!!\r\n"
							if ${*$exp}{exp_Exp_Internal};
						print STDERR (
							"    Before match string: `",
							$exp->_trim_length( _make_readable( ($before) ) ),
							"'\r\n",
							"    Match string: `",
							_make_readable($match),
							"'\r\n",
							"    After match string: `",
							$exp->_trim_length( _make_readable( ($after) ) ),
							"'\r\n",
							"    Matchlist: (",
							join(
								",  ",
								map { "`" . $exp->_trim_length( _make_readable( ($_) ) ) . "'" } @matchlist,
							),
							")\r\n",
						) if ( ${*$exp}{exp_Exp_Internal} );

						# call hook function if defined
						if ( $pattern->[3] ) {
							print STDERR (
								"Calling hook $pattern->[3]...\r\n",
								)
								if ( ${*$exp}{exp_Exp_Internal}
								or $Expect::Debug );
							if ( $#{$pattern} > 3 ) {

								# call with parameters if given
								$exp_cont = &{ $pattern->[3] }( $exp, @{$pattern}[ 4 .. $#{$pattern} ] );
							} else {
								$exp_cont = &{ $pattern->[3] }($exp);
							}
						}
						if ( $exp_cont and $exp_cont eq exp_continue ) {
							print STDERR ("Continuing expect, restarting timeout...\r\n")
								if ( ${*$exp}{exp_Exp_Internal}
								or $Expect::Debug );
							$start_loop_time = time(); # restart timeout count
							next READLOOP;
						} elsif ( $exp_cont
							and $exp_cont eq exp_continue_timeout )
						{
							print STDERR ("Continuing expect...\r\n")
								if ( ${*$exp}{exp_Exp_Internal}
								or $Expect::Debug );
							next READLOOP;
						}
						last READLOOP;
					}
					print STDERR "No.\r\n" if ${*$exp}{exp_Exp_Internal};
				}
				print STDERR "\r\n" if ${*$exp}{exp_Exp_Internal};

				# don't have to match again until we get new data
				${*$exp}{exp_New_Data} = 0;
			}
		} # End of matching section

		# No match, let's see what is pending on the filehandles...
		print STDERR (
			"Waiting for new data (",
			defined($time_left) ? $time_left : 'unlimited',
			" seconds)...\r\n",
		) if ( $Expect::Exp_Internal or $Expect::Debug );
		my $nfound;
		SELECT: {
			$nfound = select( $rmask, undef, undef, $time_left );
			if ( $nfound < 0 ) {
				if ( $!{EINTR} and $Expect::IgnoreEintr ) {
					print STDERR ("ignoring EINTR, restarting select()...\r\n")
						if ( $Expect::Exp_Internal or $Expect::Debug );
					next SELECT;
				}
				print STDERR ("select() returned error code '$!'\r\n")
					if ( $Expect::Exp_Internal or $Expect::Debug );

				# returned error
				$err = "4:$!";
				last READLOOP;
			}
		}

		# go until we don't find something (== timeout).
		if ( $nfound == 0 ) {

			# No pattern, no EOF. Did we time out?
			$err = "1:TIMEOUT";
			foreach my $pat (@params) {
				foreach my $exp ( @{ $pat->[0] } ) {
					$before = ${*$exp}{exp_Before} = ${*$exp}{exp_Accum};
					next if not defined $exp->fileno(); # skip already closed
					${*$exp}{exp_Error} = $err unless ${*$exp}{exp_Error};
				}
			}
			print STDERR ("TIMEOUT\r\n")
				if ( $Expect::Debug or $Expect::Exp_Internal );
			if ($timeout_hook) {
				my $ret;
				print STDERR ("Calling timeout function $timeout_hook...\r\n")
					if ( $Expect::Debug or $Expect::Exp_Internal );
				if ( ref($timeout_hook) eq 'CODE' ) {
					$ret = &{$timeout_hook}( $params[0]->[0] );
				} else {
					if ( $#{$timeout_hook} > 3 ) {
						$ret = &{ $timeout_hook->[3] }(
							$params[0]->[0],
							@{$timeout_hook}[ 4 .. $#{$timeout_hook} ]
						);
					} else {
						$ret = &{ $timeout_hook->[3] }( $params[0]->[0] );
					}
				}
				if ( $ret and $ret eq exp_continue ) {
					$start_loop_time = time(); # restart timeout count
					next READLOOP;
				}
			}
			last READLOOP;
		}

		my @bits = split( //, unpack( 'b*', $rmask ) );
		foreach my $pat (@params) {
			foreach my $exp ( @{ $pat->[0] } ) {
				next if not defined $exp->fileno(); # skip already closed
				if ( $bits[ $exp->fileno() ] ) {
					print STDERR ("${*$exp}{exp_Pty_Handle}: new data.\r\n")
						if $Expect::Debug;

					# read in what we found.
					my $buffer;
					my $nread = sysread( $exp, $buffer, 2048 );

					# Make errors (nread undef) show up as EOF.
					$nread = 0 unless defined($nread);

					if ( $nread == 0 ) {
						print STDERR ("${*$exp}{exp_Pty_Handle}: EOF\r\n")
							if ($Expect::Debug);
						$before = ${*$exp}{exp_Before} = $exp->clear_accum();
						$err = "2:EOF";
						${*$exp}{exp_Error}   = $err;
						${*$exp}{exp_Has_EOF} = 1;
						$exp_cont = undef;
						foreach my $eof_pat ( grep { $_->[1] eq '-eof' } @{$pat}[ 1 .. $#{$pat} ] ) {
							my $ret;
							print STDERR ( "Calling EOF hook $eof_pat->[3]...\r\n", )
								if ($Expect::Debug);
							if ( $#{$eof_pat} > 3 ) {

								# call with parameters if given
								$ret = &{ $eof_pat->[3] }( $exp, @{$eof_pat}[ 4 .. $#{$eof_pat} ] );
							} else {
								$ret = &{ $eof_pat->[3] }($exp);
							}
							if ($ret
								and (  $ret eq exp_continue
									or $ret eq exp_continue_timeout )
								)
							{
								$exp_cont = $ret;
							}
						}

						# is it dead?
						if ( defined( ${*$exp}{exp_Pid} ) ) {
							my $ret =
								waitpid( ${*$exp}{exp_Pid}, POSIX::WNOHANG );
							if ( $ret == ${*$exp}{exp_Pid} ) {
								printf STDERR (
									"%s: exit(0x%02X)\r\n",
									${*$exp}{exp_Pty_Handle}, $?
								) if ($Expect::Debug);
								$err = "3:Child PID ${*$exp}{exp_Pid} exited with status $?";
								${*$exp}{exp_Error} = $err;
								${*$exp}{exp_Exit}  = $?;
								delete $Expect::Spawned_PIDs{ ${*$exp}{exp_Pid} };
								${*$exp}{exp_Pid} = undef;
							}
						}
						print STDERR ("${*$exp}{exp_Pty_Handle}: closing...\r\n")
							if ($Expect::Debug);
						$exp->hard_close();
						next;
					}
					print STDERR ("${*$exp}{exp_Pty_Handle}: read $nread byte(s).\r\n")
						if ($Expect::Debug);

					# ugly hack for broken solaris ttys that spew <blank><backspace>
					# into our pretty output
					$buffer =~ s/ \cH//g if not ${*$exp}{exp_Raw_Pty};

					# Append it to the accumulator.
					${*$exp}{exp_Accum} .= $buffer;
					if ( exists ${*$exp}{exp_Max_Accum}
						and ${*$exp}{exp_Max_Accum} )
					{
						${*$exp}{exp_Accum} = $exp->_trim_length(
							${*$exp}{exp_Accum},
							${*$exp}{exp_Max_Accum}
						);
					}
					${*$exp}{exp_New_Data} = 1; # next round we try to match again

					$exp_cont = exp_continue
						if ( exists ${*$exp}{exp_Continue}
						and ${*$exp}{exp_Continue} );

					# Now propagate what we have read to other listeners...
					$exp->_print_handles($buffer);

					# End handle reading section.
				}
			}
		} # end read loop
		$start_loop_time = time() # restart timeout count
			if ( $exp_cont and $exp_cont eq exp_continue );
	}

	# End READLOOP

	# Post loop. Do we have anything?
	# Tell us status
	if ( $Expect::Debug or $Expect::Exp_Internal ) {
		if ($exp_matched) {
			print STDERR (
				"Returning from expect ",
				${*$exp_matched}{exp_Error} ? 'un' : '',
				"successfully.",
				${*$exp_matched}{exp_Error}
				? "\r\n  Error: ${*$exp_matched}{exp_Error}."
				: '',
				"\r\n"
			);
		} else {
			print STDERR ("Returning from expect with TIMEOUT or EOF\r\n");
		}
		if ( $Expect::Debug and $exp_matched ) {
			print STDERR "  ${*$exp_matched}{exp_Pty_Handle}: accumulator: `";
			if ( ${*$exp_matched}{exp_Error} ) {
				print STDERR (
					$exp_matched->_trim_length( _make_readable( ${*$exp_matched}{exp_Before} ) ),
					"'\r\n"
				);
			} else {
				print STDERR (
					$exp_matched->_trim_length( _make_readable( ${*$exp_matched}{exp_Accum} ) ),
					"'\r\n"
				);
			}
		}
	}

	if ($exp_matched) {
		return wantarray
			? (
			${*$exp_matched}{exp_Match_Number}, ${*$exp_matched}{exp_Error},
			${*$exp_matched}{exp_Match},        ${*$exp_matched}{exp_Before},
			${*$exp_matched}{exp_After},        $exp_matched,
			)
			: ${*$exp_matched}{exp_Match_Number};
	}

	return wantarray ? ( undef, $err, undef, $before, undef, undef ) : undef;
}

# Patterns are arrays that consist of
# [ $pattern_type, $pattern, $sub, @subparms ]
# optional $pattern_type is '-re' (RegExp, default) or '-ex' (exact);
# $sub is optional CODE ref, which is called as &{$sub}($exp, @subparms)
#   if pattern matched;
# the $parm_nr gets unshifted onto the array for reporting purposes.

sub _add_patterns_to_list {
	my ($listref, $timeoutlistref,$store_parm_nr, @params) = @_;

	# $timeoutlistref gets timeout patterns
	my $parm_nr        = $store_parm_nr || 1;
	foreach my $parm (@params) {
		if ( not ref($parm) eq 'ARRAY' ) {
			return "Parameter #$parm_nr is not an ARRAY ref.";
		}
		$parm = [@$parm];                    # make copy
		if ( $parm->[0] =~ m/\A-/ ) {

			# it's an option
			if (    $parm->[0] ne '-re'
				and $parm->[0] ne '-ex' )
			{
				return "Unknown option $parm->[0] in pattern #$parm_nr";
			}
		} else {
			if ( $parm->[0] eq 'timeout' ) {
				if ( defined $timeoutlistref ) {
					splice @$parm, 0, 1, ( "-$parm->[0]", undef );
					unshift @$parm, $store_parm_nr ? $parm_nr : undef;
					push @$timeoutlistref, $parm;
				}
				next;
			} elsif ( $parm->[0] eq 'eof' ) {
				splice @$parm, 0, 1, ( "-$parm->[0]", undef );
			} else {
				unshift @$parm, '-re'; # defaults to RegExp
			}
		}
		if ( @$parm > 2 ) {
			if ( ref( $parm->[2] ) ne 'CODE' ) {
				croak(
					"Pattern #$parm_nr doesn't have a CODE reference",
					"after the pattern."
				);
			}
		} else {
			push @$parm, undef;        # make sure we have three elements
		}

		unshift @$parm, $store_parm_nr ? $parm_nr : undef;
		push @$listref, $parm;
		$parm_nr++;
	}

	return;
}

######################################################################
# $process->interact([$in_handle],[$escape sequence])
# If you don't specify in_handle STDIN  will be used.
sub interact {
	my ($self, $infile, $escape_sequence) = @_;

	my $outfile;
	my @old_group = $self->set_group();

	# If the handle is STDIN we'll
	# $infile->fileno == 0 should be stdin.. follow stdin rules.
	no strict 'subs'; # Allow bare word 'STDIN'
	unless ( defined($infile) ) {
		# We need a handle object Associated with STDIN.
		$infile = IO::File->new;
		$infile->IO::File::fdopen( STDIN, 'r' );
		$outfile = IO::File->new;
		$outfile->IO::File::fdopen( STDOUT, 'w' );
	} elsif ( fileno($infile) == fileno(STDIN) ) {

		# With STDIN we want output to go to stdout.
		$outfile = IO::File->new;
		$outfile->IO::File::fdopen( STDOUT, 'w' );
	} else {
		undef($outfile);
	}

	# Here we assure ourselves we have an Expect object.
	my $in_object = Expect->exp_init($infile);
	if ( defined($outfile) ) {

		# as above.. we want output to go to stdout if we're given stdin.
		my $out_object = Expect->exp_init($outfile);
		$out_object->manual_stty(1);
		$self->set_group($out_object);
	} else {
		$self->set_group($in_object);
	}
	$in_object->set_group($self);
	$in_object->set_seq( $escape_sequence, undef ) if defined($escape_sequence);

	# interconnect normally sets stty -echo raw. Interact really sort
	# of implies we don't do that by default. If anyone wanted to they could
	# set it before calling interact, of use interconnect directly.
	my $old_manual_stty_val = $self->manual_stty();
	$self->manual_stty(1);

	# I think this is right. Don't send stuff from in_obj to stdout by default.
	# in theory whatever 'self' is should echo what's going on.
	my $old_log_stdout_val = $self->log_stdout();
	$self->log_stdout(0);
	$in_object->log_stdout(0);

	# Allow for the setting of an optional EOF escape function.
	#  $in_object->set_seq('EOF',undef);
	#  $self->set_seq('EOF',undef);
	Expect::interconnect( $self, $in_object );
	$self->log_stdout($old_log_stdout_val);
	$self->set_group(@old_group);

	# If old_group was undef, make sure that occurs. This is a slight hack since
	# it modifies the value directly.
	# Normally an undef passed to set_group will return the current groups.
	# It is possible that it may be of worth to make it possible to undef
	# The current group without doing this.
	unless (@old_group) {
		@{ ${*$self}{exp_Listen_Group} } = ();
	}
	$self->manual_stty($old_manual_stty_val);

	return;
}

sub interconnect {
	my (@handles) = @_;

	#  my ($handle)=(shift); call as Expect::interconnect($spawn1,$spawn2,...)
	my ( $nread );
	my ( $rout, $emask, $eout );
	my ( $escape_character_buffer );
	my ( $read_mask, $temp_mask ) = ( '', '' );

	# Get read/write handles
	foreach my $handle (@handles) {
		$temp_mask = '';
		vec( $temp_mask, $handle->fileno(), 1 ) = 1;

		# Under Linux w/ 5.001 the next line comes up w/ 'Uninit var.'.
		# It appears to be impossible to make the warning go away.
		# doing something like $temp_mask='' unless defined ($temp_mask)
		# has no effect whatsoever. This may be a bug in 5.001.
		$read_mask = $read_mask | $temp_mask;
	}
	if ($Expect::Debug) {
		print STDERR "Read handles:\r\n";
		foreach my $handle (@handles) {
			print STDERR "\tRead handle: ";
			print STDERR "'${*$handle}{exp_Pty_Handle}'\r\n";
			print STDERR "\t\tListen Handles:";
			foreach my $write_handle ( @{ ${*$handle}{exp_Listen_Group} } ) {
				print STDERR " '${*$write_handle}{exp_Pty_Handle}'";
			}
			print STDERR ".\r\n";
		}
	}

	#  I think if we don't set raw/-echo here we may have trouble. We don't
	# want a bunch of echoing crap making all the handles jabber at each other.
	foreach my $handle (@handles) {
		unless ( ${*$handle}{"exp_Manual_Stty"} ) {

			# This is probably O/S specific.
			${*$handle}{exp_Stored_Stty} = $handle->exp_stty('-g');
			print STDERR "Setting tty for ${*$handle}{exp_Pty_Handle} to 'raw -echo'.\r\n"
				if ${*$handle}{"exp_Debug"};
			$handle->exp_stty("raw -echo");
		}
		foreach my $write_handle ( @{ ${*$handle}{exp_Listen_Group} } ) {
			unless ( ${*$write_handle}{"exp_Manual_Stty"} ) {
				${*$write_handle}{exp_Stored_Stty} =
					$write_handle->exp_stty('-g');
				print STDERR "Setting ${*$write_handle}{exp_Pty_Handle} to 'raw -echo'.\r\n"
					if ${*$handle}{"exp_Debug"};
				$write_handle->exp_stty("raw -echo");
			}
		}
	}

	print STDERR "Attempting interconnection\r\n" if $Expect::Debug;

	# Wait until the process dies or we get EOF
	# In the case of !${*$handle}{exp_Pid} it means
	# the handle was exp_inited instead of spawned.
	CONNECT_LOOP:

	# Go until we have a reason to stop
	while (1) {

		# test each handle to see if it's still alive.
		foreach my $read_handle (@handles) {
			waitpid( ${*$read_handle}{exp_Pid}, WNOHANG )
				if ( exists( ${*$read_handle}{exp_Pid} )
				and ${*$read_handle}{exp_Pid} );
			if (    exists( ${*$read_handle}{exp_Pid} )
				and ( ${*$read_handle}{exp_Pid} )
				and ( !kill( 0, ${*$read_handle}{exp_Pid} ) ) )
			{
				print STDERR
					"Got EOF (${*$read_handle}{exp_Pty_Handle} died) reading ${*$read_handle}{exp_Pty_Handle}\r\n"
					if ${*$read_handle}{"exp_Debug"};
				last CONNECT_LOOP
					unless defined( ${ ${*$read_handle}{exp_Function} }{"EOF"} );
				last CONNECT_LOOP
					unless &{ ${ ${*$read_handle}{exp_Function} }{"EOF"} }
					( @{ ${ ${*$read_handle}{exp_Parameters} }{"EOF"} } );
			}
		}

		# Every second? No, go until we get something from someone.
		my $nfound = select( $rout = $read_mask, undef, $eout = $emask, undef );

		# Is there anything to share?  May be -1 if interrupted by a signal...
		next CONNECT_LOOP if not defined $nfound or $nfound < 1;

		# Which handles have stuff?
		my @bits = split( //, unpack( 'b*', $rout ) );
		$eout = 0 unless defined($eout);
		my @ebits = split( //, unpack( 'b*', $eout ) );

		#    print "Ebits: $eout\r\n";
		foreach my $read_handle (@handles) {
			if ( $bits[ $read_handle->fileno() ] ) {
				$nread = sysread(
					$read_handle, ${*$read_handle}{exp_Pty_Buffer},
					1024
				);

				# Appease perl -w
				$nread = 0 unless defined($nread);
				print STDERR "interconnect: read $nread byte(s) from ${*$read_handle}{exp_Pty_Handle}.\r\n"
					if ${*$read_handle}{"exp_Debug"} > 1;

				# Test for escape seq. before printing.
				# Appease perl -w
				$escape_character_buffer = ''
					unless defined($escape_character_buffer);
				$escape_character_buffer .= ${*$read_handle}{exp_Pty_Buffer};
				foreach my $escape_sequence ( keys( %{ ${*$read_handle}{exp_Function} } ) ) {
					print STDERR "Tested escape sequence $escape_sequence from ${*$read_handle}{exp_Pty_Handle}"
						if ${*$read_handle}{"exp_Debug"} > 1;

					# Make sure it doesn't grow out of bounds.
					$escape_character_buffer = $read_handle->_trim_length(
						$escape_character_buffer,
						${*$read_handle}{"exp_Max_Accum"}
					) if ( ${*$read_handle}{"exp_Max_Accum"} );
					if ( $escape_character_buffer =~ /($escape_sequence)/ ) {
						my $match = $1;
						if ( ${*$read_handle}{"exp_Debug"} ) {
							print STDERR
								"\r\ninterconnect got escape sequence from ${*$read_handle}{exp_Pty_Handle}.\r\n";

							# I'm going to make the esc. seq. pretty because it will
							# probably contain unprintable characters.
							print STDERR "\tEscape Sequence: '"
								. _trim_length(
								undef,
								_make_readable($escape_sequence)
								) . "'\r\n";
							print STDERR "\tMatched by string: '" . _trim_length( undef, _make_readable($match) ) . "'\r\n";
						}

						# Print out stuff before the escape.
						# Keep in mind that the sequence may have been split up
						# over several reads.
						# Let's get rid of it from this read. If part of it was
						# in the last read there's not a lot we can do about it now.
						if ( ${*$read_handle}{exp_Pty_Buffer} =~ /([\w\W]*)($escape_sequence)/ ) {
							$read_handle->_print_handles($1);
						} else {
							$read_handle->_print_handles( ${*$read_handle}{exp_Pty_Buffer} );
						}

						# Clear the buffer so no more matches can be made and it will
						# only be printed one time.
						${*$read_handle}{exp_Pty_Buffer} = '';
						$escape_character_buffer = '';

						# Do the function here. Must return non-zero to continue.
						# More cool syntax. Maybe I should turn these in to objects.
						last CONNECT_LOOP
							unless &{ ${ ${*$read_handle}{exp_Function} }{$escape_sequence} }
							( @{ ${ ${*$read_handle}{exp_Parameters} }{$escape_sequence} } );
					}
				}
				$nread = 0 unless defined($nread); # Appease perl -w?
				waitpid( ${*$read_handle}{exp_Pid}, WNOHANG )
					if ( defined( ${*$read_handle}{exp_Pid} )
					&& ${*$read_handle}{exp_Pid} );
				if ( $nread == 0 ) {
					print STDERR "Got EOF reading ${*$read_handle}{exp_Pty_Handle}\r\n"
						if ${*$read_handle}{"exp_Debug"};
					last CONNECT_LOOP
						unless defined( ${ ${*$read_handle}{exp_Function} }{"EOF"} );
					last CONNECT_LOOP
						unless &{ ${ ${*$read_handle}{exp_Function} }{"EOF"} }
						( @{ ${ ${*$read_handle}{exp_Parameters} }{"EOF"} } );
				}
				last CONNECT_LOOP if ( $nread < 0 ); # This would be an error
				$read_handle->_print_handles( ${*$read_handle}{exp_Pty_Buffer} );
			}

			# I'm removing this because I haven't determined what causes exceptions
			# consistently.
			if (0) #$ebits[$read_handle->fileno()])
			{
				print STDERR "Got Exception reading ${*$read_handle}{exp_Pty_Handle}\r\n"
					if ${*$read_handle}{"exp_Debug"};
				last CONNECT_LOOP
					unless defined( ${ ${*$read_handle}{exp_Function} }{"EOF"} );
				last CONNECT_LOOP
					unless &{ ${ ${*$read_handle}{exp_Function} }{"EOF"} }
					( @{ ${ ${*$read_handle}{exp_Parameters} }{"EOF"} } );
			}
		}
	}
	foreach my $handle (@handles) {
		unless ( ${*$handle}{"exp_Manual_Stty"} ) {
			$handle->exp_stty( ${*$handle}{exp_Stored_Stty} );
		}
		foreach my $write_handle ( @{ ${*$handle}{exp_Listen_Group} } ) {
			unless ( ${*$write_handle}{"exp_Manual_Stty"} ) {
				$write_handle->exp_stty( ${*$write_handle}{exp_Stored_Stty} );
			}
		}
	}

	return;
}

# user can decide if log output gets also sent to logfile
sub print_log_file {
	my ($self, @params) = @_;

	if ( ${*$self}{exp_Log_File} ) {
		if ( ref( ${*$self}{exp_Log_File} ) eq 'CODE' ) {
			${*$self}{exp_Log_File}->(@params);
		} else {
			${*$self}{exp_Log_File}->print(@params);
		}
	}

	return;
}

# we provide our own print so we can debug what gets sent to the
# processes...
sub print {
	my ( $self, @args ) = @_;

	return if not defined $self->fileno(); # skip if closed
	if ( ${*$self}{exp_Exp_Internal} ) {
		my $args = _make_readable( join( '', @args ) );
		cluck "Sending '$args' to ${*$self}{exp_Pty_Handle}\r\n";
	}
	foreach my $arg (@args) {
		while ( length($arg) > 80 ) {
			$self->SUPER::print( substr( $arg, 0, 80 ) );
			$arg = substr( $arg, 80 );
		}
		$self->SUPER::print($arg);
	}

	return;
}

# make an alias for Tcl/Expect users for a DWIM experience...
*send = \&print;

# This is an Expect standard. It's nice for talking to modems and the like
# where from time to time they get unhappy if you send items too quickly.
sub send_slow {
	my ($self, $sleep_time, @chunks) = @_;

	return if not defined $self->fileno(); # skip if closed

	# Flushing makes it so each character can be seen separately.
	my $chunk;
	while ( $chunk = shift @chunks ) {
		my @linechars = split( '', $chunk );
		foreach my $char (@linechars) {

			# How slow?
			select( undef, undef, undef, $sleep_time );

			print $self $char;
			print STDERR "Printed character \'" . _make_readable($char) . "\' to ${*$self}{exp_Pty_Handle}.\r\n"
				if ${*$self}{"exp_Debug"} > 1;

			# I think I can get away with this if I save it in accum
			if ( ${*$self}{"exp_Log_Stdout"} || ${*$self}{exp_Log_Group} ) {
				my $rmask = "";
				vec( $rmask, $self->fileno(), 1 ) = 1;

				# .01 sec granularity should work. If we miss something it will
				# probably get flushed later, maybe in an expect call.
				while ( select( $rmask, undef, undef, .01 ) ) {
					my $ret = sysread( $self, ${*$self}{exp_Pty_Buffer}, 1024 );
					last if not defined $ret or $ret == 0;

					# Is this necessary to keep? Probably.. #
					# if you need to expect it later.
					${*$self}{exp_Accum} .= ${*$self}{exp_Pty_Buffer};
					${*$self}{exp_Accum} = $self->_trim_length(
						${*$self}{exp_Accum},
						${*$self}{"exp_Max_Accum"}
					) if ( ${*$self}{"exp_Max_Accum"} );
					$self->_print_handles( ${*$self}{exp_Pty_Buffer} );
					print STDERR "Received \'"
						. $self->_trim_length( _make_readable($char) )
						. "\' from ${*$self}{exp_Pty_Handle}\r\n"
						if ${*$self}{"exp_Debug"} > 1;
				}
			}
		}
	}

	return;
}

sub test_handles {
	my ($timeout, @handle_list)  = @_;

	# This should be called by Expect::test_handles($timeout,@objects);
	my ( $allmask, $rout );
	foreach my $handle (@handle_list) {
		my $rmask = '';
		vec( $rmask, $handle->fileno(), 1 ) = 1;
		$allmask = '' unless defined($allmask);
		$allmask = $allmask | $rmask;
	}
	my $nfound = select( $rout = $allmask, undef, undef, $timeout );
	return () unless $nfound;

	# Which handles have stuff?
	my @bits = split( //, unpack( 'b*', $rout ) );

	my $handle_num  = 0;
	my @return_list = ();
	foreach my $handle (@handle_list) {

		# I go to great lengths to get perl -w to shut the hell up.
		if ( defined( $bits[ $handle->fileno() ] )
			and ( $bits[ $handle->fileno() ] ) )
		{
			push( @return_list, $handle_num );
		}
	} continue {
		$handle_num++;
	}

	return @return_list;
}

# Be nice close. This should emulate what an interactive shell does after a
# command finishes... sort of. We're not as patient as a shell.
sub soft_close {
	my ($self) = @_;

	my ( $nfound, $nread, $rmask, $end_time, $temp_buffer );

	# Give it 15 seconds to cough up an eof.
	cluck "Closing ${*$self}{exp_Pty_Handle}.\r\n" if ${*$self}{exp_Debug};
	return -1 if not defined $self->fileno(); # skip if handle already closed
	unless ( exists ${*$self}{exp_Has_EOF} and ${*$self}{exp_Has_EOF} ) {
		$end_time = time() + 15;
		while ( $end_time > time() ) {
			my $select_time = $end_time - time();

			# Sanity check.
			$select_time = 0 if $select_time < 0;
			$rmask = '';
			vec( $rmask, $self->fileno(), 1 ) = 1;
			($nfound) = select( $rmask, undef, undef, $select_time );
			last unless ( defined($nfound) && $nfound );
			$nread = sysread( $self, $temp_buffer, 8096 );

			# 0 = EOF.
			unless ( defined($nread) && $nread ) {
				print STDERR "Got EOF from ${*$self}{exp_Pty_Handle}.\r\n"
					if ${*$self}{exp_Debug};
				last;
			}
			$self->_print_handles($temp_buffer);
		}
		if ( ( $end_time <= time() ) && ${*$self}{exp_Debug} ) {
			print STDERR "Timed out waiting for an EOF from ${*$self}{exp_Pty_Handle}.\r\n";
		}
	}
	my $close_status = $self->close();
	if ( $close_status && ${*$self}{exp_Debug} ) {
		print STDERR "${*$self}{exp_Pty_Handle} closed.\r\n";
	}

	# quit now if it isn't a process.
	return $close_status unless defined( ${*$self}{exp_Pid} );

	# Now give it 15 seconds to die.
	$end_time = time() + 15;
	while ( $end_time > time() ) {
		my $returned_pid = waitpid( ${*$self}{exp_Pid}, &WNOHANG );

		# Stop here if the process dies.
		if ( defined($returned_pid) && $returned_pid ) {
			delete $Expect::Spawned_PIDs{$returned_pid};
			if ( ${*$self}{exp_Debug} ) {
				printf STDERR (
					"Pid %d of %s exited, Status: 0x%02X\r\n",
					${*$self}{exp_Pid},
					${*$self}{exp_Pty_Handle}, $?
				);
			}
			${*$self}{exp_Pid}  = undef;
			${*$self}{exp_Exit} = $?;
			return ${*$self}{exp_Exit};
		}
		sleep 1; # Keep loop nice.
	}

	# Send it a term if it isn't dead.
	if ( ${*$self}{exp_Debug} ) {
		print STDERR "${*$self}{exp_Pty_Handle} not exiting, sending TERM.\r\n";
	}
	kill TERM => ${*$self}{exp_Pid};

	# Now to be anal retentive.. wait 15 more seconds for it to die.
	$end_time = time() + 15;
	while ( $end_time > time() ) {
		my $returned_pid = waitpid( ${*$self}{exp_Pid}, &WNOHANG );
		if ( defined($returned_pid) && $returned_pid ) {
			delete $Expect::Spawned_PIDs{$returned_pid};
			if ( ${*$self}{exp_Debug} ) {
				printf STDERR (
					"Pid %d of %s terminated, Status: 0x%02X\r\n",
					${*$self}{exp_Pid},
					${*$self}{exp_Pty_Handle}, $?
				);
			}
			${*$self}{exp_Pid}  = undef;
			${*$self}{exp_Exit} = $?;
			return $?;
		}
		sleep 1;
	}

	# Since this is a 'soft' close, sending it a -9 would be inappropriate.
	return;
}

# 'Make it go away' close.
sub hard_close {
	my ($self) = @_;

	cluck "Closing ${*$self}{exp_Pty_Handle}.\r\n" if ${*$self}{exp_Debug};

	# Don't wait for an EOF.
	my $close_status = $self->close();
	if ( $close_status && ${*$self}{exp_Debug} ) {
		print STDERR "${*$self}{exp_Pty_Handle} closed.\r\n";
	}

	# Return now if handle.
	return $close_status unless defined( ${*$self}{exp_Pid} );

	# Now give it 5 seconds to die. Less patience here if it won't die.
	my $end_time = time() + 5;
	while ( $end_time > time() ) {
		my $returned_pid = waitpid( ${*$self}{exp_Pid}, &WNOHANG );

		# Stop here if the process dies.
		if ( defined($returned_pid) && $returned_pid ) {
			delete $Expect::Spawned_PIDs{$returned_pid};
			if ( ${*$self}{exp_Debug} ) {
				printf STDERR (
					"Pid %d of %s terminated, Status: 0x%02X\r\n",
					${*$self}{exp_Pid},
					${*$self}{exp_Pty_Handle}, $?
				);
			}
			${*$self}{exp_Pid}  = undef;
			${*$self}{exp_Exit} = $?;
			return ${*$self}{exp_Exit};
		}
		sleep 1; # Keep loop nice.
	}

	# Send it a term if it isn't dead.
	if ( ${*$self}{exp_Debug} ) {
		print STDERR "${*$self}{exp_Pty_Handle} not exiting, sending TERM.\r\n";
	}
	kill TERM => ${*$self}{exp_Pid};

	# wait 15 more seconds for it to die.
	$end_time = time() + 15;
	while ( $end_time > time() ) {
		my $returned_pid = waitpid( ${*$self}{exp_Pid}, &WNOHANG );
		if ( defined($returned_pid) && $returned_pid ) {
			delete $Expect::Spawned_PIDs{$returned_pid};
			if ( ${*$self}{exp_Debug} ) {
				printf STDERR (
					"Pid %d of %s terminated, Status: 0x%02X\r\n",
					${*$self}{exp_Pid},
					${*$self}{exp_Pty_Handle}, $?
				);
			}
			${*$self}{exp_Pid}  = undef;
			${*$self}{exp_Exit} = $?;
			return ${*$self}{exp_Exit};
		}
		sleep 1;
	}
	kill KILL => ${*$self}{exp_Pid};

	# wait 5 more seconds for it to die.
	$end_time = time() + 5;
	while ( $end_time > time() ) {
		my $returned_pid = waitpid( ${*$self}{exp_Pid}, &WNOHANG );
		if ( defined($returned_pid) && $returned_pid ) {
			delete $Expect::Spawned_PIDs{$returned_pid};
			if ( ${*$self}{exp_Debug} ) {
				printf STDERR (
					"Pid %d of %s killed, Status: 0x%02X\r\n",
					${*$self}{exp_Pid},
					${*$self}{exp_Pty_Handle}, $?
				);
			}
			${*$self}{exp_Pid}  = undef;
			${*$self}{exp_Exit} = $?;
			return ${*$self}{exp_Exit};
		}
		sleep 1;
	}
	warn "Pid ${*$self}{exp_Pid} of ${*$self}{exp_Pty_Handle} is HUNG.\r\n";
	${*$self}{exp_Pid} = undef;

	return;
}

# These should not be called externally.

sub _init_vars {
	my ($self) = @_;

	# for every spawned process or filehandle.
	${*$self}{exp_Log_Stdout} = $Expect::Log_Stdout
		if defined($Expect::Log_Stdout);
	${*$self}{exp_Log_Group}     = $Expect::Log_Group;
	${*$self}{exp_Debug}         = $Expect::Debug;
	${*$self}{exp_Exp_Internal}  = $Expect::Exp_Internal;
	${*$self}{exp_Manual_Stty}   = $Expect::Manual_Stty;
	${*$self}{exp_Stored_Stty}   = 'sane';
	${*$self}{exp_Do_Soft_Close} = $Expect::Do_Soft_Close;

	# sysread doesn't like my or local vars.
	${*$self}{exp_Pty_Buffer} = '';

	# Initialize accumulator.
	${*$self}{exp_Max_Accum}  = $Expect::Exp_Max_Accum;
	${*$self}{exp_Accum}      = '';
	${*$self}{exp_NoTransfer} = 0;

	# create empty expect_before & after lists
	${*$self}{exp_expect_before_list} = [];
	${*$self}{exp_expect_after_list}  = [];

	return;
}

sub _make_readable {
	my ($s) = @_;

	$s = '' if not defined($s);
	study $s;          # Speed things up?
	$s =~ s/\\/\\\\/g; # So we can tell easily(?) what is a backslash
	$s =~ s/\n/\\n/g;
	$s =~ s/\r/\\r/g;
	$s =~ s/\t/\\t/g;
	$s =~ s/\'/\\\'/g; # So we can tell whassa quote and whassa notta quote.
	$s =~ s/\"/\\\"/g;

	# Formfeed (does anyone use formfeed?)
	$s =~ s/\f/\\f/g;
	$s =~ s/\010/\\b/g;

	# escape control chars high/low, but allow ISO 8859-1 chars
	$s =~ s/([\000-\037\177-\237\377])/sprintf("\\%03lo",ord($1))/ge;

	return $s;
}

sub _trim_length {
	my ($self, $string, $length) = @_;

	# This is sort of a reverse truncation function
	# Mostly so we don't have to see the full output when we're using
	# Also used if Max_Accum gets set to limit the size of the accumulator
	# for matching functions.
	# exp_internal

	croak('No string passed') if not defined $string;

	# If we're not passed a length (_trim_length is being used for debugging
	# purposes) AND debug >= 3, don't trim.
	return ($string)
		if (defined($self)
		and ${*$self}{"exp_Debug"} >= 3
		and ( !( defined($length) ) ) );
	my $indicate_truncation = ($length ? '' : '...');
	$length ||= 1021;
	return $string if $length >= length $string;

	# We wouldn't want the accumulator to begin with '...' if max_accum is passed
	# This is because this funct. gets called internally w/ max_accum
	# and is also used to print information back to the user.
	return $indicate_truncation . substr( $string, ( length($string) - $length ), $length );
}

sub _print_handles {
	my ($self, $print_this) = @_;

	# Given crap from 'self' and the handles self wants to print to, print to
	# them. these are indicated by the handle's 'group'
	if ( ${*$self}{exp_Log_Group} ) {
		foreach my $handle ( @{ ${*$self}{exp_Listen_Group} } ) {
			$print_this = '' unless defined($print_this);

			# Appease perl -w
			print STDERR "Printed '"
				. $self->_trim_length( _make_readable($print_this) )
				. "' to ${*$handle}{exp_Pty_Handle} from ${*$self}{exp_Pty_Handle}.\r\n"
				if ( ${*$handle}{"exp_Debug"} > 1 );
			print $handle $print_this;
		}
	}

	# If ${*$self}{exp_Pty_Handle} is STDIN this would make it echo.
	print STDOUT $print_this
		if ${*$self}{"exp_Log_Stdout"};
	$self->print_log_file($print_this);
	$| = 1; # This should not be necessary but autoflush() doesn't always work.

	return;
}

sub _get_mode {
	my ($handle)      = @_;

	my ($fcntl_flags) = '';

	# What mode are we opening with? use fcntl to find out.
	$fcntl_flags = fcntl( \*{$handle}, Fcntl::F_GETFL, $fcntl_flags );
	die "fcntl returned undef during exp_init of $handle, $!\r\n"
		unless defined($fcntl_flags);
	if ( $fcntl_flags | (Fcntl::O_RDWR) ) {
		return 'rw';
	} elsif ( $fcntl_flags | (Fcntl::O_WRONLY) ) {
		return 'w';
	} else {

		# Under Solaris (among others?) O_RDONLY is implemented as 0. so |O_RDONLY would fail.
		return 'r';
	}
}

sub _undef {
	return undef;

	# Seems a little retarded but &CORE::undef fails in interconnect.
	# This is used for the default escape sequence function.
	# w/out the leading & it won't compile.
}

# clean up child processes
sub DESTROY {
	my ($self) = @_;

	my $status = $?;   # save this as it gets mangled by the terminating spawned children
	if ( ${*$self}{exp_Do_Soft_Close} ) {
		$self->soft_close();
	}
	$self->hard_close();
	$? = $status;      # restore it. otherwise deleting an Expect object may mangle $?, which is unintuitive

	return;
}

1;
__END__

=head1 NAME

Expect - automate interactions with command line programs that expose a text terminal interface.

=head1 SYNOPSIS

  use Expect;

  # create an Expect object by spawning another process
  my $exp = Expect->spawn($command, @params)
    or die "Cannot spawn $command: $!\n";

  # or by using an already opened filehandle (e.g. from Net::Telnet)
  my $exp = Expect->exp_init(\*FILEHANDLE);

  # if you prefer the OO mindset:
  my $exp = Expect->new;
  $exp->raw_pty(1);
  $exp->spawn($command, @parameters)
    or die "Cannot spawn $command: $!\n";

  # send some string there:
  $exp->send("string\n");

  # or, for the filehandle mindset:
  print $exp "string\n";

  # then do some pattern matching with either the simple interface
  $patidx = $exp->expect($timeout, @match_patterns);

  # or multi-match on several spawned commands with callbacks,
  # just like the Tcl version
  $exp->expect($timeout,
             [ qr/regex1/ => sub { my $exp = shift;
                       $exp->send("response\n");
                       exp_continue; } ],
             [ "regexp2" , \&callback, @cbparms ],
            );

  # if no longer needed, do a soft_close to nicely shut down the command
  $exp->soft_close();

  # or be less patient with
  $exp->hard_close();

Expect.pm is built to either spawn a process or take an existing filehandle
and interact with it such that normally interactive tasks can be done
without operator assistance. This concept makes more sense if you are
already familiar with the versatile Tcl version of Expect.
The public functions that make up Expect.pm are:

  Expect->new()
  Expect::interconnect(@objects_to_be_read_from)
  Expect::test_handles($timeout, @objects_to_test)
  Expect::version($version_requested | undef);
  $object->spawn(@command)
  $object->clear_accum()
  $object->set_accum($value)
  $object->debug($debug_level)
  $object->exp_internal(0 | 1)
  $object->notransfer(0 | 1)
  $object->raw_pty(0 | 1)
  $object->stty(@stty_modes) # See the IO::Stty docs
  $object->slave()
  $object->before();
  $object->match();
  $object->after();
  $object->matchlist();
  $object->match_number();
  $object->error();
  $object->command();
  $object->exitstatus();
  $object->pty_handle();
  $object->do_soft_close();
  $object->restart_timeout_upon_receive(0 | 1);
  $object->interact($other_object, $escape_sequence)
  $object->log_group(0 | 1 | undef)
  $object->log_user(0 | 1 | undef)
  $object->log_file("filename" | $filehandle | \&coderef | undef)
  $object->manual_stty(0 | 1 | undef)
  $object->match_max($max_buffersize or undef)
  $object->pid();
  $object->send_slow($delay, @strings_to_send)
  $object->set_group(@listen_group_objects | undef)
  $object->set_seq($sequence,\&function,\@parameters);

There are several configurable package variables that affect the behavior of Expect. They are:

  $Expect::Debug;
  $Expect::Exp_Internal;
  $Expect::IgnoreEintr;
  $Expect::Log_Group;
  $Expect::Log_Stdout;
  $Expect::Manual_Stty;
  $Expect::Multiline_Matching;
  $Expect::Do_Soft_Close;

=head1 DESCRIPTION

See an explanation of L<What is Expect|http://code-maven.com/expect>

The Expect module is a successor of Comm.pl and a descendent of Chat.pl. It
more closely resembles the Tcl Expect language than its predecessors. It
does not contain any of the networking code found in Comm.pl. I suspect this
would be obsolete anyway given the advent of IO::Socket and external tools
such as netcat.

Expect.pm is an attempt to have more of a switch() & case feeling to make
decision processing more fluid.  Three separate types of debugging have
been implemented to make code production easier.

It is possible to interconnect multiple file handles (and processes) much
like Tcl's Expect. An attempt was made to enable all the features of Tcl's
Expect without forcing Tcl on the victim programmer :-) .

Please, before you consider using Expect, read the FAQs about
L</"I want to automate password entry for su/ssh/scp/rsh/..."> and
L</"I want to use Expect to automate [anything with a buzzword]...">


=head1 USAGE

=over 4

=item new

Creates a new Expect object, i.e. a pty.  You can change parameters on
it before actually spawning a command.  This is important if you want
to modify the terminal settings for the slave.  See slave() below.
The object returned is actually a reblessed IO::Pty filehandle, so see
there for additional methods.


=item Expect->exp_init(\*FILEHANDLE) I<or>

=item Expect->init(\*FILEHANDLE)

Initializes $new_handle_object for use with other Expect functions. It must
be passed a B<_reference_> to FILEHANDLE if you want it to work properly.
IO::File objects are preferable. Returns a reference to the newly created
object.

You can use only real filehandles, certain tied filehandles
(e.g. Net::SSH2) that lack a fileno() will not work. Net::Telnet
objects can be used but have been reported to work only for certain
hosts. YMMV.


=item Expect->spawn($command, @parameters) I<or>

=item $object->spawn($command, @parameters) I<or>

=item Expect->new($command, @parameters)

Forks and execs $command. Returns an Expect object upon success or
C<undef> if the fork was unsuccessful or the command could not be
found.  spawn() passes its parameters unchanged to Perls exec(), so
look there for detailed semantics.

Note that if spawn cannot exec() the given command, the Expect object
is still valid and the next expect() will see "Cannot exec", so you
can use that for error handling.

Also note that you cannot reuse an object with an already spawned
command, even if that command has exited.  Sorry, but you have to
allocate a new object...


=item $object->debug(0 | 1 | 2 | 3 | undef)

Sets debug level for $object. 1 refers to general debugging
information, 2 refers to verbose debugging and 0 refers to no
debugging. If you call debug() with no parameters it will return the
current debugging level.  When the object is created the debugging
level will match that $Expect::Debug, normally 0.

The '3' setting is new with 1.05, and adds the additional
functionality of having the _full_ accumulated buffer printed every
time data is read from an Expect object. This was implemented by
request. I recommend against using this unless you think you need it
as it can create quite a quantity of output under some circumstances..


=item $object->exp_internal(1 | 0)

Sets/unsets 'exp_internal' debugging. This is similar in nature to its Tcl
counterpart. It is extremely valuable when debugging expect() sequences.
When the object is created the exp_internal setting will match the value of
$Expect::Exp_Internal, normally 0. Returns the current setting if called
without parameters. It is highly recommended that you make use of the
debugging features lest you have angry code.


=item $object->raw_pty(1 | 0)

Set pty to raw mode before spawning.  This disables echoing, CR->LF
translation and an ugly hack for broken Solaris TTYs (which send
<space><backspace> to slow things down) and thus gives a more
pipe-like behaviour (which is important if you want to transfer binary
content).  Note that this must be set I<before> spawning the program.


=item $object->stty(qw(mode1 mode2...))

Sets the tty mode for $object's associated terminal to the given
modes.  Note that on many systems the master side of the pty is not a
tty, so you have to modify the slave pty instead, see next item.  This
needs IO::Stty installed, which is no longer required.


=item $object->slave()

Returns a filehandle to the slave part of the pty.  Very useful in modifying
the terminal settings:

  $object->slave->stty(qw(raw -echo));

Typical values are 'sane', 'raw', and 'raw -echo'.  Note that I
recommend setting the terminal to 'raw' or 'raw -echo', as this avoids
a lot of hassle and gives pipe-like (i.e. transparent) behaviour
(without the buffering issue).


=item $object->print(@strings) I<or>

=item $object->send(@strings)

Sends the given strings to the spawned command.  Note that the strings
are not logged in the logfile (see print_log_file) but will probably
be echoed back by the pty, depending on pty settings (default is echo)
and thus end up there anyway.  This must also be taken into account
when expect()ing for an answer: the next string will be the command
just sent.  I suggest setting the pty to raw, which disables echo and
makes the pty transparently act like a bidirectional pipe.


=item $object->expect($timeout, @match_patterns)

=over 4

=item Simple interface

Given $timeout in seconds Expect will wait for $object's handle to produce
one of the match_patterns, which are matched exactly by default. If you
want a regexp match, use a regexp object (C<qr//>) or prefix the pattern with '-re'.

  $object->expect(15, 'match me exactly', qr/match\s+me\s+exactly/);
  $object->expect(15, 'match me exactly','-re','match\s+me\s+exactly');

Due to o/s limitations $timeout should be a round number. If $timeout
is 0 Expect will check one time to see if $object's handle contains
any of the match_patterns. If $timeout is undef Expect
will wait forever for a pattern to match. If you don't want to 
explicitly put the timeout on all calls to C<expect>, you can set 
it via the C<timeout> method . If the first argument of C<expect> 
doesn't look like a number, that value will be used.

  $object->timeout(15);
  $object->expect('match me exactly','-re','match\s+me\s+exactly');


If called in a scalar context, expect() will return the position of
the matched pattern within @matched_patterns, or undef if no pattern was
matched. This is a position starting from 1, so if you want to know
which of an array of @matched_patterns matched you should subtract one
from the return value.

If called in an array context expect() will return
($matched_pattern_position, $error, $successfully_matching_string,
$before_match, and $after_match).

C<$matched_pattern_position> will contain the value that would have been
returned if expect() had been called in a scalar context.

C<$error> is
the error that occurred that caused expect() to return. $error will
contain a number followed by a string equivalent expressing the nature
of the error. Possible values are undef, indicating no error,
'1:TIMEOUT' indicating that $timeout seconds had elapsed without a
match, '2:EOF' indicating an eof was read from $object, '3: spawn
id($fileno) died' indicating that the process exited before matching
and '4:$!' indicating whatever error was set in $ERRNO during the last
read on $object's handle or during select(). All handles indicated by
set_group plus STDOUT will have all data to come out of $object
printed to them during expect() if log_group and log_stdout are set.

C<$successfully_matching_string>
C<$before_match>
C<$after_match>

Changed from older versions is the regular expression handling. By
default now all strings passed to expect() are treated as literals. To
match a regular expression pass '-re' as a parameter in front of the
pattern you want to match as a regexp.

This change makes it possible to match literals and regular expressions
in the same expect() call.

Also new is multiline matching. ^ will now match the beginning of
lines. Unfortunately, because perl doesn't use $/ in determining where
lines break using $ to find the end of a line frequently doesn't work. This
is because your terminal is returning "\r\n" at the end of every line. One
way to check for a pattern at the end of a line would be to use \r?$ instead
of $.

Example: Spawning telnet to a host, you might look for the escape
character.  telnet would return to you "\r\nEscape character is
'^]'.\r\n". To find this you might use $match='^Escape char.*\.\r?$';

  $telnet->expect(10,'-re',$match);

=item New more Tcl/Expect-like interface

  expect($timeout,
       '-i', [ $obj1, $obj2, ... ],
             [ $re_pattern, sub { ...; exp_continue; }, @subparms, ],
             [ 'eof', sub { ... } ],
             [ 'timeout', sub { ... }, \$subparm1 ],
       '-i', [ $objn, ...],
       '-ex', $exact_pattern, sub { ... },
              $exact_pattern, sub { ...; exp_continue_timeout; },
       '-re', $re_pattern, sub { ... },
       '-i', \@object_list, @pattern_list,
       ...);


It's now possible to expect on more than one connection at a time by
specifying 'C<-i>' and a single Expect object or a ref to an array
containing Expect objects, e.g.

 expect($timeout,
        '-i', $exp1, @patterns_1,
        '-i', [ $exp2, $exp3 ], @patterns_2_3,
       )

Furthermore, patterns can now be specified as array refs containing
[$regexp, sub { ...}, @optional_subprams] . When the pattern matches,
the subroutine is called with parameters ($matched_expect_obj,
@optional_subparms). The subroutine can return the symbol
`exp_continue' to continue the expect matching with timeout starting
anew or return the symbol `exp_continue_timeout' for continuing expect
without resetting the timeout count.

 $exp->expect($timeout,
              [ qr/username: /i, sub { my $self = shift;
                                       $self->send("$username\n");
                                       exp_continue; }],
              [ qr/password: /i, sub { my $self = shift;
                                       $self->send("$password\n");
                                       exp_continue; }],
             $shell_prompt);


`expect' is now exported by default.

=back

=item $object->exp_before() I<or>

=item $object->before()

before() returns the 'before' part of the last expect() call. If the last
expect() call didn't match anything, exp_before() will return the entire
output of the object accumulated before the expect() call finished.

Note that this is something different than Tcl Expects before()!!


=item $object->exp_after() I<or>

=item $object->after()

returns the 'after' part of the last expect() call. If the last
expect() call didn't match anything, exp_after() will return undef().


=item $object->exp_match() I<or>

=item $object->match()

returns the string matched by the last expect() call, undef if
no string was matched.


=item $object->exp_match_number() I<or>

=item $object->match_number()

exp_match_number() returns the number of the pattern matched by the last
expect() call. Keep in mind that the first pattern in a list of patterns is 1,
not 0. Returns undef if no pattern was matched.


=item $object->exp_matchlist() I<or>

=item $object->matchlist()

exp_matchlist() returns a list of matched substrings from the brackets
() inside the regexp that last matched. ($object->matchlist)[0]
thus corresponds to $1, ($object->matchlist)[1] to $2, etc.


=item $object->exp_error() I<or>

=item $object->error()

exp_error() returns the error generated by the last expect() call if
no pattern was matched. It is typically useful to examine the value returned by
before() to find out what the output of the object was in determining
why it didn't match any of the patterns.


=item $object->clear_accum()

Clear the contents of the accumulator for $object. This gets rid of
any residual contents of a handle after expect() or send_slow() such
that the next expect() call will only see new data from $object. The
contents of the accumulator are returned.


=item $object->set_accum($value)

Sets the content of the accumulator for $object to $value. The
previous content of the accumulator is returned.


=item $object->exp_command() I<or>

=item $object->command()

exp_command() returns the string that was used to spawn the command. Helpful
for debugging and for reused patternmatch subroutines.


=item $object->exp_exitstatus() I<or>

=item $object->exitstatus()

Returns the exit status of $object (if it already exited).


=item $object->exp_pty_handle() I<or>

=item $object->pty_handle()

Returns a string representation of the attached pty, for example:
`spawn id(5)' (pty has fileno 5), `handle id(7)' (pty was initialized
from fileno 7) or `STDIN'. Useful for debugging.


=item $object->restart_timeout_upon_receive(0 | 1)

If this is set to 1, the expect timeout is retriggered whenever something
is received from the spawned command.  This allows to perform some
aliveness testing and still expect for patterns.

    $exp->restart_timeout_upon_receive(1);
    $exp->expect($timeout,
                 [ timeout => \&report_timeout ],
                 [ qr/pattern/ => \&handle_pattern],
                );

Now the timeout isn't triggered if the command produces any kind of output,
i.e. is still alive, but you can act upon patterns in the output.


=item $object->notransfer(1 | 0)

Do not truncate the content of the accumulator after a match.
Normally, the accumulator is set to the remains that come after the
matched string.  Note that this setting is per object and not per
pattern, so if you want to have normal acting patterns that truncate
the accumulator, you have to add a

    $exp->set_accum($exp->after);

to their callback, e.g.

    $exp->notransfer(1);
    $exp->expect($timeout,
                 # accumulator not truncated, pattern1 will match again
                 [ "pattern1" => sub { my $self = shift;
                                       ...
                                     } ],
                 # accumulator truncated, pattern2 will not match again
                 [ "pattern2" => sub { my $self = shift;
                                       ...
                                       $self->set_accum($self->after());
                                     } ],
                );

This is only a temporary fix until I can rewrite the pattern matching
part so it can take that additional -notransfer argument.


=item Expect::interconnect(@objects);

Read from @objects and print to their @listen_groups until an escape sequence
is matched from one of @objects and the associated function returns 0 or undef.
The special escape sequence 'EOF' is matched when an object's handle returns
an end of file. Note that it is not necessary to include objects that only
accept data in @objects since the escape sequence is _read_ from an object.
Further note that the listen_group for a write-only object is always empty.
Why would you want to have objects listening to STDOUT (for example)?
By default every member of @objects _as well as every member of its listen
group_ will be set to 'raw -echo' for the duration of interconnection.
Setting $object->manual_stty() will stop this behavior per object.
The original tty settings will be restored as interconnect exits.

For a generic way to interconnect processes, take a look at L<IPC::Run>.


=item Expect::test_handles(@objects)

Given a set of objects determines which objects' handles have data ready
to be read. B<Returns an array> who's members are positions in @objects that
have ready handles. Returns undef if there are no such handles ready.


=item Expect::version($version_requested or undef);

Returns current version of Expect. As of .99 earlier versions are not
supported. Too many things were changed to make versioning possible.


=item $object->interact( C<\*FILEHANDLE, $escape_sequence>)

interact() is essentially a macro for calling interconnect() for
connecting 2 processes together. \*FILEHANDLE defaults to \*STDIN and
$escape_sequence defaults to undef. Interaction ceases when $escape_sequence
is read from B<FILEHANDLE>, not $object. $object's listen group will
consist solely of \*FILEHANDLE for the duration of the interaction.
\*FILEHANDLE will not be echoed on STDOUT.


=item $object->log_group(0 | 1 | undef)

Set/unset logging of $object to its 'listen group'. If set all objects
in the listen group will have output from $object printed to them during
$object->expect(), $object->send_slow(), and C<Expect::interconnect($object
, ...)>. Default value is on. During creation of $object the setting will
match the value of $Expect::Log_Group, normally 1.


=item $object->log_user(0 | 1 | undef) I<or>

=item $object->log_stdout(0 | 1 | undef)

Set/unset logging of object's handle to STDOUT. This corresponds to Tcl's
log_user variable. Returns current setting if called without parameters.
Default setting is off for initialized handles.  When a process object is
created (not a filehandle initialized with exp_init) the log_stdout setting
will match the value of $Expect::Log_Stdout variable, normally 1.
If/when you initialize STDIN it is usually associated with a tty which
will by default echo to STDOUT anyway, so be careful or you will have
multiple echoes.


=item $object->log_file("filename" | $filehandle | \&coderef | undef)

Log session to a file.  All characters send to or received from the
spawned process are written to the file.  Normally appends to the
logfile, but you can pass an additional mode of "w" to truncate the
file upon open():

  $object->log_file("filename", "w");

Returns the logfilehandle.

If called with an undef value, stops logging and closes logfile:

  $object->log_file(undef);

If called without argument, returns the logfilehandle:

  $fh = $object->log_file();

Can be set to a code ref, which will be called instead of printing
to the logfile:

  $object->log_file(\&myloggerfunc);


=item $object->print_log_file(@strings)

Prints to logfile (if opened) or calls the logfile hook function.
This allows the user to add arbitrary text to the logfile.  Note that
this could also be done as $object->log_file->print() but would only
work for log files, not code hooks.


=item $object->set_seq($sequence, \&function, \@function_parameters)

During Expect->interconnect() if $sequence is read from $object &function
will be executed with parameters @function_parameters. It is B<_highly
recommended_> that the escape sequence be a single character since the
likelihood is great that the sequence will be broken into to separate reads
from the $object's handle, making it impossible to strip $sequence from
getting printed to $object's listen group. \&function should be something
like 'main::control_w_function' and @function_parameters should be an
array defined by the caller, passed by reference to set_seq().
Your function should return a non-zero value if execution of interconnect()
is to resume after the function returns, zero or undefined if interconnect()
should return after your function returns.
The special sequence 'EOF' matches the end of file being reached by $object.
See interconnect() for details.


=item $object->set_group(@listener_objects)

@listener_objects is the list of objects that should have their handles
printed to by $object when Expect::interconnect, $object->expect() or
$object->send_slow() are called. Calling w/out parameters will return
the current list of the listener objects.


=item $object->manual_stty(0 | 1 | undef)

Sets/unsets whether or not Expect should make reasonable guesses as to
when and how to set tty parameters for $object. Will match
$Expect::Manual_Stty value (normally 0) when $object is created. If called
without parameters manual_stty() will return the current manual_stty setting.


=item $object->match_max($maximum_buffer_length | undef) I<or>

=item $object->max_accum($maximum_buffer_length | undef)

Set the maximum accumulator size for object. This is useful if you think
that the accumulator will grow out of hand during expect() calls. Since
the buffer will be matched by every match_pattern it may get slow if the
buffer gets too large. Returns current value if called without parameters.
Not defined by default.


=item $object->notransfer(0 | 1)

If set, matched strings will not be deleted from the accumulator.
Returns current value if called without parameters.  False by default.


=item $object->exp_pid() I<or>

=item $object->pid()

Return pid of $object, if one exists. Initialized filehandles will not have
pids (of course).


=item $object->send_slow($delay, @strings);

print each character from each string of @strings one at a time with $delay
seconds before each character. This is handy for devices such as modems
that can be annoying if you send them data too fast. After each character
$object will be checked to determine whether or not it has any new data ready
and if so update the accumulator for future expect() calls and print the
output to STDOUT and @listen_group if log_stdout and log_group are
appropriately set.

=back

=head2 Configurable Package Variables:

=over 4

=item $Expect::Debug

Defaults to 0. Newly created objects have a $object->debug() value
of $Expect::Debug. See $object->debug();

=item $Expect::Do_Soft_Close

Defaults to 0. When destroying objects, soft_close may take up to half
a minute to shut everything down.  From now on, only hard_close will
be called, which is less polite but still gives the process a chance
to terminate properly.  Set this to '1' for old behaviour.

=item $Expect::Exp_Internal

Defaults to 0. Newly created objects have a $object->exp_internal()
value of $Expect::Exp_Internal. See $object->exp_internal().

=item $Expect::IgnoreEintr

Defaults to 0. If set to 1, when waiting for new data, Expect will
ignore EINTR errors and restart the select() call instead.

=item $Expect::Log_Group

Defaults to 1. Newly created objects have a $object->log_group()
value of $Expect::Log_Group. See $object->log_group().

=item $Expect::Log_Stdout

Defaults to 1 for spawned commands, 0 for file handles
attached with exp_init(). Newly created objects have a
$object->log_stdout() value of $Expect::Log_Stdout. See
$object->log_stdout().

=item $Expect::Manual_Stty

Defaults to 0. Newly created objects have a $object->manual_stty()
value of $Expect::Manual_Stty. See $object->manual_stty().

=item $Expect::Multiline_Matching

Defaults to 1. Affects whether or not expect() uses the /m flag for
doing regular expression matching. If set to 1 /m is used.

This makes a difference when you are trying to match ^ and $. If
you have this on you can match lines in the middle of a page of output
using ^ and $ instead of it matching the beginning and end of the entire
expression. I think this is handy.

The $Expect::Multiline_Matching turns on and off Expect's multi-line
matching mode. But this only has an effect if you pass in a string, and
then use '-re' mode. If you pass in a regular expression value (via
qr//), then the qr//'s own flags are preserved irrespective of what it
gets interpolated into. There was a bug in Perl 5.8.x where interpolating
a regex without /m into a match with /m would incorrectly apply the /m
to the inner regex too, but this was fixed in Perl 5.10. The correct
behavior, as seen in Perl 5.10, is that if you pass in a regex (via
qr//), then $Expect::Multiline_Matching has no effect. 
So if you pass in a regex, then you must use the qr's flags
to control whether it is multiline (which by default it is not, opposite
of the default behavior of Expect).

=back

=head1 CONTRIBUTIONS

Lee Eakin <leakin@japh.itg.ti.com> has ported the kibitz script
from Tcl/Expect to Perl/Expect.

Jeff Carr <jcarr@linuxmachines.com> provided a simple example of how
handle terminal window resize events (transmitted via the WINCH
signal) in a ssh session.

You can find both scripts in the examples/ subdir.  Thanks to both!

Historical notes:

There are still a few lines of code dating back to the inspirational
Comm.pl and Chat.pl modules without which this would not have been possible.
Kudos to Eric Arnold <Eric.Arnold@Sun.com> and Randal 'Nuke your NT box with
one line of perl code' Schwartz<merlyn@stonehenge.com> for making these
available to the perl public.

As of .98 I think all the old code is toast. No way could this have been done
without it though. Special thanks to Graham Barr for helping make sense of
the IO::Handle stuff as well as providing the highly recommended IO::Tty
module.


=head1 REFERENCES

Mark Rogaski <rogaski@att.com> wrote:

"I figured that you'd like to know that Expect.pm has been very
useful to AT&T Labs over the past couple of years (since I first talked to
Austin about design decisions). We use Expect.pm for managing
the switches in our network via the telnet interface, and such automation
has significantly increased our reliability. So, you can honestly say that
one of the largest digital networks in existence (AT&T Frame Relay) uses
Expect.pm quite extensively."


=head1 FAQ - Frequently Asked Questions

This is a growing collection of things that might help.
Please send you questions that are not answered here to
RGiersig@cpan.org


=head2 What systems does Expect run on?

Expect itself doesn't have real system dependencies, but the underlying
IO::Tty needs pseudoterminals. IO::Stty uses POSIX.pm and Fcntl.pm.

I have used it on Solaris, Linux and AIX, others report *BSD and OSF
as working.  Generally, any modern POSIX Unix should do, but there
are exceptions to every rule.  Feedback is appreciated.

See L<IO::Tty> for a list of verified systems.


=head2 Can I use this module with ActivePerl on Windows?

Up to now, the answer was 'No', but this has changed.

You still cannot use ActivePerl, but if you use the Cygwin environment
(http://sources.redhat.com), which brings its own perl, and have
the latest IO::Tty (v0.05 or later) installed, it should work (feedback
appreciated).


=head2 The examples in the tutorial don't work!

The tutorial is hopelessly out of date and needs a serious overhaul.
I apologize for this, I have concentrated my efforts mainly on the
functionality.  Volunteers welcomed.


=head2 How can I find out what Expect is doing?

If you set

  $Expect::Exp_Internal = 1;

Expect will tell you very verbosely what it is receiving and sending,
what matching it is trying and what it found.  You can do this on a
per-command base with

  $exp->exp_internal(1);

You can also set

  $Expect::Debug = 1;  # or 2, 3 for more verbose output

or

  $exp->debug(1);

which gives you even more output.


=head2 I am seeing the output of the command I spawned.  Can I turn that off?

Yes, just set

  $Expect::Log_Stdout = 0;

to globally disable it or

   $exp->log_stdout(0);

for just that command.  'log_user' is provided as an alias so
Tcl/Expect user get a DWIM experience... :-)


=head2 No, I mean that when I send some text to the spawned process, it gets echoed back and I have to deal with it in the next expect.

This is caused by the pty, which has probably 'echo' enabled.  A
solution would be to set the pty to raw mode, which in general is
cleaner for communication between two programs (no more unexpected
character translations).  Unfortunately this would break a lot of old
code that sends "\r" to the program instead of "\n" (translating this
is also handled by the pty), so I won't add this to Expect just like that.
But feel free to experiment with C<$exp-E<gt>raw_pty(1)>.


=head2 How do I send control characters to a process?

A: You can send any characters to a process with the print command. To
represent a control character in Perl, use \c followed by the letter. For
example, control-G can be represented with "\cG" . Note that this will not
work if you single-quote your string. So, to send control-C to a process in
$exp, do:

  print $exp "\cC";

Or, if you prefer:

  $exp->send("\cC");

The ability to include control characters in a string like this is provided
by Perl, not by Expect.pm . Trying to learn Expect.pm without a thorough
grounding in Perl can be very daunting. We suggest you look into some of
the excellent Perl learning material, such as the books _Programming Perl_
and _Learning Perl_ by O'Reilly, as well as the extensive online Perl
documentation available through the perldoc command.


=head2 My script fails from time to time without any obvious reason.  It seems that I am sometimes loosing output from the spawned program.

You could be exiting too fast without giving the spawned program
enough time to finish.  Try adding $exp->soft_close() to terminate the
program gracefully or do an expect() for 'eof'.

Alternatively, try adding a 'sleep 1' after you spawn() the program.
It could be that pty creation on your system is just slow (but this is
rather improbable if you are using the latest IO-Tty).


=head2 I want to automate password entry for su/ssh/scp/rsh/...

You shouldn't use Expect for this.  Putting passwords, especially
root passwords, into scripts in clear text can mean severe security
problems.  I strongly recommend using other means.  For 'su', consider
switching to 'sudo', which gives you root access on a per-command and
per-user basis without the need to enter passwords.  'ssh'/'scp' can be
set up with RSA authentication without passwords.  'rsh' can use
the .rhost mechanism, but I'd strongly suggest to switch to 'ssh'; to
mention 'rsh' and 'security' in the same sentence makes an oxymoron.

It will work for 'telnet', though, and there are valid uses for it,
but you still might want to consider using 'ssh', as keeping cleartext
passwords around is very insecure.


=head2 I want to use Expect to automate [anything with a buzzword]...

Are you sure there is no other, easier way?  As a rule of thumb,
Expect is useful for automating things that expect to talk to a human,
where no formal standard applies.  For other tasks that do follow a
well-defined protocol, there are often better-suited modules that
already can handle those protocols.  Don't try to do HTTP requests by
spawning telnet to port 80, use LWP instead.  To automate FTP, take a
look at L<Net::FTP> or C<ncftp> (http://www.ncftp.org).  You don't use
a screwdriver to hammer in your nails either, or do you?


=head2 Is it possible to use threads with Expect?

Basically yes, with one restriction: you must spawn() your programs in
the main thread and then pass the Expect objects to the handling
threads. The reason is that spawn() uses fork(), and L<perlthrtut>:

  "Thinking of mixing fork() and threads?  Please lie down and wait until the feeling passes."


=head2 I want to log the whole session to a file.

Use

  $exp->log_file("filename");

or

  $exp->log_file($filehandle);

or even

  $exp->log_file(\&log_procedure);

for maximum flexibility.

Note that the logfile is appended to by default, but you can
specify an optional mode "w" to truncate the logfile:

  $exp->log_file("filename", "w");

To stop logging, just call it with a false argument:

  $exp->log_file(undef);


=head2 How can I turn off multi-line matching for my regexps?

To globally unset multi-line matching for all regexps:

  $Expect::Multiline_Matching = 0;

You can do that on a per-regexp basis by stating C<(?-m)> inside the regexp
(you need perl5.00503 or later for that).


=head2 How can I expect on multiple spawned commands?

You can use the B<-i> parameter to specify a single object or a list
of Expect objects.  All following patterns will be evaluated against
that list.

You can specify B<-i> multiple times to create groups of objects
and patterns to match against within the same expect statement.

This works just like in Tcl/Expect.

See the source example below.


=head2 I seem to have problems with ptys!

Well, pty handling is really a black magic, as it is extremely system
dependent.  I have extensively revised IO-Tty, so these problems
should be gone.

If your system is listed in the "verified" list of IO::Tty, you
probably have some non-standard setup, e.g. you compiled your
Linux-kernel yourself and disabled ptys.  Please ask your friendly
sysadmin for help.

If your system is not listed, unpack the latest version of IO::Tty,
do a 'perl Makefile.PL; make; make test; uname C<-a>' and send me the
results and I'll see what I can deduce from that.


=head2 I just want to read the output of a process without expect()ing anything. How can I do this?

[ Are you sure you need Expect for this?  How about qx() or open("prog|")? ]

By using expect without any patterns to match.

  $process->expect(undef); # Forever until EOF
  $process->expect($timeout); # For a few seconds
  $process->expect(0); # Is there anything ready on the handle now?


=head2 Ok, so now how do I get what was read on the handle?

  $read = $process->before();


=head2  Where's IO::Pty?

Find it on CPAN as IO-Tty, which provides both.


=head2 How come when I automate the passwd program to change passwords for me passwd dies before changing the password sometimes/every time?

What's happening is you are closing the handle before passwd exits.
When you close the handle to a process, it is sent a signal (SIGPIPE?)
telling it that STDOUT has gone away. The default behavior for
processes is to die in this circumstance. Two ways you can make this
not happen are:

  $process->soft_close();

This will wait 15 seconds for a process to come up with an EOF by
itself before killing it.

  $process->expect(undef);

This will wait forever for the process to match an empty set of
patterns. It will return when the process hits an EOF.

As a rule, you should always expect() the result of your transaction
before you continue with processing.


=head2 How come when I try to make a logfile with log_file() or set_group() it doesn't print anything after the last time I run expect()?

Output is only printed to the logfile/group when Expect reads from the
process, during expect(), send_slow() and interconnect().
One way you can force this is to make use of

  $process->expect(undef);

and

  $process->expect(0);

which will make expect() run with an empty pattern set forever or just
for an instant to capture the output of $process. The output is
available in the accumulator, so you can grab it using
$process->before().


=head2 I seem to have problems with terminal settings, double echoing, etc.

Tty settings are a major pain to keep track of. If you find unexpected
behavior such as double-echoing or a frozen session, doublecheck the
documentation for default settings. When in doubt, handle them
yourself using $exp->stty() and manual_stty() functions.  As of .98
you shouldn't have to worry about stty settings getting fouled unless
you use interconnect or intentionally change them (like doing -echo to
get a password).

If you foul up your terminal's tty settings, kill any hung processes
and enter 'stty sane' at a shell prompt. This should make your
terminal manageable again.

Note that IO::Tty returns ptys with your systems default setting
regarding echoing, CRLF translation etc. and Expect does not change
them.  I have considered setting the ptys to 'raw' without any
translation whatsoever, but this would break a lot of existing things,
as '\r' translation would not work anymore.  On the other hand, a raw
pty works much like a pipe and is more WYGIWYE (what you get is what
you expect), so I suggest you set it to 'raw' by yourself:

  $exp = Expect->new;
  $exp->raw_pty(1);
  $exp->spawn(...);

To disable echo:

  $exp->slave->stty(qw(-echo));


=head2 I'm spawning a telnet/ssh session and then let the user interact with it.  But screen-oriented applications on the other side don't work properly.

You have to set the terminal screen size for that.  Luckily, IO::Pty
already has a method for that, so modify your code to look like this:

  my $exp = Expect->new;
  $exp->slave->clone_winsize_from(\*STDIN);
  $exp->spawn("telnet somehost);

Also, some applications need the TERM shell variable set so they know
how to move the cursor across the screen.  When logging in, the remote
shell sends a query (Ctrl-Z I think) and expects the terminal to
answer with a string, e.g. 'xterm'.  If you really want to go that way
(be aware, madness lies at its end), you can handle that and send back
the value in $ENV{TERM}.  This is only a hand-waving explanation,
please figure out the details by yourself.


=head2 I set the terminal size as explained above, but if I resize the window, the application does not notice this.

You have to catch the signal WINCH ("window size changed"), change the
terminal size and propagate the signal to the spawned application:

  my $exp = Expect->new;
  $exp->slave->clone_winsize_from(\*STDIN);
  $exp->spawn("ssh somehost);
  $SIG{WINCH} = \&winch;

  sub winch {
    $exp->slave->clone_winsize_from(\*STDIN);
    kill WINCH => $exp->pid if $exp->pid;
    $SIG{WINCH} = \&winch;
  }

  $exp->interact();

There is an example file ssh.pl in the examples/ subdir that shows how
this works with ssh. Please note that I do strongly object against
using Expect to automate ssh login, as there are better way to do that
(see L<ssh-keygen>).

=head2 I noticed that the test uses a string that resembles, but not exactly matches, a well-known sentence that contains every character.  What does that mean?

That means you are anal-retentive. :-)  [Gotcha there!]


=head2 I get a "Could not assign a pty" error when running as a non-root user on an IRIX box?

The OS may not be configured to grant additional pty's (pseudo terminals)
to non-root users.  /usr/sbin/mkpts should be 4755, not 700 for this
to work.  I don't know about security implications if you do this.


=head2 How come I don't notice when the spawned process closes its stdin/out/err??

You are probably on one of the systems where the master doesn't get an
EOF when the slave closes stdin/out/err.

One possible solution is when you spawn a process, follow it with a
unique string that would indicate the process is finished.

  $process = Expect->spawn('telnet somehost; echo ____END____');

And then $process->expect($timeout,'____END____','other','patterns');


=head1 Source Examples


=head2 How to automate login

  my $telnet = Net::Telnet->new("remotehost") # see Net::Telnet
    or die "Cannot telnet to remotehost: $!\n";;
  my $exp = Expect->exp_init($telnet);

  # deprecated use of spawned telnet command
  # my $exp = Expect->spawn("telnet localhost")
  #   or die "Cannot spawn telnet: $!\n";;

  my $spawn_ok;
  $exp->expect($timeout,
           [
        qr'login: $',
        sub {
                  $spawn_ok = 1;
          my $fh = shift;
          $fh->send("$username\n");
                  exp_continue;
        }
           ],
           [
        'Password: $',
        sub {
          my $fh = shift;
          print $fh "$password\n";
                  exp_continue;
        }
           ],
           [
        eof =>
        sub {
                  if ($spawn_ok) {
            die "ERROR: premature EOF in login.\n";
                  } else {
            die "ERROR: could not spawn telnet.\n";
                  }
        }
           ],
           [
        timeout =>
        sub {
          die "No login.\n";
        }
           ],
           '-re', qr'[#>:] $', #' wait for shell prompt, then exit expect
          );


=head2 How to expect on multiple spawned commands

  foreach my $cmd (@list_of_commands) {
    push @commands, Expect->spawn($cmd);
  }

  expect($timeout,
     '-i', \@commands,
     [
      qr"pattern",        # find this pattern in output of all commands
      sub {
        my $obj = shift;    # object that matched
        print $obj "something\n";
        exp_continue;    # we don't want to terminate the expect call
      }
     ],
     '-i', $some_other_command,
     [
      "some other pattern",
      sub {
        my ($obj, $parmref) = @_;
        # ...

        # now we exit the expect command
      },
      \$parm
     ],
    );


=head2 How to propagate terminal sizes

  my $exp = Expect->new;
  $exp->slave->clone_winsize_from(\*STDIN);
  $exp->spawn("ssh somehost);
  $SIG{WINCH} = \&winch;

  sub winch {
    $exp->slave->clone_winsize_from(\*STDIN);
    kill WINCH => $exp->pid if $exp->pid;
    $SIG{WINCH} = \&winch;
  }

  $exp->interact();

=head1 HOMEPAGE

L<http://sourceforge.net/projects/expectperl/> though the source code is now in GitHub: L<https://github.com/jacoby/expect.pm>


=head1 MAILING LISTS

There are two mailing lists available, expectperl-announce and
expectperl-discuss, at

  http://lists.sourceforge.net/lists/listinfo/expectperl-announce

and

  http://lists.sourceforge.net/lists/listinfo/expectperl-discuss


=head1 BUG TRACKING

You can use the CPAN Request Tracker http://rt.cpan.org/ and submit
new bugs under

  http://rt.cpan.org/Ticket/Create.html?Queue=Expect


=head1 AUTHORS

(c) 1997 Austin Schutz E<lt>F<ASchutz@users.sourceforge.net>E<gt> (retired)

expect() interface & functionality enhancements (c) 1999-2006 Roland Giersig.

This module is now maintained by Dave Jacoby E<lt>F<jacoby@cpan.org>E<gt>

=head1 LICENSE

This module can be used under the same terms as Perl.


=head1 DISCLAIMER

THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR
TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
DAMAGE.

In other words: Use at your own risk.  Provided as is.  Your mileage
may vary.  Read the source, Luke!

And finally, just to be sure:

Any Use of This Product, in Any Manner Whatsoever, Will Increase the
Amount of Disorder in the Universe. Although No Liability Is Implied
Herein, the Consumer Is Warned That This Process Will Ultimately Lead
to the Heat Death of the Universe.

=cut
PK       ! �~� "   "    perl5/Parse/CPAN/Meta.pmnu ��6�$        use 5.008001;
use strict;
package Parse::CPAN::Meta;
# ABSTRACT: Parse META.yml and META.json CPAN metadata files
our $VERSION = '1.4414'; # VERSION

use Exporter;
use Carp 'croak';

our @ISA = qw/Exporter/;
our @EXPORT_OK = qw/Load LoadFile/;

sub load_file {
  my ($class, $filename) = @_;

  my $meta = _slurp($filename);

  if ($filename =~ /\.ya?ml$/) {
    return $class->load_yaml_string($meta);
  }
  elsif ($filename =~ /\.json$/) {
    return $class->load_json_string($meta);
  }
  else {
    $class->load_string($meta); # try to detect yaml/json
  }
}

sub load_string {
  my ($class, $string) = @_;
  if ( $string =~ /^---/ ) { # looks like YAML
    return $class->load_yaml_string($string);
  }
  elsif ( $string =~ /^\s*\{/ ) { # looks like JSON
    return $class->load_json_string($string);
  }
  else { # maybe doc-marker-free YAML
    return $class->load_yaml_string($string);
  }
}

sub load_yaml_string {
  my ($class, $string) = @_;
  my $backend = $class->yaml_backend();
  my $data = eval { no strict 'refs'; &{"$backend\::Load"}($string) };
  croak $@ if $@;
  return $data || {}; # in case document was valid but empty
}

sub load_json_string {
  my ($class, $string) = @_;
  my $data = eval { $class->json_backend()->new->decode($string) };
  croak $@ if $@;
  return $data || {};
}

sub yaml_backend {
  if (! defined $ENV{PERL_YAML_BACKEND} ) {
    _can_load( 'CPAN::Meta::YAML', 0.011 )
      or croak "CPAN::Meta::YAML 0.011 is not available\n";
    return "CPAN::Meta::YAML";
  }
  else {
    my $backend = $ENV{PERL_YAML_BACKEND};
    _can_load( $backend )
      or croak "Could not load PERL_YAML_BACKEND '$backend'\n";
    $backend->can("Load")
      or croak "PERL_YAML_BACKEND '$backend' does not implement Load()\n";
    return $backend;
  }
}

sub json_backend {
  if (! $ENV{PERL_JSON_BACKEND} or $ENV{PERL_JSON_BACKEND} eq 'JSON::PP') {
    _can_load( 'JSON::PP' => 2.27103 )
      or croak "JSON::PP 2.27103 is not available\n";
    return 'JSON::PP';
  }
  else {
    _can_load( 'JSON' => 2.5 )
      or croak  "JSON 2.5 is required for " .
                "\$ENV{PERL_JSON_BACKEND} = '$ENV{PERL_JSON_BACKEND}'\n";
    return "JSON";
  }
}

sub _slurp {
  require Encode;
  open my $fh, "<:raw", "$_[0]" ## no critic
    or die "can't open $_[0] for reading: $!";
  my $content = do { local $/; <$fh> };
  $content = Encode::decode('UTF-8', $content, Encode::PERLQQ());
  return $content;
}
  
sub _can_load {
  my ($module, $version) = @_;
  (my $file = $module) =~ s{::}{/}g;
  $file .= ".pm";
  return 1 if $INC{$file};
  return 0 if exists $INC{$file}; # prior load failed
  eval { require $file; 1 }
    or return 0;
  if ( defined $version ) {
    eval { $module->VERSION($version); 1 }
      or return 0;
  }
  return 1;
}

# Kept for backwards compatibility only
# Create an object from a file
sub LoadFile ($) {
  return Load(_slurp(shift));
}

# Parse a document from a string.
sub Load ($) {
  require CPAN::Meta::YAML;
  my $object = eval { CPAN::Meta::YAML::Load(shift) };
  croak $@ if $@;
  return $object;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Parse::CPAN::Meta - Parse META.yml and META.json CPAN metadata files

=head1 VERSION

version 1.4414

=head1 SYNOPSIS

    #############################################
    # In your file
    
    ---
    name: My-Distribution
    version: 1.23
    resources:
      homepage: "http://example.com/dist/My-Distribution"
    
    
    #############################################
    # In your program
    
    use Parse::CPAN::Meta;
    
    my $distmeta = Parse::CPAN::Meta->load_file('META.yml');
    
    # Reading properties
    my $name     = $distmeta->{name};
    my $version  = $distmeta->{version};
    my $homepage = $distmeta->{resources}{homepage};

=head1 DESCRIPTION

B<Parse::CPAN::Meta> is a parser for F<META.json> and F<META.yml> files, using
L<JSON::PP> and/or L<CPAN::Meta::YAML>.

B<Parse::CPAN::Meta> provides three methods: C<load_file>, C<load_json_string>,
and C<load_yaml_string>.  These will read and deserialize CPAN metafiles, and
are described below in detail.

B<Parse::CPAN::Meta> provides a legacy API of only two functions,
based on the YAML functions of the same name. Wherever possible,
identical calling semantics are used.  These may only be used with YAML sources.

All error reporting is done with exceptions (die'ing).

Note that META files are expected to be in UTF-8 encoding, only.  When
converted string data, it must first be decoded from UTF-8.

=begin Pod::Coverage


=end Pod::Coverage

=head1 METHODS

=head2 load_file

  my $metadata_structure = Parse::CPAN::Meta->load_file('META.json');

  my $metadata_structure = Parse::CPAN::Meta->load_file('META.yml');

This method will read the named file and deserialize it to a data structure,
determining whether it should be JSON or YAML based on the filename.
The file will be read using the ":utf8" IO layer.

=head2 load_yaml_string

  my $metadata_structure = Parse::CPAN::Meta->load_yaml_string($yaml_string);

This method deserializes the given string of YAML and returns the first
document in it.  (CPAN metadata files should always have only one document.)
If the source was UTF-8 encoded, the string must be decoded before calling
C<load_yaml_string>.

=head2 load_json_string

  my $metadata_structure = Parse::CPAN::Meta->load_json_string($json_string);

This method deserializes the given string of JSON and the result.  
If the source was UTF-8 encoded, the string must be decoded before calling
C<load_json_string>.

=head2 load_string

  my $metadata_structure = Parse::CPAN::Meta->load_string($some_string);

If you don't know whether a string contains YAML or JSON data, this method
will use some heuristics and guess.  If it can't tell, it assumes YAML.

=head2 yaml_backend

  my $backend = Parse::CPAN::Meta->yaml_backend;

Returns the module name of the YAML serializer. See L</ENVIRONMENT>
for details.

=head2 json_backend

  my $backend = Parse::CPAN::Meta->json_backend;

Returns the module name of the JSON serializer.  This will either
be L<JSON::PP> or L<JSON>.  Even if C<PERL_JSON_BACKEND> is set,
this will return L<JSON> as further delegation is handled by
the L<JSON> module.  See L</ENVIRONMENT> for details.

=head1 FUNCTIONS

For maintenance clarity, no functions are exported by default.  These functions
are available for backwards compatibility only and are best avoided in favor of
C<load_file>.

=head2 Load

  my @yaml = Parse::CPAN::Meta::Load( $string );

Parses a string containing a valid YAML stream into a list of Perl data
structures.

=head2 LoadFile

  my @yaml = Parse::CPAN::Meta::LoadFile( 'META.yml' );

Reads the YAML stream from a file instead of a string.

=head1 ENVIRONMENT

=head2 PERL_JSON_BACKEND

By default, L<JSON::PP> will be used for deserializing JSON data. If the
C<PERL_JSON_BACKEND> environment variable exists, is true and is not
"JSON::PP", then the L<JSON> module (version 2.5 or greater) will be loaded and
used to interpret C<PERL_JSON_BACKEND>.  If L<JSON> is not installed or is too
old, an exception will be thrown.

=head2 PERL_YAML_BACKEND

By default, L<CPAN::Meta::YAML> will be used for deserializing YAML data. If
the C<PERL_YAML_BACKEND> environment variable is defined, then it is interpreted
as a module to use for deserialization.  The given module must be installed,
must load correctly and must implement the C<Load()> function or an exception
will be thrown.

=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan

=head1 SUPPORT

=head2 Bugs / Feature Requests

Please report any bugs or feature requests through the issue tracker
at L<http://rt.cpan.org/Public/Dist/Display.html?Name=Parse-CPAN-Meta>.
You will be notified automatically of any progress on your issue.

=head2 Source Code

This is open source software.  The code repository is available for
public review and contribution under the terms of the license.

L<https://github.com/Perl-Toolchain-Gang/Parse-CPAN-Meta>

  git clone https://github.com/Perl-Toolchain-Gang/Parse-CPAN-Meta.git

=head1 AUTHORS

=over 4

=item *

Adam Kennedy <adamk@cpan.org>

=item *

David Golden <dagolden@cpan.org>

=back

=head1 CONTRIBUTORS

=over 4

=item *

Graham Knop <haarg@haarg.org>

=item *

Joshua ben Jore <jjore@cpan.org>

=item *

Neil Bowers <neil@bowers.com>

=item *

Ricardo Signes <rjbs@cpan.org>

=item *

Steffen Mueller <smueller@cpan.org>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2014 by Adam Kennedy and Contributors.

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

=cut
PK       ! �sI�C  �C    perl5/Net/HTTP/Methods.pmnu ��6�$        package Net::HTTP::Methods;
our $VERSION = '6.19';
use strict;
use warnings;
use URI;

my $CRLF = "\015\012";   # "\r\n" is not portable

*_bytes = defined(&utf8::downgrade) ?
    sub {
        unless (utf8::downgrade($_[0], 1)) {
            require Carp;
            Carp::croak("Wide character in HTTP request (bytes required)");
        }
        return $_[0];
    }
    :
    sub {
        return $_[0];
    };


sub new {
    my $class = shift;
    unshift(@_, "Host") if @_ == 1;
    my %cnf = @_;
    require Symbol;
    my $self = bless Symbol::gensym(), $class;
    return $self->http_configure(\%cnf);
}

sub http_configure {
    my($self, $cnf) = @_;

    die "Listen option not allowed" if $cnf->{Listen};
    my $explicit_host = (exists $cnf->{Host});
    my $host = delete $cnf->{Host};
    my $peer = $cnf->{PeerAddr} || $cnf->{PeerHost};
    if (!$peer) {
	die "No Host option provided" unless $host;
	$cnf->{PeerAddr} = $peer = $host;
    }

    # CONNECTIONS
    # PREFER: port number from PeerAddr, then PeerPort, then http_default_port
    my $peer_uri = URI->new("http://$peer");
    $cnf->{"PeerPort"} =  $peer_uri->_port || $cnf->{PeerPort} ||  $self->http_default_port;
    $cnf->{"PeerAddr"} = $peer_uri->host;

    # HOST header:
    # If specified but blank, ignore.
    # If specified with a value, add the port number
    # If not specified, set to PeerAddr and port number
    # ALWAYS: If IPv6 address, use [brackets]  (thanks to the URI package)
    # ALWAYS: omit port number if http_default_port
    if (($host) || (! $explicit_host)) {
        my $uri =  ($explicit_host) ? URI->new("http://$host") : $peer_uri->clone;
        if (!$uri->_port) {
            # Always use *our*  $self->http_default_port  instead of URI's  (Covers HTTP, HTTPS)
            $uri->port( $cnf->{PeerPort} ||  $self->http_default_port);
        }
        my $host_port = $uri->host_port;               # Returns host:port or [ipv6]:port
        my $remove = ":" . $self->http_default_port;   # we want to remove the default port number
        if (substr($host_port,0-length($remove)) eq $remove) {
            substr($host_port,0-length($remove)) = "";
        }
        $host = $host_port;
    }

    $cnf->{Proto} = 'tcp';

    my $keep_alive = delete $cnf->{KeepAlive};
    my $http_version = delete $cnf->{HTTPVersion};
    $http_version = "1.1" unless defined $http_version;
    my $peer_http_version = delete $cnf->{PeerHTTPVersion};
    $peer_http_version = "1.0" unless defined $peer_http_version;
    my $send_te = delete $cnf->{SendTE};
    my $max_line_length = delete $cnf->{MaxLineLength};
    $max_line_length = 8*1024 unless defined $max_line_length;
    my $max_header_lines = delete $cnf->{MaxHeaderLines};
    $max_header_lines = 128 unless defined $max_header_lines;

    return undef unless $self->http_connect($cnf);

    $self->host($host);
    $self->keep_alive($keep_alive);
    $self->send_te($send_te);
    $self->http_version($http_version);
    $self->peer_http_version($peer_http_version);
    $self->max_line_length($max_line_length);
    $self->max_header_lines($max_header_lines);

    ${*$self}{'http_buf'} = "";

    return $self;
}

sub http_default_port {
    80;
}

# set up property accessors
for my $method (qw(host keep_alive send_te max_line_length max_header_lines peer_http_version)) {
    my $prop_name = "http_" . $method;
    no strict 'refs';
    *$method = sub {
	my $self = shift;
	my $old = ${*$self}{$prop_name};
	${*$self}{$prop_name} = shift if @_;
	return $old;
    };
}

# we want this one to be a bit smarter
sub http_version {
    my $self = shift;
    my $old = ${*$self}{'http_version'};
    if (@_) {
	my $v = shift;
	$v = "1.0" if $v eq "1";  # float
	unless ($v eq "1.0" or $v eq "1.1") {
	    require Carp;
	    Carp::croak("Unsupported HTTP version '$v'");
	}
	${*$self}{'http_version'} = $v;
    }
    $old;
}

sub format_request {
    my $self = shift;
    my $method = shift;
    my $uri = shift;

    my $content = (@_ % 2) ? pop : "";

    for ($method, $uri) {
	require Carp;
	Carp::croak("Bad method or uri") if /\s/ || !length;
    }

    push(@{${*$self}{'http_request_method'}}, $method);
    my $ver = ${*$self}{'http_version'};
    my $peer_ver = ${*$self}{'http_peer_http_version'} || "1.0";

    my @h;
    my @connection;
    my %given = (host => 0, "content-length" => 0, "te" => 0);
    while (@_) {
	my($k, $v) = splice(@_, 0, 2);
	my $lc_k = lc($k);
	if ($lc_k eq "connection") {
	    $v =~ s/^\s+//;
	    $v =~ s/\s+$//;
	    push(@connection, split(/\s*,\s*/, $v));
	    next;
	}
	if (exists $given{$lc_k}) {
	    $given{$lc_k}++;
	}
	push(@h, "$k: $v");
    }

    if (length($content) && !$given{'content-length'}) {
	push(@h, "Content-Length: " . length($content));
    }

    my @h2;
    if ($given{te}) {
	push(@connection, "TE") unless grep lc($_) eq "te", @connection;
    }
    elsif ($self->send_te && gunzip_ok()) {
	# gzip is less wanted since the IO::Uncompress::Gunzip interface for
	# it does not really allow chunked decoding to take place easily.
	push(@h2, "TE: deflate,gzip;q=0.3");
	push(@connection, "TE");
    }

    unless (grep lc($_) eq "close", @connection) {
	if ($self->keep_alive) {
	    if ($peer_ver eq "1.0") {
		# from looking at Netscape's headers
		push(@h2, "Keep-Alive: 300");
		unshift(@connection, "Keep-Alive");
	    }
	}
	else {
	    push(@connection, "close") if $ver ge "1.1";
	}
    }
    push(@h2, "Connection: " . join(", ", @connection)) if @connection;
    unless ($given{host}) {
	my $h = ${*$self}{'http_host'};
	push(@h2, "Host: $h") if $h;
    }

    return _bytes(join($CRLF, "$method $uri HTTP/$ver", @h2, @h, "", $content));
}


sub write_request {
    my $self = shift;
    $self->print($self->format_request(@_));
}

sub format_chunk {
    my $self = shift;
    return $_[0] unless defined($_[0]) && length($_[0]);
    return _bytes(sprintf("%x", length($_[0])) . $CRLF . $_[0] . $CRLF);
}

sub write_chunk {
    my $self = shift;
    return 1 unless defined($_[0]) && length($_[0]);
    $self->print(_bytes(sprintf("%x", length($_[0])) . $CRLF . $_[0] . $CRLF));
}

sub format_chunk_eof {
    my $self = shift;
    my @h;
    while (@_) {
	push(@h, sprintf "%s: %s$CRLF", splice(@_, 0, 2));
    }
    return _bytes(join("", "0$CRLF", @h, $CRLF));
}

sub write_chunk_eof {
    my $self = shift;
    $self->print($self->format_chunk_eof(@_));
}


sub my_read {
    die if @_ > 3;
    my $self = shift;
    my $len = $_[1];
    for (${*$self}{'http_buf'}) {
	if (length) {
	    $_[0] = substr($_, 0, $len, "");
	    return length($_[0]);
	}
	else {
	    die "read timeout" unless $self->can_read;
	    return $self->sysread($_[0], $len);
	}
    }
}


sub my_readline {
    my $self = shift;
    my $what = shift;
    for (${*$self}{'http_buf'}) {
	my $max_line_length = ${*$self}{'http_max_line_length'};
	my $pos;
	while (1) {
	    # find line ending
	    $pos = index($_, "\012");
	    last if $pos >= 0;
	    die "$what line too long (limit is $max_line_length)"
		if $max_line_length && length($_) > $max_line_length;

	    # need to read more data to find a line ending
            my $new_bytes = 0;

          READ:
            {   # wait until bytes start arriving
                $self->can_read
                     or die "read timeout";

                # consume all incoming bytes
                my $bytes_read = $self->sysread($_, 1024, length);
                if(defined $bytes_read) {
                    $new_bytes += $bytes_read;
                }
                elsif($!{EINTR} || $!{EAGAIN} || $!{EWOULDBLOCK}) {
                    redo READ;
                }
                else {
                    # if we have already accumulated some data let's at
                    # least return that as a line
                    length or die "$what read failed: $!";
                }

                # no line-ending, no new bytes
                return length($_) ? substr($_, 0, length($_), "") : undef
                    if $new_bytes==0;
            }
	}
	die "$what line too long ($pos; limit is $max_line_length)"
	    if $max_line_length && $pos > $max_line_length;

	my $line = substr($_, 0, $pos+1, "");
	$line =~ s/(\015?\012)\z// || die "Assert";
	return wantarray ? ($line, $1) : $line;
    }
}


sub can_read {
    my $self = shift;
    return 1 unless defined(fileno($self));
    return 1 if $self->isa('IO::Socket::SSL') && $self->pending;
    return 1 if $self->isa('Net::SSL') && $self->can('pending') && $self->pending;

    # With no timeout, wait forever.  An explicit timeout of 0 can be
    # used to just check if the socket is readable without waiting.
    my $timeout = @_ ? shift : (${*$self}{io_socket_timeout} || undef);

    my $fbits = '';
    vec($fbits, fileno($self), 1) = 1;
  SELECT:
    {
        my $before;
        $before = time if $timeout;
        my $nfound = select($fbits, undef, undef, $timeout);
        if ($nfound < 0) {
            if ($!{EINTR} || $!{EAGAIN} || $!{EWOULDBLOCK}) {
                # don't really think EAGAIN/EWOULDBLOCK can happen here
                if ($timeout) {
                    $timeout -= time - $before;
                    $timeout = 0 if $timeout < 0;
                }
                redo SELECT;
            }
            die "select failed: $!";
        }
        return $nfound > 0;
    }
}


sub _rbuf {
    my $self = shift;
    if (@_) {
	for (${*$self}{'http_buf'}) {
	    my $old;
	    $old = $_ if defined wantarray;
	    $_ = shift;
	    return $old;
	}
    }
    else {
	return ${*$self}{'http_buf'};
    }
}

sub _rbuf_length {
    my $self = shift;
    return length ${*$self}{'http_buf'};
}


sub _read_header_lines {
    my $self = shift;
    my $junk_out = shift;

    my @headers;
    my $line_count = 0;
    my $max_header_lines = ${*$self}{'http_max_header_lines'};
    while (my $line = my_readline($self, 'Header')) {
	if ($line =~ /^(\S+?)\s*:\s*(.*)/s) {
	    push(@headers, $1, $2);
	}
	elsif (@headers && $line =~ s/^\s+//) {
	    $headers[-1] .= " " . $line;
	}
	elsif ($junk_out) {
	    push(@$junk_out, $line);
	}
	else {
	    die "Bad header: '$line'\n";
	}
	if ($max_header_lines) {
	    $line_count++;
	    if ($line_count >= $max_header_lines) {
		die "Too many header lines (limit is $max_header_lines)";
	    }
	}
    }
    return @headers;
}


sub read_response_headers {
    my($self, %opt) = @_;
    my $laxed = $opt{laxed};

    my($status, $eol) = my_readline($self, 'Status');
    unless (defined $status) {
	die "Server closed connection without sending any data back";
    }

    my($peer_ver, $code, $message) = split(/\s+/, $status, 3);
    if (!$peer_ver || $peer_ver !~ s,^HTTP/,, || $code !~ /^[1-5]\d\d$/) {
	die "Bad response status line: '$status'" unless $laxed;
	# assume HTTP/0.9
	${*$self}{'http_peer_http_version'} = "0.9";
	${*$self}{'http_status'} = "200";
	substr(${*$self}{'http_buf'}, 0, 0) = $status . ($eol || "");
	return 200 unless wantarray;
	return (200, "Assumed OK");
    };

    ${*$self}{'http_peer_http_version'} = $peer_ver;
    ${*$self}{'http_status'} = $code;

    my $junk_out;
    if ($laxed) {
	$junk_out = $opt{junk_out} || [];
    }
    my @headers = $self->_read_header_lines($junk_out);

    # pick out headers that read_entity_body might need
    my @te;
    my $content_length;
    for (my $i = 0; $i < @headers; $i += 2) {
	my $h = lc($headers[$i]);
	if ($h eq 'transfer-encoding') {
	    my $te = $headers[$i+1];
	    $te =~ s/^\s+//;
	    $te =~ s/\s+$//;
	    push(@te, $te) if length($te);
	}
	elsif ($h eq 'content-length') {
	    # ignore bogus and overflow values
	    if ($headers[$i+1] =~ /^\s*(\d{1,15})(?:\s|$)/) {
		$content_length = $1;
	    }
	}
    }
    ${*$self}{'http_te'} = join(",", @te);
    ${*$self}{'http_content_length'} = $content_length;
    ${*$self}{'http_first_body'}++;
    delete ${*$self}{'http_trailers'};
    return $code unless wantarray;
    return ($code, $message, @headers);
}


sub read_entity_body {
    my $self = shift;
    my $buf_ref = \$_[0];
    my $size = $_[1];
    die "Offset not supported yet" if $_[2];

    my $chunked;
    my $bytes;

    if (${*$self}{'http_first_body'}) {
	${*$self}{'http_first_body'} = 0;
	delete ${*$self}{'http_chunked'};
	delete ${*$self}{'http_bytes'};
	my $method = shift(@{${*$self}{'http_request_method'}});
	my $status = ${*$self}{'http_status'};
	if ($method eq "HEAD") {
	    # this response is always empty regardless of other headers
	    $bytes = 0;
	}
	elsif (my $te = ${*$self}{'http_te'}) {
	    my @te = split(/\s*,\s*/, lc($te));
	    die "Chunked must be last Transfer-Encoding '$te'"
		unless pop(@te) eq "chunked";
	    pop(@te) while @te && $te[-1] eq "chunked";  # ignore repeated chunked spec

	    for (@te) {
		if ($_ eq "deflate" && inflate_ok()) {
		    #require Compress::Raw::Zlib;
		    my ($i, $status) = Compress::Raw::Zlib::Inflate->new();
		    die "Can't make inflator: $status" unless $i;
		    $_ = sub { my $out; $i->inflate($_[0], \$out); $out }
		}
		elsif ($_ eq "gzip" && gunzip_ok()) {
		    #require IO::Uncompress::Gunzip;
		    my @buf;
		    $_ = sub {
			push(@buf, $_[0]);
			return "" unless $_[1];
			my $input = join("", @buf);
			my $output;
			IO::Uncompress::Gunzip::gunzip(\$input, \$output, Transparent => 0)
			    or die "Can't gunzip content: $IO::Uncompress::Gunzip::GunzipError";
			return \$output;
		    };
		}
		elsif ($_ eq "identity") {
		    $_ = sub { $_[0] };
		}
		else {
		    die "Can't handle transfer encoding '$te'";
		}
	    }

	    @te = reverse(@te);

	    ${*$self}{'http_te2'} = @te ? \@te : "";
	    $chunked = -1;
	}
	elsif (defined(my $content_length = ${*$self}{'http_content_length'})) {
	    $bytes = $content_length;
	}
        elsif ($status =~ /^(?:1|[23]04)/) {
            # RFC 2616 says that these responses should always be empty
            # but that does not appear to be true in practice [RT#17907]
            $bytes = 0;
        }
	else {
	    # XXX Multi-Part types are self delimiting, but RFC 2616 says we
	    # only has to deal with 'multipart/byteranges'

	    # Read until EOF
	}
    }
    else {
	$chunked = ${*$self}{'http_chunked'};
	$bytes   = ${*$self}{'http_bytes'};
    }

    if (defined $chunked) {
	# The state encoded in $chunked is:
	#   $chunked == 0:   read CRLF after chunk, then chunk header
        #   $chunked == -1:  read chunk header
	#   $chunked > 0:    bytes left in current chunk to read

	if ($chunked <= 0) {
	    my $line = my_readline($self, 'Entity body');
	    if ($chunked == 0) {
		die "Missing newline after chunk data: '$line'"
		    if !defined($line) || $line ne "";
		$line = my_readline($self, 'Entity body');
	    }
	    die "EOF when chunk header expected" unless defined($line);
	    my $chunk_len = $line;
	    $chunk_len =~ s/;.*//;  # ignore potential chunk parameters
	    unless ($chunk_len =~ /^([\da-fA-F]+)\s*$/) {
		die "Bad chunk-size in HTTP response: $line";
	    }
	    $chunked = hex($1);
	    ${*$self}{'http_chunked'} = $chunked;
	    if ($chunked == 0) {
		${*$self}{'http_trailers'} = [$self->_read_header_lines];
		$$buf_ref = "";

		my $n = 0;
		if (my $transforms = delete ${*$self}{'http_te2'}) {
		    for (@$transforms) {
			$$buf_ref = &$_($$buf_ref, 1);
		    }
		    $n = length($$buf_ref);
		}

		# in case somebody tries to read more, make sure we continue
		# to return EOF
		delete ${*$self}{'http_chunked'};
		${*$self}{'http_bytes'} = 0;

		return $n;
	    }
	}

	my $n = $chunked;
	$n = $size if $size && $size < $n;
	$n = my_read($self, $$buf_ref, $n);
	return undef unless defined $n;

	${*$self}{'http_chunked'} = $chunked - $n;

	if ($n > 0) {
	    if (my $transforms = ${*$self}{'http_te2'}) {
		for (@$transforms) {
		    $$buf_ref = &$_($$buf_ref, 0);
		}
		$n = length($$buf_ref);
		$n = -1 if $n == 0;
	    }
	}
	return $n;
    }
    elsif (defined $bytes) {
	unless ($bytes) {
	    $$buf_ref = "";
	    return 0;
	}
	my $n = $bytes;
	$n = $size if $size && $size < $n;
	$n = my_read($self, $$buf_ref, $n);
	${*$self}{'http_bytes'} = defined $n ? $bytes - $n : $bytes;
	return $n;
    }
    else {
	# read until eof
	$size ||= 8*1024;
	return my_read($self, $$buf_ref, $size);
    }
}

sub get_trailers {
    my $self = shift;
    @{${*$self}{'http_trailers'} || []};
}

BEGIN {
my $gunzip_ok;
my $inflate_ok;

sub gunzip_ok {
    return $gunzip_ok if defined $gunzip_ok;

    # Try to load IO::Uncompress::Gunzip.
    local $@;
    local $SIG{__DIE__};
    $gunzip_ok = 0;

    eval {
	require IO::Uncompress::Gunzip;
	$gunzip_ok++;
    };

    return $gunzip_ok;
}

sub inflate_ok {
    return $inflate_ok if defined $inflate_ok;

    # Try to load Compress::Raw::Zlib.
    local $@;
    local $SIG{__DIE__};
    $inflate_ok = 0;

    eval {
	require Compress::Raw::Zlib;
	$inflate_ok++;
    };

    return $inflate_ok;
}

} # BEGIN

1;

=pod

=encoding UTF-8

=head1 NAME

Net::HTTP::Methods - Methods shared by Net::HTTP and Net::HTTPS

=head1 VERSION

version 6.19

=head1 AUTHOR

Gisle Aas <gisle@activestate.com>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2001-2017 by Gisle Aas.

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

=cut

__END__

# ABSTRACT: Methods shared by Net::HTTP and Net::HTTPS
PK       ! �c�	  �	    perl5/Net/HTTP/NB.pmnu ��6�$        package Net::HTTP::NB;
our $VERSION = '6.19';
use strict;
use warnings;

use base 'Net::HTTP';

sub can_read {
    return 1;
}

sub sysread {
    my $self = $_[0];
    if (${*$self}{'httpnb_read_count'}++) {
	${*$self}{'http_buf'} = ${*$self}{'httpnb_save'};
	die "Multi-read\n";
    }
    my $buf;
    my $offset = $_[3] || 0;
    my $n = sysread($self, $_[1], $_[2], $offset);
    ${*$self}{'httpnb_save'} .= substr($_[1], $offset);
    return $n;
}

sub read_response_headers {
    my $self = shift;
    ${*$self}{'httpnb_read_count'} = 0;
    ${*$self}{'httpnb_save'} = ${*$self}{'http_buf'};
    my @h = eval { $self->SUPER::read_response_headers(@_) };
    if ($@) {
	return if $@ eq "Multi-read\n";
	die;
    }
    return @h;
}

sub read_entity_body {
    my $self = shift;
    ${*$self}{'httpnb_read_count'} = 0;
    ${*$self}{'httpnb_save'} = ${*$self}{'http_buf'};
    # XXX I'm not so sure this does the correct thing in case of
    # transfer-encoding transforms
    my $n = eval { $self->SUPER::read_entity_body(@_); };
    if ($@) {
	$_[0] = "";
	return -1;
    }
    return $n;
}

1;

=pod

=encoding UTF-8

=head1 NAME

Net::HTTP::NB - Non-blocking HTTP client

=head1 VERSION

version 6.19

=head1 SYNOPSIS

 use Net::HTTP::NB;
 my $s = Net::HTTP::NB->new(Host => "www.perl.com") || die $@;
 $s->write_request(GET => "/");

 use IO::Select;
 my $sel = IO::Select->new($s);

 READ_HEADER: {
    die "Header timeout" unless $sel->can_read(10);
    my($code, $mess, %h) = $s->read_response_headers;
    redo READ_HEADER unless $code;
 }

 while (1) {
    die "Body timeout" unless $sel->can_read(10);
    my $buf;
    my $n = $s->read_entity_body($buf, 1024);
    last unless $n;
    print $buf;
 }

=head1 DESCRIPTION

Same interface as C<Net::HTTP> but it will never try multiple reads
when the read_response_headers() or read_entity_body() methods are
invoked.  This make it possible to multiplex multiple Net::HTTP::NB
using select without risk blocking.

If read_response_headers() did not see enough data to complete the
headers an empty list is returned.

If read_entity_body() did not see new entity data in its read
the value -1 is returned.

=head1 SEE ALSO

L<Net::HTTP>

=head1 AUTHOR

Gisle Aas <gisle@activestate.com>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2001-2017 by Gisle Aas.

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

=cut

__END__

#ABSTRACT: Non-blocking HTTP client

PK       ! �Y�f�'  �'    perl5/Net/HTTP.pmnu ��6�$        package Net::HTTP;
our $VERSION = '6.19';
use strict;
use warnings;

use vars qw($SOCKET_CLASS);
unless ($SOCKET_CLASS) {
    # Try several, in order of capability and preference
    if (eval { require IO::Socket::IP }) {
       $SOCKET_CLASS = "IO::Socket::IP";    # IPv4+IPv6
    } elsif (eval { require IO::Socket::INET6 }) {
       $SOCKET_CLASS = "IO::Socket::INET6"; # IPv4+IPv6
    } elsif (eval { require IO::Socket::INET }) {
       $SOCKET_CLASS = "IO::Socket::INET";  # IPv4 only
    } else {
       require IO::Socket;
       $SOCKET_CLASS = "IO::Socket::INET";
    }
}
require Net::HTTP::Methods;
require Carp;

our @ISA = ($SOCKET_CLASS, 'Net::HTTP::Methods');

sub new {
    my $class = shift;
    Carp::croak("No Host option provided") unless @_;
    $class->SUPER::new(@_);
}

sub configure {
    my($self, $cnf) = @_;
    $self->http_configure($cnf);
}

sub http_connect {
    my($self, $cnf) = @_;
    $self->SUPER::configure($cnf);
}

1;

=pod

=encoding UTF-8

=head1 NAME

Net::HTTP - Low-level HTTP connection (client)

=head1 VERSION

version 6.19

=head1 SYNOPSIS

 use Net::HTTP;
 my $s = Net::HTTP->new(Host => "www.perl.com") || die $@;
 $s->write_request(GET => "/", 'User-Agent' => "Mozilla/5.0");
 my($code, $mess, %h) = $s->read_response_headers;

 while (1) {
    my $buf;
    my $n = $s->read_entity_body($buf, 1024);
    die "read failed: $!" unless defined $n;
    last unless $n;
    print $buf;
 }

=head1 DESCRIPTION

The C<Net::HTTP> class is a low-level HTTP client.  An instance of the
C<Net::HTTP> class represents a connection to an HTTP server.  The
HTTP protocol is described in RFC 2616.  The C<Net::HTTP> class
supports C<HTTP/1.0> and C<HTTP/1.1>.

C<Net::HTTP> is a sub-class of one of C<IO::Socket::IP> (IPv6+IPv4),
C<IO::Socket::INET6> (IPv6+IPv4), or C<IO::Socket::INET> (IPv4 only).  
You can mix the methods described below with reading and writing from the
socket directly.  This is not necessary a good idea, unless you know what
you are doing.

The following methods are provided (in addition to those of
C<IO::Socket::INET>):

=over

=item $s = Net::HTTP->new( %options )

The C<Net::HTTP> constructor method takes the same options as
C<IO::Socket::INET>'s as well as these:

  Host:            Initial host attribute value
  KeepAlive:       Initial keep_alive attribute value
  SendTE:          Initial send_te attribute_value
  HTTPVersion:     Initial http_version attribute value
  PeerHTTPVersion: Initial peer_http_version attribute value
  MaxLineLength:   Initial max_line_length attribute value
  MaxHeaderLines:  Initial max_header_lines attribute value

The C<Host> option is also the default for C<IO::Socket::INET>'s
C<PeerAddr>.  The C<PeerPort> defaults to 80 if not provided.
The C<PeerPort> specification can also be embedded in the C<PeerAddr>
by preceding it with a ":", and closing the IPv6 address on brackets "[]" if
necessary: "192.0.2.1:80","[2001:db8::1]:80","any.example.com:80".

The C<Listen> option provided by C<IO::Socket::INET>'s constructor
method is not allowed.

If unable to connect to the given HTTP server then the constructor
returns C<undef> and $@ contains the reason.  After a successful
connect, a C<Net:HTTP> object is returned.

=item $s->host

Get/set the default value of the C<Host> header to send.  The $host
must not be set to an empty string (or C<undef>) for HTTP/1.1.

=item $s->keep_alive

Get/set the I<keep-alive> value.  If this value is TRUE then the
request will be sent with headers indicating that the server should try
to keep the connection open so that multiple requests can be sent.

The actual headers set will depend on the value of the C<http_version>
and C<peer_http_version> attributes.

=item $s->send_te

Get/set the a value indicating if the request will be sent with a "TE"
header to indicate the transfer encodings that the server can choose to
use.  The list of encodings announced as accepted by this client depends
on availability of the following modules: C<Compress::Raw::Zlib> for
I<deflate>, and C<IO::Compress::Gunzip> for I<gzip>.

=item $s->http_version

Get/set the HTTP version number that this client should announce.
This value can only be set to "1.0" or "1.1".  The default is "1.1".

=item $s->peer_http_version

Get/set the protocol version number of our peer.  This value will
initially be "1.0", but will be updated by a successful
read_response_headers() method call.

=item $s->max_line_length

Get/set a limit on the length of response line and response header
lines.  The default is 8192.  A value of 0 means no limit.

=item $s->max_header_length

Get/set a limit on the number of header lines that a response can
have.  The default is 128.  A value of 0 means no limit.

=item $s->format_request($method, $uri, %headers, [$content])

Format a request message and return it as a string.  If the headers do
not include a C<Host> header, then a header is inserted with the value
of the C<host> attribute.  Headers like C<Connection> and
C<Keep-Alive> might also be added depending on the status of the
C<keep_alive> attribute.

If $content is given (and it is non-empty), then a C<Content-Length>
header is automatically added unless it was already present.

=item $s->write_request($method, $uri, %headers, [$content])

Format and send a request message.  Arguments are the same as for
format_request().  Returns true if successful.

=item $s->format_chunk( $data )

Returns the string to be written for the given chunk of data.  

=item $s->write_chunk($data)

Will write a new chunk of request entity body data.  This method
should only be used if the C<Transfer-Encoding> header with a value of
C<chunked> was sent in the request.  Note, writing zero-length data is
a no-op.  Use the write_chunk_eof() method to signal end of entity
body data.

Returns true if successful.

=item $s->format_chunk_eof( %trailers )

Returns the string to be written for signaling EOF when a
C<Transfer-Encoding> of C<chunked> is used.

=item $s->write_chunk_eof( %trailers )

Will write eof marker for chunked data and optional trailers.  Note
that trailers should not really be used unless is was signaled
with a C<Trailer> header.

Returns true if successful.

=item ($code, $mess, %headers) = $s->read_response_headers( %opts )

Read response headers from server and return it.  The $code is the 3
digit HTTP status code (see L<HTTP::Status>) and $mess is the textual
message that came with it.  Headers are then returned as key/value
pairs.  Since key letter casing is not normalized and the same key can
even occur multiple times, assigning these values directly to a hash
is not wise.  Only the $code is returned if this method is called in
scalar context.

As a side effect this method updates the 'peer_http_version'
attribute.

Options might be passed in as key/value pairs.  There are currently
only two options supported; C<laxed> and C<junk_out>.

The C<laxed> option will make read_response_headers() more forgiving
towards servers that have not learned how to speak HTTP properly.  The
C<laxed> option is a boolean flag, and is enabled by passing in a TRUE
value.  The C<junk_out> option can be used to capture bad header lines
when C<laxed> is enabled.  The value should be an array reference.
Bad header lines will be pushed onto the array.

The C<laxed> option must be specified in order to communicate with
pre-HTTP/1.0 servers that don't describe the response outcome or the
data they send back with a header block.  For these servers
peer_http_version is set to "0.9" and this method returns (200,
"Assumed OK").

The method will raise an exception (die) if the server does not speak
proper HTTP or if the C<max_line_length> or C<max_header_length>
limits are reached.  If the C<laxed> option is turned on and
C<max_line_length> and C<max_header_length> checks are turned off,
then no exception will be raised and this method will always
return a response code.

=item $n = $s->read_entity_body($buf, $size);

Reads chunks of the entity body content.  Basically the same interface
as for read() and sysread(), but the buffer offset argument is not
supported yet.  This method should only be called after a successful
read_response_headers() call.

The return value will be C<undef> on read errors, 0 on EOF, -1 if no data
could be returned this time, otherwise the number of bytes assigned
to $buf.  The $buf is set to "" when the return value is -1.

You normally want to retry this call if this function returns either
-1 or C<undef> with C<$!> as EINTR or EAGAIN (see L<Errno>).  EINTR
can happen if the application catches signals and EAGAIN can happen if
you made the socket non-blocking.

This method will raise exceptions (die) if the server does not speak
proper HTTP.  This can only happen when reading chunked data.

=item %headers = $s->get_trailers

After read_entity_body() has returned 0 to indicate end of the entity
body, you might call this method to pick up any trailers.

=item $s->_rbuf

Get/set the read buffer content.  The read_response_headers() and
read_entity_body() methods use an internal buffer which they will look
for data before they actually sysread more from the socket itself.  If
they read too much, the remaining data will be left in this buffer.

=item $s->_rbuf_length

Returns the number of bytes in the read buffer.  This should always be
the same as:

    length($s->_rbuf)

but might be more efficient.

=back

=head1 SUBCLASSING

The read_response_headers() and read_entity_body() will invoke the
sysread() method when they need more data.  Subclasses might want to
override this method to control how reading takes place.

The object itself is a glob.  Subclasses should avoid using hash key
names prefixed with C<http_> and C<io_>.

=head1 SEE ALSO

L<LWP>, L<IO::Socket::INET>, L<Net::HTTP::NB>

=head1 AUTHOR

Gisle Aas <gisle@activestate.com>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2001-2017 by Gisle Aas.

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

=cut

__END__

# ABSTRACT: Low-level HTTP connection (client)

PK       ! %��9! 9!   perl5/Net/IP.pmnu ��6�$        # Copyright (c) 1999 - 2002                           RIPE NCC
#
# All Rights Reserved
#
# Permission to use, copy, modify, and distribute this software and its
# documentation for any purpose and without fee is hereby granted,
# provided that the above copyright notice appear in all copies and that
# both that copyright notice and this permission notice appear in
# supporting documentation, and that the name of the author not be
# used in advertising or publicity pertaining to distribution of the
# software without specific, written prior permission.
#
# THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS; IN NO EVENT SHALL
# AUTHOR BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY
# DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN
# AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

#------------------------------------------------------------------------------
# Module Header
# Filename          : IP.pm
# Purpose           : Provide functions to manipulate IPv4/v6 addresses
# Author            : Manuel Valente <manuel.valente@gmail.com>
# Date              : 19991124
# Description       :
# Language Version  : Perl 5
# OSs Tested        : BSDI 3.1 - Linux
# Command Line      : ipcount
# Input Files       :
# Output Files      :
# External Programs : Math::BigInt.pm
# Problems          :
# To Do             :
# Comments          : Based on ipv4pack.pm (Monica) and iplib.pm (Lee)
#                     Math::BigInt is only loaded if int functions are used
# $Id: IP.pm,v 1.23 2003/02/18 16:13:01 manuel Exp $
#------------------------------------------------------------------------------

package Net::IP;

use strict;
use Math::BigInt;

# Global Variables definition
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $ERROR $ERRNO
  %IPv4ranges %IPv6ranges $useBigInt
  $IP_NO_OVERLAP $IP_PARTIAL_OVERLAP $IP_A_IN_B_OVERLAP $IP_B_IN_A_OVERLAP $IP_IDENTICAL);

$VERSION = '1.26';

require Exporter;

@ISA = qw(Exporter);

# Functions and variables exported in all cases
@EXPORT = qw(&Error &Errno
  $IP_NO_OVERLAP $IP_PARTIAL_OVERLAP $IP_A_IN_B_OVERLAP $IP_B_IN_A_OVERLAP $IP_IDENTICAL
);

# Functions exported on demand (with :PROC)
@EXPORT_OK = qw(&Error &Errno &ip_iptobin &ip_bintoip &ip_bintoint &ip_inttobin
  &ip_get_version &ip_is_ipv4 &ip_is_ipv6 &ip_expand_address &ip_get_mask
  &ip_last_address_bin &ip_splitprefix &ip_prefix_to_range
  &ip_is_valid_mask &ip_bincomp &ip_binadd &ip_get_prefix_length
  &ip_range_to_prefix &ip_compress_address &ip_is_overlap
  &ip_get_embedded_ipv4 &ip_aggregate &ip_iptype &ip_check_prefix
  &ip_reverse &ip_normalize &ip_normal_range &ip_iplengths
  $IP_NO_OVERLAP $IP_PARTIAL_OVERLAP $IP_A_IN_B_OVERLAP $IP_B_IN_A_OVERLAP $IP_IDENTICAL
);

%EXPORT_TAGS = (PROC => [@EXPORT_OK],);

# Definition of the Ranges for IPv4 IPs
%IPv4ranges = (
    '00000000'                         => 'PRIVATE',     # 0/8
    '00001010'                         => 'PRIVATE',     # 10/8
    '0110010001'                       => 'SHARED',      # 100.64/10
    '01111111'                         => 'LOOPBACK',    # 127.0/8
    '1010100111111110'                 => 'LINK-LOCAL',  # 169.254/16
    '101011000001'                     => 'PRIVATE',     # 172.16/12
    '110000000000000000000000'         => 'RESERVED',    # 192.0.0/24
    '110000000000000000000010'         => 'TEST-NET',    # 192.0.2/24
    '110000000101100001100011'         => '6TO4-RELAY',  # 192.88.99.0/24 
    '1100000010101000'                 => 'PRIVATE',     # 192.168/16
    '110001100001001'                  => 'RESERVED',    # 198.18/15
    '110001100011001101100100'         => 'TEST-NET',    # 198.51.100/24
    '110010110000000001110001'         => 'TEST-NET',    # 203.0.113/24
    '1110'                             => 'MULTICAST',   # 224/4
    '1111'                             => 'RESERVED',    # 240/4
    '11111111111111111111111111111111' => 'BROADCAST',   # 255.255.255.255/32
);

# Definition of the Ranges for Ipv6 IPs
%IPv6ranges = (
    '00000000'                                      => 'RESERVED',                  # ::/8
    ('0' x 128)                                     => 'UNSPECIFIED',               # ::/128
    ('0' x 127) . '1'                               => 'LOOPBACK',                  # ::1/128
    ('0' x  80) . ('1' x 16)                        => 'IPV4MAP',                   # ::FFFF:0:0/96
    '00000001'                                      => 'RESERVED',                  # 0100::/8
    '0000000100000000' . ('0' x 48)                 => 'DISCARD',                   # 0100::/64
    '0000001'                                       => 'RESERVED',                  # 0200::/7
    '000001'                                        => 'RESERVED',                  # 0400::/6
    '00001'                                         => 'RESERVED',                  # 0800::/5
    '0001'                                          => 'RESERVED',                  # 1000::/4
    '001'                                           => 'GLOBAL-UNICAST',            # 2000::/3
    '0010000000000001' . ('0' x 16)                 => 'TEREDO',                    # 2001::/32
    '00100000000000010000000000000010' . ('0' x 16) => 'BMWG',                      # 2001:0002::/48            
    '00100000000000010000110110111000'              => 'DOCUMENTATION',             # 2001:DB8::/32
    '0010000000000001000000000001'                  => 'ORCHID',                    # 2001:10::/28
    '0010000000000010'                              => '6TO4',                      # 2002::/16
    '010'                                           => 'RESERVED',                  # 4000::/3
    '011'                                           => 'RESERVED',                  # 6000::/3
    '100'                                           => 'RESERVED',                  # 8000::/3
    '101'                                           => 'RESERVED',                  # A000::/3
    '110'                                           => 'RESERVED',                  # C000::/3
    '1110'                                          => 'RESERVED',                  # E000::/4
    '11110'                                         => 'RESERVED',                  # F000::/5
    '111110'                                        => 'RESERVED',                  # F800::/6
    '1111110'                                       => 'UNIQUE-LOCAL-UNICAST',      # FC00::/7
    '111111100'                                     => 'RESERVED',                  # FE00::/9
    '1111111010'                                    => 'LINK-LOCAL-UNICAST',        # FE80::/10
    '1111111011'                                    => 'RESERVED',                  # FEC0::/10
    '11111111'                                      => 'MULTICAST',                 # FF00::/8
);

# Overlap constants
$IP_NO_OVERLAP      = 0;
$IP_PARTIAL_OVERLAP = 1;
$IP_A_IN_B_OVERLAP  = -1;
$IP_B_IN_A_OVERLAP  = -2;
$IP_IDENTICAL       = -3;

# ----------------------------------------------------------
# OVERLOADING

use overload (
    '+'    => 'ip_add_num',
    'bool' => sub { @_ },
);

#------------------------------------------------------------------------------
# Subroutine ip_num_add
# Purpose           : Add an integer to an IP
# Params            : Number to add
# Returns           : New object or undef
# Note              : Used by overloading - returns undef when
#                     the end of the range is reached

sub ip_add_num {
    my $self = shift;

    my ($value) = @_;
	
    my $ip = $self->intip + $value;
	
    my $last = $self->last_int;

    # Reached the end of the range ?
    if ($ip > $self->last_int) {
        return;
    }

    my $newb = ip_inttobin($ip, $self->version);
    $newb = ip_bintoip($newb, $self->version);

    my $newe = ip_inttobin($last, $self->version);
    $newe = ip_bintoip($newe, $self->version);

    my $new = new Net::IP("$newb - $newe");

    return ($new);
}

# -----------------------------------------------------------------------------

#------------------------------------------------------------------------------
# Subroutine new
# Purpose           : Create an instance of an IP object
# Params            : Class, IP prefix, IP version
# Returns           : Object reference or undef
# Note              : New just allocates a new object - set() does all the work
sub new {
    my ($class, $data, $ipversion) = (@_);

    # Allocate new object
    my $self = {};

    bless($self, $class);

    # Pass everything to set()
    unless ($self->set($data, $ipversion)) {
        return;
    }

    return $self;
}

#------------------------------------------------------------------------------
# Subroutine set
# Purpose           : Set the IP for an IP object
# Params            : Data, IP type
# Returns           : 1 (success) or undef (failure)
sub set {
    my $self = shift;

    my ($data, $ipversion) = @_;

    # Normalize data as received - this should return 2 IPs
    my ($begin, $end) = ip_normalize($data, $ipversion) or do {
        $self->{error} = $ERROR;
        $self->{errno} = $ERRNO;
        return;
    };

    # Those variables are set when the object methods are called
    # We need to reset everything
    for (
        qw(ipversion errno prefixlen binmask reverse_ip last_ip iptype
        binip error ip intformat hexformat mask last_bin last_int prefix is_prefix)
      )
    {
        delete($self->{$_});
    }

    # Determine IP version for this object
    return unless ($self->{ipversion} = $ipversion || ip_get_version($begin));

    # Set begin IP address
    $self->{ip} = $begin;

    # Set Binary IP address
    return
      unless ($self->{binip} = ip_iptobin($self->ip(), $self->version()));

    $self->{is_prefix} = 0;

    # Set end IP address
    # If single IP: begin and end IPs are identical
    $end ||= $begin;
    $self->{last_ip} = $end;

    # Try to determine the IP version
    my $ver = ip_get_version($end) || return;

    # Check if begin and end addresses have the same version
    if ($ver != $self->version()) {
        $ERRNO = 201;
        $ERROR =
          "Begin and End addresses have different IP versions - $begin - $end";
        $self->{errno} = $ERRNO;
        $self->{error} = $ERROR;
        return;
    }

    # Get last binary address
    return
      unless ($self->{last_bin} =
        ip_iptobin($self->last_ip(), $self->version()));

    # Check that End IP >= Begin IP
    unless (ip_bincomp($self->binip(), 'le', $self->last_bin())) {
        $ERRNO = 202;
        $ERROR = "Begin address is greater than End address $begin - $end";
        $self->{errno} = $ERRNO;
        $self->{error} = $ERROR;
        return;
    }

    # Find all prefixes (eg:/24) in the current range
    my @prefixes = $self->find_prefixes() or return;

    # If there is only one prefix:
    if (scalar(@prefixes) == 1) {

        # Get length of prefix
        return
          unless ((undef, $self->{prefixlen}) = ip_splitprefix($prefixes[0]));

        # Set prefix boolean var
        # This value is 1 if the IP range only contains a single /nn prefix
        $self->{is_prefix} = 1;
    }

    # If the range is a single prefix:
    if ($self->{is_prefix}) {

        # Set mask property
        $self->{binmask} = ip_get_mask($self->prefixlen(), $self->version());

        # Check that the mask is valid
        unless (
            ip_check_prefix(
                $self->binip(), $self->prefixlen(), $self->version()
            )
          )
        {
            $self->{error} = $ERROR;
            $self->{errno} = $ERRNO;
            return;
        }
    }

    return ($self);
}

sub print {
    my $self = shift;

    if ($self->{is_prefix}) {
        return ($self->short() . '/' . $self->prefixlen());
    }
    else {
        return (sprintf("%s - %s", $self->ip(), $self->last_ip()));
    }
}

#------------------------------------------------------------------------------
# Subroutine error
# Purpose           : Return the current error message
# Returns           : Error string
sub error {
    my $self = shift;
    return $self->{error};
}

#------------------------------------------------------------------------------
# Subroutine errno
# Purpose           : Return the current error number
# Returns           : Error number
sub errno {
    my $self = shift;
    return $self->{errno};
}

#------------------------------------------------------------------------------
# Subroutine binip
# Purpose           : Return the IP as a binary string
# Returns           : binary string
sub binip {
    my $self = shift;
    return $self->{binip};
}

#------------------------------------------------------------------------------
# Subroutine prefixlen
# Purpose           : Get the IP prefix length
# Returns           : prefix length
sub prefixlen {
    my $self = shift;
    return $self->{prefixlen};
}

#------------------------------------------------------------------------------
# Subroutine version
# Purpose           : Return the IP version
# Returns           : IP version
sub version {
    my $self = shift;
    return $self->{ipversion};
}

#------------------------------------------------------------------------------
# Subroutine version
# Purpose           : Return the IP in quad format
# Returns           : IP string
sub ip {
    my $self = shift;
    return $self->{ip};
}

#------------------------------------------------------------------------------
# Subroutine is_prefix
# Purpose           : Check if range of IPs is a prefix
# Returns           : boolean
sub is_prefix {
    my $self = shift;
    return $self->{is_prefix};
}

#------------------------------------------------------------------------------
# Subroutine binmask
# Purpose           : Return the binary mask of an IP prefix
# Returns           : Binary mask (as string)
sub binmask {
    my $self = shift;
    return $self->{binmask};
}

#------------------------------------------------------------------------------
# Subroutine size
# Purpose           : Return the number of addresses contained in an IP object
# Returns           : Number of addresses
sub size {
    my $self = shift;

	my $size = new Math::BigInt($self->last_int);
	$size->badd(1);
	
	$size->bsub($self->intip);
}	
	
# All the following functions work the same way: the method is just a frontend
# to the real function. When the real function is called, the output is cached
# so that next time the same function is called,the frontend function directly
# returns the result.

#------------------------------------------------------------------------------
# Subroutine intip
# Purpose           : Return the IP in integer format
# Returns           : Integer
sub intip {
    my $self = shift;

    return ($self->{intformat}) if defined($self->{intformat});

    my $int = ip_bintoint($self->binip());

    if (!$int) {
        $self->{error} = $ERROR;
        $self->{errno} = $ERRNO;
        return;
    }

    $self->{intformat} = $int;

    return ($int);
}

#------------------------------------------------------------------------------
# Subroutine hexip
# Purpose           : Return the IP in hex format
# Returns           : hex string
sub hexip {
	my $self = shift;
	return $self->{'hexformat'} if(defined($self->{'hexformat'}));
	$self->{'hexformat'} = $self->intip->as_hex();
	return $self->{'hexformat'};
}

#------------------------------------------------------------------------------
# Subroutine hexmask
# Purpose           : Return the mask back in hex
# Returns           : hex string
sub hexmask {
	my $self = shift;

	return $self->{hexmask} if(defined($self->{hexmask}));
	
	my $intmask = ip_bintoint($self->binmask);
	
	$self->{'hexmask'} = $intmask->as_hex();
	
	return ($self->{'hexmask'});
}

#------------------------------------------------------------------------------
# Subroutine prefix
# Purpose           : Return the Prefix (n.n.n.n/s)
# Returns           : IP Prefix
sub prefix {
    my $self = shift;

    if (not $self->is_prefix()) {
        $self->{error} = "IP range $self->{ip} is not a Prefix.";
        $self->{errno} = 209;
        return;
    }

    return ($self->{prefix}) if defined($self->{prefix});

    my $prefix = $self->ip() . '/' . $self->prefixlen();

    if (!$prefix) {
        $self->{error} = $ERROR;
        $self->{errno} = $ERRNO;
        return;
    }

    $self->{prefix} = $prefix;

    return ($prefix);
}

#------------------------------------------------------------------------------
# Subroutine mask
# Purpose           : Return the IP mask in quad format
# Returns           : Mask (string)
sub mask {
    my $self = shift;

    if (not $self->is_prefix()) {
        $self->{error} = "IP range $self->{ip} is not a Prefix.";
        $self->{errno} = 209;
        return;
    }

    return ($self->{mask}) if defined($self->{mask});

    my $mask = ip_bintoip($self->binmask(), $self->version());

    if (!$mask) {
        $self->{error} = $ERROR;
        $self->{errno} = $ERRNO;
        return;
    }

    $self->{mask} = $mask;

    return ($mask);
}

#------------------------------------------------------------------------------
# Subroutine short
# Purpose           : Get the short format of an IP address or a Prefix
# Returns           : short format IP or undef
sub short {
    my $self = shift;

    my $r;

    if ($self->version == 6) {
        $r = ip_compress_address($self->ip(), $self->version());
    }
    else {
        $r = ip_compress_v4_prefix($self->ip(), $self->prefixlen());
    }

    if (!defined($r)) {
        $self->{error} = $ERROR;
        $self->{errno} = $ERRNO;
        return;
    }

    return ($r);
}

#------------------------------------------------------------------------------
# Subroutine iptype
# Purpose           : Return the type of an IP
# Returns           : Type or undef (failure)
sub iptype {
    my ($self) = shift;

    return ($self->{iptype}) if defined($self->{iptype});

    my $type = ip_iptype($self->binip(), $self->version());

    if (!$type) {
        $self->{error} = $ERROR;
        $self->{errno} = $ERRNO;
        return;
    }

    $self->{iptype} = $type;

    return ($type);
}

#------------------------------------------------------------------------------
# Subroutine reverse_ip
# Purpose           : Return the Reverse IP
# Returns           : Reverse IP or undef(failure)
sub reverse_ip {
    my ($self) = shift;

    if (not $self->is_prefix()) {
        $self->{error} = "IP range $self->{ip} is not a Prefix.";
        $self->{errno} = 209;
        return;
    }

    return ($self->{reverse_ip}) if defined($self->{reverse_ip});

    my $rev = ip_reverse($self->ip(), $self->prefixlen(), $self->version());

    if (!$rev) {
        $self->{error} = $ERROR;
        $self->{errno} = $ERRNO;
        return;
    }

    $self->{reverse_ip} = $rev;

    return ($rev);
}

#------------------------------------------------------------------------------
# Subroutine last_bin
# Purpose           : Get the last IP of a range in binary format
# Returns           : Last binary IP or undef (failure)
sub last_bin {
    my ($self) = shift;

    return ($self->{last_bin}) if defined($self->{last_bin});

    my $last;

    if ($self->is_prefix()) {
        $last =
          ip_last_address_bin($self->binip(), $self->prefixlen(),
            $self->version());
    }
    else {
        $last = ip_iptobin($self->last_ip(), $self->version());
    }

    if (!$last) {
        $self->{error} = $ERROR;
        $self->{errno} = $ERRNO;
        return;
    }

    $self->{last_bin} = $last;

    return ($last);
}

#------------------------------------------------------------------------------
# Subroutine last_int
# Purpose           : Get the last IP of a range in integer format
# Returns           : Last integer IP or undef (failure)
sub last_int {
    my ($self) = shift;

    return ($self->{last_int}) if defined($self->{last_int});

    my $last_bin = $self->last_bin() or return;

    my $last_int = ip_bintoint($last_bin, $self->version()) or return;

    $self->{last_int} = $last_int;

    return ($last_int);
}

#------------------------------------------------------------------------------
# Subroutine last_ip
# Purpose           : Get the last IP of a prefix in IP format
# Returns           : IP or undef (failure)
sub last_ip {
    my ($self) = shift;

    return ($self->{last_ip}) if defined($self->{last_ip});

    my $last = ip_bintoip($self->last_bin(), $self->version());

    if (!$last) {
        $self->{error} = $ERROR;
        $self->{errno} = $ERRNO;
        return;
    }

    $self->{last_ip} = $last;

    return ($last);
}

#------------------------------------------------------------------------------
# Subroutine find_prefixes
# Purpose           : Get all prefixes in the range defined by two IPs
# Params            : IP
# Returns           : List of prefixes or undef (failure)
sub find_prefixes {
    my ($self) = @_;

    my @list =
      ip_range_to_prefix($self->binip(), $self->last_bin(), $self->version());

    if (!scalar(@list)) {
        $self->{error} = $ERROR;
        $self->{errno} = $ERRNO;
        return;
    }

    return (@list);
}

#------------------------------------------------------------------------------
# Subroutine bincomp
# Purpose           : Compare two IPs
# Params            : Operation, IP to compare
# Returns           : 1 (True), 0 (False) or undef (problem)
# Comments          : Operation can be lt, le, gt, ge
sub bincomp {
    my ($self, $op, $other) = @_;

    my $a = ip_bincomp($self->binip(), $op, $other->binip());

    unless (defined $a) {
        $self->{error} = $ERROR;
        $self->{errno} = $ERRNO;
        return;
    }

    return ($a);
}

#------------------------------------------------------------------------------
# Subroutine binadd
# Purpose           : Add two IPs
# Params            : IP to add
# Returns           : New IP object or undef (failure)
sub binadd {
    my ($self, $other) = @_;

    my $ip = ip_binadd($self->binip(), $other->binip());

    if (!$ip) {
        $self->{error} = $ERROR;
        $self->{errno} = $ERRNO;
        return;
    }

    my $new = new Net::IP(ip_bintoip($ip, $self->version())) or return;

    return ($new);
}

#------------------------------------------------------------------------------
# Subroutine aggregate
# Purpose           : Aggregate (append) two IPs
# Params            : IP to add
# Returns           : New IP object or undef (failure)
sub aggregate {
    my ($self, $other) = @_;

    my $r = ip_aggregate(
        $self->binip(),  $self->last_bin(),
        $other->binip(), $other->last_bin(),
        $self->version()
    );

    if (!$r) {
        $self->{error} = $ERROR;
        $self->{errno} = $ERRNO;
        return;
    }

    return (new Net::IP($r));
}

#------------------------------------------------------------------------------
# Subroutine overlaps
# Purpose           : Check if two prefixes overlap
# Params            : Prefix to compare
# Returns           : $NO_OVERLAP         (no overlap)
#                     $IP_PARTIAL_OVERLAP (overlap)
#                     $IP_A_IN_B_OVERLAP  (range1 is included in range2)
#                     $IP_B_IN_A_OVERLAP  (range2 is included in range1)
#                     $IP_IDENTICAL       (range1 == range2)
#                     or undef (problem)

sub overlaps {
    my ($self, $other) = @_;

    my $r = ip_is_overlap(
        $self->binip(),  $self->last_bin(),
        $other->binip(), $other->last_bin()
    );

    if (!defined($r)) {
        $self->{error} = $ERROR;
        $self->{errno} = $ERRNO;
        return;
    }

    return ($r);
}

#------------------------------------------------------------------------------
# Subroutine auth
# Purpose           : Return Authority information from IP::Authority
# Params            : IP object
# Returns           : Authority Source

sub auth {
    my ($self) = shift;

    return ($self->{auth}) if defined($self->{auth});

    my $auth = ip_auth($self->ip, $self->version);

    if (!$auth) {
        $self->{error} = $ERROR;
        $self->{errno} = $ERRNO;
        return;
    }

    $self->{auth} = $auth;

    return ($self->{auth});
}

#------------------------------ PROCEDURAL INTERFACE --------------------------
#------------------------------------------------------------------------------
# Subroutine Error
# Purpose           : Return the ERROR string
# Returns           : string
sub Error {
    return ($ERROR);
}

#------------------------------------------------------------------------------
# Subroutine Error
# Purpose           : Return the ERRNO value
# Returns           : number
sub Errno {
    return ($ERRNO);
}

#------------------------------------------------------------------------------
# Subroutine ip_iplengths
# Purpose           : Get the length in bits of an IP from its version
# Params            : IP version
# Returns           : Number of bits

sub ip_iplengths {
    my ($version) = @_;

    if ($version == 4) {
        return (32);
    }
    elsif ($version == 6) {
        return (128);
    }
    else {
        return;
    }
}

#------------------------------------------------------------------------------
# Subroutine ip_iptobin
# Purpose           : Transform an IP address into a bit string
# Params            : IP address, IP version
# Returns           : bit string on success, undef otherwise
sub ip_iptobin {
    my ($ip, $ipversion) = @_;

    # v4 -> return 32-bit array
    if ($ipversion == 4) {
        return unpack('B32', pack('C4C4C4C4', split(/\./, $ip)));
    }

    # Strip ':'
    $ip =~ s/://g;

    # Check size
    unless (length($ip) == 32) {
        $ERROR = "Bad IP address $ip";
        $ERRNO = 102;
        return;
    }

    # v6 -> return 128-bit array
    return unpack('B128', pack('H32', $ip));
}

#------------------------------------------------------------------------------
# Subroutine ip_bintoip
# Purpose           : Transform a bit string into an IP address
# Params            : bit string, IP version
# Returns           : IP address on success, undef otherwise
sub ip_bintoip {
    my ($binip, $ip_version) = @_;

    # Define normal size for address
    my $len = ip_iplengths($ip_version);

    if ($len < length($binip)) {
        $ERROR = "Invalid IP length for binary IP $binip\n";
        $ERRNO = 189;
        return;
    }

    # Prepend 0s if address is less than normal size
    $binip = '0' x ($len - length($binip)) . $binip;

    # IPv4
    if ($ip_version == 4) {
        return join '.', unpack('C4C4C4C4', pack('B32', $binip));
    }

    # IPv6
    return join(':', unpack('H4H4H4H4H4H4H4H4', pack('B128', $binip)));
}

#------------------------------------------------------------------------------
# Subroutine ip_bintoint
# Purpose           : Transform a bit string into an Integer
# Params            : bit string
# Returns           : BigInt
sub ip_bintoint {
    my $binip = shift;

    # $n is the increment, $dec is the returned value
    my ($n, $dec) = (Math::BigInt->new(1), Math::BigInt->new(0));


    # Reverse the bit string
    foreach (reverse(split '', $binip)) {

        # If the nth bit is 1, add 2**n to $dec
        $_ and $dec += $n;
        $n *= 2;
    }

    # Strip leading + sign
    $dec =~ s/^\+//;
    return $dec;
}

#------------------------------------------------------------------------------
# Subroutine ip_inttobin
# Purpose           : Transform a BigInt into a bit string
# Comments          : sets warnings (-w) off.
#                     This is necessary because Math::BigInt is not compliant
# Params            : BigInt, IP version
# Returns           : bit string
sub ip_inttobin {

    my $dec = Math::BigInt->new(shift);

    # Find IP version
    my $ip_version = shift;

    unless ($ip_version) {
        $ERROR = "Cannot determine IP version for $dec";
        $ERRNO = 101;
        return;
    }

	my $binip = $dec->as_bin();
	$binip =~ s/^0b//;

    # Define normal size for address
    my $len = ip_iplengths($ip_version);
	
    # Prepend 0s if result is less than normal size
    $binip = '0' x ($len - length($binip)) . $binip;

	
	return $binip;

}

#------------------------------------------------------------------------------
# Subroutine ip_get_version
# Purpose           : Get an IP version
# Params            : IP address
# Returns           : 4, 6, 0(don't know)
sub ip_get_version {
    my $ip = shift;

    # If the address does not contain any ':', maybe it's IPv4
    $ip !~ /:/ and ip_is_ipv4($ip) and return '4';

    # Is it IPv6 ?
    ip_is_ipv6($ip) and return '6';

    return;
}

#------------------------------------------------------------------------------
# Subroutine ip_is_ipv4
# Purpose           : Check if an IP address is version 4
# Params            : IP address
# Returns           : 1 (yes) or 0 (no)
sub ip_is_ipv4 {
    my $ip = shift;

    # Check for invalid chars
    unless ($ip =~ m/^[\d\.]+$/) {
        $ERROR = "Invalid chars in IP $ip";
        $ERRNO = 107;
        return 0;
    }

    if ($ip =~ m/^\./) {
        $ERROR = "Invalid IP $ip - starts with a dot";
        $ERRNO = 103;
        return 0;
    }

    if ($ip =~ m/\.$/) {
        $ERROR = "Invalid IP $ip - ends with a dot";
        $ERRNO = 104;
        return 0;
    }

    # Single Numbers are considered to be IPv4
    if ($ip =~ m/^(\d+)$/ and $1 < 256) { return 1 }

    # Count quads
    my $n = ($ip =~ tr/\./\./);

    # IPv4 must have from 1 to 4 quads
    unless ($n >= 0 and $n < 4) {
        $ERROR = "Invalid IP address $ip";
        $ERRNO = 105;
        return 0;
    }

    # Check for empty quads
    if ($ip =~ m/\.\./) {
        $ERROR = "Empty quad in IP address $ip";
        $ERRNO = 106;
        return 0;
    }

    foreach (split /\./, $ip) {

        # Check for invalid quads
        unless ($_ >= 0 and $_ < 256) {
            $ERROR = "Invalid quad in IP address $ip - $_";
            $ERRNO = 107;
            return 0;
        }
    }
    return 1;
}

#------------------------------------------------------------------------------
# Subroutine ip_is_ipv6
# Purpose           : Check if an IP address is version 6
# Params            : IP address
# Returns           : 1 (yes) or 0 (no)
sub ip_is_ipv6 {
    my $ip = shift;

    # Count octets
    my $n = ($ip =~ tr/:/:/);
    return 0 unless ($n > 0 and $n < 8);

    # $k is a counter
    my $k;

    foreach (split /:/, $ip) {
        $k++;

        # Empty octet ?
        next if ($_ eq '');

        # Normal v6 octet ?
        next if (/^[a-f\d]{1,4}$/i);

        # Last octet - is it IPv4 ?
        if ( ($k == $n + 1) && ip_is_ipv4($_) ) {
            $n++; # ipv4 is two octets
            next;
        }

        $ERROR = "Invalid IP address $ip";
        $ERRNO = 108;
        return 0;
    }

    # Does the IP address start with : ?
    if ($ip =~ m/^:[^:]/) {
        $ERROR = "Invalid address $ip (starts with :)";
        $ERRNO = 109;
        return 0;
    }

    # Does the IP address finish with : ?
    if ($ip =~ m/[^:]:$/) {
        $ERROR = "Invalid address $ip (ends with :)";
        $ERRNO = 110;
        return 0;
    }

    # Does the IP address have more than one '::' pattern ?
    if ($ip =~ s/:(?=:)/:/g > 1) {
        $ERROR = "Invalid address $ip (More than one :: pattern)";
        $ERRNO = 111;
        return 0;
    }

    # number of octets
    if ($n != 7 && $ip !~ /::/) {
        $ERROR = "Invalid number of octets $ip";
        $ERRNO = 112;
        return 0;
    }
    
    # valid IPv6 address
    return 1;
}

#------------------------------------------------------------------------------
# Subroutine ip_expand_address
# Purpose           : Expand an address from compact notation
# Params            : IP address, IP version
# Returns           : expanded IP address or undef on failure
sub ip_expand_address {
    my ($ip, $ip_version) = @_;

    unless ($ip_version) {
        $ERROR = "Cannot determine IP version for $ip";
        $ERRNO = 101;
        return;
    }

    # v4 : add .0 for missing quads
    if ($ip_version == 4) {
        my @quads = split /\./, $ip;

        # check number of quads
        if (scalar(@quads) > 4) {
            $ERROR = "Not a valid IPv address $ip";
            $ERRNO = 102;
            return;
        }
        my @clean_quads = (0, 0, 0, 0);

        foreach my $q (reverse @quads) {
            
            #check quad data
            if ($q !~ m/^\d{1,3}$/) {
                $ERROR = "Not a valid IPv4 address $ip";
                $ERRNO = 102;
                return;
            }
            
            # build clean ipv4
            unshift(@clean_quads, $q + 1 - 1);
        }

        return (join '.', @clean_quads[ 0 .. 3 ]);
    }

    # Keep track of ::
    my $num_of_double_colon = ($ip =~ s/::/:!:/g);
    if ($num_of_double_colon > 1) {
        $ERROR = "Too many :: in ip";
        $ERRNO = 102;
        return;
    }

    # IP as an array
    my @ip = split /:/, $ip;

    # Number of octets
    my $num = scalar(@ip);

    foreach (0 .. (scalar(@ip) - 1)) {

        # Embedded IPv4
        if ($ip[$_] =~ /\./) {

            # Expand Ipv4 address
            # Convert into binary
            # Convert into hex
            # Keep the last two octets

            $ip[$_] = substr( ip_bintoip( ip_iptobin( ip_expand_address($ip[$_], 4), 4), 6), -9);

            # Has an error occured here ?
            return unless (defined($ip[$_]));

            # $num++ because we now have one more octet:
            # IPv4 address becomes two octets
            $num++;
            next;
        }

        # Add missing trailing 0s
        $ip[$_] = ('0' x (4 - length($ip[$_]))) . $ip[$_];
    }

    # Now deal with '::' ('000!')
    foreach (0 .. (scalar(@ip) - 1)) {

        # Find the pattern
        next unless ($ip[$_] eq '000!');

        # @empty is the IP address 0
        my @empty = map { $_ = '0' x 4 } (0 .. 7);

        # Replace :: with $num '0000' octets
        $ip[$_] = join ':', @empty[ 0 .. 8 - $num ];
        last;
    }

    return (lc(join ':', @ip));
}

#------------------------------------------------------------------------------
# Subroutine ip_get_mask
# Purpose           : Get IP mask from prefix length.
# Params            : Prefix length, IP version
# Returns           : Binary Mask
sub ip_get_mask {
    my ($len, $ip_version) = @_;

    unless ($ip_version) {
        $ERROR = "Cannot determine IP version";
        $ERRNO = 101;
        return;
    }

    my $size = ip_iplengths($ip_version);

    # mask is $len 1s plus the rest as 0s
    return (('1' x $len) . ('0' x ($size - $len)));
}

#------------------------------------------------------------------------------
# Subroutine ip_last_address_bin
# Purpose           : Return the last binary address of a range
# Params            : First binary IP, prefix length, IP version
# Returns           : Binary IP
sub ip_last_address_bin {
    my ($binip, $len, $ip_version) = @_;

    unless ($ip_version) {
        $ERROR = "Cannot determine IP version";
        $ERRNO = 101;
        return;
    }

    my $size = ip_iplengths($ip_version);

    # Find the part of the IP address which will not be modified
    $binip = substr($binip, 0, $len);

    # Fill with 1s the variable part
    return ($binip . ('1' x ($size - length($binip))));
}

#------------------------------------------------------------------------------
# Subroutine ip_splitprefix
# Purpose           : Split a prefix into IP and prefix length
# Comments          : If it was passed a simple IP, it just returns it
# Params            : Prefix
# Returns           : IP, optionnaly length of prefix
sub ip_splitprefix {
    my $prefix = shift;

    # Find the '/'
    return unless ($prefix =~ m!^([^/]+?)(/\d+)?$!);

    my ($ip, $len) = ($1, $2);

    defined($len) and $len =~ s!/!!;

    return ($ip, $len);
}

#------------------------------------------------------------------------------
# Subroutine ip_prefix_to_range
# Purpose           : Get a range from a prefix
# Params            : IP, Prefix length, IP version
# Returns           : First IP, last IP
sub ip_prefix_to_range {
    my ($ip, $len, $ip_version) = @_;

    unless ($ip_version) {
        $ERROR = "Cannot determine IP version";
        $ERRNO = 101;
        return;
    }

    # Expand the first IP address
    $ip = ip_expand_address($ip, $ip_version);

    # Turn into a binary
    # Get last address
    # Turn into an IP
    my $binip = ip_iptobin($ip, $ip_version) or return;

    return unless (ip_check_prefix($binip, $len, $ip_version));

    my $lastip = ip_last_address_bin($binip, $len, $ip_version) or return;
    return unless ($lastip = ip_bintoip($lastip, $ip_version));

    return ($ip, $lastip);
}

#------------------------------------------------------------------------------
# Subroutine ip_is_valid_mask
# Purpose           : Check the validity of an IP mask (11110000)
# Params            : Mask
# Returns           : 1 or undef (invalid)
sub ip_is_valid_mask {
    my ($mask, $ip_version) = @_;

    unless ($ip_version) {
        $ERROR = "Cannot determine IP version for $mask";
        $ERRNO = 101;
        return;
    }

    my $len = ip_iplengths($ip_version);

    if (length($mask) != $len) {
        $ERROR = "Invalid mask length for $mask";
        $ERRNO = 150;
        return;
    }

    # The mask should be of the form 111110000000
    unless ($mask =~ m/^1*0*$/) {
        $ERROR = "Invalid mask $mask";
        $ERRNO = 151;
        return;
    }

    return 1;
}

#------------------------------------------------------------------------------
# Subroutine ip_bincomp
# Purpose           : Compare binary Ips with <, >, <=, >=
# Comments          : Operators are lt(<), le(<=), gt(>), and ge(>=)
# Params            : First binary IP, operator, Last binary Ip
# Returns           : 1 (yes), 0 (no), or undef (problem)
sub ip_bincomp {
    my ($begin, $op, $end) = @_;

    my ($b, $e);

    if ($op =~ /^l[te]$/)    # Operator is lt or le
    {
        ($b, $e) = ($end, $begin);
    }
    elsif ($op =~ /^g[te]$/)    # Operator is gt or ge
    {
        ($b, $e) = ($begin, $end);
    }
    else {
        $ERROR = "Invalid Operator $op\n";
        $ERRNO = 131;
        return;
    }

    # le or ge -> return 1 if IPs are identical
    return (1) if ($op =~ /e/ and ($begin eq $end));

    # Check IP sizes
    unless (length($b) eq length($e)) {
        $ERROR = "IP addresses of different length\n";
        $ERRNO = 130;
        return;
    }

    my $c;

    # Foreach bit
    for (0 .. length($b) - 1) {

        # substract the two bits
        $c = substr($b, $_, 1) - substr($e, $_, 1);

        # Check the result
        return (1) if ($c == 1);
        return (0) if ($c == -1);
    }

    # IPs are identical
    return 0;
}

#------------------------------------------------------------------------------
# Subroutine ip_binadd
# Purpose           : Add two binary IPs
# Params            : First binary IP, Last binary Ip
# Returns           : Binary sum or undef (problem)
sub ip_binadd {
    my ($b, $e) = @_;

    # Check IP length
    unless (length($b) eq length($e)) {
        $ERROR = "IP addresses of different length\n";
        $ERRNO = 130;
        return;
    }

    # Reverse the two IPs
    $b = scalar(reverse $b);
    $e = scalar(reverse $e);

    my ($carry, $result, $c) = (0);

    # Foreach bit (reversed)
    for (0 .. length($b) - 1) {

        # add the two bits plus the carry
        $c     = substr($b, $_, 1) + substr($e, $_, 1) + $carry;
        $carry = 0;

        # sum = 0 => $c = 0, $carry = 0
        # sum = 1 => $c = 1, $carry = 0
        # sum = 2 => $c = 0, $carry = 1
        # sum = 3 => $c = 1, $carry = 1
        if ($c > 1) {
            $c -= 2;
            $carry = 1;
        }

        $result .= $c;
    }

    # Reverse result
    return scalar(reverse($result));
}

#------------------------------------------------------------------------------
# Subroutine ip_get_prefix_length
# Purpose           : Get the prefix length for a given range of IPs
# Params            : First binary IP, Last binary IP
# Returns           : Length of prefix or undef (problem)
sub ip_get_prefix_length {
    my ($bin1, $bin2) = @_;

    # Check length of IPs
    unless (length($bin1) eq length($bin2)) {
        $ERROR = "IP addresses of different length\n";
        $ERRNO = 130;
        return;
    }

    # reverse IPs
    $bin1 = scalar(reverse $bin1);
    $bin2 = scalar(reverse $bin2);

    # foreach bit
    for (0 .. length($bin1) - 1) {

        # If bits are equal it means we have reached the longest prefix
        return ("$_") if (substr($bin1, $_, 1) eq substr($bin2, $_, 1));

    }

    # Return 32 (IPv4) or 128 (IPv6)
    return length($bin1);
}

#------------------------------------------------------------------------------
# Subroutine ip_range_to_prefix
# Purpose           : Return all prefixes between two IPs
# Params            : First IP, Last IP, IP version
# Returns           : List of Prefixes or undef (problem)
sub ip_range_to_prefix {
    my ($binip, $endbinip, $ip_version) = @_;

    unless ($ip_version) {
        $ERROR = "Cannot determine IP version";
        $ERRNO = 101;
        return;
    }

    unless (length($binip) eq length($endbinip)) {
        $ERROR = "IP addresses of different length\n";
        $ERRNO = 130;
        return;
    }

    my ($len, $nbits, $current, $add, @prefix);

    # 1 in binary
    my $one = ('0' x (ip_iplengths($ip_version) - 1)) . '1';

    # While we have not reached the last IP
    while (ip_bincomp($binip, 'le', $endbinip) == 1) {

        # Find all 0s at the end
        if ($binip =~ m/(0+)$/) {

            # nbits = nb of 0 bits
            $nbits = length($1);
        }
        else {
            $nbits = 0;
        }

        do {
            $current = $binip;
            $add     = '1' x $nbits;

            # Replace $nbits 0s with 1s
            $current =~ s/0{$nbits}$/$add/;
            $nbits--;

            # Decrease $nbits if $current >= $endbinip
        } while (ip_bincomp($current, 'le', $endbinip) != 1);

        # Find Prefix length
        $len =
          (ip_iplengths($ip_version)) - ip_get_prefix_length($binip, $current);

        # Push prefix in list
        push(@prefix, ip_bintoip($binip, $ip_version) . "/$len");

        # Add 1 to current IP
        $binip = ip_binadd($current, $one);

        # Exit if IP is 32/128 1s
        last if ($current =~ m/^1+$/);
    }

    return (@prefix);
}

#------------------------------------------------------------------------------
# Subroutine ip_compress_v4_prefix
# Purpose           : Compress an IPv4 Prefix
# Params            : IP, Prefix length
# Returns           : Compressed IP - ie: 194.5
sub ip_compress_v4_prefix {
    my ($ip, $len) = @_;

    my @quads = split /\./, $ip;

    my $qlen = int(($len - 1) / 8);

    $qlen = 0 if ($qlen < 0);

    my $newip = join '.', @quads[ 0 .. $qlen ];

    return ($newip);
}

#------------------------------------------------------------------------------
# Subroutine ip_compress_address
# Purpose           : Compress an IPv6 address
# Params            : IP, IP version
# Returns           : Compressed IP or undef (problem)
sub ip_compress_address {
    my ($ip, $ip_version) = @_;

    unless ($ip_version) {
        $ERROR = "Cannot determine IP version for $ip";
        $ERRNO = 101;
        return;
    }

    # Just return if IP is IPv4
    return ($ip) if ($ip_version == 4);

    # already compressed addresses must be expanded first
    $ip = ip_expand_address( $ip, $ip_version);
    
    # Remove leading 0s: 0034 -> 34; 0000 -> 0
    $ip =~ s/
	(^|:)        # Find beginning or ':' -> $1
	0+           # 1 or several 0s
	(?=          # Look-ahead
	[a-fA-F\d]+  # One or several Hexs
	(?::|$))     # ':' or end
	/$1/gx;

    my $reg = '';

    # Find the longuest :0:0: sequence
    while (
        $ip =~ m/
	((?:^|:)     # Find beginning or ':' -> $1
	0(?::0)+     # 0 followed by 1 or several ':0'
	(?::|$))     # ':' or end
	/gx
      )
    {
        $reg = $1 if (length($reg) < length($1));
    }

    # Replace sequence by '::'
    $ip =~ s/$reg/::/ if ($reg ne '');

    return $ip;
}

#------------------------------------------------------------------------------
# Subroutine ip_is_overlap
# Purpose           : Check if two ranges overlap
# Params            : Four binary IPs (begin of range 1,end1,begin2,end2)
# Returns           : $NO_OVERLAP         (no overlap)
#                     $IP_PARTIAL_OVERLAP (overlap)
#                     $IP_A_IN_B_OVERLAP  (range1 is included in range2)
#                     $IP_B_IN_A_OVERLAP  (range2 is included in range1)
#                     $IP_IDENTICAL       (range1 == range2)
#                     or undef (problem)

sub ip_is_overlap {
    my ($b1, $e1, $b2, $e2) = (@_);

    my $swap;
    $swap = 0;

    unless ((length($b1) eq length($e1))
        and (length($b2) eq length($e2))
        and (length($b1) eq length($b2)))
    {
        $ERROR = "IP addresses of different length\n";
        $ERRNO = 130;
        return;
    }

    # begin1 <= end1 ?
    unless (ip_bincomp($b1, 'le', $e1) == 1) {
        $ERROR = "Invalid range	$b1 - $e1";
        $ERRNO = 140;
        return;
    }

    # begin2 <= end2 ?
    unless (ip_bincomp($b2, 'le', $e2) == 1) {
        $ERROR = "Invalid range	$b2 - $e2";
        $ERRNO = 140;
        return;
    }

    # b1 == b2 ?
    if ($b1 eq $b2) {

        # e1 == e2
        return ($IP_IDENTICAL) if ($e1 eq $e2);

        # e1 < e2 ?
        return (
            ip_bincomp($e1, 'lt', $e2)
            ? $IP_A_IN_B_OVERLAP
            : $IP_B_IN_A_OVERLAP
        );
    }

    # e1 == e2 ?
    if ($e1 eq $e2) {

        # b1 < b2
        return (
            ip_bincomp($b1, 'lt', $b2)
            ? $IP_B_IN_A_OVERLAP
            : $IP_A_IN_B_OVERLAP
        );
    }

    # b1 < b2
    if ((ip_bincomp($b1, 'lt', $b2) == 1)) {

        # e1 < b2
        return ($IP_NO_OVERLAP) if (ip_bincomp($e1, 'lt', $b2) == 1);

        # e1 < e2 ?
        return (
            ip_bincomp($e1, 'lt', $e2)
            ? $IP_PARTIAL_OVERLAP
            : $IP_B_IN_A_OVERLAP
        );
    }
    else    # b1 > b2
    {

        # e2 < b1
        return ($IP_NO_OVERLAP) if (ip_bincomp($e2, 'lt', $b1) == 1);

        # e2 < e1 ?
        return (
            ip_bincomp($e2, 'lt', $e1)
            ? $IP_PARTIAL_OVERLAP
            : $IP_A_IN_B_OVERLAP
        );
    }
}

#------------------------------------------------------------------------------
# Subroutine get_embedded_ipv4
# Purpose           : Get an IPv4 embedded in an IPv6 address
# Params            : IPv6
# Returns           : IPv4 or undef (not found)
sub ip_get_embedded_ipv4 {
    my $ipv6 = shift;

    my @ip = split /:/, $ipv6;

    # Bugfix by Norbert Koch
    return unless (@ip);

    # last octet should be ipv4
    return ($ip[-1]) if (ip_is_ipv4($ip[-1]));

    return;
}

#------------------------------------------------------------------------------
# Subroutine aggregate
# Purpose           : Aggregate 2 ranges
# Params            : 1st range (1st IP, Last IP), last range (1st IP, last IP),
#                     IP version
# Returns           : prefix or undef (invalid)
sub ip_aggregate {
    my ($binbip1, $bineip1, $binbip2, $bineip2, $ip_version) = @_;

    unless ($ip_version) {
        $ERROR = "Cannot determine IP version for $binbip1";
        $ERRNO = 101;
        return;
    }

    # Bin 1
    my $one = (('0' x (ip_iplengths($ip_version) - 1)) . '1');

    # $eip1 + 1 = $bip2 ?
    unless (ip_binadd($bineip1, $one) eq $binbip2) {
        $ERROR = "Ranges not contiguous - $bineip1 - $binbip2";
        $ERRNO = 160;
        return;
    }

    # Get ranges
    my @prefix = ip_range_to_prefix($binbip1, $bineip2, $ip_version);

    # There should be only one range
    return if scalar(@prefix) < 1;

    if (scalar(@prefix) > 1) {
        $ERROR = "$binbip1 - $bineip2 is not a single prefix";
        $ERRNO = 161;
        return;
    }
    return ($prefix[0]);

}

#------------------------------------------------------------------------------
# Subroutine ip_iptype
# Purpose           : Return the type of an IP (Public, Private, Reserved)
# Params            : IP to test, IP version
# Returns           : type or undef (invalid)
sub ip_iptype {
    my ($ip, $ip_version) = @_;

    # handle known ip versions
    return ip_iptypev4($ip) if $ip_version == 4;
    return ip_iptypev6($ip) if $ip_version == 6;

    # unsupported ip version
    $ERROR = "IP version $ip not supported";
    $ERRNO = 180;
    return;
}

#------------------------------------------------------------------------------
# Subroutine ip_iptypev4
# Purpose           : Return the type of an IP (Public, Private, Reserved)
# Params            : IP to test, IP version
# Returns           : type or undef (invalid)
sub ip_iptypev4 {
    my ($ip) = @_;

    # check ip
    if ($ip !~ m/^[01]{1,32}$/) {
        $ERROR = "$ip is not a binary IPv4 address $ip";
        $ERRNO = 180;
        return;
    }
    
    # see if IP is listed
    foreach (sort { length($b) <=> length($a) } keys %IPv4ranges) {
        return ($IPv4ranges{$_}) if ($ip =~ m/^$_/);
    }

    # not listed means IP is public
    return 'PUBLIC';
}

#------------------------------------------------------------------------------
# Subroutine ip_iptypev6
# Purpose           : Return the type of an IP (Public, Private, Reserved)
# Params            : IP to test, IP version
# Returns           : type or undef (invalid)
sub ip_iptypev6 {
    my ($ip) = @_;

    # check ip
    if ($ip !~ m/^[01]{1,128}$/) {
        $ERROR = "$ip is not a binary IPv6 address";
        $ERRNO = 180;
        return;
    }
    
    foreach (sort { length($b) <=> length($a) } keys %IPv6ranges) {
        return ($IPv6ranges{$_}) if ($ip =~ m/^$_/);
    }

    # How did we get here? All IPv6 addresses should match 
    $ERROR = "Cannot determine type for $ip";
    $ERRNO = 180;
    return;
}

#------------------------------------------------------------------------------
# Subroutine ip_check_prefix
# Purpose           : Check the validity of a prefix
# Params            : binary IP, length of prefix, IP version
# Returns           : 1 or undef (invalid)
sub ip_check_prefix {
    my ($binip, $len, $ipversion) = (@_);

    # Check if len is longer than IP
    if ($len > length($binip)) {
        $ERROR =
          "Prefix length $len is longer than IP address ("
          . length($binip) . ")";
        $ERRNO = 170;
        return;
    }

    my $rest = substr($binip, $len);

    # Check if last part of the IP (len part) has only 0s
    unless ($rest =~ /^0*$/) {
        $ERROR = "Invalid prefix $binip/$len";
        $ERRNO = 171;
        return;
    }

    # Check if prefix length is correct
    unless (length($rest) + $len == ip_iplengths($ipversion)) {
        $ERROR = "Invalid prefix length /$len";
        $ERRNO = 172;
        return;
    }

    return 1;
}

#------------------------------------------------------------------------------
# Subroutine ip_reverse
# Purpose           : Get a reverse name from a prefix
# Comments          : From Lee's iplib.pm
# Params            : IP, length of prefix, IP version
# Returns           : Reverse name or undef (error)
sub ip_reverse {
    my ($ip, $len, $ip_version) = (@_);

    $ip_version ||= ip_get_version($ip);
    unless ($ip_version) {
        $ERROR = "Cannot determine IP version for $ip";
        $ERRNO = 101;
        return;
    }

    if ($ip_version == 4) {
        my @quads    = split /\./, $ip;
        my $no_quads = ($len / 8);

        my @reverse_quads = reverse @quads;

        while (@reverse_quads and $reverse_quads[0] == 0) {
            shift(@reverse_quads);
        }

        return join '.', @reverse_quads, 'in-addr', 'arpa.';
    }
    elsif ($ip_version == 6) {
        my @rev_groups = reverse split /:/, ip_expand_address($ip, 6);
        my @result;

        foreach (@rev_groups) {
            my @revhex = reverse split //;
            push @result, @revhex;
        }

        # This takes the zone above if it's not exactly on a nibble
        my $first_nibble_index = $len ? 32 - (int($len / 4)) : 0;
        return join '.', @result[ $first_nibble_index .. $#result ], 'ip6',
          'arpa.';
    }
}

#------------------------------------------------------------------------------
# Subroutine ip_normalize
# Purpose           : Normalize data to a range of IP addresses
# Params            : IP or prefix or range
# Returns           : ip1, ip2 (if range) or undef (error)
sub ip_normalize {
    my ($data) = shift;

    my $ipversion;

    my ($len, $ip, $ip2, $real_len, $first, $last, $curr_bin, $addcst, $clen);

    # Prefix
    if ($data =~ m!^(\S+?)(/\S+)$!) {
        ($ip, $len) = ($1, $2);

        return unless ($ipversion = ip_get_version($ip));
        return unless ($ip        = ip_expand_address($ip, $ipversion));
        return unless ($curr_bin  = ip_iptobin($ip, $ipversion));

        my $one = '0' x (ip_iplengths($ipversion) - 1) . '1';

        while ($len) {
            last unless ($len =~ s!^/(\d+)(\,|$)!!);

            $clen   = $1;
            $addcst = length($2) > 0;

            return unless (ip_check_prefix($curr_bin, $clen, $ipversion));

            return
              unless ($curr_bin =
                ip_last_address_bin($curr_bin, $clen, $ipversion));

            if ($addcst) {
                return unless ($curr_bin = ip_binadd($curr_bin, $one));
            }
        }

        return ($ip, ip_bintoip($curr_bin, $ipversion));
    }

    # Range
    elsif ($data =~ /^(.+?)\s*\-\s*(.+)$/) {
        ($ip, $ip2) = ($1, $2);

        return unless ($ipversion = ip_get_version($ip));

        return unless ($ip  = ip_expand_address($ip,  $ipversion));
        return unless ($ip2 = ip_expand_address($ip2, $ipversion));

        return ($ip, $ip2);
    }

    # IP + Number
    elsif ($data =~ /^(.+?)\s+\+\s+(.+)$/) {
        ($ip, $len) = ($1, $2);

        return unless ($ipversion = ip_get_version($ip));
        return unless ($ip        = ip_expand_address($ip, $ipversion));

        my ($bin_ip);
        return unless ($bin_ip = ip_iptobin($ip, $ipversion));

        return unless ($len = ip_inttobin($len, $ipversion));

        return unless ($ip2 = ip_binadd($bin_ip, $len));
        return unless ($ip2 = ip_bintoip($ip2,   $ipversion));

        return ($ip, $ip2);
    }

    # Single IP
    else {
        $ip = $data;

        return unless ($ipversion = ip_get_version($ip));

        return unless ($ip = ip_expand_address($ip, $ipversion));

        return $ip;
    }
}

#------------------------------------------------------------------------------
# Subroutine normal_range
# Purpose           : Return the normalized format of a range
# Params            : IP or prefix or range
# Returns           : "ip1 - ip2" or undef (error)
sub ip_normal_range {
    my ($data) = shift;

    my ($ip1, $ip2) = ip_normalize($data);

    return unless ($ip1);

    $ip2 ||= $ip1;

    return ("$ip1 - $ip2");
}

#------------------------------------------------------------------------------
# Subroutine ip_auth
# Purpose           : Get Authority information from IP::Authority Module
# Comments          : Requires IP::Authority
# Params            : IP, length of prefix
# Returns           : Reverse name or undef (error)
sub ip_auth {
    my ($ip, $ip_version) = (@_);

    unless ($ip_version) {
        $ERROR = "Cannot determine IP version for $ip";
        $ERRNO = 101;
        die;
        return;
    }

    if ($ip_version != 4) {

        $ERROR = "Cannot get auth information: Not an IPv4 address";
        $ERRNO = 308;
        die;
        return;
    }

    require IP::Authority;

    my $reg = new IP::Authority;

    return ($reg->inet_atoauth($ip));
}

1;

__END__
=encoding utf8
=head1 NAME

Net::IP - Perl extension for manipulating IPv4/IPv6 addresses

=head1 SYNOPSIS

  use Net::IP;
  
  my $ip = new Net::IP ('193.0.1/24') or die (Net::IP::Error());
  print ("IP  : ".$ip->ip()."\n");
  print ("Sho : ".$ip->short()."\n");
  print ("Bin : ".$ip->binip()."\n");
  print ("Int : ".$ip->intip()."\n");
  print ("Mask: ".$ip->mask()."\n");
  print ("Last: ".$ip->last_ip()."\n");
  print ("Len : ".$ip->prefixlen()."\n");
  print ("Size: ".$ip->size()."\n");
  print ("Type: ".$ip->iptype()."\n");
  print ("Rev:  ".$ip->reverse_ip()."\n");

=head1 DESCRIPTION

This module provides functions to deal with B<IPv4/IPv6> addresses. The module
can be used as a class, allowing the user to instantiate IP objects, which can
be single IP addresses, prefixes, or ranges of addresses. There is also a 
procedural way of accessing most of the functions. Most subroutines can take 
either B<IPv4> or B<IPv6> addresses transparently.

=head1 OBJECT-ORIENTED INTERFACE

=head2 Object Creation

A Net::IP object can be created from a single IP address:
  
  $ip = new Net::IP ('193.0.1.46') || die ...

Or from a Classless Prefix (a /24 prefix is equivalent to a C class):

  $ip = new Net::IP ('195.114.80/24') || die ...

Or from a range of addresses:

  $ip = new Net::IP ('20.34.101.207 - 201.3.9.99') || die ...
  
Or from a address plus a number:

  $ip = new Net::IP ('20.34.10.0 + 255') || die ...
  
The new() function accepts IPv4 and IPv6 addresses:

  $ip = new Net::IP ('dead:beef::/32') || die ...

Optionnaly, the function can be passed the version of the IP. Otherwise, it
tries to guess what the version is (see B<_is_ipv4()> and B<_is_ipv6()>).

  $ip = new Net::IP ('195/8',4); # Class A

=head1 OBJECT METHODS

Most of these methods are front-ends for the real functions, which use a 
procedural interface. Most functions return undef on failure, and a true
value on success. A detailed description of the procedural interface is 
provided below.

=head2 set

Set an IP address in an existing IP object. This method has the same 
functionality as the new() method, except that it reuses an existing object to
store the new IP.

C<$ip-E<gt>set('130.23.1/24',4);>

Like new(), set() takes two arguments - a string used to build an IP address,
prefix, or range, and optionally, the IP version of the considered address.

It returns an IP object on success, and undef on failure.

=head2 error

Return the current object error string. The error string is set whenever one 
of the methods produces an error. Also, a global, class-wide B<Error()> 
function is avaliable.

C<warn ($ip-E<gt>error());>

=head2 errno

Return the current object error number. The error number is set whenever one 
of the methods produces an error. Also, a global B<$ERRNO> variable is set
when an error is produced.

C<warn ($ip-E<gt>errno());>

=head2 ip

Return the IP address (or first IP of the prefix or range) in quad format, as
a string.

C<print ($ip-E<gt>ip());>

=head2 binip

Return the IP address as a binary string of 0s and 1s.

C<print ($ip-E<gt>binip());>

=head2 prefixlen

Return the length in bits of the current prefix.

C<print ($ip-E<gt>prefixlen());>

=head2 version

Return the version of the current IP object (4 or 6).

C<print ($ip-E<gt>version());>

=head2 size

Return the number of IP addresses in the current prefix or range.
Use of this function requires Math::BigInt.

C<print ($ip-E<gt>size());>

=head2 binmask

Return the binary mask of the current prefix, if applicable.

C<print ($ip-E<gt>binmask());>

=head2 mask

Return the mask in quad format of the current prefix.

C<print ($ip-E<gt>mask());>

=head2 prefix

Return the full prefix (ip+prefix length) in quad (standard) format.

C<print ($ip-E<gt>prefix());>

=head2 print

Print the IP object (IP/Prefix or First - Last)

C<print ($ip-E<gt>print());>

=head2 intip

Convert the IP in integer format and return it as a Math::BigInt object.

C<print ($ip-E<gt>intip());>

=head2 hexip

Return the IP in hex format

C<print ($ip-E<gt>hexip());>

=head2 hexmask

Return the mask in hex format

C<print ($ip-E<gt>hexmask());>

=head2 short

Return the IP in short format:  
	IPv4 addresses: 194.5/16
	IPv6 addresses: ab32:f000::


C<print ($ip-E<gt>short());>

=head2 iptype

Return the IP Type - this describes the type of an IP (Public, Private, 
Reserved, etc.) See procedural interface ip_iptype for more details.

C<print ($ip-E<gt>iptype());>

=head2 reverse_ip

Return the reverse IP for a given IP address (in.addr. format).

C<print ($ip-E<gt>reserve_ip());>

=head2 last_ip

Return the last IP of a prefix/range in quad format.

C<print ($ip-E<gt>last_ip());>

=head2 last_bin

Return the last IP of a prefix/range in binary format.

C<print ($ip-E<gt>last_bin());>

=head2 last_int

Return the last IP of a prefix/range in integer format.

C<print ($ip-E<gt>last_int());>

=head2 find_prefixes

This function finds all the prefixes that can be found between the two 
addresses of a range. The function returns a list of prefixes.

C<@list = $ip-E<gt>find_prefixes($other_ip));>

=head2 bincomp

Binary comparaison of two IP objects. The function takes an operation 
and an IP object as arguments. It returns a boolean value.

The operation can be one of:
lt: less than (smaller than)
le: smaller or equal to
gt: greater than
ge: greater or equal to

C<if ($ip-E<gt>bincomp('lt',$ip2) {...}>

=head2 binadd

Binary addition of two IP objects. The value returned is an IP object.

C<my $sum = $ip-E<gt>binadd($ip2);>

=head2 aggregate

Aggregate 2 IPs - Append one range/prefix of IPs to another. The last address
of the first range must be the one immediately preceding the first address of 
the second range. A new IP object is returned.

C<my $total = $ip-E<gt>aggregate($ip2);>

=head2 overlaps

Check if two IP ranges/prefixes overlap each other. The value returned by the 
function should be one of:
	$IP_PARTIAL_OVERLAP (ranges overlap) 
	$IP_NO_OVERLAP      (no overlap)
	$IP_A_IN_B_OVERLAP  (range2 contains range1)
	$IP_B_IN_A_OVERLAP  (range1 contains range2)
	$IP_IDENTICAL       (ranges are identical)
	undef               (problem)

C<if ($ip-E<gt>overlaps($ip2)==$IP_A_IN_B_OVERLAP) {...};>


=head2 looping

The C<+> operator is overloaded in order to allow looping though a whole 
range of IP addresses:

  my $ip = new Net::IP ('195.45.6.7 - 195.45.6.19') || die;
  # Loop
  do {
      print $ip->ip(), "\n";
  } while (++$ip);


The ++ operator returns undef when the last address of the range is reached.


=head2 auth

Return IP authority information from the IP::Authority module

C<$auth = ip->auth ();>

Note: IPv4 only


=head1 PROCEDURAL INTERFACE

These functions do the real work in the module. Like the OO methods, 
most of these return undef on failure. In order to access error codes
and strings, instead of using $ip-E<gt>error() and $ip-E<gt>errno(), use the
global functions C<Error()> and C<Errno()>.

The functions of the procedural interface are not exported by default. In
order to import these functions, you need to modify the use statement for
the module:

C<use Net::IP qw(:PROC);>

=head2 Error

Returns the error string corresponding to the last error generated in the 
module. This is also useful for the OO interface, as if the new() function 
fails, we cannot call $ip-E<gt>error() and so we have to use Error().

warn Error();

=head2 Errno

Returns a numeric error code corresponding to the error string returned by 
Error.

=head2 ip_iptobin

Transform an IP address into a bit string. 

    Params  : IP address, IP version
    Returns : binary IP string on success, undef otherwise

C<$binip = ip_iptobin ($ip,6);>

=head2 ip_bintoip

Transform a bit string into an IP address

    Params  : binary IP, IP version
    Returns : IP address on success, undef otherwise

C<$ip = ip_bintoip ($binip,6);>

=head2 ip_bintoint

Transform a bit string into a BigInt.

    Params  : binary IP
    Returns : BigInt

C<$bigint = new Math::BigInt (ip_bintoint($binip));>

=head2 ip_inttobin

Transform a BigInt into a bit string.
I<Warning>: sets warnings (C<-w>) off. This is necessary because Math::BigInt 
is not compliant.

    Params  : BigInt, IP version
    Returns : binary IP

C<$binip = ip_inttobin ($bigint);>

=head2 ip_get_version

Try to guess the IP version of an IP address.

    Params  : IP address
    Returns : 4, 6, undef(unable to determine)

C<$version = ip_get_version ($ip)>

=head2 ip_is_ipv4

Check if an IP address is of type 4.

    Params  : IP address
    Returns : 1 (yes) or 0 (no)

C<ip_is_ipv4($ip) and print "$ip is IPv4";>

=head2 ip_is_ipv6

Check if an IP address is of type 6.

    Params            : IP address
    Returns           : 1 (yes) or 0 (no)

C<ip_is_ipv6($ip) and print "$ip is IPv6";>

=head2 ip_expand_address

Expand an IP address from compact notation.

    Params  : IP address, IP version
    Returns : expanded IP address or undef on failure

C<$ip = ip_expand_address ($ip,4);>

=head2 ip_get_mask

Get IP mask from prefix length.

    Params  : Prefix length, IP version
    Returns : Binary Mask

C<$mask = ip_get_mask ($len,6);>

=head2 ip_last_address_bin

Return the last binary address of a prefix.

    Params  : First binary IP, prefix length, IP version
    Returns : Binary IP

C<$lastbin = ip_last_address_bin ($ip,$len,6);>

=head2 ip_splitprefix

Split a prefix into IP and prefix length.
If it was passed a simple IP, it just returns it.

    Params  : Prefix
    Returns : IP, optionnaly length of prefix

C<($ip,$len) = ip_splitprefix ($prefix)>

=head2 ip_prefix_to_range

Get a range of IPs from a prefix.

    Params  : Prefix, IP version
    Returns : First IP, last IP

C<($ip1,$ip2) = ip_prefix_to_range ($prefix,6);>

=head2 ip_bincomp

Compare binary Ips with <, >, <=, >=.
 Operators are lt(<), le(<=), gt(>), and ge(>=) 
 
    Params  : First binary IP, operator, Last binary IP
    Returns : 1 (yes), 0 (no), or undef (problem)

C<ip_bincomp ($ip1,'lt',$ip2) == 1 or do {}>

=head2 ip_binadd

Add two binary IPs.

    Params  : First binary IP, Last binary IP
    Returns : Binary sum or undef (problem)

C<$binip = ip_binadd ($bin1,$bin2);>

=head2 ip_get_prefix_length

Get the prefix length for a given range of 2 IPs.

    Params  : First binary IP, Last binary IP
    Returns : Length of prefix or undef (problem)

C<$len = ip_get_prefix_length ($ip1,$ip2);>

=head2 ip_range_to_prefix

Return all prefixes between two IPs.

    Params  : First IP (binary format), Last IP (binary format), IP version
    Returns : List of Prefixes or undef (problem)

The prefixes returned have the form q.q.q.q/nn.

C<@prefix = ip_range_to_prefix ($ip1,$ip2,6);>


=head2 ip_compress_v4_prefix

Compress an IPv4 Prefix.

    Params  : IP, Prefix length
    Returns : Compressed Prefix

C<$ip = ip_compress_v4_prefix ($ip, $len);>


=head2 ip_compress_address

Compress an IPv6 address. Just returns the IP if it is an IPv4.

    Params  : IP, IP version
    Returns : Compressed IP or undef (problem)

C<$ip = ip_compress_adress ($ip, $version);>

=head2 ip_is_overlap

Check if two ranges of IPs overlap.

    Params  : Four binary IPs (begin of range 1,end1,begin2,end2), IP version
	$IP_PARTIAL_OVERLAP (ranges overlap) 
	$IP_NO_OVERLAP      (no overlap)
	$IP_A_IN_B_OVERLAP  (range2 contains range1)
	$IP_B_IN_A_OVERLAP  (range1 contains range2)
	$IP_IDENTICAL       (ranges are identical)
	undef               (problem)

C<(ip_is_overlap($rb1,$re1,$rb2,$re2,4) eq $IP_A_IN_B_OVERLAP) and do {};>

=head2 ip_get_embedded_ipv4

Get an IPv4 embedded in an IPv6 address

    Params  : IPv6
    Returns : IPv4 string or undef (not found)

C<$ip4 = ip_get_embedded($ip6);>

=head2 ip_check_mask

Check the validity of a binary IP mask

    Params  : Mask
    Returns : 1 or undef (invalid)

C<ip_check_mask($binmask) or do {};>

Checks if mask has only 1s followed by 0s.

=head2 ip_aggregate

Aggregate 2 ranges of binary IPs

    Params  : 1st range (1st IP, Last IP), last range (1st IP, last IP), IP version
    Returns : prefix or undef (invalid)

C<$prefix = ip_aggregate ($bip1,$eip1,$bip2,$eip2) || die ...>

=head2 ip_iptypev4

Return the type of an IPv4 address. 

    Params:  binary IP
    Returns: type as of the following table or undef (invalid ip)
    
See RFC 5735 and RFC 6598

S<Address Block       Present Use                Reference>
S<------------------------------------------------------------------->
S<0.0.0.0/8           "This" Network             RFC 1122 PRIVATE>
S<10.0.0.0/8          Private-Use Networks       RFC 1918 PRIVATE>
S<100.64.0.0/10       CGN Shared Address Space   RFC 6598 SHARED>
S<127.0.0.0/8         Loopback                   RFC 1122 LOOPBACK>
S<169.254.0.0/16      Link Local                 RFC 3927 LINK-LOCAL>
S<172.16.0.0/12       Private-Use Networks       RFC 1918 PRIVATE>
S<192.0.0.0/24        IETF Protocol Assignments  RFC 5736 RESERVED>
S<192.0.2.0/24        TEST-NET-1                 RFC 5737 TEST-NET>
S<192.88.99.0/24      6to4 Relay Anycast         RFC 3068 6TO4-RELAY>
S<192.168.0.0/16      Private-Use Networks       RFC 1918 PRIVATE>
S<198.18.0.0/15       Network Interconnect>
S<                    Device Benchmark Testing   RFC 2544 RESERVED>
S<198.51.100.0/24     TEST-NET-2                 RFC 5737 TEST-NET>
S<203.0.113.0/24      TEST-NET-3                 RFC 5737 TEST-NET>
S<224.0.0.0/4         Multicast                  RFC 3171 MULTICAST>
S<240.0.0.0/4         Reserved for Future Use    RFC 1112 RESERVED>
S<255.255.255.255/32  Limited Broadcast          RFC 919  BROADCAST>
S<                                               RFC 922>

=head2 ip_iptypev6

Return the type of an IPv6 address.

    Params:  binary ip
    Returns: type as of the following table or undef (invalid)
    
See L<IANA Internet Protocol Version 6 Address Space|http://www.iana.org/assignments/ipv6-address-space/ipv6-address-space.txt>  and L<IANA IPv6 Special Purpose Address Registry|http://www.iana.org/assignments/iana-ipv6-special-registry/iana-ipv6-special-registry.txt>

 
S<Prefix      Allocation           Reference>
S<------------------------------------------------------------->
S<0000::/8    Reserved by IETF     [RFC4291] RESERVED>
S<0100::/8    Reserved by IETF     [RFC4291] RESERVED>
S<0200::/7    Reserved by IETF     [RFC4048] RESERVED>
S<0400::/6    Reserved by IETF     [RFC4291] RESERVED>
S<0800::/5    Reserved by IETF     [RFC4291] RESERVED>
S<1000::/4    Reserved by IETF     [RFC4291] RESERVED>
S<2000::/3    Global Unicast       [RFC4291] GLOBAL-UNICAST>
S<4000::/3    Reserved by IETF     [RFC4291] RESERVED>
S<6000::/3    Reserved by IETF     [RFC4291] RESERVED>
S<8000::/3    Reserved by IETF     [RFC4291] RESERVED>
S<A000::/3    Reserved by IETF     [RFC4291] RESERVED>
S<C000::/3    Reserved by IETF     [RFC4291] RESERVED>
S<E000::/4    Reserved by IETF     [RFC4291] RESERVED>
S<F000::/5    Reserved by IETF     [RFC4291] RESERVED>
S<F800::/6    Reserved by IETF     [RFC4291] RESERVED>
S<FC00::/7    Unique Local Unicast [RFC4193] UNIQUE-LOCAL-UNICAST>
S<FE00::/9    Reserved by IETF     [RFC4291] RESERVED>
S<FE80::/10   Link Local Unicast   [RFC4291] LINK-LOCAL-UNICAST>
S<FEC0::/10   Reserved by IETF     [RFC3879] RESERVED>
S<FF00::/8    Multicast            [RFC4291] MULTICAST>

   
S<Prefix          Assignment            Reference>
S<--------------------------------------------------------------------->
S<::1/128         Loopback Address      [RFC4291] UNSPECIFIED>
S<::/128          Unspecified Address   [RFC4291] LOOPBACK>
S<::FFFF:0:0/96   IPv4-mapped Address   [RFC4291] IPV4MAP>
S<0100::/64       Discard-Only Prefix   [RFC6666] DISCARD>
S<2001:0000::/32  TEREDO                [RFC4380] TEREDO>
S<2001:0002::/48  BMWG                  [RFC5180] BMWG>
S<2001:db8::/32   Documentation Prefix  [RFC3849] DOCUMENTATION>
S<2001:10::/28    ORCHID                [RFC4843] ORCHID>
S<2002::/16       6to4                  [RFC3056] 6TO4>
S<FC00::/7        Unique-Local          [RFC4193] UNIQUE-LOCAL-UNICAST>
S<FE80::/10       Linked-Scoped Unicast [RFC4291] LINK-LOCAL-UNICAST>
S<FF00::/8        Multicast             [RFC4291] MULTICAST>
  

=head2 ip_iptype

Return the type of an IP (Public, Private, Reserved)

    Params  : Binary IP to test, IP version (defaults to 6)
    Returns : type (see ip_iptypev4 and ip_iptypev6 for details) or undef (invalid)

C<$type = ip_iptype ($ip);>    

=head2 ip_check_prefix

Check the validity of a prefix

    Params  : binary IP, length of prefix, IP version
    Returns : 1 or undef (invalid)

Checks if the variant part of a prefix only has 0s, and the length is correct.

C<ip_check_prefix ($ip,$len,$ipv) or do {};>

=head2 ip_reverse

Get a reverse name from a prefix

    Params  : IP, length of prefix, IP version
    Returns : Reverse name or undef (error)

C<$reverse = ip_reverse ($ip);>

=head2 ip_normalize

Normalize data to a range/prefix of IP addresses

    Params  : Data String (Single IP, Range, Prefix)
    Returns : ip1, ip2 (if range/prefix) or undef (error)

C<($ip1,$ip2) = ip_normalize ($data);>

=head2 ip_auth

Return IP authority information from the IP::Authority module

    Params  : IP, version
    Returns : Auth info (RI for RIPE, AR for ARIN, etc)

C<$auth = ip_auth ($ip,4);>

Note: IPv4 only


=head1 BUGS

The Math::BigInt library is needed for functions that use integers. These are
ip_inttobin, ip_bintoint, and the size method. In a next version, 
Math::BigInt will become optionnal.

=head1 AUTHORS

Manuel Valente <manuel.valente@gmail.com>.

Original IPv4 code by Monica Cortes Sack <mcortes@ripe.net>.

Original IPv6 code by Lee Wilmot <lee@ripe.net>.

=head1 BASED ON

ipv4pack.pm, iplib.pm, iplibncc.pm.

=head1 SEE ALSO

perl(1), IP::Authority

=cut
PK       ! �1��  �    perl5/Net/HTTPS.pmnu ��6�$        package Net::HTTPS;
our $VERSION = '6.19';
use strict;
use warnings;

# Figure out which SSL implementation to use
use vars qw($SSL_SOCKET_CLASS);
if ($SSL_SOCKET_CLASS) {
    # somebody already set it
}
elsif ($SSL_SOCKET_CLASS = $ENV{PERL_NET_HTTPS_SSL_SOCKET_CLASS}) {
    unless ($SSL_SOCKET_CLASS =~ /^(IO::Socket::SSL|Net::SSL)\z/) {
	die "Bad socket class [$SSL_SOCKET_CLASS]";
    }
    eval "require $SSL_SOCKET_CLASS";
    die $@ if $@;
}
elsif ($IO::Socket::SSL::VERSION) {
    $SSL_SOCKET_CLASS = "IO::Socket::SSL"; # it was already loaded
}
elsif ($Net::SSL::VERSION) {
    $SSL_SOCKET_CLASS = "Net::SSL";
}
else {
    eval { require IO::Socket::SSL; };
    if ($@) {
	my $old_errsv = $@;
	eval {
	    require Net::SSL;  # from Crypt-SSLeay
	};
	if ($@) {
	    $old_errsv =~ s/\s\(\@INC contains:.*\)/)/g;
	    die $old_errsv . $@;
	}
	$SSL_SOCKET_CLASS = "Net::SSL";
    }
    else {
	$SSL_SOCKET_CLASS = "IO::Socket::SSL";
    }
}

require Net::HTTP::Methods;

our @ISA=($SSL_SOCKET_CLASS, 'Net::HTTP::Methods');

sub configure {
    my($self, $cnf) = @_;
    $self->http_configure($cnf);
}

sub http_connect {
    my($self, $cnf) = @_;
    if ($self->isa("Net::SSL")) {
	if ($cnf->{SSL_verify_mode}) {
	    if (my $f = $cnf->{SSL_ca_file}) {
		$ENV{HTTPS_CA_FILE} = $f;
	    }
	    if (my $f = $cnf->{SSL_ca_path}) {
		$ENV{HTTPS_CA_DIR} = $f;
	    }
	}
	if ($cnf->{SSL_verifycn_scheme}) {
	    $@ = "Net::SSL from Crypt-SSLeay can't verify hostnames; either install IO::Socket::SSL or turn off verification by setting the PERL_LWP_SSL_VERIFY_HOSTNAME environment variable to 0";
	    return undef;
	}
    }
    $self->SUPER::configure($cnf);
}

sub http_default_port {
    443;
}

if ($SSL_SOCKET_CLASS eq "Net::SSL") {
    # The underlying SSLeay classes fails to work if the socket is
    # placed in non-blocking mode.  This override of the blocking
    # method makes sure it stays the way it was created.
    *blocking = sub { };
}

1;

=pod

=encoding UTF-8

=head1 NAME

Net::HTTPS - Low-level HTTP over SSL/TLS connection (client)

=head1 VERSION

version 6.19

=head1 DESCRIPTION

The C<Net::HTTPS> is a low-level HTTP over SSL/TLS client.  The interface is the same
as the interface for C<Net::HTTP>, but the constructor takes additional parameters
as accepted by L<IO::Socket::SSL>.  The C<Net::HTTPS> object is an C<IO::Socket::SSL>
too, which makes it inherit additional methods from that base class.

For historical reasons this module also supports using C<Net::SSL> (from the
Crypt-SSLeay distribution) as its SSL driver and base class.  This base is
automatically selected if available and C<IO::Socket::SSL> isn't.  You might
also force which implementation to use by setting $Net::HTTPS::SSL_SOCKET_CLASS
before loading this module.  If not set this variable is initialized from the
C<PERL_NET_HTTPS_SSL_SOCKET_CLASS> environment variable.

=head1 ENVIRONMENT

You might set the C<PERL_NET_HTTPS_SSL_SOCKET_CLASS> environment variable to the name
of the base SSL implementation (and Net::HTTPS base class) to use.  The default
is C<IO::Socket::SSL>.  Currently the only other supported value is C<Net::SSL>.

=head1 SEE ALSO

L<Net::HTTP>, L<IO::Socket::SSL>

=head1 AUTHOR

Gisle Aas <gisle@activestate.com>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2001-2017 by Gisle Aas.

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

=cut

__END__

#ABSTRACT: Low-level HTTP over SSL/TLS connection (client)

PK       ! 4;{g�  �    perl5/lib/core/only.pmnu ��6�$        package lib::core::only;

use strict;
use warnings FATAL => 'all';
use Config;

sub import {
  @INC = @Config{qw(privlibexp archlibexp)};
  return
}

=head1 NAME

lib::core::only - Remove all non-core paths from @INC to avoid site/vendor dirs

=head1 SYNOPSIS

  use lib::core::only; # now @INC contains only the two core directories

To get only the core directories plus the ones for the local::lib in scope:

  $ perl -mlocal::lib -Mlib::core::only -Mlocal::lib=~/perl5 myscript.pl

To attempt to do a self-contained build (but note this will not reliably
propagate into subprocesses, see the CAVEATS below):

  $ PERL5OPT='-mlocal::lib -Mlib::core::only -Mlocal::lib=~/perl5' cpan

Please note that it is necessary to use C<local::lib> twice for this to work.
First so that C<lib::core::only> doesn't prevent C<local::lib> from loading
(it's not currently in core) and then again after C<lib::core::only> so that
the local paths are not removed.

=head1 DESCRIPTION

lib::core::only is simply a shortcut to say "please reduce my @INC to only
the core lib and archlib (architecture-specific lib) directories of this perl".

You might want to do this to ensure a local::lib contains only the code you
need, or to test an L<App::FatPacker|App::FatPacker> tree, or to avoid known
bad vendor packages.

You might want to use this to try and install a self-contained tree of perl
modules. Be warned that that probably won't work (see L</CAVEATS>).

This module was extracted from L<local::lib|local::lib>'s --self-contained
feature, and contains the only part that ever worked. I apologise to anybody
who thought anything else did.

=head1 CAVEATS

This does B<not> propagate properly across perl invocations like local::lib's
stuff does. It can't. It's only a module import, so it B<only affects the
specific perl VM instance in which you load and import() it>.

If you want to cascade it across invocations, you can set the PERL5OPT
environment variable to '-Mlib::core::only' and it'll sort of work. But be
aware that taint mode ignores this, so some modules' build and test code
probably will as well.

You also need to be aware that perl's command line options are not processed
in order - -I options take effect before -M options, so

  perl -Mlib::core::only -Ilib

is unlike to do what you want - it's exactly equivalent to:

  perl -Mlib::core::only

If you want to combine a core-only @INC with additional paths, you need to
add the additional paths using -M options and the L<lib|lib> module:

  perl -Mlib::core::only -Mlib=lib

  # or if you're trying to test compiled code:

  perl -Mlib::core::only -Mblib

For more information on the impossibility of sanely propagating this across
module builds without help from the build program, see
L<http://www.shadowcat.co.uk/blog/matt-s-trout/tainted-love> - and for ways
to achieve the old --self-contained feature's results, look at
L<App::FatPacker|App::FatPacker>'s tree function, and at
L<App::cpanminus|cpanm>'s --local-lib-contained feature.

=head1 AUTHOR

Matt S. Trout <mst@shadowcat.co.uk>

=head1 LICENSE

This library is free software under the same terms as perl itself.

=head1 COPYRIGHT

(c) 2010 the lib::core::only L</AUTHOR> as specified above.

=cut

1;
PK       ! |����@  �@    perl5/FFI/CheckLib.pmnu ��6�$        package FFI::CheckLib;

use strict;
use warnings;
use File::Spec;
use Carp qw( croak carp );
use base qw( Exporter );

our @EXPORT = qw(
  find_lib
  assert_lib
  check_lib
  check_lib_or_exit
  find_lib_or_exit
  find_lib_or_die
);

our @EXPORT_OK = qw(
  which
  where
  has_symbols
);

# ABSTRACT: Check that a library is available for FFI
our $VERSION = '0.27'; # VERSION


our $system_path = [];
our $os ||= $^O;
my $try_ld_on_text = 0;

if($os eq 'MSWin32' || $os eq 'msys')
{
  $system_path = eval {
    require Env;
    Env->import('@PATH');
    \our @PATH;
  };
  die $@ if $@;
}
else
{
  $system_path = eval {
    require DynaLoader;
    no warnings 'once';
    \@DynaLoader::dl_library_path;
  };
  die $@ if $@;
}

our $pattern = [ qr{^lib(.*?)\.so(?:\.([0-9]+(?:\.[0-9]+)*))?$} ];
our $version_split = qr/\./;

if($os eq 'cygwin')
{
  push @$pattern, qr{^cyg(.*?)(?:-([0-9])+)?\.dll$};
}
elsif($os eq 'msys')
{
  # doesn't seem as though msys uses psudo libfoo.so files
  # in the way that cygwin sometimes does.  we can revisit
  # this if we find otherwise.
  $pattern = [ qr{^msys-(.*?)(?:-([0-9])+)?\.dll$} ];
}
elsif($os eq 'MSWin32')
{
  #  handle cases like libgeos-3-7-0___.dll and libgtk-2.0-0.dll
  $pattern = [ qr{^(?:lib)?(\w+?)(?:-([0-9-\.]+))?_*\.dll$}i ];
  $version_split = qr/\-/;
}
elsif($os eq 'darwin')
{
  push @$pattern, qr{^lib(.*?)(?:\.([0-9]+(?:\.[0-9]+)*))?\.(?:dylib|bundle)$};
}
elsif($os eq 'linux')
{
  if(-e '/etc/redhat-release' && -x '/usr/bin/ld')
  {
    $try_ld_on_text = 1;
  }
}

sub _matches
{
  my($filename, $path) = @_;

  foreach my $regex (@$pattern)
  {
    return [
      $1,                                            # 0    capture group 1 library name
      File::Spec->catfile($path, $filename),         # 1    full path to library
      defined $2 ? (split $version_split, $2) : (),  # 2... capture group 2 library version
    ] if $filename =~ $regex;
  }
  return ();
}

sub _cmp
{
  my($A,$B) = @_;

  return $A->[0] cmp $B->[0] if $A->[0] ne $B->[0];

  my $i=2;
  while(1)
  {
    return 0  if !defined($A->[$i]) && !defined($B->[$i]);
    return -1 if !defined $A->[$i];
    return 1  if !defined $B->[$i];
    return $B->[$i] <=> $A->[$i] if $A->[$i] != $B->[$i];
    $i++;
  }
}


my $diagnostic;

sub _is_binary
{
  -B $_[0]
}

sub find_lib
{
  my(%args) = @_;

  undef $diagnostic;
  croak "find_lib requires lib argument" unless defined $args{lib};

  my $recursive = $args{_r} || $args{recursive} || 0;

  # make arguments be lists.
  foreach my $arg (qw( lib libpath symbol verify alien ))
  {
    next if ref $args{$arg} eq 'ARRAY';
    if(defined $args{$arg})
    {
      $args{$arg} = [ $args{$arg} ];
    }
    else
    {
      $args{$arg} = [];
    }
  }

  if(defined $args{systempath} && !ref($args{systempath}))
  {
    $args{systempath} = [ $args{systempath} ];
  }

  my @path = @{ $args{libpath} };
  @path = map { _recurse($_) } @path if $recursive;
  push @path, grep { defined } defined $args{systempath}
    ? @{ $args{systempath} }
    : @$system_path;

  my $any = 1 if grep { $_ eq '*' } @{ $args{lib} };
  my %missing = map { $_ => 1 } @{ $args{lib} };
  my %symbols = map { $_ => 1 } @{ $args{symbol} };
  my @found;

  delete $missing{'*'};

  foreach my $alien (@{ $args{alien} })
  {
    unless($alien =~ /^([A-Za-z_][A-Za-z_0-9]*)(::[A-Za-z_][A-Za-z_0-9]*)*$/)
    {
        croak "Doesn't appear to be a valid Alien name $alien";
    }
    unless(eval { $alien->can('dynamic_libs') })
    {
      my $pm = "$alien.pm";
      $pm =~ s/::/\//g;
      require $pm;
      unless(eval { $alien->can('dynamic_libs') })
      {
        croak "Alien $alien doesn't provide a dynamic_libs method";
      }
    }
    push @path, [$alien->dynamic_libs];
  }

  foreach my $path (@path)
  {
    next if ref $path ne 'ARRAY' && ! -d $path;

    my @maybe =
      # make determinist based on names and versions
      sort { _cmp($a,$b) }
      # Filter out the items that do not match the name that we are looking for
      # Filter out any broken symbolic links
      grep { ($any || $missing{$_->[0]} ) && (-e $_->[1]) }
      ref $path eq 'ARRAY'
        ? do {
          map {
            my($v, $d, $f) = File::Spec->splitpath($_);
            _matches($f, File::Spec->catpath($v,$d));
          } @$path;
        }
        : do {
          my $dh;
          opendir $dh, $path;
          # get [ name, full_path ] mapping,
          # each entry is a 2 element list ref
          map { _matches($_,$path) } readdir $dh;
        };

    if($try_ld_on_text && $args{try_linker_script})
    {
      # This is tested in t/ci.t only
      @maybe = map {
        -B $_->[1] ? $_ : do {
          my($name, $so) = @$_;
          my $output = `/usr/bin/ld -t $so -o /dev/null -shared`;
          $output =~ /\((.*?lib.*\.so.*?)\)/
            ? [$name, $1]
            : die "unable to parse ld output";
        }
      } @maybe;
    }

    midloop:
    foreach my $lib (@maybe)
    {
      next unless $any || $missing{$lib->[0]};

      foreach my $verify (@{ $args{verify} })
      {
        next midloop unless $verify->(@$lib);
      }

      delete $missing{$lib->[0]};

      if(%symbols)
      {
        require DynaLoader;
        my $dll = DynaLoader::dl_load_file($lib->[1],0);
        foreach my $symbol (keys %symbols)
        {
          if(DynaLoader::dl_find_symbol($dll, $symbol) ? 1 : 0)
          {
            delete $symbols{$symbol}
          }
        }
        DynaLoader::dl_unload_file($dll);
      }

      my $found = $lib->[1];

      unless($any)
      {
        while(-l $found)
        {
          require File::Basename;
          my $dir = File::Basename::dirname($found);
          $found = File::Spec->rel2abs( readlink($found), $dir );
        }
      }

      push @found, $found;
    }
  }

  if(%missing)
  {
    my @missing = sort keys %missing;
    if(@missing > 1)
    { $diagnostic = "libraries not found: @missing" }
    else
    { $diagnostic = "library not found: @missing" }
  }
  elsif(%symbols)
  {
    my @missing = sort keys %symbols;
    if(@missing > 1)
    { $diagnostic = "symbols not found: @missing" }
    else
    { $diagnostic = "symbol not found: @missing" }
  }

  return if %symbols;
  return $found[0] unless wantarray;
  return @found;
}

sub _recurse
{
  my($dir) = @_;
  return unless -d $dir;
  my $dh;
  opendir $dh, $dir;
  my @list = grep { -d $_ } map { File::Spec->catdir($dir, $_) } grep !/^\.\.?$/, readdir $dh;
  closedir $dh;
  ($dir, map { _recurse($_) } @list);
}


sub assert_lib
{
  croak $diagnostic || 'library not found' unless check_lib(@_);
}


sub check_lib_or_exit
{
  unless(check_lib(@_))
  {
    carp $diagnostic || 'library not found';
    exit;
  }
}


sub find_lib_or_exit
{
  my(@libs) = find_lib(@_);
  unless(@libs)
  {
    carp $diagnostic || 'library not found';
    exit;
  }
  return unless @libs;
  wantarray ? @libs : $libs[0];
}


sub find_lib_or_die
{
  my(@libs) = find_lib(@_);
  unless(@libs)
  {
    croak $diagnostic || 'library not found';
  }
  return unless @libs;
  wantarray ? @libs : $libs[0];
}


sub check_lib
{
  find_lib(@_) ? 1 : 0;
}


sub which
{
  my($name) = @_;
  croak("cannot which *") if $name eq '*';
  scalar find_lib( lib => $name );
}


sub where
{
  my($name) = @_;
  $name eq '*'
    ? find_lib(lib => '*')
    : find_lib(lib => '*', verify => sub { $_[0] eq $name });
}


sub has_symbols
{
  my($path, @symbols) = @_;
  require DynaLoader;
  my $dll = DynaLoader::dl_load_file($path, 0);

  my $ok = 1;

  foreach my $symbol (@symbols)
  {
    unless(DynaLoader::dl_find_symbol($dll, $symbol))
    {
      $ok = 0;
      last;
    }
  }

  DynaLoader::dl_unload_file($dll);

  $ok;
}


sub system_path
{
  $system_path;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

FFI::CheckLib - Check that a library is available for FFI

=head1 VERSION

version 0.27

=head1 SYNOPSIS

 use FFI::CheckLib;
 
 check_lib_or_exit( lib => 'jpeg', symbol => 'jinit_memory_mgr' );
 check_lib_or_exit( lib => [ 'iconv', 'jpeg' ] );
 
 # or prompt for path to library and then:
 print "where to find jpeg library: ";
 my $path = <STDIN>;
 check_lib_or_exit( lib => 'jpeg', libpath => $path );

=head1 DESCRIPTION

This module checks whether a particular dynamic library is available for
FFI to use. It is modeled heavily on L<Devel::CheckLib>, but will find
dynamic libraries even when development packages are not installed.  It
also provides a L<find_lib|FFI::CheckLib#find_lib> function that will
return the full path to the found dynamic library, which can be feed
directly into L<FFI::Platypus> or another FFI system.

Although intended mainly for FFI modules via L<FFI::Platypus> and
similar, this module does not actually use any FFI to do its detection
and probing.  This module does not have any non-core runtime dependencies.
The test suite does depend on L<Test2::Suite>.

=head1 FUNCTIONS

All of these take the same named parameters and are exported by default.

=head2 find_lib

 my(@libs) = find_lib(%args);

This will return a list of dynamic libraries, or empty list if none were
found.

[version 0.05]

If called in scalar context it will return the first library found.

Arguments are key value pairs with these keys:

=over 4

=item lib

Must be either a string with the name of a single library or a reference
to an array of strings of library names.  Depending on your platform,
C<CheckLib> will prepend C<lib> or append C<.dll> or C<.so> when
searching.

[version 0.11]

As a special case, if C<*> is specified then any libs found will match.

=item libpath

A string or array of additional paths to search for libraries.

=item systempath

[version 0.11]

A string or array of system paths to search for instead of letting
L<FFI::CheckLib> determine the system path.  You can set this to C<[]>
in order to not search I<any> system paths.

=item symbol

A string or a list of symbol names that must be found.

=item verify

A code reference used to verify a library really is the one that you
want.  It should take two arguments, which is the name of the library
and the full path to the library pathname.  It should return true if it
is acceptable, and false otherwise.  You can use this in conjunction
with L<FFI::Platypus> to determine if it is going to meet your needs.
Example:

 use FFI::CheckLib;
 use FFI::Platypus;
 
 my($lib) = find_lib(
   lib => 'foo',
   verify => sub {
     my($name, $libpath) = @_;
 
     my $ffi = FFI::Platypus->new;
     $ffi->lib($libpath);
 
     my $f = $ffi->function('foo_version', [] => 'int');
 
     return $f->call() >= 500; # we accept version 500 or better
   },
 );

=item recursive

[version 0.11]

Recursively search for libraries in any non-system paths (those provided
via C<libpath> above).

=item try_linker_script

[version 0.24]

Some vendors provide C<.so> files that are linker scripts that point to
the real binary shared library.  These linker scripts can be used by gcc
or clang, but are not directly usable by L<FFI::Platypus> and friends.
On select platforms, this options will use the linker command (C<ld>)
to attempt to resolve the real C<.so> for non-binary files.  Since there
is extra overhead this is off by default.

An example is libyaml on Red Hat based Linux distributions.  On Debian
these are handled with symlinks and no trickery is required.

=item alien

[version 0.25]

If no libraries can be found, try the given aliens instead.  The Alien
classes specified must provide the L<Alien::Base> interface for dynamic
libraries, which is to say they should provide a method called
C<dynamic_libs> that returns a list of dynamic libraries.

=back

=head2 assert_lib

 assert_lib(%args);

This behaves exactly the same as L<find_lib|FFI::CheckLib#find_lib>,
except that instead of returning empty list of failure it throws an
exception.

=head2 check_lib_or_exit

 check_lib_or_exit(%args);

This behaves exactly the same as L<assert_lib|FFI::CheckLib#assert_lib>,
except that instead of dying, it warns (with exactly the same error
message) and exists.  This is intended for use in C<Makefile.PL> or
C<Build.PL>

=head2 find_lib_or_exit

[version 0.05]

 my(@libs) = find_lib_or_exit(%args);

This behaves exactly the same as L<find_lib|FFI::CheckLib#find_lib>,
except that if the library is not found, it will call exit with an
appropriate diagnostic.

=head2 find_lib_or_die

[version 0.06]

 my(@libs) = find_lib_or_die(%args);

This behaves exactly the same as L<find_lib|FFI::CheckLib#find_lib>,
except that if the library is not found, it will die with an appropriate
diagnostic.

=head2 check_lib

 my $bool = check_lib(%args);

This behaves exactly the same as L<find_lib|FFI::CheckLib#find_lib>,
except that it returns true (1) on finding the appropriate libraries or
false (0) otherwise.

=head2 which

[version 0.17]

 my $path = where($name);

Return the path to the first library that matches the given name.

Not exported by default.

=head2 where

[version 0.17]

 my @paths = where($name);

Return the paths to all the libraries that match the given name.

Not exported by default.

=head2 has_symbols

[version 0.17]

 my $bool = has_symbols($path, @symbol_names);

Returns true if I<all> of the symbols can be found in the dynamic library located
at the given path.  Can be useful in conjunction with C<verify> with C<find_lib>
above.

Not exported by default.

=head2 system_path

[version 0.20]

 my $path = FFI::CheckLib::system_path;

Returns the system path as a list reference.  On some systems, this is C<PATH>
on others it might be C<LD_LIBRARY_PATH> on still others it could be something
completely different.  So although you I<may> add items to this list, you should
probably do some careful consideration before you do so.

This function is not exportable, even on request.

=head1 FAQ

=over 4

=item Why not just use C<dlopen>?

Calling C<dlopen> on a library name and then C<dlclose> immediately can tell
you if you have the exact name of a library available on a system.  It does
have a number of drawbacks as well.

=over 4

=item No absolute or relative path

It only tells you that the library is I<somewhere> on the system, not having
the absolute or relative path makes it harder to generate useful diagnostics.

=item POSIX only

This doesn't work on non-POSIX systems like Microsoft Windows. If you are
using a POSIX emulation layer on Windows that provides C<dlopen>, like
Cygwin, there are a number of gotchas there as well.  Having a layer written
in Perl handles this means that developers on Unix can develop FFI that will
more likely work on these platforms without special casing them.

=item inconsistent implementations

Even on POSIX systems you have inconsistent implementations.  OpenBSD for
example don't usually include symlinks for C<.so> files meaning you need
to know the exact C<.so> version.

=item non-system directories

By default C<dlopen> only works for libraries in the system paths.  Most
platforms have a way of configuring the search for different non-system
paths, but none of them are portable, and are usually discouraged anyway.
L<Alien> and friends need to do searches for dynamic libraries in
non-system directories for C<share> installs.

=back

=item My 64-bit Perl is misconfigured and has 32-bit libraries in its search path.  Is that a bug in L<FFI::CheckLib>?

Nope.

=item The way L<FFI::CheckLib> is implemented it won't work on AIX, HP-UX, OpenVMS or Plan 9.

I know for a fact that it doesn't work on AIX I<as currently implemented>
because I used to develop on AIX in the early 2000s, and I am aware of some
of the technical challenges.  There are probably other systems that it won't
work on.  I would love to add support for these platforms.  Realistically
these platforms have a tiny market share, and absent patches from users or
the companies that own these operating systems (patches welcome), or hardware
/ CPU time donations, these platforms are unsupportable anyway.

=back

=head1 SEE ALSO

=over 4

=item L<FFI::Platypus>

Call library functions dynamically without a compiler.

=item L<Dist::Zilla::Plugin::FFI::CheckLib>

L<Dist::Zilla> plugin for this module.

=back

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Bakkiaraj Murugesan (bakkiaraj)

Dan Book (grinnz, DBOOK)

Ilya Pavlov (Ilya, ILUX)

Shawn Laffan (SLAFFAN)

Petr Pisar (ppisar)

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2014-2018 by Graham Ollis.

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

=cut
PK       ! ����L  �L    perl5/XML/SAX/Expat.pmnu �7��m        
###
# XML::SAX::Expat - SAX2 Driver for Expat (XML::Parser)
# Originally by Robin Berjon
###

package XML::SAX::Expat;
use strict;
use base qw(XML::SAX::Base);
use XML::NamespaceSupport   qw();
use XML::Parser             qw();

use vars qw($VERSION);
$VERSION = '0.51';


#,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,#
#`,`, Variations on parse `,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,#
#```````````````````````````````````````````````````````````````````#

#-------------------------------------------------------------------#
# CharacterStream
#-------------------------------------------------------------------#
sub _parse_characterstream {
    my $p       = shift;
    my $xml     = shift;
    my $opt     = shift;

    my $expat = $p->_create_parser($opt);
    my $result = $expat->parse($xml);
    $p->_cleanup;
    return $result;
}
#-------------------------------------------------------------------#

#-------------------------------------------------------------------#
# ByteStream
#-------------------------------------------------------------------#
sub _parse_bytestream {
    my $p       = shift;
    my $xml     = shift;
    my $opt     = shift;

    my $expat = $p->_create_parser($opt);
    my $result = $expat->parse($xml);
    $p->_cleanup;
    return $result;
}
#-------------------------------------------------------------------#

#-------------------------------------------------------------------#
# String
#-------------------------------------------------------------------#
sub _parse_string {
    my $p       = shift;
    my $xml     = shift;
    my $opt     = shift;

    my $expat = $p->_create_parser($opt);
    my $result = $expat->parse($xml);
    $p->_cleanup;
    return $result;
}
#-------------------------------------------------------------------#

#-------------------------------------------------------------------#
# SystemId
#-------------------------------------------------------------------#
sub _parse_systemid {
    my $p       = shift;
    my $xml     = shift;
    my $opt     = shift;

    my $expat = $p->_create_parser($opt);
    my $result = $expat->parsefile($xml);
    $p->_cleanup;
    return $result;
}
#-------------------------------------------------------------------#


#-------------------------------------------------------------------#
# $p->_create_parser(\%options)
#-------------------------------------------------------------------#
sub _create_parser {
    my $self = shift;
    my $opt  = shift;

    die "ParserReference: parser instance ($self) already parsing\n"
         if $self->{_InParse};

    my $featUri = 'http://xml.org/sax/features/';
    my $ppe = ($self->get_feature($featUri . 'external-general-entities') or
               $self->get_feature($featUri . 'external-parameter-entities') ) ? 1 : 0;

    my $expat = XML::Parser->new( ParseParamEnt => $ppe );
    $expat->{__XSE} = $self;
    $expat->setHandlers(
                        Init        => \&_handle_init,
                        Final       => \&_handle_final,
                        Start       => \&_handle_start,
                        End         => \&_handle_end,
                        Char        => \&_handle_char,
                        Comment     => \&_handle_comment,
                        Proc        => \&_handle_proc,
                        CdataStart  => \&_handle_start_cdata,
                        CdataEnd    => \&_handle_end_cdata,
                        Unparsed    => \&_handle_unparsed_entity,
                        Notation    => \&_handle_notation_decl,
                        #ExternEnt
                        #ExternEntFin
                        Entity      => \&_handle_entity_decl,
                        Element     => \&_handle_element_decl,
                        Attlist     => \&_handle_attr_decl,
                        Doctype     => \&_handle_start_doctype,
                        DoctypeFin  => \&_handle_end_doctype,
                        XMLDecl     => \&_handle_xml_decl,
                      );

    $self->{_InParse} = 1;
    $self->{_NodeStack} = [];
    $self->{_NSStack} = [];
    $self->{_NSHelper} = XML::NamespaceSupport->new({xmlns => 1});
    $self->{_started} = 0;

    return $expat;
}
#-------------------------------------------------------------------#


#-------------------------------------------------------------------#
# $p->_cleanup
#-------------------------------------------------------------------#
sub _cleanup {
    my $self = shift;

    $self->{_InParse} = 0;
    delete $self->{_NodeStack};
}
#-------------------------------------------------------------------#


#,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,#
#`,`, Expat Handlers ,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,#
#```````````````````````````````````````````````````````````````````#

#-------------------------------------------------------------------#
# _handle_init
#-------------------------------------------------------------------#
sub _handle_init {
    #my $self    = shift()->{__XSE};

    #my $document = {};
    #push @{$self->{_NodeStack}}, $document;
    #$self->SUPER::start_document($document);
}
#-------------------------------------------------------------------#

#-------------------------------------------------------------------#
# _handle_final
#-------------------------------------------------------------------#
sub _handle_final {
    my $self    = shift()->{__XSE};

    #my $document = pop @{$self->{_NodeStack}};
    return $self->SUPER::end_document({});
}
#-------------------------------------------------------------------#

#-------------------------------------------------------------------#
# _handle_start
#-------------------------------------------------------------------#
sub _handle_start {
    my $self    = shift()->{__XSE};
    my $e_name  = shift;
    my %attr    = @_;

    # start_document data
    $self->_handle_start_document({}) unless $self->{_started};

    # take care of namespaces
    my $nsh = $self->{_NSHelper};
    $nsh->push_context;
    my @new_ns;
    for my $k (grep !index($_, 'xmlns'), keys %attr) {
        $k =~ m/^xmlns(:(.*))?$/;
        my $prefix = $2 || '';
        $nsh->declare_prefix($prefix, $attr{$k});
        my $ns = {
                    Prefix       => $prefix,
                    NamespaceURI => $attr{$k},
                 };
        push @new_ns, $ns;
        $self->SUPER::start_prefix_mapping($ns);
    }
    push @{$self->{_NSStack}}, \@new_ns;


    # create the attributes
    my %saxattr;
    map {
        my ($ns,$prefix,$lname) = $nsh->process_attribute_name($_);
        $saxattr{'{' . ($ns || '') . '}' . $lname} = {
                                    Name         => $_,
                                    LocalName    => $lname || '',
                                    Prefix       => $prefix || '',
                                    Value        => $attr{$_},
                                    NamespaceURI => $ns || '',
                                 };
    } keys %attr;


    # now the element
    my ($ns,$prefix,$lname) = $nsh->process_element_name($e_name);
    my $element = {
                    Name         => $e_name,
                    LocalName    => $lname || '',
                    Prefix       => $prefix || '',
                    NamespaceURI => $ns || '',
                    Attributes   => \%saxattr,
                   };

    push @{$self->{_NodeStack}}, $element;
    $self->SUPER::start_element($element);
}
#-------------------------------------------------------------------#

#-------------------------------------------------------------------#
# _handle_end
#-------------------------------------------------------------------#
sub _handle_end {
    my $self    = shift()->{__XSE};

    my %element = %{pop @{$self->{_NodeStack}}};
    delete $element{Attributes};
    $self->SUPER::end_element(\%element);

    my $prev_ns = pop @{$self->{_NSStack}};
    for my $ns (@$prev_ns) {
        $self->SUPER::end_prefix_mapping( { %$ns } );
    }
    $self->{_NSHelper}->pop_context;
}
#-------------------------------------------------------------------#

#-------------------------------------------------------------------#
# _handle_char
#-------------------------------------------------------------------#
sub _handle_char {
    $_[0]->{__XSE}->_handle_start_document({}) unless $_[0]->{__XSE}->{_started};
    $_[0]->{__XSE}->SUPER::characters({ Data => $_[1] });
}
#-------------------------------------------------------------------#

#-------------------------------------------------------------------#
# _handle_comment
#-------------------------------------------------------------------#
sub _handle_comment {
    $_[0]->{__XSE}->_handle_start_document({}) unless $_[0]->{__XSE}->{_started};
    $_[0]->{__XSE}->SUPER::comment({ Data => $_[1] });
}
#-------------------------------------------------------------------#

#-------------------------------------------------------------------#
# _handle_proc
#-------------------------------------------------------------------#
sub _handle_proc {
    $_[0]->{__XSE}->_handle_start_document({}) unless $_[0]->{__XSE}->{_started};
    $_[0]->{__XSE}->SUPER::processing_instruction({ Target => $_[1], Data => $_[2] });
}
#-------------------------------------------------------------------#

#-------------------------------------------------------------------#
# _handle_start_cdata
#-------------------------------------------------------------------#
sub _handle_start_cdata {
    $_[0]->{__XSE}->SUPER::start_cdata( {} );
}
#-------------------------------------------------------------------#

#-------------------------------------------------------------------#
# _handle_end_cdata
#-------------------------------------------------------------------#
sub _handle_end_cdata {
    $_[0]->{__XSE}->SUPER::end_cdata( {} );
}
#-------------------------------------------------------------------#

#-------------------------------------------------------------------#
# _handle_xml_decl
#-------------------------------------------------------------------#
sub _handle_xml_decl {
    my $self    = shift()->{__XSE};
    my $version     = shift;
    my $encoding    = shift;
    my $standalone  = shift;

    if (not defined $standalone) { $standalone = '';    }
    elsif ($standalone)          { $standalone = 'yes'; }
    else                         { $standalone = 'no';  }
    my $xd = {
                Version     => $version,
                Encoding    => $encoding,
                Standalone  => $standalone,
             };
    #$self->SUPER::xml_decl($xd);
    $self->_handle_start_document($xd);
}
#-------------------------------------------------------------------#

#-------------------------------------------------------------------#
# _handle_notation_decl
#-------------------------------------------------------------------#
sub _handle_notation_decl {
    my $self    = shift()->{__XSE};
    my $notation    = shift;
    shift;
    my $system      = shift;
    my $public      = shift;

    my $not = {
                Name        => $notation,
                PublicId    => $public,
                SystemId    => $system,
              };
    $self->SUPER::notation_decl($not);
}
#-------------------------------------------------------------------#

#-------------------------------------------------------------------#
# _handle_unparsed_entity
#-------------------------------------------------------------------#
sub _handle_unparsed_entity {
    my $self    = shift()->{__XSE};
    my $name        = shift;
    my $system      = shift;
    my $public      = shift;
    my $notation    = shift;

    my $ue = {
                Name        => $name,
                PublicId    => $public,
                SystemId    => $system,
                Notation    => $notation,
             };
    $self->SUPER::unparsed_entity_decl($ue);
}
#-------------------------------------------------------------------#

#-------------------------------------------------------------------#
# _handle_element_decl
#-------------------------------------------------------------------#
sub _handle_element_decl {
    $_[0]->{__XSE}->SUPER::element_decl({ Name => $_[1], Model => "$_[2]" });
}
#-------------------------------------------------------------------#


#-------------------------------------------------------------------#
# _handle_attr_decl
#-------------------------------------------------------------------#
sub _handle_attr_decl {
    my $self    = shift()->{__XSE};
    my $ename   = shift;
    my $aname   = shift;
    my $type    = shift;
    my $default = shift;
    my $fixed   = shift;

    my ($vd, $value);
    if ($fixed) {
        $vd = '#FIXED';
        $default =~ s/^(?:"|')//; #"
        $default =~ s/(?:"|')$//; #"
        $value = $default;
    }
    else {
        if ($default =~ m/^#/) {
            $vd = $default;
            $value = '';
        }
        else {
            $vd = ''; # maybe there's a default ?
            $default =~ s/^(?:"|')//; #"
            $default =~ s/(?:"|')$//; #"
            $value = $default;
        }
    }

    my $at = {
                eName           => $ename,
                aName           => $aname,
                Type            => $type,
                ValueDefault    => $vd,
                Value           => $value,
             };
    $self->SUPER::attribute_decl($at);
}
#-------------------------------------------------------------------#

#-------------------------------------------------------------------#
# _handle_entity_decl
#-------------------------------------------------------------------#
sub _handle_entity_decl {
    my $self    = shift()->{__XSE};
    my $name    = shift;
    my $val     = shift;
    my $sys     = shift;
    my $pub     = shift;
    my $ndata   = shift;
    my $isprm   = shift;

    # deal with param ents
    if ($isprm) {
        $name = '%' . $name;
    }

    # int vs ext
    if ($val) {
        my $ent = {
                    Name    => $name,
                    Value   => $val,
                  };
        $self->SUPER::internal_entity_decl($ent);
    }
    else {
        my $ent = {
                    Name        => $name,
                    PublicId    => $pub || '',
                    SystemId    => $sys,
                  };
        $self->SUPER::external_entity_decl($ent);
    }
}
#-------------------------------------------------------------------#


#-------------------------------------------------------------------#
# _handle_start_doctype
#-------------------------------------------------------------------#
sub _handle_start_doctype {
    my $self    = shift()->{__XSE};
    my $name    = shift;
    my $sys     = shift;
    my $pub     = shift;

    $self->_handle_start_document({}) unless $self->{_started};

    my $dtd = {
                Name        => $name,
                SystemId    => $sys,
                PublicId    => $pub,
              };
    $self->SUPER::start_dtd($dtd);
}
#-------------------------------------------------------------------#

#-------------------------------------------------------------------#
# _handle_end_doctype
#-------------------------------------------------------------------#
sub _handle_end_doctype {
    $_[0]->{__XSE}->SUPER::end_dtd( {} );
}
#-------------------------------------------------------------------#


#-------------------------------------------------------------------#
# _handle_start_document
#-------------------------------------------------------------------#
sub _handle_start_document {
    $_[0]->SUPER::start_document($_[1]);
    $_[0]->{_started} = 1;
}
#-------------------------------------------------------------------#


#-------------------------------------------------------------------#
# supported_features
#-------------------------------------------------------------------#
sub supported_features {
    return (
             $_[0]->SUPER::supported_features,
             'http://xml.org/sax/features/external-general-entities',
             'http://xml.org/sax/features/external-parameter-entities',
           );
}
#-------------------------------------------------------------------#


#,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,#
#`,`, Private Helpers `,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,#
#```````````````````````````````````````````````````````````````````#

#-------------------------------------------------------------------#
# _create_node
#-------------------------------------------------------------------#
#sub _create_node {
#    shift;
#    # this may check for a factory later
#    return {@_};
#}
#-------------------------------------------------------------------#


1;
#,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,#
#`,`, Documentation `,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,#
#```````````````````````````````````````````````````````````````````#

=pod

=head1 NAME

XML::SAX::Expat - SAX2 Driver for Expat (XML::Parser)

=head1 SYNOPSIS

  use XML::SAX::Expat;
  use XML::SAX::MyFooHandler;
  my $h = XML::SAX::MyFooHandler->new;
  my $p = XML::SAX::Expat->new(Handler => $h);
  $p->parse_file('/path/to/foo.xml');

=head1 DESCRIPTION

This is an implementation of a SAX2 driver sitting on top of Expat
(XML::Parser) which Ken MacLeod posted to perl-xml and which I have
updated.

It is still incomplete, though most of the basic SAX2 events should be
available. The SAX2 spec is currently available from L<http://perl-xml.sourceforge.net/perl-sax/>.

A more friendly URL as well as a PODification of the spec are in the
works.

=head1 METHODS

The methods defined in this class correspond to those listed in the
PerlSAX2 specification, available above.

=head1 FEATURES AND CAVEATS

=over 2

=item supported_features

Returns:

  * http://xml.org/sax/features/external-general-entities
  * http://xml.org/sax/features/external-parameter-entities
  * [ Features supported by ancestors ]

Turning one of the first two on also turns the other on (this maps
to the XML::Parser ParseParamEnts option). This may be fixed in the
future, so don't rely on this behaviour.

=back

=head1 MISSING PARTS

XML::Parser has no listed callbacks for the following events, which
are therefore not presently generated (ways may be found in the
future):

  * ignorable_whitespace
  * skipped_entity
  * start_entity / end_entity
  * resolve_entity

Ways of signalling them are welcome. In addition to those,
set_document_locator is not yet called.

=head1 TODO

  - reuse Ken's tests and add more

=head1 AUTHOR

Robin Berjon; stolen from Ken Macleod, ken@bitsko.slc.ut.us, and with
suggestions and feedback from perl-xml. Currently maintained by Bjoern
Hoehrmann, L<http://bjoern.hoehrmann.de/>.

=head1 COPYRIGHT AND LICENSE

Copyright (c) 2001-2008 Robin Berjon. All rights reserved. This program is
free software; you can redistribute it and/or modify it under the same
terms as Perl itself.

=head1 SEE ALSO

XML::Parser::PerlSAX

=cut
PK       ! �q�i� �   perl5/XML/Simple.pmnu ��6�$        package XML::Simple;
$XML::Simple::VERSION = '2.25';
=head1 NAME

XML::Simple - An API for simple XML files

=head1 SYNOPSIS

PLEASE DO NOT USE THIS MODULE IN NEW CODE.  If you ignore this
warning and use it anyway, the C<qw(:strict)> mode will save you a little pain.

    use XML::Simple qw(:strict);

    my $ref = XMLin([<xml file or string>] [, <options>]);

    my $xml = XMLout($hashref [, <options>]);

Or the object oriented way:

    require XML::Simple qw(:strict);

    my $xs = XML::Simple->new([<options>]);

    my $ref = $xs->XMLin([<xml file or string>] [, <options>]);

    my $xml = $xs->XMLout($hashref [, <options>]);

(or see L<"SAX SUPPORT"> for 'the SAX way').

Note, in these examples, the square brackets are used to denote optional items
not to imply items should be supplied in arrayrefs.

=cut

# See after __END__ for more POD documentation


# Load essentials here, other modules loaded on demand later

use strict;
use warnings;
use warnings::register;
use Carp;
use Scalar::Util qw();
require Exporter;


##############################################################################
# Define some constants
#

use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $PREFERRED_PARSER);

@ISA               = qw(Exporter);
@EXPORT            = qw(XMLin XMLout);
@EXPORT_OK         = qw(xml_in xml_out);

my %StrictMode     = ();

my @KnownOptIn     = qw(keyattr keeproot forcecontent contentkey noattr
                        searchpath forcearray cache suppressempty parseropts
                        grouptags nsexpand datahandler varattr variables
                        normalisespace normalizespace valueattr strictmode);

my @KnownOptOut    = qw(keyattr keeproot contentkey noattr
                        rootname xmldecl outputfile noescape suppressempty
                        grouptags nsexpand handler noindent attrindent nosort
                        valueattr numericescape strictmode);

my @DefKeyAttr     = qw(name key id);
my $DefRootName    = qq(opt);
my $DefContentKey  = qq(content);
my $DefXmlDecl     = qq(<?xml version='1.0' standalone='yes'?>);

my $xmlns_ns       = 'http://www.w3.org/2000/xmlns/';
my $bad_def_ns_jcn = '{' . $xmlns_ns . '}';     # LibXML::SAX workaround


##############################################################################
# Globals for use by caching routines
#

my %MemShareCache  = ();
my %MemCopyCache   = ();


##############################################################################
# Wrapper for Exporter - handles ':strict'
#

sub import {
  # Handle the :strict tag

  my($calling_package) = caller();
  _strict_mode_for_caller(1) if grep(/^:strict$/, @_);

  # Pass everything else to Exporter.pm

  @_ = grep(!/^:strict$/, @_);
  goto &Exporter::import;
}


##############################################################################
# Constructor for optional object interface.
#

sub new {
  my $class = shift;

  if(@_ % 2) {
    croak "Default options must be name=>value pairs (odd number supplied)";
  }

  my %known_opt;
  @known_opt{@KnownOptIn, @KnownOptOut} = ();

  my %raw_opt = @_;
  $raw_opt{strictmode} = _strict_mode_for_caller()
    unless exists $raw_opt{strictmode};
  my %def_opt;
  while(my($key, $val) = each %raw_opt) {
    my $lkey = lc($key);
    $lkey =~ s/_//g;
    croak "Unrecognised option: $key" unless(exists($known_opt{$lkey}));
    $def_opt{$lkey} = $val;
  }
  my $self = { def_opt => \%def_opt };

  return(bless($self, $class));
}


##############################################################################
# Sub: _strict_mode_for_caller()
#
# Gets or sets the XML::Simple :strict mode flag for the calling namespace.
# Walks back through call stack to find the calling namespace and sets the
# :strict mode flag for that namespace if an argument was supplied and returns
# the flag value if not.
#

sub _strict_mode_for_caller {
  my $set_mode = @_;
  my $frame = 1;
  while(my($package) = caller($frame++)) {
    next if $package eq 'XML::Simple';
    $StrictMode{$package} = 1 if $set_mode;
    return $StrictMode{$package};
  }
  return(0);
}


##############################################################################
# Sub: _get_object()
#
# Helper routine called from XMLin() and XMLout() to create an object if none
# was provided.  Note, this routine does mess with the caller's @_ array.
#

sub _get_object {
  my $self;
  if($_[0]  and  UNIVERSAL::isa($_[0], 'XML::Simple')) {
    $self = shift;
  }
  else {
    $self = XML::Simple->new();
  }

  return $self;
}


##############################################################################
# Sub/Method: XMLin()
#
# Exported routine for slurping XML into a hashref - see pod for info.
#
# May be called as object method or as a plain function.
#
# Expects one arg for the source XML, optionally followed by a number of
# name => value option pairs.
#

sub XMLin {
  my $self = &_get_object;      # note, @_ is passed implicitly

  my $target = shift;


  # Work out whether to parse a string, a file or a filehandle

  if(not defined $target) {
    return $self->parse_file(undef, @_);
  }

  elsif($target eq '-') {
    local($/) = undef;
    $target = <STDIN>;
    return $self->parse_string(\$target, @_);
  }

  elsif(my $type = ref($target)) {
    if($type eq 'SCALAR') {
      return $self->parse_string($target, @_);
    }
    else {
      return $self->parse_fh($target, @_);
    }
  }

  elsif($target =~ m{<.*?>}s) {
    return $self->parse_string(\$target, @_);
  }

  else {
    return $self->parse_file($target, @_);
  }
}


##############################################################################
# Sub/Method: parse_file()
#
# Same as XMLin, but only parses from a named file.
#

sub parse_file {
  my $self = &_get_object;      # note, @_ is passed implicitly

  my $filename = shift;

  $self->handle_options('in', @_);

  $filename = $self->default_config_file if not defined $filename;

  $filename = $self->find_xml_file($filename, @{$self->{opt}->{searchpath}});

  # Check cache for previous parse

  if($self->{opt}->{cache}) {
    foreach my $scheme (@{$self->{opt}->{cache}}) {
      my $method = 'cache_read_' . $scheme;
      my $opt = $self->$method($filename);
      return($opt) if($opt);
    }
  }

  my $ref = $self->build_simple_tree($filename, undef);

  if($self->{opt}->{cache}) {
    my $method = 'cache_write_' . $self->{opt}->{cache}->[0];
    $self->$method($ref, $filename);
  }

  return $ref;
}


##############################################################################
# Sub/Method: parse_fh()
#
# Same as XMLin, but only parses from a filehandle.
#

sub parse_fh {
  my $self = &_get_object;      # note, @_ is passed implicitly

  my $fh = shift;
  croak "Can't use " . (defined $fh ? qq{string ("$fh")} : 'undef') .
        " as a filehandle" unless ref $fh;

  $self->handle_options('in', @_);

  return $self->build_simple_tree(undef, $fh);
}


##############################################################################
# Sub/Method: parse_string()
#
# Same as XMLin, but only parses from a string or a reference to a string.
#

sub parse_string {
  my $self = &_get_object;      # note, @_ is passed implicitly

  my $string = shift;

  $self->handle_options('in', @_);

  return $self->build_simple_tree(undef, ref $string ? $string : \$string);
}


##############################################################################
# Method: default_config_file()
#
# Returns the name of the XML file to parse if no filename (or XML string)
# was provided.
#

sub default_config_file {
  my $self = shift;

  require File::Basename;

  my($basename, $script_dir, $ext) = File::Basename::fileparse($0, '\.[^\.]+');

  # Add script directory to searchpath

  if($script_dir) {
    unshift(@{$self->{opt}->{searchpath}}, $script_dir);
  }

  return $basename . '.xml';
}


##############################################################################
# Method: build_simple_tree()
#
# Builds a 'tree' data structure as provided by XML::Parser and then
# 'simplifies' it as specified by the various options in effect.
#

sub build_simple_tree {
  my $self = shift;

  my $tree = eval {
    $self->build_tree(@_);
  };
  Carp::croak("$@XML::Simple called") if $@;

  return $self->{opt}->{keeproot}
         ? $self->collapse({}, @$tree)
         : $self->collapse(@{$tree->[1]});
}


##############################################################################
# Method: build_tree()
#
# This routine will be called if there is no suitable pre-parsed tree in a
# cache.  It parses the XML and returns an XML::Parser 'Tree' style data
# structure (summarised in the comments for the collapse() routine below).
#
# XML::Simple requires the services of another module that knows how to parse
# XML.  If XML::SAX is installed, the default SAX parser will be used,
# otherwise XML::Parser will be used.
#
# This routine expects to be passed a filename as argument 1 or a 'string' as
# argument 2.  The 'string' might be a string of XML (passed by reference to
# save memory) or it might be a reference to an IO::Handle.  (This
# non-intuitive mess results in part from the way XML::Parser works but that's
# really no excuse).
#

sub build_tree {
  my $self     = shift;
  my $filename = shift;
  my $string   = shift;


  my $preferred_parser = $PREFERRED_PARSER;
  unless(defined($preferred_parser)) {
    $preferred_parser = $ENV{XML_SIMPLE_PREFERRED_PARSER} || '';
  }
  if($preferred_parser eq 'XML::Parser') {
    return($self->build_tree_xml_parser($filename, $string));
  }

  eval { require XML::SAX; };      # We didn't need it until now
  if($@) {                         # No XML::SAX - fall back to XML::Parser
    if($preferred_parser) {        # unless a SAX parser was expressly requested
      croak "XMLin() could not load XML::SAX";
    }
    return($self->build_tree_xml_parser($filename, $string));
  }

  $XML::SAX::ParserPackage = $preferred_parser if($preferred_parser);

  my $sp = XML::SAX::ParserFactory->parser(Handler => $self);

  $self->{nocollapse} = 1;
  my($tree);
  if($filename) {
    $tree = $sp->parse_uri($filename);
  }
  else {
    if(ref($string) && ref($string) ne 'SCALAR') {
      $tree = $sp->parse_file($string);
    }
    else {
      $tree = $sp->parse_string($$string);
    }
  }

  return($tree);
}


##############################################################################
# Method: build_tree_xml_parser()
#
# This routine will be called if XML::SAX is not installed, or if XML::Parser
# was specifically requested.  It takes the same arguments as build_tree() and
# returns the same data structure (XML::Parser 'Tree' style).
#

sub build_tree_xml_parser {
  my $self     = shift;
  my $filename = shift;
  my $string   = shift;


  eval {
    local($^W) = 0;      # Suppress warning from Expat.pm re File::Spec::load()
    require XML::Parser; # We didn't need it until now
  };
  if($@) {
    croak "XMLin() requires either XML::SAX or XML::Parser";
  }

  if($self->{opt}->{nsexpand}) {
    carp "'nsexpand' option requires XML::SAX";
  }

  my $xp = $self->new_xml_parser();

  my($tree);
  if($filename) {
    # $tree = $xp->parsefile($filename);  # Changed due to prob w/mod_perl
    open(my $xfh, '<', $filename) || croak qq($filename - $!);
    $tree = $xp->parse($xfh);
  }
  else {
    $tree = $xp->parse($$string);
  }

  return($tree);
}


##############################################################################
# Method: new_xml_parser()
#
# Simply calls the XML::Parser constructor.  Override this method to customise
# the behaviour of the parser.
#

sub new_xml_parser {
  my($self) = @_;

  my $xp = XML::Parser->new(Style => 'Tree', @{$self->{opt}->{parseropts}});
  $xp->setHandlers(ExternEnt => sub {return $_[2]});

  return $xp;
}


##############################################################################
# Method: cache_write_storable()
#
# Wrapper routine for invoking Storable::nstore() to cache a parsed data
# structure.
#

sub cache_write_storable {
  my($self, $data, $filename) = @_;

  my $cachefile = $self->storable_filename($filename);

  require Storable;           # We didn't need it until now

  if ('VMS' eq $^O) {
    Storable::nstore($data, $cachefile);
  }
  else {
    # If the following line fails for you, your Storable.pm is old - upgrade
    Storable::lock_nstore($data, $cachefile);
  }

}


##############################################################################
# Method: cache_read_storable()
#
# Wrapper routine for invoking Storable::retrieve() to read a cached parsed
# data structure.  Only returns cached data if the cache file exists and is
# newer than the source XML file.
#

sub cache_read_storable {
  my($self, $filename) = @_;

  my $cachefile = $self->storable_filename($filename);

  return unless(-r $cachefile);
  return unless((stat($cachefile))[9] > (stat($filename))[9]);

  require Storable;           # We didn't need it until now

  if ('VMS' eq $^O) {
    return(Storable::retrieve($cachefile));
  }
  else {
    return(Storable::lock_retrieve($cachefile));
  }

}


##############################################################################
# Method: storable_filename()
#
# Translates the supplied source XML filename into a filename for the storable
# cached data.  A '.stor' suffix is added after stripping an optional '.xml'
# suffix.
#

sub storable_filename {
  my($self, $cachefile) = @_;

  $cachefile =~ s{(\.xml)?$}{.stor};
  return $cachefile;
}


##############################################################################
# Method: cache_write_memshare()
#
# Takes the supplied data structure reference and stores it away in a global
# hash structure.
#

sub cache_write_memshare {
  my($self, $data, $filename) = @_;

  $MemShareCache{$filename} = [time(), $data];
}


##############################################################################
# Method: cache_read_memshare()
#
# Takes a filename and looks in a global hash for a cached parsed version.
#

sub cache_read_memshare {
  my($self, $filename) = @_;

  return unless($MemShareCache{$filename});
  return unless($MemShareCache{$filename}->[0] > (stat($filename))[9]);

  return($MemShareCache{$filename}->[1]);

}


##############################################################################
# Method: cache_write_memcopy()
#
# Takes the supplied data structure and stores a copy of it in a global hash
# structure.
#

sub cache_write_memcopy {
  my($self, $data, $filename) = @_;

  require Storable;           # We didn't need it until now

  $MemCopyCache{$filename} = [time(), Storable::dclone($data)];
}


##############################################################################
# Method: cache_read_memcopy()
#
# Takes a filename and looks in a global hash for a cached parsed version.
# Returns a reference to a copy of that data structure.
#

sub cache_read_memcopy {
  my($self, $filename) = @_;

  return unless($MemCopyCache{$filename});
  return unless($MemCopyCache{$filename}->[0] > (stat($filename))[9]);

  return(Storable::dclone($MemCopyCache{$filename}->[1]));

}


##############################################################################
# Sub/Method: XMLout()
#
# Exported routine for 'unslurping' a data structure out to XML.
#
# Expects a reference to a data structure and an optional list of option
# name => value pairs.
#

sub XMLout {
  my $self = &_get_object;      # note, @_ is passed implicitly

  croak "XMLout() requires at least one argument" unless(@_);
  my $ref = shift;

  $self->handle_options('out', @_);


  # If namespace expansion is set, XML::NamespaceSupport is required

  if($self->{opt}->{nsexpand}) {
    require XML::NamespaceSupport;
    $self->{nsup} = XML::NamespaceSupport->new();
    $self->{ns_prefix} = 'aaa';
  }


  # Wrap top level arrayref in a hash

  if(UNIVERSAL::isa($ref, 'ARRAY')) {
    $ref = { anon => $ref };
  }


  # Extract rootname from top level hash if keeproot enabled

  if($self->{opt}->{keeproot}) {
    my(@keys) = keys(%$ref);
    if(@keys == 1) {
      $ref = $ref->{$keys[0]};
      $self->{opt}->{rootname} = $keys[0];
    }
  }

  # Ensure there are no top level attributes if we're not adding root elements

  elsif($self->{opt}->{rootname} eq '') {
    if(UNIVERSAL::isa($ref, 'HASH')) {
      my $refsave = $ref;
      $ref = {};
      foreach (keys(%$refsave)) {
        if(ref($refsave->{$_})) {
          $ref->{$_} = $refsave->{$_};
        }
        else {
          $ref->{$_} = [ $refsave->{$_} ];
        }
      }
    }
  }


  # Encode the hashref and write to file if necessary

  $self->{_ancestors} = {};
  my $xml = $self->value_to_xml($ref, $self->{opt}->{rootname}, '');
  delete $self->{_ancestors};

  if($self->{opt}->{xmldecl}) {
    $xml = $self->{opt}->{xmldecl} . "\n" . $xml;
  }

  if($self->{opt}->{outputfile}) {
    if(ref($self->{opt}->{outputfile})) {
      my $fh = $self->{opt}->{outputfile};
      if(UNIVERSAL::isa($fh, 'GLOB') and !UNIVERSAL::can($fh, 'print')) {
        eval { require IO::Handle; };
        croak $@ if $@;
      }
      return($fh->print($xml));
    }
    else {
      open(my $out, '>', "$self->{opt}->{outputfile}") ||
        croak "open($self->{opt}->{outputfile}): $!";
      binmode($out, ':utf8') if($] >= 5.008);
      print $out $xml or croak "print: $!";
      close $out or croak "close: $!";
    }
  }
  elsif($self->{opt}->{handler}) {
    require XML::SAX;
    my $sp = XML::SAX::ParserFactory->parser(
               Handler => $self->{opt}->{handler}
             );
    return($sp->parse_string($xml));
  }
  else {
    return($xml);
  }
}


##############################################################################
# Method: handle_options()
#
# Helper routine for both XMLin() and XMLout().  Both routines handle their
# first argument and assume all other args are options handled by this routine.
# Saves a hash of options in $self->{opt}.
#
# If default options were passed to the constructor, they will be retrieved
# here and merged with options supplied to the method call.
#
# First argument should be the string 'in' or the string 'out'.
#
# Remaining arguments should be name=>value pairs.  Sets up default values
# for options not supplied.  Unrecognised options are a fatal error.
#

sub handle_options  {
  my $self = shift;
  my $dirn = shift;


  # Determine valid options based on context

  my %known_opt;
  if($dirn eq 'in') {
    @known_opt{@KnownOptIn} = @KnownOptIn;
  }
  else {
    @known_opt{@KnownOptOut} = @KnownOptOut;
  }


  # Store supplied options in hashref and weed out invalid ones

  if(@_ % 2) {
    croak "Options must be name=>value pairs (odd number supplied)";
  }
  my %raw_opt  = @_;
  my $opt      = {};
  $self->{opt} = $opt;

  while(my($key, $val) = each %raw_opt) {
    my $lkey = lc($key);
    $lkey =~ s/_//g;
    croak "Unrecognised option: $key" unless($known_opt{$lkey});
    $opt->{$lkey} = $val;
  }


  # Merge in options passed to constructor

  foreach (keys(%known_opt)) {
    unless(exists($opt->{$_})) {
      if(exists($self->{def_opt}->{$_})) {
        $opt->{$_} = $self->{def_opt}->{$_};
      }
    }
  }


  # Set sensible defaults if not supplied

  if(exists($opt->{rootname})) {
    unless(defined($opt->{rootname})) {
      $opt->{rootname} = '';
    }
  }
  else {
    $opt->{rootname} = $DefRootName;
  }

  if($opt->{xmldecl}  and  $opt->{xmldecl} eq '1') {
    $opt->{xmldecl} = $DefXmlDecl;
  }

  if(exists($opt->{contentkey})) {
    if($opt->{contentkey} =~ m{^-(.*)$}) {
      $opt->{contentkey} = $1;
      $opt->{collapseagain} = 1;
    }
  }
  else {
    $opt->{contentkey} = $DefContentKey;
  }

  unless(exists($opt->{normalisespace})) {
    $opt->{normalisespace} = $opt->{normalizespace};
  }
  $opt->{normalisespace} = 0 unless(defined($opt->{normalisespace}));

  # Cleanups for values assumed to be arrays later

  if($opt->{searchpath}) {
    unless(ref($opt->{searchpath})) {
      $opt->{searchpath} = [ $opt->{searchpath} ];
    }
  }
  else  {
    $opt->{searchpath} = [ ];
  }

  if($opt->{cache}  and !ref($opt->{cache})) {
    $opt->{cache} = [ $opt->{cache} ];
  }
  if($opt->{cache}) {
    $_ = lc($_) foreach (@{$opt->{cache}});
    foreach my $scheme (@{$opt->{cache}}) {
      my $method = 'cache_read_' . $scheme;
      croak "Unsupported caching scheme: $scheme"
        unless($self->can($method));
    }
  }

  if(exists($opt->{parseropts})) {
    if(warnings::enabled()) {
      carp "Warning: " .
           "'ParserOpts' is deprecated, contact the author if you need it";
    }
  }
  else {
    $opt->{parseropts} = [ ];
  }


  # Special cleanup for {forcearray} which could be regex, arrayref or boolean
  # or left to default to 0

  if(exists($opt->{forcearray})) {
    if(ref($opt->{forcearray}) eq 'Regexp') {
      $opt->{forcearray} = [ $opt->{forcearray} ];
    }

    if(ref($opt->{forcearray}) eq 'ARRAY') {
      my @force_list = @{$opt->{forcearray}};
      if(@force_list) {
        $opt->{forcearray} = {};
        foreach my $tag (@force_list) {
          if(ref($tag) eq 'Regexp') {
            push @{$opt->{forcearray}->{_regex}}, $tag;
          }
          else {
            $opt->{forcearray}->{$tag} = 1;
          }
        }
      }
      else {
        $opt->{forcearray} = 0;
      }
    }
    else {
      $opt->{forcearray} = ( $opt->{forcearray} ? 1 : 0 );
    }
  }
  else {
    if($opt->{strictmode}  and  $dirn eq 'in') {
      croak "No value specified for 'ForceArray' option in call to XML$dirn()";
    }
    $opt->{forcearray} = 0;
  }


  # Special cleanup for {keyattr} which could be arrayref or hashref or left
  # to default to arrayref

  if(exists($opt->{keyattr}))  {
    if(ref($opt->{keyattr})) {
      if(ref($opt->{keyattr}) eq 'HASH') {

        # Make a copy so we can mess with it

        $opt->{keyattr} = { %{$opt->{keyattr}} };


        # Convert keyattr => { elem => '+attr' }
        # to keyattr => { elem => [ 'attr', '+' ] }

        foreach my $el (keys(%{$opt->{keyattr}})) {
          if($opt->{keyattr}->{$el} =~ /^(\+|-)?(.*)$/) {
            $opt->{keyattr}->{$el} = [ $2, ($1 ? $1 : '') ];
            if($opt->{strictmode}  and  $dirn eq 'in') {
              next if($opt->{forcearray} == 1);
              next if(ref($opt->{forcearray}) eq 'HASH'
                      and $opt->{forcearray}->{$el});
              croak "<$el> set in KeyAttr but not in ForceArray";
            }
          }
          else {
            delete($opt->{keyattr}->{$el}); # Never reached (famous last words?)
          }
        }
      }
      else {
        if(@{$opt->{keyattr}} == 0) {
          delete($opt->{keyattr});
        }
      }
    }
    else {
      $opt->{keyattr} = [ $opt->{keyattr} ];
    }
  }
  else  {
    if($opt->{strictmode}) {
      croak "No value specified for 'KeyAttr' option in call to XML$dirn()";
    }
    $opt->{keyattr} = [ @DefKeyAttr ];
  }


  # Special cleanup for {valueattr} which could be arrayref or hashref

  if(exists($opt->{valueattr})) {
    if(ref($opt->{valueattr}) eq 'ARRAY') {
      $opt->{valueattrlist} = {};
      $opt->{valueattrlist}->{$_} = 1 foreach(@{ delete $opt->{valueattr} });
    }
  }

  # make sure there's nothing weird in {grouptags}

  if($opt->{grouptags}) {
    croak "Illegal value for 'GroupTags' option - expected a hashref"
      unless UNIVERSAL::isa($opt->{grouptags}, 'HASH');

    while(my($key, $val) = each %{$opt->{grouptags}}) {
      next if $key ne $val;
      croak "Bad value in GroupTags: '$key' => '$val'";
    }
  }


  # Check the {variables} option is valid and initialise variables hash

  if($opt->{variables} and !UNIVERSAL::isa($opt->{variables}, 'HASH')) {
    croak "Illegal value for 'Variables' option - expected a hashref";
  }

  if($opt->{variables}) {
    $self->{_var_values} = { %{$opt->{variables}} };
  }
  elsif($opt->{varattr}) {
    $self->{_var_values} = {};
  }

}


##############################################################################
# Method: find_xml_file()
#
# Helper routine for XMLin().
# Takes a filename, and a list of directories, attempts to locate the file in
# the directories listed.
# Returns a full pathname on success; croaks on failure.
#

sub find_xml_file  {
  my $self = shift;
  my $file = shift;
  my @search_path = @_;


  require File::Basename;
  require File::Spec;

  my($filename, $filedir) = File::Basename::fileparse($file);

  if($filename ne $file) {        # Ignore searchpath if dir component
    return($file) if(-e $file);
  }
  else {
    my($path);
    foreach $path (@search_path)  {
      my $fullpath = File::Spec->catfile($path, $file);
      return($fullpath) if(-e $fullpath);
    }
  }

  # If user did not supply a search path, default to current directory

  if(!@search_path) {
    return($file) if(-e $file);
    croak "File does not exist: $file";
  }

  croak "Could not find $file in ", join(':', @search_path);
}


##############################################################################
# Method: collapse()
#
# Helper routine for XMLin().  This routine really comprises the 'smarts' (or
# value add) of this module.
#
# Takes the parse tree that XML::Parser produced from the supplied XML and
# recurses through it 'collapsing' unnecessary levels of indirection (nested
# arrays etc) to produce a data structure that is easier to work with.
#
# Elements in the original parser tree are represented as an element name
# followed by an arrayref.  The first element of the array is a hashref
# containing the attributes.  The rest of the array contains a list of any
# nested elements as name+arrayref pairs:
#
#  <element name>, [ { <attribute hashref> }, <element name>, [ ... ], ... ]
#
# The special element name '0' (zero) flags text content.
#
# This routine cuts down the noise by discarding any text content consisting of
# only whitespace and then moves the nested elements into the attribute hash
# using the name of the nested element as the hash key and the collapsed
# version of the nested element as the value.  Multiple nested elements with
# the same name will initially be represented as an arrayref, but this may be
# 'folded' into a hashref depending on the value of the keyattr option.
#

sub collapse {
  my $self = shift;


  # Start with the hash of attributes

  my $attr  = shift;
  if($self->{opt}->{noattr}) {                    # Discard if 'noattr' set
    $attr = $self->new_hashref;
  }
  elsif($self->{opt}->{normalisespace} == 2) {
    while(my($key, $value) = each %$attr) {
      $attr->{$key} = $self->normalise_space($value)
    }
  }


  # Do variable substitutions

  if(my $var = $self->{_var_values}) {
    while(my($key, $val) = each(%$attr)) {
      $val =~ s^\$\{([\w.]+)\}^ $self->get_var($1) ^ge;
      $attr->{$key} = $val;
    }
  }


  # Roll up 'value' attributes (but only if no nested elements)

  if(!@_  and  keys %$attr == 1) {
    my($k) = keys %$attr;
    if($self->{opt}->{valueattrlist}  and $self->{opt}->{valueattrlist}->{$k}) {
      return $attr->{$k};
    }
  }


  # Add any nested elements

  my($key, $val);
  while(@_) {
    $key = shift;
    $val = shift;
    $val = '' if not defined $val;

    if(ref($val)) {
      $val = $self->collapse(@$val);
      next if(!defined($val)  and  $self->{opt}->{suppressempty});
    }
    elsif($key eq '0') {
      next if($val =~ m{^\s*$}s);  # Skip all whitespace content

      $val = $self->normalise_space($val)
        if($self->{opt}->{normalisespace} == 2);

      # do variable substitutions

      if(my $var = $self->{_var_values}) {
        $val =~ s^\$\{(\w+)\}^ $self->get_var($1) ^ge;
      }


      # look for variable definitions

      if(my $var = $self->{opt}->{varattr}) {
        if(exists $attr->{$var}) {
          $self->set_var($attr->{$var}, $val);
        }
      }


      # Collapse text content in element with no attributes to a string

      if(!%$attr  and  !@_) {
        return($self->{opt}->{forcecontent} ?
          { $self->{opt}->{contentkey} => $val } : $val
        );
      }
      $key = $self->{opt}->{contentkey};
    }


    # Combine duplicate attributes into arrayref if required

    if(exists($attr->{$key})) {
      if(UNIVERSAL::isa($attr->{$key}, 'ARRAY')) {
        push(@{$attr->{$key}}, $val);
      }
      else {
        $attr->{$key} = [ $attr->{$key}, $val ];
      }
    }
    elsif(defined($val)  and  UNIVERSAL::isa($val, 'ARRAY')) {
      $attr->{$key} = [ $val ];
    }
    else {
      if( $key ne $self->{opt}->{contentkey}
          and (
            ($self->{opt}->{forcearray} == 1)
            or (
              (ref($self->{opt}->{forcearray}) eq 'HASH')
              and (
                $self->{opt}->{forcearray}->{$key}
                or (grep $key =~ $_, @{$self->{opt}->{forcearray}->{_regex}})
              )
            )
          )
        ) {
        $attr->{$key} = [ $val ];
      }
      else {
        $attr->{$key} = $val;
      }
    }

  }


  # Turn arrayrefs into hashrefs if key fields present

  if($self->{opt}->{keyattr}) {
    while(($key,$val) = each %$attr) {
      if(defined($val)  and  UNIVERSAL::isa($val, 'ARRAY')) {
        $attr->{$key} = $self->array_to_hash($key, $val);
      }
    }
  }


  # disintermediate grouped tags

  if($self->{opt}->{grouptags}) {
    while(my($key, $val) = each(%$attr)) {
      next unless(UNIVERSAL::isa($val, 'HASH') and (keys %$val == 1));
      next unless(exists($self->{opt}->{grouptags}->{$key}));

      my($child_key, $child_val) =  %$val;

      if($self->{opt}->{grouptags}->{$key} eq $child_key) {
        $attr->{$key}= $child_val;
      }
    }
  }


  # Fold hashes containing a single anonymous array up into just the array

  my $count = scalar keys %$attr;
  if($count == 1
     and  exists $attr->{anon}
     and  UNIVERSAL::isa($attr->{anon}, 'ARRAY')
  ) {
    return($attr->{anon});
  }


  # Do the right thing if hash is empty, otherwise just return it

  if(!%$attr  and  exists($self->{opt}->{suppressempty})) {
    if(defined($self->{opt}->{suppressempty})  and
       $self->{opt}->{suppressempty} eq '') {
      return('');
    }
    return(undef);
  }


  # Roll up named elements with named nested 'value' attributes

  if($self->{opt}->{valueattr}) {
    while(my($key, $val) = each(%$attr)) {
      next unless($self->{opt}->{valueattr}->{$key});
      next unless(UNIVERSAL::isa($val, 'HASH') and (keys %$val == 1));
      my($k) = keys %$val;
      next unless($k eq $self->{opt}->{valueattr}->{$key});
      $attr->{$key} = $val->{$k};
    }
  }

  return($attr)

}


##############################################################################
# Method: set_var()
#
# Called when a variable definition is encountered in the XML.  (A variable
# definition looks like <element attrname="name">value</element> where attrname
# matches the varattr setting).
#

sub set_var {
  my($self, $name, $value) = @_;

  $self->{_var_values}->{$name} = $value;
}


##############################################################################
# Method: get_var()
#
# Called during variable substitution to get the value for the named variable.
#

sub get_var {
  my($self, $name) = @_;

  my $value = $self->{_var_values}->{$name};
  return $value if(defined($value));

  return '${' . $name . '}';
}


##############################################################################
# Method: normalise_space()
#
# Strips leading and trailing whitespace and collapses sequences of whitespace
# characters to a single space.
#

sub normalise_space {
  my($self, $text) = @_;

  $text =~ s/^\s+//s;
  $text =~ s/\s+$//s;
  $text =~ s/\s\s+/ /sg;

  return $text;
}


##############################################################################
# Method: array_to_hash()
#
# Helper routine for collapse().
# Attempts to 'fold' an array of hashes into an hash of hashes.  Returns a
# reference to the hash on success or the original array if folding is
# not possible.  Behaviour is controlled by 'keyattr' option.
#

sub array_to_hash {
  my $self     = shift;
  my $name     = shift;
  my $arrayref = shift;

  my $hashref  = $self->new_hashref;

  my($i, $key, $val, $flag);


  # Handle keyattr => { .... }

  if(ref($self->{opt}->{keyattr}) eq 'HASH') {
    return($arrayref) unless(exists($self->{opt}->{keyattr}->{$name}));
    ($key, $flag) = @{$self->{opt}->{keyattr}->{$name}};
    for($i = 0; $i < @$arrayref; $i++)  {
      if(UNIVERSAL::isa($arrayref->[$i], 'HASH') and
         exists($arrayref->[$i]->{$key})
      ) {
        $val = $arrayref->[$i]->{$key};
        if(ref($val)) {
          $self->die_or_warn("<$name> element has non-scalar '$key' key attribute");
          return($arrayref);
        }
        $val = $self->normalise_space($val)
          if($self->{opt}->{normalisespace} == 1);
        $self->die_or_warn("<$name> element has non-unique value in '$key' key attribute: $val")
          if(exists($hashref->{$val}));
        $hashref->{$val} = $self->new_hashref( %{$arrayref->[$i]} );
        $hashref->{$val}->{"-$key"} = $hashref->{$val}->{$key} if($flag eq '-');
        delete $hashref->{$val}->{$key} unless($flag eq '+');
      }
      else {
        $self->die_or_warn("<$name> element has no '$key' key attribute");
        return($arrayref);
      }
    }
  }


  # Or assume keyattr => [ .... ]

  else {
    my $default_keys =
      join(',', @DefKeyAttr) eq join(',', @{$self->{opt}->{keyattr}});

    ELEMENT: for($i = 0; $i < @$arrayref; $i++)  {
      return($arrayref) unless(UNIVERSAL::isa($arrayref->[$i], 'HASH'));

      foreach $key (@{$self->{opt}->{keyattr}}) {
        if(defined($arrayref->[$i]->{$key}))  {
          $val = $arrayref->[$i]->{$key};
          if(ref($val)) {
            $self->die_or_warn("<$name> element has non-scalar '$key' key attribute")
              if not $default_keys;
            return($arrayref);
          }
          $val = $self->normalise_space($val)
            if($self->{opt}->{normalisespace} == 1);
          $self->die_or_warn("<$name> element has non-unique value in '$key' key attribute: $val")
            if(exists($hashref->{$val}));
          $hashref->{$val} = $self->new_hashref( %{$arrayref->[$i]} );
          delete $hashref->{$val}->{$key};
          next ELEMENT;
        }
      }

      return($arrayref);    # No keyfield matched
    }
  }

  # collapse any hashes which now only have a 'content' key

  if($self->{opt}->{collapseagain}) {
    $hashref = $self->collapse_content($hashref);
  }

  return($hashref);
}


##############################################################################
# Method: die_or_warn()
#
# Takes a diagnostic message and does one of three things:
# 1. dies if strict mode is enabled
# 2. warns if warnings are enabled but strict mode is not
# 3. ignores message and returns silently if neither strict mode nor warnings
#    are enabled
#

sub die_or_warn {
  my $self = shift;
  my $msg  = shift;

  croak $msg if($self->{opt}->{strictmode});
  if(warnings::enabled()) {
    carp "Warning: $msg";
  }
}


##############################################################################
# Method: new_hashref()
#
# This is a hook routine for overriding in a sub-class.  Some people believe
# that using Tie::IxHash here will solve order-loss problems.
#

sub new_hashref {
  my $self = shift;

  return { @_ };
}


##############################################################################
# Method: collapse_content()
#
# Helper routine for array_to_hash
#
# Arguments expected are:
# - an XML::Simple object
# - a hashref
# the hashref is a former array, turned into a hash by array_to_hash because
# of the presence of key attributes
# at this point collapse_content avoids over-complicated structures like
# dir => { libexecdir    => { content => '$exec_prefix/libexec' },
#          localstatedir => { content => '$prefix' },
#        }
# into
# dir => { libexecdir    => '$exec_prefix/libexec',
#          localstatedir => '$prefix',
#        }

sub collapse_content {
  my $self       = shift;
  my $hashref    = shift;

  my $contentkey = $self->{opt}->{contentkey};

  # first go through the values,checking that they are fit to collapse
  foreach my $val (values %$hashref) {
    return $hashref unless (     (ref($val) eq 'HASH')
                             and (keys %$val == 1)
                             and (exists $val->{$contentkey})
                           );
  }

  # now collapse them
  foreach my $key (keys %$hashref) {
    $hashref->{$key}=  $hashref->{$key}->{$contentkey};
  }

  return $hashref;
}


##############################################################################
# Method: value_to_xml()
#
# Helper routine for XMLout() - recurses through a data structure building up
# and returning an XML representation of that structure as a string.
#
# Arguments expected are:
# - the data structure to be encoded (usually a reference)
# - the XML tag name to use for this item
# - a string of spaces for use as the current indent level
#

sub value_to_xml {
  my $self = shift;;


  # Grab the other arguments

  my($ref, $name, $indent) = @_;

  my $named = (defined($name) and $name ne '' ? 1 : 0);

  my $nl = "\n";

  my $is_root = $indent eq '' ? 1 : 0;   # Warning, dirty hack!
  if($self->{opt}->{noindent}) {
    $indent = '';
    $nl     = '';
  }


  # Convert to XML

  my $refaddr = Scalar::Util::refaddr($ref);
  if($refaddr) {
    croak "circular data structures not supported"
      if $self->{_ancestors}->{$refaddr};
    $self->{_ancestors}->{$refaddr} = $ref;  # keep ref alive until we delete it
  }
  else {
    if($named) {
      return(join('',
              $indent, '<', $name, '>',
              ($self->{opt}->{noescape} ? $ref : $self->escape_value($ref)),
              '</', $name, ">", $nl
            ));
    }
    else {
      return("$ref$nl");
    }
  }


  # Unfold hash to array if possible

  if(UNIVERSAL::isa($ref, 'HASH')      # It is a hash
     and keys %$ref                    # and it's not empty
     and $self->{opt}->{keyattr}       # and folding is enabled
     and !$is_root                     # and its not the root element
  ) {
    $ref = $self->hash_to_array($name, $ref);
  }


  my @result = ();
  my($key, $value);


  # Handle hashrefs

  if(UNIVERSAL::isa($ref, 'HASH')) {

    # Reintermediate grouped values if applicable

    if($self->{opt}->{grouptags}) {
      $ref = $self->copy_hash($ref);
      while(my($key, $val) = each %$ref) {
        if($self->{opt}->{grouptags}->{$key}) {
          $ref->{$key} = $self->new_hashref(
            $self->{opt}->{grouptags}->{$key} => $val
          );
        }
      }
    }


    # Scan for namespace declaration attributes

    my $nsdecls = '';
    my $default_ns_uri;
    if($self->{nsup}) {
      $ref = $self->copy_hash($ref);
      $self->{nsup}->push_context();

      # Look for default namespace declaration first

      if(exists($ref->{xmlns})) {
        $self->{nsup}->declare_prefix('', $ref->{xmlns});
        $nsdecls .= qq( xmlns="$ref->{xmlns}");
        delete($ref->{xmlns});
      }
      $default_ns_uri = $self->{nsup}->get_uri('');


      # Then check all the other keys

      foreach my $qname (keys(%$ref)) {
        my($uri, $lname) = $self->{nsup}->parse_jclark_notation($qname);
        if($uri) {
          if($uri eq $xmlns_ns) {
            $self->{nsup}->declare_prefix($lname, $ref->{$qname});
            $nsdecls .= qq( xmlns:$lname="$ref->{$qname}");
            delete($ref->{$qname});
          }
        }
      }

      # Translate any remaining Clarkian names

      foreach my $qname (keys(%$ref)) {
        my($uri, $lname) = $self->{nsup}->parse_jclark_notation($qname);
        if($uri) {
          if($default_ns_uri  and  $uri eq $default_ns_uri) {
            $ref->{$lname} = $ref->{$qname};
            delete($ref->{$qname});
          }
          else {
            my $prefix = $self->{nsup}->get_prefix($uri);
            unless($prefix) {
              # $self->{nsup}->declare_prefix(undef, $uri);
              # $prefix = $self->{nsup}->get_prefix($uri);
              $prefix = $self->{ns_prefix}++;
              $self->{nsup}->declare_prefix($prefix, $uri);
              $nsdecls .= qq( xmlns:$prefix="$uri");
            }
            $ref->{"$prefix:$lname"} = $ref->{$qname};
            delete($ref->{$qname});
          }
        }
      }
    }


    my @nested = ();
    my $text_content = undef;
    if($named) {
      push @result, $indent, '<', $name, $nsdecls;
    }

    if(keys %$ref) {
      my $first_arg = 1;
      foreach my $key ($self->sorted_keys($name, $ref)) {
        my $value = $ref->{$key};
        next if(substr($key, 0, 1) eq '-');
        if(!defined($value)) {
          next if $self->{opt}->{suppressempty};
          unless(exists($self->{opt}->{suppressempty})
             and !defined($self->{opt}->{suppressempty})
          ) {
            carp 'Use of uninitialized value' if warnings::enabled();
          }
          if($key eq $self->{opt}->{contentkey}) {
            $text_content = '';
          }
          else {
            $value = exists($self->{opt}->{suppressempty}) ? {} : '';
          }
        }

        if(!ref($value)
           and $self->{opt}->{valueattr}
           and $self->{opt}->{valueattr}->{$key}
        ) {
          $value = $self->new_hashref(
            $self->{opt}->{valueattr}->{$key} => $value
          );
        }

        if(ref($value)  or  $self->{opt}->{noattr}) {
          push @nested,
            $self->value_to_xml($value, $key, "$indent  ");
        }
        else {
          if($key eq $self->{opt}->{contentkey}) {
            $value = $self->escape_value($value) unless($self->{opt}->{noescape});
            $text_content = $value;
          }
          else {
            $value = $self->escape_attr($value) unless($self->{opt}->{noescape});
            push @result, "\n$indent " . ' ' x length($name)
              if($self->{opt}->{attrindent}  and  !$first_arg);
            push @result, ' ', $key, '="', $value , '"';
            $first_arg = 0;
          }
        }
      }
    }
    else {
      $text_content = '';
    }

    if(@nested  or  defined($text_content)) {
      if($named) {
        push @result, ">";
        if(defined($text_content)) {
          push @result, $text_content;
          $nested[0] =~ s/^\s+// if(@nested);
        }
        else {
          push @result, $nl;
        }
        if(@nested) {
          push @result, @nested, $indent;
        }
        push @result, '</', $name, ">", $nl;
      }
      else {
        push @result, @nested;             # Special case if no root elements
      }
    }
    else {
      push @result, " />", $nl;
    }
    $self->{nsup}->pop_context() if($self->{nsup});
  }


  # Handle arrayrefs

  elsif(UNIVERSAL::isa($ref, 'ARRAY')) {
    foreach $value (@$ref) {
      next if !defined($value) and $self->{opt}->{suppressempty};
      if(!ref($value)) {
        push @result,
             $indent, '<', $name, '>',
             ($self->{opt}->{noescape} ? $value : $self->escape_value($value)),
             '</', $name, ">$nl";
      }
      elsif(UNIVERSAL::isa($value, 'HASH')) {
        push @result, $self->value_to_xml($value, $name, $indent);
      }
      else {
        push @result,
               $indent, '<', $name, ">$nl",
               $self->value_to_xml($value, 'anon', "$indent  "),
               $indent, '</', $name, ">$nl";
      }
    }
  }

  else {
    croak "Can't encode a value of type: " . ref($ref);
  }


  delete $self->{_ancestors}->{$refaddr};

  return(join('', @result));
}


##############################################################################
# Method: sorted_keys()
#
# Returns the keys of the referenced hash sorted into alphabetical order, but
# with the 'key' key (as in KeyAttr) first, if there is one.
#

sub sorted_keys {
  my($self, $name, $ref) = @_;

  return keys %$ref if $self->{opt}->{nosort};

  my %hash = %$ref;
  my $keyattr = $self->{opt}->{keyattr};

  my @key;

  if(ref $keyattr eq 'HASH') {
    if(exists $keyattr->{$name} and exists $hash{$keyattr->{$name}->[0]}) {
      push @key, $keyattr->{$name}->[0];
      delete $hash{$keyattr->{$name}->[0]};
    }
  }
  elsif(ref $keyattr eq 'ARRAY') {
    foreach (@{$keyattr}) {
      if(exists $hash{$_}) {
        push @key, $_;
        delete $hash{$_};
        last;
      }
    }
  }

  return(@key, sort keys %hash);
}

##############################################################################
# Method: escape_value()
#
# Helper routine for automatically escaping values for XMLout().
# Expects a scalar data value.  Returns escaped version.
#

sub escape_value {
  my($self, $data) = @_;

  return '' unless(defined($data));

  $data =~ s/&/&amp;/sg;
  $data =~ s/</&lt;/sg;
  $data =~ s/>/&gt;/sg;
  $data =~ s/"/&quot;/sg;

  my $level = $self->{opt}->{numericescape} or return $data;

  return $self->numeric_escape($data, $level);
}

sub numeric_escape {
  my($self, $data, $level) = @_;

  if($self->{opt}->{numericescape} eq '2') {
    $data =~ s/([^\x00-\x7F])/'&#' . ord($1) . ';'/gse;
  }
  else {
    $data =~ s/([^\x00-\xFF])/'&#' . ord($1) . ';'/gse;
  }

  return $data;
}

##############################################################################
# Method: escape_attr()
#
# Helper routine for escaping attribute values.  Defaults to escape_value(),
# but may be overridden by a subclass to customise behaviour.
#

sub escape_attr {
  my $self = shift;

  return $self->escape_value(@_);
}


##############################################################################
# Method: hash_to_array()
#
# Helper routine for value_to_xml().
# Attempts to 'unfold' a hash of hashes into an array of hashes.  Returns a
# reference to the array on success or the original hash if unfolding is
# not possible.
#

sub hash_to_array {
  my $self    = shift;
  my $parent  = shift;
  my $hashref = shift;

  my $arrayref = [];

  my($key, $value);

  my @keys = $self->{opt}->{nosort} ? keys %$hashref : sort keys %$hashref;
  foreach $key (@keys) {
    $value = $hashref->{$key};
    return($hashref) unless(UNIVERSAL::isa($value, 'HASH'));

    if(ref($self->{opt}->{keyattr}) eq 'HASH') {
      return($hashref) unless(defined($self->{opt}->{keyattr}->{$parent}));
      push @$arrayref, $self->copy_hash(
        $value, $self->{opt}->{keyattr}->{$parent}->[0] => $key
      );
    }
    else {
      push(@$arrayref, { $self->{opt}->{keyattr}->[0] => $key, %$value });
    }
  }

  return($arrayref);
}


##############################################################################
# Method: copy_hash()
#
# Helper routine for hash_to_array().  When unfolding a hash of hashes into
# an array of hashes, we need to copy the key from the outer hash into the
# inner hash.  This routine makes a copy of the original hash so we don't
# destroy the original data structure.  You might wish to override this
# method if you're using tied hashes and don't want them to get untied.
#

sub copy_hash {
  my($self, $orig, @extra) = @_;

  return { @extra, %$orig };
}

##############################################################################
# Methods required for building trees from SAX events
##############################################################################

sub start_document {
  my $self = shift;

  $self->handle_options('in') unless($self->{opt});

  $self->{lists} = [];
  $self->{curlist} = $self->{tree} = [];
}


sub start_element {
  my $self    = shift;
  my $element = shift;

  my $name = $element->{Name};
  if($self->{opt}->{nsexpand}) {
    $name = $element->{LocalName} || '';
    if($element->{NamespaceURI}) {
      $name = '{' . $element->{NamespaceURI} . '}' . $name;
    }
  }
  my $attributes = {};
  if($element->{Attributes}) {  # Might be undef
    foreach my $attr (values %{$element->{Attributes}}) {
      if($self->{opt}->{nsexpand}) {
        my $name = $attr->{LocalName} || '';
        if($attr->{NamespaceURI}) {
          $name = '{' . $attr->{NamespaceURI} . '}' . $name
        }
        $name = 'xmlns' if($name eq $bad_def_ns_jcn);
        $attributes->{$name} = $attr->{Value};
      }
      else {
        $attributes->{$attr->{Name}} = $attr->{Value};
      }
    }
  }
  my $newlist = [ $attributes ];
  push @{ $self->{lists} }, $self->{curlist};
  push @{ $self->{curlist} }, $name => $newlist;
  $self->{curlist} = $newlist;
}


sub characters {
  my $self  = shift;
  my $chars = shift;

  my $text  = $chars->{Data};
  my $clist = $self->{curlist};
  my $pos = $#$clist;

  if ($pos > 0 and $clist->[$pos - 1] eq '0') {
    $clist->[$pos] .= $text;
  }
  else {
    push @$clist, 0 => $text;
  }
}


sub end_element {
  my $self    = shift;

  $self->{curlist} = pop @{ $self->{lists} };
}


sub end_document {
  my $self = shift;

  delete($self->{curlist});
  delete($self->{lists});

  my $tree = $self->{tree};
  delete($self->{tree});


  # Return tree as-is to XMLin()

  return($tree) if($self->{nocollapse});


  # Or collapse it before returning it to SAX parser class

  if($self->{opt}->{keeproot}) {
    $tree = $self->collapse({}, @$tree);
  }
  else {
    $tree = $self->collapse(@{$tree->[1]});
  }

  if($self->{opt}->{datahandler}) {
    return($self->{opt}->{datahandler}->($self, $tree));
  }

  return($tree);
}

*xml_in  = \&XMLin;
*xml_out = \&XMLout;

1;

__END__

=head1 STATUS OF THIS MODULE

The use of this module in new code is B<strongly discouraged>.  Other modules
are available which provide more straightforward and consistent interfaces.  In
particular, L<XML::LibXML> is highly recommended and you can refer to
L<Perl XML::LibXML by Example|http://grantm.github.io/perl-libxml-by-example/>
for a tutorial introduction.

L<XML::Twig> is another excellent alternative.

The major problems with this module are the large number of options (some of
which have unfortunate defaults) and the arbitrary ways in which these options
interact - often producing unexpected results.

Patches with bug fixes and documentation fixes are welcome, but new features
are unlikely to be added.

=head1 QUICK START

Say you have a script called B<foo> and a file of configuration options
called B<foo.xml> containing the following:

  <config logdir="/var/log/foo/" debugfile="/tmp/foo.debug">
    <server name="sahara" osname="solaris" osversion="2.6">
      <address>10.0.0.101</address>
      <address>10.0.1.101</address>
    </server>
    <server name="gobi" osname="irix" osversion="6.5">
      <address>10.0.0.102</address>
    </server>
    <server name="kalahari" osname="linux" osversion="2.0.34">
      <address>10.0.0.103</address>
      <address>10.0.1.103</address>
    </server>
  </config>

The following lines of code in B<foo>:

  use XML::Simple qw(:strict);

  my $config = XMLin(undef, KeyAttr => { server => 'name' }, ForceArray => [ 'server', 'address' ]);

will 'slurp' the configuration options into the hashref $config (because no
filename or XML string was passed as the first argument to C<XMLin()> the name
and location of the XML file will be inferred from name and location of the
script).  You can dump out the contents of the hashref using Data::Dumper:

  use Data::Dumper;

  print Dumper($config);

which will produce something like this (formatting has been adjusted for
brevity):

  {
      'logdir'        => '/var/log/foo/',
      'debugfile'     => '/tmp/foo.debug',
      'server'        => {
          'sahara'        => {
              'osversion'     => '2.6',
              'osname'        => 'solaris',
              'address'       => [ '10.0.0.101', '10.0.1.101' ]
          },
          'gobi'          => {
              'osversion'     => '6.5',
              'osname'        => 'irix',
              'address'       => [ '10.0.0.102' ]
          },
          'kalahari'      => {
              'osversion'     => '2.0.34',
              'osname'        => 'linux',
              'address'       => [ '10.0.0.103', '10.0.1.103' ]
          }
      }
  }

Your script could then access the name of the log directory like this:

  print $config->{logdir};

similarly, the second address on the server 'kalahari' could be referenced as:

  print $config->{server}->{kalahari}->{address}->[1];

Note: If the mapping between the output of Data::Dumper and the print
statements above is not obvious to you, then please refer to the 'references'
tutorial (AKA: "Mark's very short tutorial about references") at L<perlreftut>.

In this example, the C<< ForceArray >> option was used to list elements that
might occur multiple times and should therefore be represented as arrayrefs
(even when only one element is present).

The C<< KeyAttr >> option was used to indicate that each C<< <server> >>
element has a unique identifier in the C<< name >> attribute.  This allows you
to index directly to a particular server record using the name as a hash key
(as shown above).

For simple requirements, that's really all there is to it.  If you want to
store your XML in a different directory or file, or pass it in as a string or
even pass it in via some derivative of an IO::Handle, you'll need to check out
L<"OPTIONS">.  If you want to turn off or tweak the array folding feature (that
neat little transformation that produced $config->{server}) you'll find options
for that as well.

If you want to generate XML (for example to write a modified version of
$config back out as XML), check out C<XMLout()>.

If your needs are not so simple, this may not be the module for you.  In that
case, you might want to read L<"WHERE TO FROM HERE?">.

=head1 DESCRIPTION

The XML::Simple module provides a simple API layer on top of an underlying XML
parsing module (either XML::Parser or one of the SAX2 parser modules).  Two
functions are exported: C<XMLin()> and C<XMLout()>.  Note: you can explicitly
request the lower case versions of the function names: C<xml_in()> and
C<xml_out()>.

The simplest approach is to call these two functions directly, but an
optional object oriented interface (see L<"OPTIONAL OO INTERFACE"> below)
allows them to be called as methods of an B<XML::Simple> object.  The object
interface can also be used at either end of a SAX pipeline.

=head2 XMLin()

Parses XML formatted data and returns a reference to a data structure which
contains the same information in a more readily accessible form.  (Skip
down to L<"EXAMPLES"> below, for more sample code).

C<XMLin()> accepts an optional XML specifier followed by zero or more 'name =>
value' option pairs.  The XML specifier can be one of the following:

=over 4

=item A filename

If the filename contains no directory components C<XMLin()> will look for the
file in each directory in the SearchPath (see L<"OPTIONS"> below) or in the
current directory if the SearchPath option is not defined.  eg:

  $ref = XMLin('/etc/params.xml');

Note, the filename '-' can be used to parse from STDIN.

=item undef

If there is no XML specifier, C<XMLin()> will check the script directory and
each of the SearchPath directories for a file with the same name as the script
but with the extension '.xml'.  Note: if you wish to specify options, you
must specify the value 'undef'.  eg:

  $ref = XMLin(undef, ForceArray => 1);

=item A string of XML

A string containing XML (recognised by the presence of '<' and '>' characters)
will be parsed directly.  eg:

  $ref = XMLin('<opt username="bob" password="flurp" />');

=item An IO::Handle object

An IO::Handle object will be read to EOF and its contents parsed. eg:

  $fh = IO::File->new('/etc/params.xml');
  $ref = XMLin($fh);

=back

=head2 XMLout()

Takes a data structure (generally a hashref) and returns an XML encoding of
that structure.  If the resulting XML is parsed using C<XMLin()>, it should
return a data structure equivalent to the original (see caveats below).

The C<XMLout()> function can also be used to output the XML as SAX events
see the C<Handler> option and L<"SAX SUPPORT"> for more details).

When translating hashes to XML, hash keys which have a leading '-' will be
silently skipped.  This is the approved method for marking elements of a
data structure which should be ignored by C<XMLout>.  (Note: If these items
were not skipped the key names would be emitted as element or attribute names
with a leading '-' which would not be valid XML).

=head2 Caveats

Some care is required in creating data structures which will be passed to
C<XMLout()>.  Hash keys from the data structure will be encoded as either XML
element names or attribute names.  Therefore, you should use hash key names
which conform to the relatively strict XML naming rules:

Names in XML must begin with a letter.  The remaining characters may be
letters, digits, hyphens (-), underscores (_) or full stops (.).  It is also
allowable to include one colon (:) in an element name but this should only be
used when working with namespaces (B<XML::Simple> can only usefully work with
namespaces when teamed with a SAX Parser).

You can use other punctuation characters in hash values (just not in hash
keys) however B<XML::Simple> does not support dumping binary data.

If you break these rules, the current implementation of C<XMLout()> will
simply emit non-compliant XML which will be rejected if you try to read it
back in.  (A later version of B<XML::Simple> might take a more proactive
approach).

Note also that although you can nest hashes and arrays to arbitrary levels,
circular data structures are not supported and will cause C<XMLout()> to die.

If you wish to 'round-trip' arbitrary data structures from Perl to XML and back
to Perl, then you should probably disable array folding (using the KeyAttr
option) both with C<XMLout()> and with C<XMLin()>.  If you still don't get the
expected results, you may prefer to use L<XML::Dumper> which is designed for
exactly that purpose.

Refer to L<"WHERE TO FROM HERE?"> if C<XMLout()> is too simple for your needs.


=head1 OPTIONS

B<XML::Simple> supports a number of options (in fact as each release of
B<XML::Simple> adds more options, the module's claim to the name 'Simple'
becomes increasingly tenuous).  If you find yourself repeatedly having to
specify the same options, you might like to investigate L<"OPTIONAL OO
INTERFACE"> below.

If you can't be bothered reading the documentation, refer to
L<"STRICT MODE"> to automatically catch common mistakes.

Because there are so many options, it's hard for new users to know which ones
are important, so here are the two you really need to know about:

=over 4

=item *

check out C<ForceArray> because you'll almost certainly want to turn it on

=item *

make sure you know what the C<KeyAttr> option does and what its default value is
because it may surprise you otherwise (note in particular that 'KeyAttr'
affects both C<XMLin> and C<XMLout>)

=back

The option name headings below have a trailing 'comment' - a hash followed by
two pieces of metadata:

=over 4

=item *

Options are marked with 'I<in>' if they are recognised by C<XMLin()> and
'I<out>' if they are recognised by C<XMLout()>.

=item *

Each option is also flagged to indicate whether it is:

 'important'   - don't use the module until you understand this one
 'handy'       - you can skip this on the first time through
 'advanced'    - you can skip this on the second time through
 'SAX only'    - don't worry about this unless you're using SAX (or
                 alternatively if you need this, you also need SAX)
 'seldom used' - you'll probably never use this unless you were the
                 person that requested the feature

=back

The options are listed alphabetically:

Note: option names are no longer case sensitive so you can use the mixed case
versions shown here; all lower case as required by versions 2.03 and earlier;
or you can add underscores between the words (eg: key_attr).


=head2 AttrIndent => 1 I<# out - handy>

When you are using C<XMLout()>, enable this option to have attributes printed
one-per-line with sensible indentation rather than all on one line.

=head2 Cache => [ cache schemes ] I<# in - advanced>

Because loading the B<XML::Parser> module and parsing an XML file can consume a
significant number of CPU cycles, it is often desirable to cache the output of
C<XMLin()> for later reuse.

When parsing from a named file, B<XML::Simple> supports a number of caching
schemes.  The 'Cache' option may be used to specify one or more schemes (using
an anonymous array).  Each scheme will be tried in turn in the hope of finding
a cached pre-parsed representation of the XML file.  If no cached copy is
found, the file will be parsed and the first cache scheme in the list will be
used to save a copy of the results.  The following cache schemes have been
implemented:

=over 4

=item storable

Utilises B<Storable.pm> to read/write a cache file with the same name as the
XML file but with the extension .stor

=item memshare

When a file is first parsed, a copy of the resulting data structure is retained
in memory in the B<XML::Simple> module's namespace.  Subsequent calls to parse
the same file will return a reference to this structure.  This cached version
will persist only for the life of the Perl interpreter (which in the case of
mod_perl for example, may be some significant time).

Because each caller receives a reference to the same data structure, a change
made by one caller will be visible to all.  For this reason, the reference
returned should be treated as read-only.

=item memcopy

This scheme works identically to 'memshare' (above) except that each caller
receives a reference to a new data structure which is a copy of the cached
version.  Copying the data structure will add a little processing overhead,
therefore this scheme should only be used where the caller intends to modify
the data structure (or wishes to protect itself from others who might).  This
scheme uses B<Storable.pm> to perform the copy.

=back

Warning! The memory-based caching schemes compare the timestamp on the file to
the time when it was last parsed.  If the file is stored on an NFS filesystem
(or other network share) and the clock on the file server is not exactly
synchronised with the clock where your script is run, updates to the source XML
file may appear to be ignored.

=head2 ContentKey => 'keyname' I<# in+out - seldom used>

When text content is parsed to a hash value, this option lets you specify a
name for the hash key to override the default 'content'.  So for example:

  XMLin('<opt one="1">Text</opt>', ContentKey => 'text')

will parse to:

  { 'one' => 1, 'text' => 'Text' }

instead of:

  { 'one' => 1, 'content' => 'Text' }

C<XMLout()> will also honour the value of this option when converting a hashref
to XML.

You can also prefix your selected key name with a '-' character to have
C<XMLin()> try a little harder to eliminate unnecessary 'content' keys after
array folding.  For example:

  XMLin(
    '<opt><item name="one">First</item><item name="two">Second</item></opt>',
    KeyAttr => {item => 'name'},
    ForceArray => [ 'item' ],
    ContentKey => '-content'
  )

will parse to:

  {
    'item' => {
      'one' =>  'First'
      'two' =>  'Second'
    }
  }

rather than this (without the '-'):

  {
    'item' => {
      'one' => { 'content' => 'First' }
      'two' => { 'content' => 'Second' }
    }
  }

=head2 DataHandler => code_ref I<# in - SAX only>

When you use an B<XML::Simple> object as a SAX handler, it will return a
'simple tree' data structure in the same format as C<XMLin()> would return.  If
this option is set (to a subroutine reference), then when the tree is built the
subroutine will be called and passed two arguments: a reference to the
B<XML::Simple> object and a reference to the data tree.  The return value from
the subroutine will be returned to the SAX driver.  (See L<"SAX SUPPORT"> for
more details).

=head2 ForceArray => 1 I<# in - important>

This option should be set to '1' to force nested elements to be represented
as arrays even when there is only one.  Eg, with ForceArray enabled, this
XML:

    <opt>
      <name>value</name>
    </opt>

would parse to this:

    {
      'name' => [
                  'value'
                ]
    }

instead of this (the default):

    {
      'name' => 'value'
    }

This option is especially useful if the data structure is likely to be written
back out as XML and the default behaviour of rolling single nested elements up
into attributes is not desirable.

If you are using the array folding feature, you should almost certainly enable
this option.  If you do not, single nested elements will not be parsed to
arrays and therefore will not be candidates for folding to a hash.  (Given that
the default value of 'KeyAttr' enables array folding, the default value of this
option should probably also have been enabled too - sorry).

=head2 ForceArray => [ names ] I<# in - important>

This alternative (and preferred) form of the 'ForceArray' option allows you to
specify a list of element names which should always be forced into an array
representation, rather than the 'all or nothing' approach above.

It is also possible (since version 2.05) to include compiled regular
expressions in the list - any element names which match the pattern will be
forced to arrays.  If the list contains only a single regex, then it is not
necessary to enclose it in an arrayref.  Eg:

  ForceArray => qr/_list$/

=head2 ForceContent => 1 I<# in - seldom used>

When C<XMLin()> parses elements which have text content as well as attributes,
the text content must be represented as a hash value rather than a simple
scalar.  This option allows you to force text content to always parse to
a hash value even when there are no attributes.  So for example:

  XMLin('<opt><x>text1</x><y a="2">text2</y></opt>', ForceContent => 1)

will parse to:

  {
    'x' => {           'content' => 'text1' },
    'y' => { 'a' => 2, 'content' => 'text2' }
  }

instead of:

  {
    'x' => 'text1',
    'y' => { 'a' => 2, 'content' => 'text2' }
  }

=head2 GroupTags => { grouping tag => grouped tag } I<# in+out - handy>

You can use this option to eliminate extra levels of indirection in your Perl
data structure.  For example this XML:

  <opt>
   <searchpath>
     <dir>/usr/bin</dir>
     <dir>/usr/local/bin</dir>
     <dir>/usr/X11/bin</dir>
   </searchpath>
 </opt>

Would normally be read into a structure like this:

  {
    searchpath => {
                    dir => [ '/usr/bin', '/usr/local/bin', '/usr/X11/bin' ]
                  }
  }

But when read in with the appropriate value for 'GroupTags':

  my $opt = XMLin($xml, GroupTags => { searchpath => 'dir' });

It will return this simpler structure:

  {
    searchpath => [ '/usr/bin', '/usr/local/bin', '/usr/X11/bin' ]
  }

The grouping element (C<< <searchpath> >> in the example) must not contain any
attributes or elements other than the grouped element.

You can specify multiple 'grouping element' to 'grouped element' mappings in
the same hashref.  If this option is combined with C<KeyAttr>, the array
folding will occur first and then the grouped element names will be eliminated.

C<XMLout> will also use the grouptag mappings to re-introduce the tags around
the grouped elements.  Beware though that this will occur in all places that
the 'grouping tag' name occurs - you probably don't want to use the same name
for elements as well as attributes.

=head2 Handler => object_ref I<# out - SAX only>

Use the 'Handler' option to have C<XMLout()> generate SAX events rather than
returning a string of XML.  For more details see L<"SAX SUPPORT"> below.

Note: the current implementation of this option generates a string of XML
and uses a SAX parser to translate it into SAX events.  The normal encoding
rules apply here - your data must be UTF8 encoded unless you specify an
alternative encoding via the 'XMLDecl' option; and by the time the data reaches
the handler object, it will be in UTF8 form regardless of the encoding you
supply.  A future implementation of this option may generate the events
directly.

=head2 KeepRoot => 1 I<# in+out - handy>

In its attempt to return a data structure free of superfluous detail and
unnecessary levels of indirection, C<XMLin()> normally discards the root
element name.  Setting the 'KeepRoot' option to '1' will cause the root element
name to be retained.  So after executing this code:

  $config = XMLin('<config tempdir="/tmp" />', KeepRoot => 1)

You'll be able to reference the tempdir as
C<$config-E<gt>{config}-E<gt>{tempdir}> instead of the default
C<$config-E<gt>{tempdir}>.

Similarly, setting the 'KeepRoot' option to '1' will tell C<XMLout()> that the
data structure already contains a root element name and it is not necessary to
add another.

=head2 KeyAttr => [ list ] I<# in+out - important>

This option controls the 'array folding' feature which translates nested
elements from an array to a hash.  It also controls the 'unfolding' of hashes
to arrays.

For example, this XML:

    <opt>
      <user login="grep" fullname="Gary R Epstein" />
      <user login="stty" fullname="Simon T Tyson" />
    </opt>

would, by default, parse to this:

    {
      'user' => [
                  {
                    'login' => 'grep',
                    'fullname' => 'Gary R Epstein'
                  },
                  {
                    'login' => 'stty',
                    'fullname' => 'Simon T Tyson'
                  }
                ]
    }

If the option 'KeyAttr => "login"' were used to specify that the 'login'
attribute is a key, the same XML would parse to:

    {
      'user' => {
                  'stty' => {
                              'fullname' => 'Simon T Tyson'
                            },
                  'grep' => {
                              'fullname' => 'Gary R Epstein'
                            }
                }
    }

The key attribute names should be supplied in an arrayref if there is more
than one.  C<XMLin()> will attempt to match attribute names in the order
supplied.  C<XMLout()> will use the first attribute name supplied when
'unfolding' a hash into an array.

Note 1: The default value for 'KeyAttr' is ['name', 'key', 'id'].  If you do
not want folding on input or unfolding on output you must set this option
to an empty list to disable the feature.

Note 2: If you wish to use this option, you should also enable the
C<ForceArray> option.  Without 'ForceArray', a single nested element will be
rolled up into a scalar rather than an array and therefore will not be folded
(since only arrays get folded).

=head2 KeyAttr => { list } I<# in+out - important>

This alternative (and preferred) method of specifying the key attributes
allows more fine grained control over which elements are folded and on which
attributes.  For example the option 'KeyAttr => { package => 'id' } will cause
any package elements to be folded on the 'id' attribute.  No other elements
which have an 'id' attribute will be folded at all.

Note: C<XMLin()> will generate a warning (or a fatal error in L<"STRICT MODE">)
if this syntax is used and an element which does not have the specified key
attribute is encountered (eg: a 'package' element without an 'id' attribute, to
use the example above).  Warnings can be suppressed with the lexical
C<no warnings;> pragma or C<no warnings 'XML::Simple';>.

Two further variations are made possible by prefixing a '+' or a '-' character
to the attribute name:

The option 'KeyAttr => { user => "+login" }' will cause this XML:

    <opt>
      <user login="grep" fullname="Gary R Epstein" />
      <user login="stty" fullname="Simon T Tyson" />
    </opt>

to parse to this data structure:

    {
      'user' => {
                  'stty' => {
                              'fullname' => 'Simon T Tyson',
                              'login'    => 'stty'
                            },
                  'grep' => {
                              'fullname' => 'Gary R Epstein',
                              'login'    => 'grep'
                            }
                }
    }

The '+' indicates that the value of the key attribute should be copied rather
than moved to the folded hash key.

A '-' prefix would produce this result:

    {
      'user' => {
                  'stty' => {
                              'fullname' => 'Simon T Tyson',
                              '-login'    => 'stty'
                            },
                  'grep' => {
                              'fullname' => 'Gary R Epstein',
                              '-login'    => 'grep'
                            }
                }
    }

As described earlier, C<XMLout> will ignore hash keys starting with a '-'.

=head2 NoAttr => 1 I<# in+out - handy>

When used with C<XMLout()>, the generated XML will contain no attributes.
All hash key/values will be represented as nested elements instead.

When used with C<XMLin()>, any attributes in the XML will be ignored.

=head2 NoEscape => 1 I<# out - seldom used>

By default, C<XMLout()> will translate the characters 'E<lt>', 'E<gt>', '&' and
'"' to '&lt;', '&gt;', '&amp;' and '&quot' respectively.  Use this option to
suppress escaping (presumably because you've already escaped the data in some
more sophisticated manner).

=head2 NoIndent => 1 I<# out - seldom used>

Set this option to 1 to disable C<XMLout()>'s default 'pretty printing' mode.
With this option enabled, the XML output will all be on one line (unless there
are newlines in the data) - this may be easier for downstream processing.

=head2 NoSort => 1 I<# out - seldom used>

Newer versions of XML::Simple sort elements and attributes alphabetically (*),
by default.  Enable this option to suppress the sorting - possibly for
backwards compatibility.

* Actually, sorting is alphabetical but 'key' attribute or element names (as in
'KeyAttr') sort first.  Also, when a hash of hashes is 'unfolded', the elements
are sorted alphabetically by the value of the key field.

=head2 NormaliseSpace => 0 | 1 | 2 I<# in - handy>

This option controls how whitespace in text content is handled.  Recognised
values for the option are:

=over 4

=item *

0 = (default) whitespace is passed through unaltered (except of course for the
normalisation of whitespace in attribute values which is mandated by the XML
recommendation)

=item *

1 = whitespace is normalised in any value used as a hash key (normalising means
removing leading and trailing whitespace and collapsing sequences of whitespace
characters to a single space)

=item *

2 = whitespace is normalised in all text content

=back

Note: you can spell this option with a 'z' if that is more natural for you.

=head2 NSExpand => 1 I<# in+out handy - SAX only>

This option controls namespace expansion - the translation of element and
attribute names of the form 'prefix:name' to '{uri}name'.  For example the
element name 'xsl:template' might be expanded to:
'{http://www.w3.org/1999/XSL/Transform}template'.

By default, C<XMLin()> will return element names and attribute names exactly as
they appear in the XML.  Setting this option to 1 will cause all element and
attribute names to be expanded to include their namespace prefix.

I<Note: You must be using a SAX parser for this option to work (ie: it does not
work with XML::Parser)>.

This option also controls whether C<XMLout()> performs the reverse translation
from '{uri}name' back to 'prefix:name'.  The default is no translation.  If
your data contains expanded names, you should set this option to 1 otherwise
C<XMLout> will emit XML which is not well formed.

I<Note: You must have the XML::NamespaceSupport module installed if you want
C<XMLout()> to translate URIs back to prefixes>.

=head2 NumericEscape => 0 | 1 | 2 I<# out - handy>

Use this option to have 'high' (non-ASCII) characters in your Perl data
structure converted to numeric entities (eg: &#8364;) in the XML output.  Three
levels are possible:

0 - default: no numeric escaping (OK if you're writing out UTF8)

1 - only characters above 0xFF are escaped (ie: characters in the 0x80-FF range are not escaped), possibly useful with ISO8859-1 output

2 - all characters above 0x7F are escaped (good for plain ASCII output)

=head2 OutputFile => <file specifier> I<# out - handy>

The default behaviour of C<XMLout()> is to return the XML as a string.  If you
wish to write the XML to a file, simply supply the filename using the
'OutputFile' option.

This option also accepts an IO handle object - especially useful in Perl 5.8.0
and later for output using an encoding other than UTF-8, eg:

  open my $fh, '>:encoding(iso-8859-1)', $path or die "open($path): $!";
  XMLout($ref, OutputFile => $fh);

Note, XML::Simple does not require that the object you pass in to the
OutputFile option inherits from L<IO::Handle> - it simply assumes the object
supports a C<print> method.

=head2 ParserOpts => [ XML::Parser Options ] I<# in - don't use this>

I<Note: This option is now officially deprecated.  If you find it useful, email
the author with an example of what you use it for.  Do not use this option to
set the ProtocolEncoding, that's just plain wrong - fix the XML>.

This option allows you to pass parameters to the constructor of the underlying
XML::Parser object (which of course assumes you're not using SAX).

=head2 RootName => 'string' I<# out - handy>

By default, when C<XMLout()> generates XML, the root element will be named
'opt'.  This option allows you to specify an alternative name.

Specifying either undef or the empty string for the RootName option will
produce XML with no root elements.  In most cases the resulting XML fragment
will not be 'well formed' and therefore could not be read back in by C<XMLin()>.
Nevertheless, the option has been found to be useful in certain circumstances.

=head2 SearchPath => [ list ] I<# in - handy>

If you pass C<XMLin()> a filename, but the filename include no directory
component, you can use this option to specify which directories should be
searched to locate the file.  You might use this option to search first in the
user's home directory, then in a global directory such as /etc.

If a filename is provided to C<XMLin()> but SearchPath is not defined, the
file is assumed to be in the current directory.

If the first parameter to C<XMLin()> is undefined, the default SearchPath
will contain only the directory in which the script itself is located.
Otherwise the default SearchPath will be empty.

=head2 StrictMode => 1 | 0  I<# in+out seldom used>

This option allows you to turn L<STRICT MODE> on or off for a particular call,
regardless of whether it was enabled at the time XML::Simple was loaded.

=head2 SuppressEmpty => 1 | '' | undef I<# in+out - handy>

This option controls what C<XMLin()> should do with empty elements (no
attributes and no content).  The default behaviour is to represent them as
empty hashes.  Setting this option to a true value (eg: 1) will cause empty
elements to be skipped altogether.  Setting the option to 'undef' or the empty
string will cause empty elements to be represented as the undefined value or
the empty string respectively.  The latter two alternatives are a little
easier to test for in your code than a hash with no keys.

The option also controls what C<XMLout()> does with undefined values.  Setting
the option to undef causes undefined values to be output as empty elements
(rather than empty attributes), it also suppresses the generation of warnings
about undefined values.  Setting the option to a true value (eg: 1) causes
undefined values to be skipped altogether on output.

=head2 ValueAttr => [ names ] I<# in - handy>

Use this option to deal elements which always have a single attribute and no
content.  Eg:

  <opt>
    <colour value="red" />
    <size   value="XXL" />
  </opt>

Setting C<< ValueAttr => [ 'value' ] >> will cause the above XML to parse to:

  {
    colour => 'red',
    size   => 'XXL'
  }

instead of this (the default):

  {
    colour => { value => 'red' },
    size   => { value => 'XXL' }
  }

Note: This form of the ValueAttr option is not compatible with C<XMLout()> -
since the attribute name is discarded at parse time, the original XML cannot be
reconstructed.

=head2 ValueAttr => { element => attribute, ... } I<# in+out - handy>

This (preferred) form of the ValueAttr option requires you to specify both
the element and the attribute names.  This is not only safer, it also allows
the original XML to be reconstructed by C<XMLout()>.

Note: You probably don't want to use this option and the NoAttr option at the
same time.

=head2 Variables => { name => value } I<# in - handy>

This option allows variables in the XML to be expanded when the file is read.
(there is no facility for putting the variable names back if you regenerate
XML using C<XMLout>).

A 'variable' is any text of the form C<${name}> which occurs in an attribute
value or in the text content of an element.  If 'name' matches a key in the
supplied hashref, C<${name}> will be replaced with the corresponding value from
the hashref.  If no matching key is found, the variable will not be replaced.
Names must match the regex: C<[\w.]+> (ie: only 'word' characters and dots are
allowed).

=head2 VarAttr => 'attr_name' I<# in - handy>

In addition to the variables defined using C<Variables>, this option allows
variables to be defined in the XML.  A variable definition consists of an
element with an attribute called 'attr_name' (the value of the C<VarAttr>
option).  The value of the attribute will be used as the variable name and the
text content of the element will be used as the value.  A variable defined in
this way will override a variable defined using the C<Variables> option.  For
example:

  XMLin( '<opt>
            <dir name="prefix">/usr/local/apache</dir>
            <dir name="exec_prefix">${prefix}</dir>
            <dir name="bindir">${exec_prefix}/bin</dir>
          </opt>',
         VarAttr => 'name', ContentKey => '-content'
        );

produces the following data structure:

  {
    dir => {
             prefix      => '/usr/local/apache',
             exec_prefix => '/usr/local/apache',
             bindir      => '/usr/local/apache/bin',
           }
  }

=head2 XMLDecl => 1  or  XMLDecl => 'string'  I<# out - handy>

If you want the output from C<XMLout()> to start with the optional XML
declaration, simply set the option to '1'.  The default XML declaration is:

        <?xml version='1.0' standalone='yes'?>

If you want some other string (for example to declare an encoding value), set
the value of this option to the complete string you require.


=head1 OPTIONAL OO INTERFACE

The procedural interface is both simple and convenient however there are a
couple of reasons why you might prefer to use the object oriented (OO)
interface:

=over 4

=item *

to define a set of default values which should be used on all subsequent calls
to C<XMLin()> or C<XMLout()>

=item *

to override methods in B<XML::Simple> to provide customised behaviour

=back

The default values for the options described above are unlikely to suit
everyone.  The OO interface allows you to effectively override B<XML::Simple>'s
defaults with your preferred values.  It works like this:

First create an XML::Simple parser object with your preferred defaults:

  my $xs = XML::Simple->new(ForceArray => 1, KeepRoot => 1);

then call C<XMLin()> or C<XMLout()> as a method of that object:

  my $ref = $xs->XMLin($xml);
  my $xml = $xs->XMLout($ref);

You can also specify options when you make the method calls and these values
will be merged with the values specified when the object was created.  Values
specified in a method call take precedence.

Note: when called as methods, the C<XMLin()> and C<XMLout()> routines may be
called as C<xml_in()> or C<xml_out()>.  The method names are aliased so the
only difference is the aesthetics.

=head2 Parsing Methods

You can explicitly call one of the following methods rather than rely on the
C<xml_in()> method automatically determining whether the target to be parsed is
a string, a file or a filehandle:

=over 4

=item parse_string(text)

Works exactly like the C<xml_in()> method but assumes the first argument is
a string of XML (or a reference to a scalar containing a string of XML).

=item parse_file(filename)

Works exactly like the C<xml_in()> method but assumes the first argument is
the name of a file containing XML.

=item parse_fh(file_handle)

Works exactly like the C<xml_in()> method but assumes the first argument is
a filehandle which can be read to get XML.

=back

=head2 Hook Methods

You can make your own class which inherits from XML::Simple and overrides
certain behaviours.  The following methods may provide useful 'hooks' upon
which to hang your modified behaviour.  You may find other undocumented methods
by examining the source, but those may be subject to change in future releases.

=over 4

=item new_xml_parser()

This method will be called when a new XML::Parser object must be constructed
(either because XML::SAX is not installed or XML::Parser is preferred).

=item handle_options(direction, name => value ...)

This method will be called when one of the parsing methods or the C<XMLout()>
method is called.  The initial argument will be a string (either 'in' or 'out')
and the remaining arguments will be name value pairs.

=item default_config_file()

Calculates and returns the name of the file which should be parsed if no
filename is passed to C<XMLin()> (default: C<$0.xml>).

=item build_simple_tree(filename, string)

Called from C<XMLin()> or any of the parsing methods.  Takes either a file name
as the first argument or C<undef> followed by a 'string' as the second
argument.  Returns a simple tree data structure.  You could override this
method to apply your own transformations before the data structure is returned
to the caller.

=item new_hashref()

When the 'simple tree' data structure is being built, this method will be
called to create any required anonymous hashrefs.

=item sorted_keys(name, hashref)

Called when C<XMLout()> is translating a hashref to XML.  This routine returns
a list of hash keys in the order that the corresponding attributes/elements
should appear in the output.

=item escape_value(string)

Called from C<XMLout()>, takes a string and returns a copy of the string with
XML character escaping rules applied.

=item escape_attr(string)

Called from C<XMLout()>, to handle attribute values.  By default, just calls
C<escape_value()>, but you can override this method if you want attributes
escaped differently than text content.

=item numeric_escape(string)

Called from C<escape_value()>, to handle non-ASCII characters (depending on the
value of the NumericEscape option).

=item copy_hash(hashref, extra_key => value, ...)

Called from C<XMLout()>, when 'unfolding' a hash of hashes into an array of
hashes.  You might wish to override this method if you're using tied hashes and
don't want them to get untied.

=back

=head2 Cache Methods

XML::Simple implements three caching schemes ('storable', 'memshare' and
'memcopy').  You can implement a custom caching scheme by implementing
two methods - one for reading from the cache and one for writing to it.

For example, you might implement a new 'dbm' scheme that stores cached data
structures using the L<MLDBM> module.  First, you would add a
C<cache_read_dbm()> method which accepted a filename for use as a lookup key
and returned a data structure on success, or undef on failure.  Then, you would
implement a C<cache_read_dbm()> method which accepted a data structure and a
filename.

You would use this caching scheme by specifying the option:

  Cache => [ 'dbm' ]

=head1 STRICT MODE

If you import the B<XML::Simple> routines like this:

  use XML::Simple qw(:strict);

the following common mistakes will be detected and treated as fatal errors

=over 4

=item *

Failing to explicitly set the C<KeyAttr> option - if you can't be bothered
reading about this option, turn it off with: KeyAttr => [ ]

=item *

Failing to explicitly set the C<ForceArray> option - if you can't be bothered
reading about this option, set it to the safest mode with: ForceArray => 1

=item *

Setting ForceArray to an array, but failing to list all the elements from the
KeyAttr hash.

=item *

Data error - KeyAttr is set to say { part => 'partnum' } but the XML contains
one or more E<lt>partE<gt> elements without a 'partnum' attribute (or nested
element).  Note: if strict mode is not set but C<use warnings;> is in force,
this condition triggers a warning.

=item *

Data error - as above, but non-unique values are present in the key attribute
(eg: more than one E<lt>partE<gt> element with the same partnum).  This will
also trigger a warning if strict mode is not enabled.

=item *

Data error - as above, but value of key attribute (eg: partnum) is not a
scalar string (due to nested elements etc).  This will also trigger a warning
if strict mode is not enabled.

=back

=head1 SAX SUPPORT

From version 1.08_01, B<XML::Simple> includes support for SAX (the Simple API
for XML) - specifically SAX2.

In a typical SAX application, an XML parser (or SAX 'driver') module generates
SAX events (start of element, character data, end of element, etc) as it parses
an XML document and a 'handler' module processes the events to extract the
required data.  This simple model allows for some interesting and powerful
possibilities:

=over 4

=item *

Applications written to the SAX API can extract data from huge XML documents
without the memory overheads of a DOM or tree API.

=item *

The SAX API allows for plug and play interchange of parser modules without
having to change your code to fit a new module's API.  A number of SAX parsers
are available with capabilities ranging from extreme portability to blazing
performance.

=item *

A SAX 'filter' module can implement both a handler interface for receiving
data and a generator interface for passing modified data on to a downstream
handler.  Filters can be chained together in 'pipelines'.

=item *

One filter module might split a data stream to direct data to two or more
downstream handlers.

=item *

Generating SAX events is not the exclusive preserve of XML parsing modules.
For example, a module might extract data from a relational database using DBI
and pass it on to a SAX pipeline for filtering and formatting.

=back

B<XML::Simple> can operate at either end of a SAX pipeline.  For example,
you can take a data structure in the form of a hashref and pass it into a
SAX pipeline using the 'Handler' option on C<XMLout()>:

  use XML::Simple;
  use Some::SAX::Filter;
  use XML::SAX::Writer;

  my $ref = {
               ....   # your data here
            };

  my $writer = XML::SAX::Writer->new();
  my $filter = Some::SAX::Filter->new(Handler => $writer);
  my $simple = XML::Simple->new(Handler => $filter);
  $simple->XMLout($ref);

You can also put B<XML::Simple> at the opposite end of the pipeline to take
advantage of the simple 'tree' data structure once the relevant data has been
isolated through filtering:

  use XML::SAX;
  use Some::SAX::Filter;
  use XML::Simple;

  my $simple = XML::Simple->new(ForceArray => 1, KeyAttr => ['partnum']);
  my $filter = Some::SAX::Filter->new(Handler => $simple);
  my $parser = XML::SAX::ParserFactory->parser(Handler => $filter);

  my $ref = $parser->parse_uri('some_huge_file.xml');

  print $ref->{part}->{'555-1234'};

You can build a filter by using an XML::Simple object as a handler and setting
its DataHandler option to point to a routine which takes the resulting tree,
modifies it and sends it off as SAX events to a downstream handler:

  my $writer = XML::SAX::Writer->new();
  my $filter = XML::Simple->new(
                 DataHandler => sub {
                                  my $simple = shift;
                                  my $data = shift;

                                  # Modify $data here

                                  $simple->XMLout($data, Handler => $writer);
                                }
               );
  my $parser = XML::SAX::ParserFactory->parser(Handler => $filter);

  $parser->parse_uri($filename);

I<Note: In this last example, the 'Handler' option was specified in the call to
C<XMLout()> but it could also have been specified in the constructor>.

=head1 ENVIRONMENT

If you don't care which parser module B<XML::Simple> uses then skip this
section entirely (it looks more complicated than it really is).

B<XML::Simple> will default to using a B<SAX> parser if one is available or
B<XML::Parser> if SAX is not available.

You can dictate which parser module is used by setting either the environment
variable 'XML_SIMPLE_PREFERRED_PARSER' or the package variable
$XML::Simple::PREFERRED_PARSER to contain the module name.  The following rules
are used:

=over 4

=item *

The package variable takes precedence over the environment variable if both are defined.  To force B<XML::Simple> to ignore the environment settings and use
its default rules, you can set the package variable to an empty string.

=item *

If the 'preferred parser' is set to the string 'XML::Parser', then
L<XML::Parser> will be used (or C<XMLin()> will die if L<XML::Parser> is not
installed).

=item *

If the 'preferred parser' is set to some other value, then it is assumed to be
the name of a SAX parser module and is passed to L<XML::SAX::ParserFactory>.
If L<XML::SAX> is not installed, or the requested parser module is not
installed, then C<XMLin()> will die.

=item *

If the 'preferred parser' is not defined at all (the normal default
state), an attempt will be made to load L<XML::SAX>.  If L<XML::SAX> is
installed, then a parser module will be selected according to
L<XML::SAX::ParserFactory>'s normal rules (which typically means the last SAX
parser installed).

=item *

if the 'preferred parser' is not defined and B<XML::SAX> is not
installed, then B<XML::Parser> will be used.  C<XMLin()> will die if
L<XML::Parser> is not installed.

=back

Note: The B<XML::SAX> distribution includes an XML parser written entirely in
Perl.  It is very portable but it is not very fast.  You should consider
installing L<XML::LibXML> or L<XML::SAX::Expat> if they are available for your
platform.

=head1 ERROR HANDLING

The XML standard is very clear on the issue of non-compliant documents.  An
error in parsing any single element (for example a missing end tag) must cause
the whole document to be rejected.  B<XML::Simple> will die with an appropriate
message if it encounters a parsing error.

If dying is not appropriate for your application, you should arrange to call
C<XMLin()> in an eval block and look for errors in $@.  eg:

    my $config = eval { XMLin() };
    PopUpMessage($@) if($@);

Note, there is a common misconception that use of B<eval> will significantly
slow down a script.  While that may be true when the code being eval'd is in a
string, it is not true of code like the sample above.

=head1 EXAMPLES

When C<XMLin()> reads the following very simple piece of XML:

    <opt username="testuser" password="frodo"></opt>

it returns the following data structure:

    {
      'username' => 'testuser',
      'password' => 'frodo'
    }

The identical result could have been produced with this alternative XML:

    <opt username="testuser" password="frodo" />

Or this (although see 'ForceArray' option for variations):

    <opt>
      <username>testuser</username>
      <password>frodo</password>
    </opt>

Repeated nested elements are represented as anonymous arrays:

    <opt>
      <person firstname="Joe" lastname="Smith">
        <email>joe@smith.com</email>
        <email>jsmith@yahoo.com</email>
      </person>
      <person firstname="Bob" lastname="Smith">
        <email>bob@smith.com</email>
      </person>
    </opt>

    {
      'person' => [
                    {
                      'email' => [
                                   'joe@smith.com',
                                   'jsmith@yahoo.com'
                                 ],
                      'firstname' => 'Joe',
                      'lastname' => 'Smith'
                    },
                    {
                      'email' => 'bob@smith.com',
                      'firstname' => 'Bob',
                      'lastname' => 'Smith'
                    }
                  ]
    }

Nested elements with a recognised key attribute are transformed (folded) from
an array into a hash keyed on the value of that attribute (see the C<KeyAttr>
option):

    <opt>
      <person key="jsmith" firstname="Joe" lastname="Smith" />
      <person key="tsmith" firstname="Tom" lastname="Smith" />
      <person key="jbloggs" firstname="Joe" lastname="Bloggs" />
    </opt>

    {
      'person' => {
                    'jbloggs' => {
                                   'firstname' => 'Joe',
                                   'lastname' => 'Bloggs'
                                 },
                    'tsmith' => {
                                  'firstname' => 'Tom',
                                  'lastname' => 'Smith'
                                },
                    'jsmith' => {
                                  'firstname' => 'Joe',
                                  'lastname' => 'Smith'
                                }
                  }
    }


The <anon> tag can be used to form anonymous arrays:

    <opt>
      <head><anon>Col 1</anon><anon>Col 2</anon><anon>Col 3</anon></head>
      <data><anon>R1C1</anon><anon>R1C2</anon><anon>R1C3</anon></data>
      <data><anon>R2C1</anon><anon>R2C2</anon><anon>R2C3</anon></data>
      <data><anon>R3C1</anon><anon>R3C2</anon><anon>R3C3</anon></data>
    </opt>

    {
      'head' => [
                  [ 'Col 1', 'Col 2', 'Col 3' ]
                ],
      'data' => [
                  [ 'R1C1', 'R1C2', 'R1C3' ],
                  [ 'R2C1', 'R2C2', 'R2C3' ],
                  [ 'R3C1', 'R3C2', 'R3C3' ]
                ]
    }

Anonymous arrays can be nested to arbitrary levels and as a special case, if
the surrounding tags for an XML document contain only an anonymous array the
arrayref will be returned directly rather than the usual hashref:

    <opt>
      <anon><anon>Col 1</anon><anon>Col 2</anon></anon>
      <anon><anon>R1C1</anon><anon>R1C2</anon></anon>
      <anon><anon>R2C1</anon><anon>R2C2</anon></anon>
    </opt>

    [
      [ 'Col 1', 'Col 2' ],
      [ 'R1C1', 'R1C2' ],
      [ 'R2C1', 'R2C2' ]
    ]

Elements which only contain text content will simply be represented as a
scalar.  Where an element has both attributes and text content, the element
will be represented as a hashref with the text content in the 'content' key
(see the C<ContentKey> option):

  <opt>
    <one>first</one>
    <two attr="value">second</two>
  </opt>

  {
    'one' => 'first',
    'two' => { 'attr' => 'value', 'content' => 'second' }
  }

Mixed content (elements which contain both text content and nested elements)
will be not be represented in a useful way - element order and significant
whitespace will be lost.  If you need to work with mixed content, then
XML::Simple is not the right tool for your job - check out the next section.

=head1 WHERE TO FROM HERE?

B<XML::Simple> is able to present a simple API because it makes some
assumptions on your behalf.  These include:

=over 4

=item *

You're not interested in text content consisting only of whitespace

=item *

You don't mind that when things get slurped into a hash the order is lost

=item *

You don't want fine-grained control of the formatting of generated XML

=item *

You would never use a hash key that was not a legal XML element name

=item *

You don't need help converting between different encodings

=back

In a serious XML project, you'll probably outgrow these assumptions fairly
quickly.  This section of the document used to offer some advice on choosing a
more powerful option.  That advice has now grown into the 'Perl-XML FAQ'
document which you can find at: L<http://perl-xml.sourceforge.net/faq/>

The advice in the FAQ boils down to a quick explanation of tree versus
event based parsers and then recommends:

For event based parsing, use SAX (do not set out to write any new code for
XML::Parser's handler API - it is obsolete).

For tree-based parsing, you could choose between the 'Perlish' approach of
L<XML::Twig> and more standards based DOM implementations - preferably one with
XPath support such as L<XML::LibXML>.


=head1 SEE ALSO

B<XML::Simple> requires either L<XML::Parser> or L<XML::SAX>.

To generate documents with namespaces, L<XML::NamespaceSupport> is required.

The optional caching functions require L<Storable>.

Answers to Frequently Asked Questions about XML::Simple are bundled with this
distribution as: L<XML::Simple::FAQ>

=head1 COPYRIGHT

Copyright 1999-2004 Grant McLean E<lt>grantm@cpan.orgE<gt>

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

=cut


PK       ! ʛ��Q  �Q    perl5/XML/Simple/FAQ.podnu ��6�$        
=head1 NAME

XML::Simple::FAQ - Frequently Asked Questions about XML::Simple

=head1 Basics


=head2 What should I use XML::Simple for?

Nothing!

It's as simple as that.

Choose a better module. See
L<Perl XML::LibXML by Example|http://grantm.github.io/perl-libxml-by-example/>
for a gentle introduction to L<XML::LibXML> with lots of examples.


=head2 What was XML::Simple designed to be used for?

XML::Simple is a Perl module that was originally developed as a tool for
reading and writing configuration data in XML format.  You could use it for
other purposes that involve storing and retrieving structured data in
XML but it's likely to be a frustrating experience.


=head2 Why store configuration data in XML anyway?

It seemed like a good idea at the time.  Now, I use and recommend
L<Config::General> which uses a format similar to that used by the Apache web
server.  This is easier to read than XML while still allowing advanced concepts
such as nested sections.

At the time XML::Simple was written, the advantages of using XML format for
configuration data were thought to include:

=over 4

=item *

Using existing XML parsing tools requires less development time, is easier
and more robust than developing your own config file parsing code

=item *

XML can represent relationships between pieces of data, such as nesting of
sections to arbitrary levels (not easily done with .INI files for example)

=item *

XML is basically just text, so you can easily edit a config file (easier than
editing a Win32 registry)

=item *

XML provides standard solutions for handling character sets and encoding
beyond basic ASCII (important for internationalization)

=item *

If it becomes necessary to change your configuration file format, there are
many tools available for performing transformations on XML files

=item *

XML is an open standard (the world does not need more proprietary binary
file formats)

=item *

Taking the extra step of developing a DTD allows the format of configuration
files to be validated before your program reads them (not directly supported
by XML::Simple)

=item *

Combining a DTD with a good XML editor can give you a GUI config editor for
minimal coding effort

=back


=head2 What isn't XML::Simple good for?

The main limitation of XML::Simple is that it does not work with 'mixed
content' (see the next question).  If you consider your XML files contain
marked up text rather than structured data, you should probably use another
module.

If your source XML documents change regularly, it's likely that you will
experience intermittent failures.  In particular, failure to properly use the
ForceArray and KeyAttr options will produce code that works when you get a list
of elements with the same name, but fails when there's only one item in the
list.  These types of problems can be avoided by not using XML::Simple in the
first place.

If you are working with very large XML files, XML::Simple's approach of
representing the whole file in memory as a 'tree' data structure may not be
suitable.


=head2 What is mixed content?

Consider this example XML:

  <document>
    <para>This is <em>mixed</em> content.</para>
  </document>

This is said to be mixed content, because the E<lt>paraE<gt> element contains
both character data (text content) and nested elements.

Here's some more XML:

  <person>
    <first_name>Joe</first_name>
    <last_name>Bloggs</last_name>
    <dob>25-April-1969</dob>
  </person>

This second example is not generally considered to be mixed content.  The
E<lt>first_nameE<gt>, E<lt>last_nameE<gt> and E<lt>dobE<gt> elements contain
only character data and the  E<lt>personE<gt> element contains only nested
elements.  (Note: Strictly speaking, the whitespace between the nested
elements is character data, but it is ignored by XML::Simple).


=head2 Why doesn't XML::Simple handle mixed content?

Because if it did, it would no longer be simple :-)

Seriously though, there are plenty of excellent modules that allow you to
work with mixed content in a variety of ways.  Handling mixed content
correctly is not easy and by ignoring these issues, XML::Simple is able to
present an API without a steep learning curve.


=head2 Which Perl modules do handle mixed content?

Every one of them except XML::Simple :-)

If you're looking for a recommendation, I'd suggest you look at the Perl-XML
FAQ at:

  http://perl-xml.sourceforge.net/faq/


=head1 Installation


=head2 How do I install XML::Simple?

If you're running ActiveState Perl, or
L<Strawberry Perl|http://strawberryperl.com/> you've probably already got
XML::Simple and therefore do not need to install it at all.  But you probably
also have L<XML::LibXML>, which is a much better module, so just use that.

If you do need to install XML::Simple, you'll need to install an XML parser
module first.  Install either XML::Parser (which you may have already) or
XML::SAX.  If you install both, XML::SAX will be used by default.

Once you have a parser installed ...

On Unix systems, try:

  perl -MCPAN -e 'install XML::Simple'

If that doesn't work, download the latest distribution from
ftp://ftp.cpan.org/pub/CPAN/authors/id/G/GR/GRANTM , unpack it and run these
commands:

  perl Makefile.PL
  make
  make test
  make install

On Win32, if you have a recent build of ActiveState Perl (618 or better) try
this command:

  ppm install XML::Simple

If that doesn't work, you really only need the Simple.pm file, so extract it
from the .tar.gz file (eg: using WinZIP) and save it in the \site\lib\XML
directory under your Perl installation (typically C:\Perl).


=head2 I'm trying to install XML::Simple and 'make test' fails

Is the directory where you've unpacked XML::Simple mounted from a file server
using NFS, SMB or some other network file sharing?  If so, that may cause
errors in the following test scripts:

  3_Storable.t
  4_MemShare.t
  5_MemCopy.t

The test suite is designed to exercise the boundary conditions of all
XML::Simple's functionality and these three scripts exercise the caching
functions.  If XML::Simple is asked to parse a file for which it has a cached
copy of a previous parse, then it compares the timestamp on the XML file with
the timestamp on the cached copy.  If the cached copy is *newer* then it will
be used.  If the cached copy is older or the same age then the file is
re-parsed.  The test scripts will get confused by networked filesystems if
the workstation and server system clocks are not synchronised (to the
second).

If you get an error in one of these three test scripts but you don't plan to
use the caching options (they're not enabled by default), then go right ahead
and run 'make install'.  If you do plan to use caching, then try unpacking
the distribution on local disk and doing the build/test there.

It's probably not a good idea to use the caching options with networked
filesystems in production.  If the file server's clock is ahead of the local
clock, XML::Simple will re-parse files when it could have used the cached
copy.  However if the local clock is ahead of the file server clock and a
file is changed immediately after it is cached, the old cached copy will be
used.

Is one of the three test scripts (above) failing but you're not running on
a network filesystem?  Are you running Win32?  If so, you may be seeing a bug
in Win32 where writes to a file do not affect its modification timestamp.

If none of these scenarios match your situation, please confirm you're
running the latest version of XML::Simple and then email the output of
'make test' to me at grantm@cpan.org

=head2 Why is XML::Simple so slow?

If you find that XML::Simple is very slow reading XML, the most likely reason
is that you have XML::SAX installed but no additional SAX parser module.  The
XML::SAX distribution includes an XML parser written entirely in Perl.  This is
very portable but not very fast.  For better performance install either
XML::SAX::Expat or XML::LibXML.


=head1 Usage

=head2 How do I use XML::Simple?

If you don't know how to use XML::Simple then the best approach is to
L<learn to use XML::LibXML|http://grantm.github.io/perl-libxml-by-example/>
instead.  Stop reading this document and use that one instead.

If you are determined to use XML::Simple, it come with copious documentation,
so L<read that|XML::Simple>.


=head2 There are so many options, which ones do I really need to know about?

Although you can get by without using any options, you shouldn't even
consider using XML::Simple in production until you know what these two
options do:

=over 4

=item *

forcearray

=item *

keyattr

=back

The reason you really need to read about them is because the default values
for these options will trip you up if you don't.  Although everyone agrees
that these defaults are not ideal, there is not wide agreement on what they
should be changed to.  The answer therefore is to read about them (see below)
and select values which are right for you.


=head2 What is the forcearray option all about?

Consider this XML in a file called ./person.xml:

  <person>
    <first_name>Joe</first_name>
    <last_name>Bloggs</last_name>
    <hobbie>bungy jumping</hobbie>
    <hobbie>sky diving</hobbie>
    <hobbie>knitting</hobbie>
  </person>

You could read it in with this line:

  my $person = XMLin('./person.xml');

Which would give you a data structure like this:

  $person = {
    'first_name' => 'Joe',
    'last_name'  => 'Bloggs',
    'hobbie'     => [ 'bungy jumping', 'sky diving', 'knitting' ]
  };

The E<lt>first_nameE<gt> and E<lt>last_nameE<gt> elements are represented as
simple scalar values which you could refer to like this:

  print "$person->{first_name} $person->{last_name}\n";

The E<lt>hobbieE<gt> elements are represented as an array - since there is
more than one.  You could refer to the first one like this:

  print $person->{hobbie}->[0], "\n";

Or the whole lot like this:

  print join(', ', @{$person->{hobbie}} ), "\n";

The catch is, that these last two lines of code will only work for people
who have more than one hobbie.  If there is only one E<lt>hobbieE<gt>
element, it will be represented as a simple scalar (just like
E<lt>first_nameE<gt> and E<lt>last_nameE<gt>).  Which might lead you to write
code like this:

  if(ref($person->{hobbie})) {
    print join(', ', @{$person->{hobbie}} ), "\n";
  }
  else {
    print $person->{hobbie}, "\n";
  }

Don't do that.

One alternative approach is to set the forcearray option to a true value:

  my $person = XMLin('./person.xml', forcearray => 1);

Which will give you a data structure like this:

  $person = {
    'first_name' => [ 'Joe' ],
    'last_name'  => [ 'Bloggs' ],
    'hobbie'     => [ 'bungy jumping', 'sky diving', 'knitting' ]
  };

Then you can use this line to refer to all the list of hobbies even if there
was only one:

  print join(', ', @{$person->{hobbie}} ), "\n";

The downside of this approach is that the E<lt>first_nameE<gt> and
E<lt>last_nameE<gt> elements will also always be represented as arrays even
though there will never be more than one:

  print "$person->{first_name}->[0] $person->{last_name}->[0]\n";

This might be OK if you change the XML to use attributes for things that
will always be singular and nested elements for things that may be plural:

  <person first_name="Jane" last_name="Bloggs">
    <hobbie>motorcycle maintenance</hobbie>
  </person>

On the other hand, if you prefer not to use attributes, then you could
specify that any E<lt>hobbieE<gt> elements should always be represented as
arrays and all other nested elements should be simple scalar values unless
there is more than one:

  my $person = XMLin('./person.xml', forcearray => [ 'hobbie' ]);

The forcearray option accepts a list of element names which should always
be forced to an array representation:

  forcearray => [ qw(hobbie qualification childs_name) ]

See the XML::Simple manual page for more information.


=head2 What is the keyattr option all about?

Consider this sample XML:

  <catalog>
    <part partnum="1842334" desc="High pressure flange" price="24.50" />
    <part partnum="9344675" desc="Threaded gasket"      price="9.25" />
    <part partnum="5634896" desc="Low voltage washer"   price="12.00" />
  </catalog>

You could slurp it in with this code:

  my $catalog = XMLin('./catalog.xml');

Which would return a data structure like this:

  $catalog = {
      'part' => [
          {
            'partnum' => '1842334',
            'desc'    => 'High pressure flange',
            'price'   => '24.50'
          },
          {
            'partnum' => '9344675',
            'desc'    => 'Threaded gasket',
            'price'   => '9.25'
          },
          {
            'partnum' => '5634896',
            'desc'    => 'Low voltage washer',
            'price'   => '12.00'
          }
      ]
  };

Then you could access the description of the first part in the catalog
with this code:

  print $catalog->{part}->[0]->{desc}, "\n";

However, if you wanted to access the description of the part with the
part number of "9344675" then you'd have to code a loop like this:

  foreach my $part (@{$catalog->{part}}) {
    if($part->{partnum} eq '9344675') {
      print $part->{desc}, "\n";
      last;
    }
  }

The knowledge that each E<lt>partE<gt> element has a unique partnum attribute
allows you to eliminate this search.  You can pass this knowledge on to
XML::Simple like this:

  my $catalog = XMLin($xml, keyattr => ['partnum']);

Which will return a data structure like this:

  $catalog = {
    'part' => {
      '5634896' => { 'desc' => 'Low voltage washer',   'price' => '12.00' },
      '1842334' => { 'desc' => 'High pressure flange', 'price' => '24.50' },
      '9344675' => { 'desc' => 'Threaded gasket',      'price' => '9.25'  }
    }
  };

XML::Simple has been able to transform $catalog->{part} from an arrayref to
a hashref (keyed on partnum).  This transformation is called 'array folding'.

Through the use of array folding, you can now index directly to the
description of the part you want:

  print $catalog->{part}->{9344675}->{desc}, "\n";

The 'keyattr' option also enables array folding when the unique key is in a
nested element rather than an attribute.  eg:

  <catalog>
    <part>
      <partnum>1842334</partnum>
      <desc>High pressure flange</desc>
      <price>24.50</price>
    </part>
    <part>
      <partnum>9344675</partnum>
      <desc>Threaded gasket</desc>
      <price>9.25</price>
    </part>
    <part>
      <partnum>5634896</partnum>
      <desc>Low voltage washer</desc>
      <price>12.00</price>
    </part>
  </catalog>

See the XML::Simple manual page for more information.


=head2 So what's the catch with 'keyattr'?

One thing to watch out for is that you might get array folding even if you
don't supply the keyattr option.  The default value for this option is:

  [ 'name', 'key', 'id']

Which means if your XML elements have a 'name', 'key' or 'id' attribute (or
nested element) then they may get folded on those values.  This means that
you can take advantage of array folding simply through careful choice of
attribute names.  On the hand, if you really don't want array folding at all,
you'll need to set 'key attr to an empty list:

  my $ref = XMLin($xml, keyattr => []);

A second 'gotcha' is that array folding only works on arrays.  That might
seem obvious, but if there's only one record in your XML and you didn't set
the 'forcearray' option then it won't be represented as an array and
consequently won't get folded into a hash.  The moral is that if you're
using array folding, you should always turn on the forcearray option.

You probably want to be as specific as you can be too.  For instance, the
safest way to parse the E<lt>catalogE<gt> example above would be:

  my $catalog = XMLin($xml, keyattr => { part => 'partnum'},
                            forcearray => ['part']);

By using the hashref for keyattr, you can specify that only E<lt>partE<gt>
elements should be folded on the 'partnum' attribute (and that the
E<lt>partE<gt> elements should not be folded on any other attribute).

By supplying a list of element names for forcearray, you're ensuring that
folding will work even if there's only one E<lt>partE<gt>.  You're also
ensuring that if the 'partnum' unique key is supplied in a nested element
then that element won't get forced to an array too.


=head2 How do I know what my data structure should look like?

The rules are fairly straightforward:

=over 4

=item *

each element gets represented as a hash

=item *

unless it contains only text, in which case it'll be a simple scalar value

=item *

or unless there's more than one element with the same name, in which case
they'll be represented as an array

=item *

unless you've got array folding enabled, in which case they'll be folded into
a hash

=item *

empty elements (no text contents B<and> no attributes) will either be
represented as an empty hash, an empty string or undef - depending on the value
of the 'suppressempty' option.

=back

If you're in any doubt, use Data::Dumper, eg:

  use XML::Simple;
  use Data::Dumper;

  my $ref = XMLin($xml);

  print Dumper($ref);


=head2 I'm getting 'Use of uninitialized value' warnings

You're probably trying to index into a non-existant hash key - try
Data::Dumper.


=head2 I'm getting a 'Not an ARRAY reference' error

Something that you expect to be an array is not.  The two most likely causes
are that you forgot to use 'forcearray' or that the array got folded into a
hash - try Data::Dumper.


=head2 I'm getting a 'No such array field' error

Something that you expect to be a hash is actually an array.  Perhaps array
folding failed because one element was missing the key attribute - try
Data::Dumper.


=head2 I'm getting an 'Out of memory' error

Something in the data structure is not as you expect and Perl may be trying
unsuccessfully to autovivify things - try Data::Dumper.

If you're already using Data::Dumper, try calling Dumper() immediately after
XMLin() - ie: before you attempt to access anything in the data structure.


=head2 My element order is getting jumbled up

If you read an XML file with XMLin() and then write it back out with
XMLout(), the order of the elements will likely be different.  (However, if
you read the file back in with XMLin() you'll get the same Perl data
structure).

The reordering happens because XML::Simple uses hashrefs to store your data
and Perl hashes do not really have any order.

It is possible that a future version of XML::Simple will use Tie::IxHash
to store the data in hashrefs which do retain the order.  However this will
not fix all cases of element order being lost.

If your application really is sensitive to element order, don't use
XML::Simple (and don't put order-sensitive values in attributes).


=head2 XML::Simple turns nested elements into attributes

If you read an XML file with XMLin() and then write it back out with
XMLout(), some data which was originally stored in nested elements may end up
in attributes.  (However, if you read the file back in with XMLin() you'll
get the same Perl data structure).

There are a number of ways you might handle this:

=over 4

=item *

use the 'forcearray' option with XMLin()

=item *

use the 'noattr' option with XMLout()

=item *

live with it

=item *

don't use XML::Simple

=back


=head2 Why does XMLout() insert E<lt>nameE<gt> elements (or attributes)?

Try setting keyattr => [].

When you call XMLin() to read XML, the 'keyattr' option controls whether arrays
get 'folded' into hashes.  Similarly, when you call XMLout(), the 'keyattr'
option controls whether hashes get 'unfolded' into arrays.  As described above,
'keyattr' is enabled by default.

=head2 Why are empty elements represented as empty hashes?

An element is always represented as a hash unless it contains only text, in
which case it is represented as a scalar string.

If you would prefer empty elements to be represented as empty strings or the
undefined value, set the 'suppressempty' option to '' or undef respectively.

=head2 Why is ParserOpts deprecated?

The C<ParserOpts> option is a remnant of the time when XML::Simple only worked
with the XML::Parser API.  Its value is completely ignored if you're using a
SAX parser, so writing code which relied on it would bar you from taking
advantage of SAX.

Even if you are using XML::Parser, it is seldom necessary to pass options to
the parser object.  A number of people have written to say they use this option
to set XML::Parser's C<ProtocolEncoding> option.  Don't do that, it's wrong,
Wrong, WRONG!  Fix the XML document so that it's well-formed and you won't have
a problem.

Having said all of that, as long as XML::Simple continues to support the
XML::Parser API, this option will not be removed.  There are currently no plans
to remove support for the XML::Parser API.

=cut


PK       ! b���  �    perl5/Data/Uniqid.pmnu ��6�$        package Data::Uniqid;

use 5.006;
use strict;
use warnings;

require Exporter;
use AutoLoader qw(AUTOLOAD);

our @ISA = qw(Exporter);

our %EXPORT_TAGS = ( 'all' => [ qw(
  suniqid  
  uniqid  
  luniqid  
) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(
  
);
our $VERSION = '0.12';

use Math::BigInt;
use Sys::Hostname;
use Time::HiRes qw( gettimeofday usleep );

sub base62() { ################################################### Base62 #####
  my($s)=@_;
  my(@c)=('0'..'9','a'..'z','A'..'Z');
  my(@p,$u,$v,$i,$n);
  my($m)=20;
  $p[0]=1;  
  for $i (1..$m) {
    $p[$i]=Math::BigInt->new($p[$i-1]);
    $p[$i]=$p[$i]->bmul(62);
  }

  $v=Math::BigInt->new($s);
  for ($i=$m;$i>=0;$i--) {
    $v=Math::BigInt->new($v);
    ($n,$v)=$v->bdiv($p[$i]);
    $u.=$c[$n];
  }
  $u=~s/^0+//;
  
  return($u);
}

sub suniqid { ########################################### get unique id #####
  my($s,$us)=gettimeofday();usleep(1);
  my($v)=sprintf("%06d%05d%06d",$us,substr($s,-5),$$);
  return(&base62($v));
}

sub uniqid { ########################################### get unique id #####
  my($s,$us)=gettimeofday();usleep(1);
  my($v)=sprintf("%06d%010d%06d",$us,$s,$$);
  return(&base62($v));
}

sub luniqid { ############################################ get unique id #####
  my($s,$us)=gettimeofday();usleep(1);
  my($ia,$ib,$ic,$id)=unpack("C4", (gethostbyname(hostname()))[4]);
  my($v)=sprintf("%06d%10d%06d%03d%03d%03d%03d",$us,$s,$$,$ia,$ib,$ic,$id);
	return(&base62($v));
}

1;
__END__

=head1 NAME

Data::Uniqid - Perl extension for simple genrating of unique id's

=head1 SYNOPSIS

  use Data::Uniqid qw ( suniqid uniqid luniqid );
  
  $id = suniqid;
  $id = uniqid;
  $id = luniqid;

=head1 DESCRIPTION

Data::Uniqid provides three simple routines for generating unique ids.
These ids are coded with a Base62 systen to make them short and handy
(e.g. to use it as part of a URL).

  suinqid
    genrates a very short id valid only for the localhost and with a 
    liftime of 1 day
  
  uniqid
    generates a short id valid on the local host 

  luniqid 
    generates a long id valid everywhere and ever


=head1 AUTHOR

Mike Wesemann, &lt;mwx@gmx.de&gt;

=head1 SEE ALSO

L<perl>.

=cut
PK       ! r�TK�  �    perl5/ok.pmnu ��6�$        package ok;
our $VERSION = '1.302183';

use strict;
use Test::More ();

sub import {
    shift;

    if (@_) {
        goto &Test::More::pass if $_[0] eq 'ok';
        goto &Test::More::use_ok;
    }

    # No argument list - croak as if we are prototyped like use_ok()
    my (undef, $file, $line) = caller();
    ($file =~ /^\(eval/) or die "Not enough arguments for 'use ok' at $file line $line\n";
}


__END__

=encoding UTF-8

=head1 NAME

ok - Alternative to Test::More::use_ok

=head1 SYNOPSIS

    use ok 'Some::Module';

=head1 DESCRIPTION

With this module, simply change all C<use_ok> in test scripts to C<use ok>,
and they will be executed at C<BEGIN> time.

Please see L<Test::use::ok> for the full description.

=head1 CC0 1.0 Universal

To the extent possible under law, 唐鳳 has waived all copyright and related
or neighboring rights to L<Test-use-ok>.

This work is published from Taiwan.

L<http://creativecommons.org/publicdomain/zero/1.0>

=cut
PK       ! -��*  *    perl5/Canary/Stability.pmnu ��6�$        =head1 NAME

Canary::Stability - canary to check perl compatibility for schmorp's modules

=head1 SYNOPSIS

 # in Makefile.PL
 use Canary::Stability DISTNAME => 2001, MINIMUM_PERL_VERSION;

=head1 DESCRIPTION

This module is used by Schmorp's modules during configuration stage to
test the installed perl for compatibility with his modules.

It's not, at this stage, meant as a tool for other module authors,
although in principle nothing prevents them from subscribing to the same
ideas.

See the F<Makefile.PL> in L<Coro> or L<AnyEvent> for usage examples.

=cut

package Canary::Stability;

BEGIN {
   $VERSION = 2013;
}

sub sgr {
   # we just assume ANSI almost everywhere
   # red 31, yellow 33, green 32
   local $| = 1;

   $ENV{PERL_CANARY_STABILITY_COLOUR} ne 0
   and ((-t STDOUT and length $ENV{TERM}) or $ENV{PERL_CANARY_STABILITY_COLOUR})
   and print "\e[$_[0]m";
}

sub import {
   my (undef, $distname, $minvers, $minperl) = @_;

   $ENV{PERL_CANARY_STABILITY_DISABLE}
      and return;

   $minperl ||= 5.008002;

   print <<EOF;

***
*** Canary::Stability COMPATIBILITY AND SUPPORT CHECK
*** =================================================
***
*** Hi!
***
*** I do my best to provide predictable and reliable software.
***
*** However, in recent releases, P5P (who maintain perl) have been
*** introducing regressions that are sometimes subtle and at other times
*** catastrophic, often for personal preferences with little or no concern
*** for existing code, most notably CPAN.
***
*** For this reason, it has become very hard for me to maintain the level
*** of reliability and support I have committed myself to in the past, at
*** least with some perl versions: I simply can't keep up working around new
*** bugs or gratituous incompatibilities, and in turn you might suffer from
*** unanticipated problems.
***
*** Therefore I have introduced a support and compatibility check, the results
*** of which follow below, together with a FAQ and some recommendations.
***
*** This check is just to let you know that there might be a risk, so you can
*** make judgement calls on how to proceed - it will not keep the module from
*** installing or working.
***
EOF

   if ($minvers > $VERSION) {
      sgr 33;
      print <<EOF;
*** The stability canary says: (nothing, it died of old age).
***
*** Your Canary::Stability module (used by $distname) is too old.
*** This is not a fatal problem - while you might want to upgrade to version
*** $minvers (currently installed version: $VERSION) to get better support
*** status testing, you might also not want to care at all, and all will
*** be well as long $distname works well enough for you, as the stability
*** canary is only used when installing the distribution.
***
EOF
   } elsif ($] < $minperl) {

      sgr 33;
      print <<EOF;
*** The stability canary says: chirp (it seems concerned about something).
***
*** Your perl version ($]) is older than the $distname distribution
*** likes ($minperl). This is not a fatal problem - the module might work
*** well with your version of perl, but it does mean the author likely
*** won't do anything to make it work if it breaks.
***
EOF

      if ($ENV{AUTOMATED_TESTING}) {
         print <<EOF;
*** Since this is an AUTOMATED_TESTING environment, the stability canary
*** decided to fail cleanly here, rather than to generate a false test
*** result.
***
EOF
         exit 0;
      }

   } elsif (defined $Internals::StabilityBranchVersion) {
      # note to people studying this modules sources:
      # the above test is not considered a clean or stable way to
      # test for the stability branch.

      sgr 32;
      print <<EOF;
*** The stability canary says: chirp! chirp! (it seems to be quite excited)
***
*** It seems you are running schmorp's stability branch of perl.
*** All should be well, and if it isn't, you should report this as a bug
*** to the $distname author.
***
EOF
   } elsif ($] < 5.021) {
      #sgr 32;
      print <<EOF;
*** The stability canary says: chirp! chirp! (it seems to be quite happy)
***
*** Your version of perl ($]) is quite supported by $distname, nothing
*** else to be said, hope it comes in handy.
***
EOF
   } else {
      sgr 31;
      print <<EOF;
*** The stability canary says: (nothing, it was driven away by harsh weather)
***
*** It seems you are running perl version $], likely the "official" or
*** "standard" version. While there is nothing wrong with doing that,
*** standard perl versions 5.022 and up are not supported by $distname.
*** While this might be fatal, it might also be all right - if you run into
*** problems, you might want to downgrade your perl or switch to the
*** stability branch.
***
*** If everything works fine, you can ignore this message.
***
EOF
      sgr 0;
      print <<EOF;
***
*** Stability canary mini-FAQ:
***
*** Do I need to do anything?
***    With luck, no. While some distributions are known to fail
***    already, most should probably work. This message is here
***    to alert you that your perl is not supported by $distname,
***    and if things go wrong, you either need to downgrade, or
***    sidegrade to the stability variant of your perl version,
***    or simply live with the consequences.
***
*** What is this canary thing?
***    It's purpose is to check support status of $distname with
***    respect to your perl version.
***
*** What is this "stability branch"?
***    It's a branch or fork of the official perl, by schmorp, to
***    improve stability and compatibility with existing modules.
***
*** How can I skip this prompt on automated installs?
***    Set PERL_CANARY_STABILITY_NOPROMPT=1 in your environment.
***    More info is in the Canary::Stability manpage.
***
*** Long version of this FAQ: http://stableperl.schmorp.de/faq.html
*** Stability Branch homepage: http://stableperl.schmorp.de/
***

EOF

      unless ($ENV{PERL_CANARY_STABILITY_NOPROMPT}) {
         require ExtUtils::MakeMaker;

         ExtUtils::MakeMaker::prompt ("Continue anyways? ", "y") =~ /^y/i
            or die "FATAL: User aborted configuration of $distname.\n";
      }
   }

   sgr 0;
}

=head1 ENVIRONMENT VARIABLES

=over 4

=item C<PERL_CANARY_STABILITY_NOPROMPT=1>

Do not prompt the user on alert messages.

=item C<PERL_CANARY_STABILITY_COLOUR=0>

Disable use of colour.

=item C<PERL_CANARY_STABILITY_COLOUR=1>

Force use of colour.

=item C<PERL_CANARY_STABILITY_DISABLE=1>

Disable this modules functionality completely.

=item C<AUTOMATED_TESTING=1>

When this variable is set to a true value and the perl minimum version
requirement is not met, the module will exit, which should skip testing
under automated testing environments.

This is done to avoid false failure or success reports when the chances of
success are already quite low and the failures are not supported by the
author.

=back

=head1 AUTHOR

 Marc Lehmann <schmorp@schmorp.de>
 http://software.schmorp.de/pkg/Canary-Stability.html

=cut

1

PK       ! F R��  �    perl5/JSON/PP/Boolean.pmnu ��6�$        =head1 NAME

JSON::PP::Boolean - dummy module providing JSON::PP::Boolean

=head1 SYNOPSIS

 # do not "use" yourself

=head1 DESCRIPTION

This module exists only to provide overload resolution for Storable and similar modules. See
L<JSON::PP> for more info about this class.

=cut

use JSON::PP ();
use strict;

1;

=head1 AUTHOR

This idea is from L<JSON::XS::Boolean> written by Marc Lehmann <schmorp[at]schmorp.de>

=cut

PK       ! ݄�M@ M@   perl5/JSON/PP.pmnu ��6�$        package JSON::PP;

# JSON-2.0

use 5.005;
use strict;
use base qw(Exporter);
use overload ();

use Carp ();
use B ();
#use Devel::Peek;

$JSON::PP::VERSION = '2.27203';

@JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json);

# instead of hash-access, i tried index-access for speed.
# but this method is not faster than what i expected. so it will be changed.

use constant P_ASCII                => 0;
use constant P_LATIN1               => 1;
use constant P_UTF8                 => 2;
use constant P_INDENT               => 3;
use constant P_CANONICAL            => 4;
use constant P_SPACE_BEFORE         => 5;
use constant P_SPACE_AFTER          => 6;
use constant P_ALLOW_NONREF         => 7;
use constant P_SHRINK               => 8;
use constant P_ALLOW_BLESSED        => 9;
use constant P_CONVERT_BLESSED      => 10;
use constant P_RELAXED              => 11;

use constant P_LOOSE                => 12;
use constant P_ALLOW_BIGNUM         => 13;
use constant P_ALLOW_BAREKEY        => 14;
use constant P_ALLOW_SINGLEQUOTE    => 15;
use constant P_ESCAPE_SLASH         => 16;
use constant P_AS_NONBLESSED        => 17;

use constant P_ALLOW_UNKNOWN        => 18;

use constant OLD_PERL => $] < 5.008 ? 1 : 0;

BEGIN {
    my @xs_compati_bit_properties = qw(
            latin1 ascii utf8 indent canonical space_before space_after allow_nonref shrink
            allow_blessed convert_blessed relaxed allow_unknown
    );
    my @pp_bit_properties = qw(
            allow_singlequote allow_bignum loose
            allow_barekey escape_slash as_nonblessed
    );

    # Perl version check, Unicode handling is enable?
    # Helper module sets @JSON::PP::_properties.
    if ($] < 5.008 ) {
        my $helper = $] >= 5.006 ? 'JSON::PP::Compat5006' : 'JSON::PP::Compat5005';
        eval qq| require $helper |;
        if ($@) { Carp::croak $@; }
    }

    for my $name (@xs_compati_bit_properties, @pp_bit_properties) {
        my $flag_name = 'P_' . uc($name);

        eval qq/
            sub $name {
                my \$enable = defined \$_[1] ? \$_[1] : 1;

                if (\$enable) {
                    \$_[0]->{PROPS}->[$flag_name] = 1;
                }
                else {
                    \$_[0]->{PROPS}->[$flag_name] = 0;
                }

                \$_[0];
            }

            sub get_$name {
                \$_[0]->{PROPS}->[$flag_name] ? 1 : '';
            }
        /;
    }

}


# Functions

my %encode_allow_method
     = map {($_ => 1)} qw/utf8 pretty allow_nonref latin1 self_encode escape_slash
                          allow_blessed convert_blessed indent indent_length allow_bignum
                          as_nonblessed
                        /;
my %decode_allow_method
     = map {($_ => 1)} qw/utf8 allow_nonref loose allow_singlequote allow_bignum
                          allow_barekey max_size relaxed/;


my $JSON; # cache

sub encode_json ($) { # encode
    ($JSON ||= __PACKAGE__->new->utf8)->encode(@_);
}


sub decode_json { # decode
    ($JSON ||= __PACKAGE__->new->utf8)->decode(@_);
}

# Obsoleted

sub to_json($) {
   Carp::croak ("JSON::PP::to_json has been renamed to encode_json.");
}


sub from_json($) {
   Carp::croak ("JSON::PP::from_json has been renamed to decode_json.");
}


# Methods

sub new {
    my $class = shift;
    my $self  = {
        max_depth   => 512,
        max_size    => 0,
        indent      => 0,
        FLAGS       => 0,
        fallback      => sub { encode_error('Invalid value. JSON can only reference.') },
        indent_length => 3,
    };

    bless $self, $class;
}


sub encode {
    return $_[0]->PP_encode_json($_[1]);
}


sub decode {
    return $_[0]->PP_decode_json($_[1], 0x00000000);
}


sub decode_prefix {
    return $_[0]->PP_decode_json($_[1], 0x00000001);
}


# accessor


# pretty printing

sub pretty {
    my ($self, $v) = @_;
    my $enable = defined $v ? $v : 1;

    if ($enable) { # indent_length(3) for JSON::XS compatibility
        $self->indent(1)->indent_length(3)->space_before(1)->space_after(1);
    }
    else {
        $self->indent(0)->space_before(0)->space_after(0);
    }

    $self;
}

# etc

sub max_depth {
    my $max  = defined $_[1] ? $_[1] : 0x80000000;
    $_[0]->{max_depth} = $max;
    $_[0];
}


sub get_max_depth { $_[0]->{max_depth}; }


sub max_size {
    my $max  = defined $_[1] ? $_[1] : 0;
    $_[0]->{max_size} = $max;
    $_[0];
}


sub get_max_size { $_[0]->{max_size}; }


sub filter_json_object {
    $_[0]->{cb_object} = defined $_[1] ? $_[1] : 0;
    $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
    $_[0];
}

sub filter_json_single_key_object {
    if (@_ > 1) {
        $_[0]->{cb_sk_object}->{$_[1]} = $_[2];
    }
    $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
    $_[0];
}

sub indent_length {
    if (!defined $_[1] or $_[1] > 15 or $_[1] < 0) {
        Carp::carp "The acceptable range of indent_length() is 0 to 15.";
    }
    else {
        $_[0]->{indent_length} = $_[1];
    }
    $_[0];
}

sub get_indent_length {
    $_[0]->{indent_length};
}

sub sort_by {
    $_[0]->{sort_by} = defined $_[1] ? $_[1] : 1;
    $_[0];
}

sub allow_bigint {
    Carp::carp("allow_bigint() is obsoleted. use allow_bignum() insted.");
}

###############################

###
### Perl => JSON
###


{ # Convert

    my $max_depth;
    my $indent;
    my $ascii;
    my $latin1;
    my $utf8;
    my $space_before;
    my $space_after;
    my $canonical;
    my $allow_blessed;
    my $convert_blessed;

    my $indent_length;
    my $escape_slash;
    my $bignum;
    my $as_nonblessed;

    my $depth;
    my $indent_count;
    my $keysort;


    sub PP_encode_json {
        my $self = shift;
        my $obj  = shift;

        $indent_count = 0;
        $depth        = 0;

        my $idx = $self->{PROPS};

        ($ascii, $latin1, $utf8, $indent, $canonical, $space_before, $space_after, $allow_blessed,
            $convert_blessed, $escape_slash, $bignum, $as_nonblessed)
         = @{$idx}[P_ASCII .. P_SPACE_AFTER, P_ALLOW_BLESSED, P_CONVERT_BLESSED,
                    P_ESCAPE_SLASH, P_ALLOW_BIGNUM, P_AS_NONBLESSED];

        ($max_depth, $indent_length) = @{$self}{qw/max_depth indent_length/};

        $keysort = $canonical ? sub { $a cmp $b } : undef;

        if ($self->{sort_by}) {
            $keysort = ref($self->{sort_by}) eq 'CODE' ? $self->{sort_by}
                     : $self->{sort_by} =~ /\D+/       ? $self->{sort_by}
                     : sub { $a cmp $b };
        }

        encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)")
             if(!ref $obj and !$idx->[ P_ALLOW_NONREF ]);

        my $str  = $self->object_to_json($obj);

        $str .= "\n" if ( $indent ); # JSON::XS 2.26 compatible

        unless ($ascii or $latin1 or $utf8) {
            utf8::upgrade($str);
        }

        if ($idx->[ P_SHRINK ]) {
            utf8::downgrade($str, 1);
        }

        return $str;
    }


    sub object_to_json {
        my ($self, $obj) = @_;
        my $type = ref($obj);

        if($type eq 'HASH'){
            return $self->hash_to_json($obj);
        }
        elsif($type eq 'ARRAY'){
            return $self->array_to_json($obj);
        }
        elsif ($type) { # blessed object?
            if (blessed($obj)) {

                return $self->value_to_json($obj) if ( $obj->isa('JSON::PP::Boolean') );

                if ( $convert_blessed and $obj->can('TO_JSON') ) {
                    my $result = $obj->TO_JSON();
                    if ( defined $result and ref( $result ) ) {
                        if ( refaddr( $obj ) eq refaddr( $result ) ) {
                            encode_error( sprintf(
                                "%s::TO_JSON method returned same object as was passed instead of a new one",
                                ref $obj
                            ) );
                        }
                    }

                    return $self->object_to_json( $result );
                }

                return "$obj" if ( $bignum and _is_bignum($obj) );
                return $self->blessed_to_json($obj) if ($allow_blessed and $as_nonblessed); # will be removed.

                encode_error( sprintf("encountered object '%s', but neither allow_blessed "
                    . "nor convert_blessed settings are enabled", $obj)
                ) unless ($allow_blessed);

                return 'null';
            }
            else {
                return $self->value_to_json($obj);
            }
        }
        else{
            return $self->value_to_json($obj);
        }
    }


    sub hash_to_json {
        my ($self, $obj) = @_;
        my @res;

        encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")
                                         if (++$depth > $max_depth);

        my ($pre, $post) = $indent ? $self->_up_indent() : ('', '');
        my $del = ($space_before ? ' ' : '') . ':' . ($space_after ? ' ' : '');

        for my $k ( _sort( $obj ) ) {
            if ( OLD_PERL ) { utf8::decode($k) } # key for Perl 5.6 / be optimized
            push @res, string_to_json( $self, $k )
                          .  $del
                          . ( $self->object_to_json( $obj->{$k} ) || $self->value_to_json( $obj->{$k} ) );
        }

        --$depth;
        $self->_down_indent() if ($indent);

        return   '{' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' )  . '}';
    }


    sub array_to_json {
        my ($self, $obj) = @_;
        my @res;

        encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")
                                         if (++$depth > $max_depth);

        my ($pre, $post) = $indent ? $self->_up_indent() : ('', '');

        for my $v (@$obj){
            push @res, $self->object_to_json($v) || $self->value_to_json($v);
        }

        --$depth;
        $self->_down_indent() if ($indent);

        return '[' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . ']';
    }


    sub value_to_json {
        my ($self, $value) = @_;

        return 'null' if(!defined $value);

        my $b_obj = B::svref_2object(\$value);  # for round trip problem
        my $flags = $b_obj->FLAGS;

        return $value # as is 
            if $flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK ); # SvTYPE is IV or NV?

        my $type = ref($value);

        if(!$type){
            return string_to_json($self, $value);
        }
        elsif( blessed($value) and  $value->isa('JSON::PP::Boolean') ){
            return $$value == 1 ? 'true' : 'false';
        }
        elsif ($type) {
            if ((overload::StrVal($value) =~ /=(\w+)/)[0]) {
                return $self->value_to_json("$value");
            }

            if ($type eq 'SCALAR' and defined $$value) {
                return   $$value eq '1' ? 'true'
                       : $$value eq '0' ? 'false'
                       : $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ? 'null'
                       : encode_error("cannot encode reference to scalar");
            }

             if ( $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ) {
                 return 'null';
             }
             else {
                 if ( $type eq 'SCALAR' or $type eq 'REF' ) {
                    encode_error("cannot encode reference to scalar");
                 }
                 else {
                    encode_error("encountered $value, but JSON can only represent references to arrays or hashes");
                 }
             }

        }
        else {
            return $self->{fallback}->($value)
                 if ($self->{fallback} and ref($self->{fallback}) eq 'CODE');
            return 'null';
        }

    }


    my %esc = (
        "\n" => '\n',
        "\r" => '\r',
        "\t" => '\t',
        "\f" => '\f',
        "\b" => '\b',
        "\"" => '\"',
        "\\" => '\\\\',
        "\'" => '\\\'',
    );


    sub string_to_json {
        my ($self, $arg) = @_;

        $arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g;
        $arg =~ s/\//\\\//g if ($escape_slash);
        $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg;

        if ($ascii) {
            $arg = JSON_PP_encode_ascii($arg);
        }

        if ($latin1) {
            $arg = JSON_PP_encode_latin1($arg);
        }

        if ($utf8) {
            utf8::encode($arg);
        }

        return '"' . $arg . '"';
    }


    sub blessed_to_json {
        my $reftype = reftype($_[1]) || '';
        if ($reftype eq 'HASH') {
            return $_[0]->hash_to_json($_[1]);
        }
        elsif ($reftype eq 'ARRAY') {
            return $_[0]->array_to_json($_[1]);
        }
        else {
            return 'null';
        }
    }


    sub encode_error {
        my $error  = shift;
        Carp::croak "$error";
    }


    sub _sort {
        defined $keysort ? (sort $keysort (keys %{$_[0]})) : keys %{$_[0]};
    }


    sub _up_indent {
        my $self  = shift;
        my $space = ' ' x $indent_length;

        my ($pre,$post) = ('','');

        $post = "\n" . $space x $indent_count;

        $indent_count++;

        $pre = "\n" . $space x $indent_count;

        return ($pre,$post);
    }


    sub _down_indent { $indent_count--; }


    sub PP_encode_box {
        {
            depth        => $depth,
            indent_count => $indent_count,
        };
    }

} # Convert


sub _encode_ascii {
    join('',
        map {
            $_ <= 127 ?
                chr($_) :
            $_ <= 65535 ?
                sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
        } unpack('U*', $_[0])
    );
}


sub _encode_latin1 {
    join('',
        map {
            $_ <= 255 ?
                chr($_) :
            $_ <= 65535 ?
                sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
        } unpack('U*', $_[0])
    );
}


sub _encode_surrogates { # from perlunicode
    my $uni = $_[0] - 0x10000;
    return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00);
}


sub _is_bignum {
    $_[0]->isa('Math::BigInt') or $_[0]->isa('Math::BigFloat');
}


#
# JSON => Perl
#

my $max_intsize;

BEGIN {
    my $checkint = 1111;
    for my $d (5..64) {
        $checkint .= 1;
        my $int   = eval qq| $checkint |;
        if ($int =~ /[eE]/) {
            $max_intsize = $d - 1;
            last;
        }
    }
}

{ # PARSE 

    my %escapes = ( #  by Jeremy Muhlich <jmuhlich [at] bitflood.org>
        b    => "\x8",
        t    => "\x9",
        n    => "\xA",
        f    => "\xC",
        r    => "\xD",
        '\\' => '\\',
        '"'  => '"',
        '/'  => '/',
    );

    my $text; # json data
    my $at;   # offset
    my $ch;   # 1chracter
    my $len;  # text length (changed according to UTF8 or NON UTF8)
    # INTERNAL
    my $depth;          # nest counter
    my $encoding;       # json text encoding
    my $is_valid_utf8;  # temp variable
    my $utf8_len;       # utf8 byte length
    # FLAGS
    my $utf8;           # must be utf8
    my $max_depth;      # max nest nubmer of objects and arrays
    my $max_size;
    my $relaxed;
    my $cb_object;
    my $cb_sk_object;

    my $F_HOOK;

    my $allow_bigint;   # using Math::BigInt
    my $singlequote;    # loosely quoting
    my $loose;          # 
    my $allow_barekey;  # bareKey

    # $opt flag
    # 0x00000001 .... decode_prefix
    # 0x10000000 .... incr_parse

    sub PP_decode_json {
        my ($self, $opt); # $opt is an effective flag during this decode_json.

        ($self, $text, $opt) = @_;

        ($at, $ch, $depth) = (0, '', 0);

        if ( !defined $text or ref $text ) {
            decode_error("malformed JSON string, neither array, object, number, string or atom");
        }

        my $idx = $self->{PROPS};

        ($utf8, $relaxed, $loose, $allow_bigint, $allow_barekey, $singlequote)
            = @{$idx}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE];

        if ( $utf8 ) {
            utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry");
        }
        else {
            utf8::upgrade( $text );
        }

        $len = length $text;

        ($max_depth, $max_size, $cb_object, $cb_sk_object, $F_HOOK)
             = @{$self}{qw/max_depth  max_size cb_object cb_sk_object F_HOOK/};

        if ($max_size > 1) {
            use bytes;
            my $bytes = length $text;
            decode_error(
                sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s"
                    , $bytes, $max_size), 1
            ) if ($bytes > $max_size);
        }

        # Currently no effect
        # should use regexp
        my @octets = unpack('C4', $text);
        $encoding =   ( $octets[0] and  $octets[1]) ? 'UTF-8'
                    : (!$octets[0] and  $octets[1]) ? 'UTF-16BE'
                    : (!$octets[0] and !$octets[1]) ? 'UTF-32BE'
                    : ( $octets[2]                ) ? 'UTF-16LE'
                    : (!$octets[2]                ) ? 'UTF-32LE'
                    : 'unknown';

        white(); # remove head white space

        my $valid_start = defined $ch; # Is there a first character for JSON structure?

        my $result = value();

        return undef if ( !$result && ( $opt & 0x10000000 ) ); # for incr_parse

        decode_error("malformed JSON string, neither array, object, number, string or atom") unless $valid_start;

        if ( !$idx->[ P_ALLOW_NONREF ] and !ref $result ) {
                decode_error(
                'JSON text must be an object or array (but found number, string, true, false or null,'
                       . ' use allow_nonref to allow this)', 1);
        }

        Carp::croak('something wrong.') if $len < $at; # we won't arrive here.

        my $consumed = defined $ch ? $at - 1 : $at; # consumed JSON text length

        white(); # remove tail white space

        if ( $ch ) {
            return ( $result, $consumed ) if ($opt & 0x00000001); # all right if decode_prefix
            decode_error("garbage after JSON object");
        }

        ( $opt & 0x00000001 ) ? ( $result, $consumed ) : $result;
    }


    sub next_chr {
        return $ch = undef if($at >= $len);
        $ch = substr($text, $at++, 1);
    }


    sub value {
        white();
        return          if(!defined $ch);
        return object() if($ch eq '{');
        return array()  if($ch eq '[');
        return string() if($ch eq '"' or ($singlequote and $ch eq "'"));
        return number() if($ch =~ /[0-9]/ or $ch eq '-');
        return word();
    }

    sub string {
        my ($i, $s, $t, $u);
        my $utf16;
        my $is_utf8;

        ($is_valid_utf8, $utf8_len) = ('', 0);

        $s = ''; # basically UTF8 flag on

        if($ch eq '"' or ($singlequote and $ch eq "'")){
            my $boundChar = $ch;

            OUTER: while( defined(next_chr()) ){

                if($ch eq $boundChar){
                    next_chr();

                    if ($utf16) {
                        decode_error("missing low surrogate character in surrogate pair");
                    }

                    utf8::decode($s) if($is_utf8);

                    return $s;
                }
                elsif($ch eq '\\'){
                    next_chr();
                    if(exists $escapes{$ch}){
                        $s .= $escapes{$ch};
                    }
                    elsif($ch eq 'u'){ # UNICODE handling
                        my $u = '';

                        for(1..4){
                            $ch = next_chr();
                            last OUTER if($ch !~ /[0-9a-fA-F]/);
                            $u .= $ch;
                        }

                        # U+D800 - U+DBFF
                        if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/) { # UTF-16 high surrogate?
                            $utf16 = $u;
                        }
                        # U+DC00 - U+DFFF
                        elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/) { # UTF-16 low surrogate?
                            unless (defined $utf16) {
                                decode_error("missing high surrogate character in surrogate pair");
                            }
                            $is_utf8 = 1;
                            $s .= JSON_PP_decode_surrogates($utf16, $u) || next;
                            $utf16 = undef;
                        }
                        else {
                            if (defined $utf16) {
                                decode_error("surrogate pair expected");
                            }

                            if ( ( my $hex = hex( $u ) ) > 127 ) {
                                $is_utf8 = 1;
                                $s .= JSON_PP_decode_unicode($u) || next;
                            }
                            else {
                                $s .= chr $hex;
                            }
                        }

                    }
                    else{
                        unless ($loose) {
                            $at -= 2;
                            decode_error('illegal backslash escape sequence in string');
                        }
                        $s .= $ch;
                    }
                }
                else{

                    if ( ord $ch  > 127 ) {
                        if ( $utf8 ) {
                            unless( $ch = is_valid_utf8($ch) ) {
                                $at -= 1;
                                decode_error("malformed UTF-8 character in JSON string");
                            }
                            else {
                                $at += $utf8_len - 1;
                            }
                        }
                        else {
                            utf8::encode( $ch );
                        }

                        $is_utf8 = 1;
                    }

                    if (!$loose) {
                        if ($ch =~ /[\x00-\x1f\x22\x5c]/)  { # '/' ok
                            $at--;
                            decode_error('invalid character encountered while parsing JSON string');
                        }
                    }

                    $s .= $ch;
                }
            }
        }

        decode_error("unexpected end of string while parsing JSON string");
    }


    sub white {
        while( defined $ch  ){
            if($ch le ' '){
                next_chr();
            }
            elsif($ch eq '/'){
                next_chr();
                if(defined $ch and $ch eq '/'){
                    1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r");
                }
                elsif(defined $ch and $ch eq '*'){
                    next_chr();
                    while(1){
                        if(defined $ch){
                            if($ch eq '*'){
                                if(defined(next_chr()) and $ch eq '/'){
                                    next_chr();
                                    last;
                                }
                            }
                            else{
                                next_chr();
                            }
                        }
                        else{
                            decode_error("Unterminated comment");
                        }
                    }
                    next;
                }
                else{
                    $at--;
                    decode_error("malformed JSON string, neither array, object, number, string or atom");
                }
            }
            else{
                if ($relaxed and $ch eq '#') { # correctly?
                    pos($text) = $at;
                    $text =~ /\G([^\n]*(?:\r\n|\r|\n|$))/g;
                    $at = pos($text);
                    next_chr;
                    next;
                }

                last;
            }
        }
    }


    sub array {
        my $a  = $_[0] || []; # you can use this code to use another array ref object.

        decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')
                                                    if (++$depth > $max_depth);

        next_chr();
        white();

        if(defined $ch and $ch eq ']'){
            --$depth;
            next_chr();
            return $a;
        }
        else {
            while(defined($ch)){
                push @$a, value();

                white();

                if (!defined $ch) {
                    last;
                }

                if($ch eq ']'){
                    --$depth;
                    next_chr();
                    return $a;
                }

                if($ch ne ','){
                    last;
                }

                next_chr();
                white();

                if ($relaxed and $ch eq ']') {
                    --$depth;
                    next_chr();
                    return $a;
                }

            }
        }

        decode_error(", or ] expected while parsing array");
    }


    sub object {
        my $o = $_[0] || {}; # you can use this code to use another hash ref object.
        my $k;

        decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')
                                                if (++$depth > $max_depth);
        next_chr();
        white();

        if(defined $ch and $ch eq '}'){
            --$depth;
            next_chr();
            if ($F_HOOK) {
                return _json_object_hook($o);
            }
            return $o;
        }
        else {
            while (defined $ch) {
                $k = ($allow_barekey and $ch ne '"' and $ch ne "'") ? bareKey() : string();
                white();

                if(!defined $ch or $ch ne ':'){
                    $at--;
                    decode_error("':' expected");
                }

                next_chr();
                $o->{$k} = value();
                white();

                last if (!defined $ch);

                if($ch eq '}'){
                    --$depth;
                    next_chr();
                    if ($F_HOOK) {
                        return _json_object_hook($o);
                    }
                    return $o;
                }

                if($ch ne ','){
                    last;
                }

                next_chr();
                white();

                if ($relaxed and $ch eq '}') {
                    --$depth;
                    next_chr();
                    if ($F_HOOK) {
                        return _json_object_hook($o);
                    }
                    return $o;
                }

            }

        }

        $at--;
        decode_error(", or } expected while parsing object/hash");
    }


    sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition
        my $key;
        while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){
            $key .= $ch;
            next_chr();
        }
        return $key;
    }


    sub word {
        my $word =  substr($text,$at-1,4);

        if($word eq 'true'){
            $at += 3;
            next_chr;
            return $JSON::PP::true;
        }
        elsif($word eq 'null'){
            $at += 3;
            next_chr;
            return undef;
        }
        elsif($word eq 'fals'){
            $at += 3;
            if(substr($text,$at,1) eq 'e'){
                $at++;
                next_chr;
                return $JSON::PP::false;
            }
        }

        $at--; # for decode_error report

        decode_error("'null' expected")  if ($word =~ /^n/);
        decode_error("'true' expected")  if ($word =~ /^t/);
        decode_error("'false' expected") if ($word =~ /^f/);
        decode_error("malformed JSON string, neither array, object, number, string or atom");
    }


    sub number {
        my $n    = '';
        my $v;

        # According to RFC4627, hex or oct digts are invalid.
        if($ch eq '0'){
            my $peek = substr($text,$at,1);
            my $hex  = $peek =~ /[xX]/; # 0 or 1

            if($hex){
                decode_error("malformed number (leading zero must not be followed by another digit)");
                ($n) = ( substr($text, $at+1) =~ /^([0-9a-fA-F]+)/);
            }
            else{ # oct
                ($n) = ( substr($text, $at) =~ /^([0-7]+)/);
                if (defined $n and length $n > 1) {
                    decode_error("malformed number (leading zero must not be followed by another digit)");
                }
            }

            if(defined $n and length($n)){
                if (!$hex and length($n) == 1) {
                   decode_error("malformed number (leading zero must not be followed by another digit)");
                }
                $at += length($n) + $hex;
                next_chr;
                return $hex ? hex($n) : oct($n);
            }
        }

        if($ch eq '-'){
            $n = '-';
            next_chr;
            if (!defined $ch or $ch !~ /\d/) {
                decode_error("malformed number (no digits after initial minus)");
            }
        }

        while(defined $ch and $ch =~ /\d/){
            $n .= $ch;
            next_chr;
        }

        if(defined $ch and $ch eq '.'){
            $n .= '.';

            next_chr;
            if (!defined $ch or $ch !~ /\d/) {
                decode_error("malformed number (no digits after decimal point)");
            }
            else {
                $n .= $ch;
            }

            while(defined(next_chr) and $ch =~ /\d/){
                $n .= $ch;
            }
        }

        if(defined $ch and ($ch eq 'e' or $ch eq 'E')){
            $n .= $ch;
            next_chr;

            if(defined($ch) and ($ch eq '+' or $ch eq '-')){
                $n .= $ch;
                next_chr;
                if (!defined $ch or $ch =~ /\D/) {
                    decode_error("malformed number (no digits after exp sign)");
                }
                $n .= $ch;
            }
            elsif(defined($ch) and $ch =~ /\d/){
                $n .= $ch;
            }
            else {
                decode_error("malformed number (no digits after exp sign)");
            }

            while(defined(next_chr) and $ch =~ /\d/){
                $n .= $ch;
            }

        }

        $v .= $n;

        if ($v !~ /[.eE]/ and length $v > $max_intsize) {
            if ($allow_bigint) { # from Adam Sussman
                require Math::BigInt;
                return Math::BigInt->new($v);
            }
            else {
                return "$v";
            }
        }
        elsif ($allow_bigint) {
            require Math::BigFloat;
            return Math::BigFloat->new($v);
        }

        return 0+$v;
    }


    sub is_valid_utf8 {

        $utf8_len = $_[0] =~ /[\x00-\x7F]/  ? 1
                  : $_[0] =~ /[\xC2-\xDF]/  ? 2
                  : $_[0] =~ /[\xE0-\xEF]/  ? 3
                  : $_[0] =~ /[\xF0-\xF4]/  ? 4
                  : 0
                  ;

        return unless $utf8_len;

        my $is_valid_utf8 = substr($text, $at - 1, $utf8_len);

        return ( $is_valid_utf8 =~ /^(?:
             [\x00-\x7F]
            |[\xC2-\xDF][\x80-\xBF]
            |[\xE0][\xA0-\xBF][\x80-\xBF]
            |[\xE1-\xEC][\x80-\xBF][\x80-\xBF]
            |[\xED][\x80-\x9F][\x80-\xBF]
            |[\xEE-\xEF][\x80-\xBF][\x80-\xBF]
            |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF]
            |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF]
            |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF]
        )$/x )  ? $is_valid_utf8 : '';
    }


    sub decode_error {
        my $error  = shift;
        my $no_rep = shift;
        my $str    = defined $text ? substr($text, $at) : '';
        my $mess   = '';
        my $type   = $] >= 5.008           ? 'U*'
                   : $] <  5.006           ? 'C*'
                   : utf8::is_utf8( $str ) ? 'U*' # 5.6
                   : 'C*'
                   ;

        for my $c ( unpack( $type, $str ) ) { # emulate pv_uni_display() ?
            $mess .=  $c == 0x07 ? '\a'
                    : $c == 0x09 ? '\t'
                    : $c == 0x0a ? '\n'
                    : $c == 0x0d ? '\r'
                    : $c == 0x0c ? '\f'
                    : $c <  0x20 ? sprintf('\x{%x}', $c)
                    : $c == 0x5c ? '\\\\'
                    : $c <  0x80 ? chr($c)
                    : sprintf('\x{%x}', $c)
                    ;
            if ( length $mess >= 20 ) {
                $mess .= '...';
                last;
            }
        }

        unless ( length $mess ) {
            $mess = '(end of string)';
        }

        Carp::croak (
            $no_rep ? "$error" : "$error, at character offset $at (before \"$mess\")"
        );

    }


    sub _json_object_hook {
        my $o    = $_[0];
        my @ks = keys %{$o};

        if ( $cb_sk_object and @ks == 1 and exists $cb_sk_object->{ $ks[0] } and ref $cb_sk_object->{ $ks[0] } ) {
            my @val = $cb_sk_object->{ $ks[0] }->( $o->{$ks[0]} );
            if (@val == 1) {
                return $val[0];
            }
        }

        my @val = $cb_object->($o) if ($cb_object);
        if (@val == 0 or @val > 1) {
            return $o;
        }
        else {
            return $val[0];
        }
    }


    sub PP_decode_box {
        {
            text    => $text,
            at      => $at,
            ch      => $ch,
            len     => $len,
            depth   => $depth,
            encoding      => $encoding,
            is_valid_utf8 => $is_valid_utf8,
        };
    }

} # PARSE


sub _decode_surrogates { # from perlunicode
    my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00);
    my $un  = pack('U*', $uni);
    utf8::encode( $un );
    return $un;
}


sub _decode_unicode {
    my $un = pack('U', hex shift);
    utf8::encode( $un );
    return $un;
}

#
# Setup for various Perl versions (the code from JSON::PP58)
#

BEGIN {

    unless ( defined &utf8::is_utf8 ) {
       require Encode;
       *utf8::is_utf8 = *Encode::is_utf8;
    }

    if ( $] >= 5.008 ) {
        *JSON::PP::JSON_PP_encode_ascii      = \&_encode_ascii;
        *JSON::PP::JSON_PP_encode_latin1     = \&_encode_latin1;
        *JSON::PP::JSON_PP_decode_surrogates = \&_decode_surrogates;
        *JSON::PP::JSON_PP_decode_unicode    = \&_decode_unicode;
    }

    if ($] >= 5.008 and $] < 5.008003) { # join() in 5.8.0 - 5.8.2 is broken.
        package JSON::PP;
        require subs;
        subs->import('join');
        eval q|
            sub join {
                return '' if (@_ < 2);
                my $j   = shift;
                my $str = shift;
                for (@_) { $str .= $j . $_; }
                return $str;
            }
        |;
    }


    sub JSON::PP::incr_parse {
        local $Carp::CarpLevel = 1;
        ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ );
    }


    sub JSON::PP::incr_skip {
        ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip;
    }


    sub JSON::PP::incr_reset {
        ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset;
    }

    eval q{
        sub JSON::PP::incr_text : lvalue {
            $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new;

            if ( $_[0]->{_incr_parser}->{incr_parsing} ) {
                Carp::croak("incr_text can not be called when the incremental parser already started parsing");
            }
            $_[0]->{_incr_parser}->{incr_text};
        }
    } if ( $] >= 5.006 );

} # Setup for various Perl versions (the code from JSON::PP58)


###############################
# Utilities
#

BEGIN {
    eval 'require Scalar::Util';
    unless($@){
        *JSON::PP::blessed = \&Scalar::Util::blessed;
        *JSON::PP::reftype = \&Scalar::Util::reftype;
        *JSON::PP::refaddr = \&Scalar::Util::refaddr;
    }
    else{ # This code is from Sclar::Util.
        # warn $@;
        eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }';
        *JSON::PP::blessed = sub {
            local($@, $SIG{__DIE__}, $SIG{__WARN__});
            ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef;
        };
        my %tmap = qw(
            B::NULL   SCALAR
            B::HV     HASH
            B::AV     ARRAY
            B::CV     CODE
            B::IO     IO
            B::GV     GLOB
            B::REGEXP REGEXP
        );
        *JSON::PP::reftype = sub {
            my $r = shift;

            return undef unless length(ref($r));

            my $t = ref(B::svref_2object($r));

            return
                exists $tmap{$t} ? $tmap{$t}
              : length(ref($$r)) ? 'REF'
              :                    'SCALAR';
        };
        *JSON::PP::refaddr = sub {
          return undef unless length(ref($_[0]));

          my $addr;
          if(defined(my $pkg = blessed($_[0]))) {
            $addr .= bless $_[0], 'Scalar::Util::Fake';
            bless $_[0], $pkg;
          }
          else {
            $addr .= $_[0]
          }

          $addr =~ /0x(\w+)/;
          local $^W;
          #no warnings 'portable';
          hex($1);
        }
    }
}


# shamely copied and modified from JSON::XS code.

$JSON::PP::true  = do { bless \(my $dummy = 1), "JSON::PP::Boolean" };
$JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" };

sub is_bool { defined $_[0] and UNIVERSAL::isa($_[0], "JSON::PP::Boolean"); }

sub true  { $JSON::PP::true  }
sub false { $JSON::PP::false }
sub null  { undef; }

###############################

package JSON::PP::Boolean;

use overload (
   "0+"     => sub { ${$_[0]} },
   "++"     => sub { $_[0] = ${$_[0]} + 1 },
   "--"     => sub { $_[0] = ${$_[0]} - 1 },
   fallback => 1,
);


###############################

package JSON::PP::IncrParser;

use strict;

use constant INCR_M_WS   => 0; # initial whitespace skipping
use constant INCR_M_STR  => 1; # inside string
use constant INCR_M_BS   => 2; # inside backslash
use constant INCR_M_JSON => 3; # outside anything, count nesting
use constant INCR_M_C0   => 4;
use constant INCR_M_C1   => 5;

$JSON::PP::IncrParser::VERSION = '1.01';

my $unpack_format = $] < 5.006 ? 'C*' : 'U*';

sub new {
    my ( $class ) = @_;

    bless {
        incr_nest    => 0,
        incr_text    => undef,
        incr_parsing => 0,
        incr_p       => 0,
    }, $class;
}


sub incr_parse {
    my ( $self, $coder, $text ) = @_;

    $self->{incr_text} = '' unless ( defined $self->{incr_text} );

    if ( defined $text ) {
        if ( utf8::is_utf8( $text ) and !utf8::is_utf8( $self->{incr_text} ) ) {
            utf8::upgrade( $self->{incr_text} ) ;
            utf8::decode( $self->{incr_text} ) ;
        }
        $self->{incr_text} .= $text;
    }


    my $max_size = $coder->get_max_size;

    if ( defined wantarray ) {

        $self->{incr_mode} = INCR_M_WS unless defined $self->{incr_mode};

        if ( wantarray ) {
            my @ret;

            $self->{incr_parsing} = 1;

            do {
                push @ret, $self->_incr_parse( $coder, $self->{incr_text} );

                unless ( !$self->{incr_nest} and $self->{incr_mode} == INCR_M_JSON ) {
                    $self->{incr_mode} = INCR_M_WS if $self->{incr_mode} != INCR_M_STR;
                }

            } until ( length $self->{incr_text} >= $self->{incr_p} );

            $self->{incr_parsing} = 0;

            return @ret;
        }
        else { # in scalar context
            $self->{incr_parsing} = 1;
            my $obj = $self->_incr_parse( $coder, $self->{incr_text} );
            $self->{incr_parsing} = 0 if defined $obj; # pointed by Martin J. Evans
            return $obj ? $obj : undef; # $obj is an empty string, parsing was completed.
        }

    }

}


sub _incr_parse {
    my ( $self, $coder, $text, $skip ) = @_;
    my $p = $self->{incr_p};
    my $restore = $p;

    my @obj;
    my $len = length $text;

    if ( $self->{incr_mode} == INCR_M_WS ) {
        while ( $len > $p ) {
            my $s = substr( $text, $p, 1 );
            $p++ and next if ( 0x20 >= unpack($unpack_format, $s) );
            $self->{incr_mode} = INCR_M_JSON;
            last;
       }
    }

    while ( $len > $p ) {
        my $s = substr( $text, $p++, 1 );

        if ( $s eq '"' ) {
            if (substr( $text, $p - 2, 1 ) eq '\\' ) {
                next;
            }

            if ( $self->{incr_mode} != INCR_M_STR  ) {
                $self->{incr_mode} = INCR_M_STR;
            }
            else {
                $self->{incr_mode} = INCR_M_JSON;
                unless ( $self->{incr_nest} ) {
                    last;
                }
            }
        }

        if ( $self->{incr_mode} == INCR_M_JSON ) {

            if ( $s eq '[' or $s eq '{' ) {
                if ( ++$self->{incr_nest} > $coder->get_max_depth ) {
                    Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)');
                }
            }
            elsif ( $s eq ']' or $s eq '}' ) {
                last if ( --$self->{incr_nest} <= 0 );
            }
            elsif ( $s eq '#' ) {
                while ( $len > $p ) {
                    last if substr( $text, $p++, 1 ) eq "\n";
                }
            }

        }

    }

    $self->{incr_p} = $p;

    return if ( $self->{incr_mode} == INCR_M_STR and not $self->{incr_nest} );
    return if ( $self->{incr_mode} == INCR_M_JSON and $self->{incr_nest} > 0 );

    return '' unless ( length substr( $self->{incr_text}, 0, $p ) );

    local $Carp::CarpLevel = 2;

    $self->{incr_p} = $restore;
    $self->{incr_c} = $p;

    my ( $obj, $tail ) = $coder->PP_decode_json( substr( $self->{incr_text}, 0, $p ), 0x10000001 );

    $self->{incr_text} = substr( $self->{incr_text}, $p );
    $self->{incr_p} = 0;

    return $obj || '';
}


sub incr_text {
    if ( $_[0]->{incr_parsing} ) {
        Carp::croak("incr_text can not be called when the incremental parser already started parsing");
    }
    $_[0]->{incr_text};
}


sub incr_skip {
    my $self  = shift;
    $self->{incr_text} = substr( $self->{incr_text}, $self->{incr_c} );
    $self->{incr_p} = 0;
}


sub incr_reset {
    my $self = shift;
    $self->{incr_text}    = undef;
    $self->{incr_p}       = 0;
    $self->{incr_mode}    = 0;
    $self->{incr_nest}    = 0;
    $self->{incr_parsing} = 0;
}

###############################


1;
__END__
=pod

=head1 NAME

JSON::PP - JSON::XS compatible pure-Perl module.

=head1 SYNOPSIS

 use JSON::PP;

 # exported functions, they croak on error
 # and expect/generate UTF-8

 $utf8_encoded_json_text = encode_json $perl_hash_or_arrayref;
 $perl_hash_or_arrayref  = decode_json $utf8_encoded_json_text;

 # OO-interface

 $coder = JSON::PP->new->ascii->pretty->allow_nonref;
 
 $json_text   = $json->encode( $perl_scalar );
 $perl_scalar = $json->decode( $json_text );
 
 $pretty_printed = $json->pretty->encode( $perl_scalar ); # pretty-printing
 
 # Note that JSON version 2.0 and above will automatically use
 # JSON::XS or JSON::PP, so you should be able to just:
 
 use JSON;


=head1 VERSION

    2.27202

L<JSON::XS> 2.27 (~2.30) compatible.

=head1 NOTE

JSON::PP had been inculded in JSON distribution (CPAN module).
It was a perl core module in Perl 5.14.

=head1 DESCRIPTION

This module is L<JSON::XS> compatible pure Perl module.
(Perl 5.8 or later is recommended)

JSON::XS is the fastest and most proper JSON module on CPAN.
It is written by Marc Lehmann in C, so must be compiled and
installed in the used environment.

JSON::PP is a pure-Perl module and has compatibility to JSON::XS.


=head2 FEATURES

=over

=item * correct unicode handling

This module knows how to handle Unicode (depending on Perl version).

See to L<JSON::XS/A FEW NOTES ON UNICODE AND PERL> and L<UNICODE HANDLING ON PERLS>.


=item * round-trip integrity

When you serialise a perl data structure using only data types supported
by JSON and Perl, the deserialised data structure is identical on the Perl
level. (e.g. the string "2.0" doesn't suddenly become "2" just because
it looks like a number). There I<are> minor exceptions to this, read the
MAPPING section below to learn about those.


=item * strict checking of JSON correctness

There is no guessing, no generating of illegal JSON texts by default,
and only JSON is accepted as input by default (the latter is a security feature).
But when some options are set, loose chcking features are available.

=back

=head1 FUNCTIONAL INTERFACE

Some documents are copied and modified from L<JSON::XS/FUNCTIONAL INTERFACE>.

=head2 encode_json

    $json_text = encode_json $perl_scalar

Converts the given Perl data structure to a UTF-8 encoded, binary string.

This function call is functionally identical to:

    $json_text = JSON::PP->new->utf8->encode($perl_scalar)

=head2 decode_json

    $perl_scalar = decode_json $json_text

The opposite of C<encode_json>: expects an UTF-8 (binary) string and tries
to parse that as an UTF-8 encoded JSON text, returning the resulting
reference.

This function call is functionally identical to:

    $perl_scalar = JSON::PP->new->utf8->decode($json_text)

=head2 JSON::PP::is_bool

    $is_boolean = JSON::PP::is_bool($scalar)

Returns true if the passed scalar represents either JSON::PP::true or
JSON::PP::false, two constants that act like C<1> and C<0> respectively
and are also used to represent JSON C<true> and C<false> in Perl strings.

=head2 JSON::PP::true

Returns JSON true value which is blessed object.
It C<isa> JSON::PP::Boolean object.

=head2 JSON::PP::false

Returns JSON false value which is blessed object.
It C<isa> JSON::PP::Boolean object.

=head2 JSON::PP::null

Returns C<undef>.

See L<MAPPING>, below, for more information on how JSON values are mapped to
Perl.


=head1 HOW DO I DECODE A DATA FROM OUTER AND ENCODE TO OUTER

This section supposes that your perl vresion is 5.8 or later.

If you know a JSON text from an outer world - a network, a file content, and so on,
is encoded in UTF-8, you should use C<decode_json> or C<JSON> module object
with C<utf8> enable. And the decoded result will contain UNICODE characters.

  # from network
  my $json        = JSON::PP->new->utf8;
  my $json_text   = CGI->new->param( 'json_data' );
  my $perl_scalar = $json->decode( $json_text );
  
  # from file content
  local $/;
  open( my $fh, '<', 'json.data' );
  $json_text   = <$fh>;
  $perl_scalar = decode_json( $json_text );

If an outer data is not encoded in UTF-8, firstly you should C<decode> it.

  use Encode;
  local $/;
  open( my $fh, '<', 'json.data' );
  my $encoding = 'cp932';
  my $unicode_json_text = decode( $encoding, <$fh> ); # UNICODE
  
  # or you can write the below code.
  #
  # open( my $fh, "<:encoding($encoding)", 'json.data' );
  # $unicode_json_text = <$fh>;

In this case, C<$unicode_json_text> is of course UNICODE string.
So you B<cannot> use C<decode_json> nor C<JSON> module object with C<utf8> enable.
Instead of them, you use C<JSON> module object with C<utf8> disable.

  $perl_scalar = $json->utf8(0)->decode( $unicode_json_text );

Or C<encode 'utf8'> and C<decode_json>:

  $perl_scalar = decode_json( encode( 'utf8', $unicode_json_text ) );
  # this way is not efficient.

And now, you want to convert your C<$perl_scalar> into JSON data and
send it to an outer world - a network or a file content, and so on.

Your data usually contains UNICODE strings and you want the converted data to be encoded
in UTF-8, you should use C<encode_json> or C<JSON> module object with C<utf8> enable.

  print encode_json( $perl_scalar ); # to a network? file? or display?
  # or
  print $json->utf8->encode( $perl_scalar );

If C<$perl_scalar> does not contain UNICODE but C<$encoding>-encoded strings
for some reason, then its characters are regarded as B<latin1> for perl
(because it does not concern with your $encoding).
You B<cannot> use C<encode_json> nor C<JSON> module object with C<utf8> enable.
Instead of them, you use C<JSON> module object with C<utf8> disable.
Note that the resulted text is a UNICODE string but no problem to print it.

  # $perl_scalar contains $encoding encoded string values
  $unicode_json_text = $json->utf8(0)->encode( $perl_scalar );
  # $unicode_json_text consists of characters less than 0x100
  print $unicode_json_text;

Or C<decode $encoding> all string values and C<encode_json>:

  $perl_scalar->{ foo } = decode( $encoding, $perl_scalar->{ foo } );
  # ... do it to each string values, then encode_json
  $json_text = encode_json( $perl_scalar );

This method is a proper way but probably not efficient.

See to L<Encode>, L<perluniintro>.


=head1 METHODS

Basically, check to L<JSON> or L<JSON::XS>.

=head2 new

    $json = JSON::PP->new

Rturns a new JSON::PP object that can be used to de/encode JSON
strings.

All boolean flags described below are by default I<disabled>.

The mutators for flags all return the JSON object again and thus calls can
be chained:

   my $json = JSON::PP->new->utf8->space_after->encode({a => [1,2]})
   => {"a": [1, 2]}

=head2 ascii

    $json = $json->ascii([$enable])
    
    $enabled = $json->get_ascii

If $enable is true (or missing), then the encode method will not generate characters outside
the code range 0..127. Any Unicode characters outside that range will be escaped using either
a single \uXXXX or a double \uHHHH\uLLLLL escape sequence, as per RFC4627.
(See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>).

In Perl 5.005, there is no character having high value (more than 255).
See to L<UNICODE HANDLING ON PERLS>.

If $enable is false, then the encode method will not escape Unicode characters unless
required by the JSON syntax or other flags. This results in a faster and more compact format.

  JSON::PP->new->ascii(1)->encode([chr 0x10401])
  => ["\ud801\udc01"]

=head2 latin1

    $json = $json->latin1([$enable])
    
    $enabled = $json->get_latin1

If $enable is true (or missing), then the encode method will encode the resulting JSON
text as latin1 (or iso-8859-1), escaping any characters outside the code range 0..255.

If $enable is false, then the encode method will not escape Unicode characters
unless required by the JSON syntax or other flags.

  JSON::XS->new->latin1->encode (["\x{89}\x{abc}"]
  => ["\x{89}\\u0abc"]    # (perl syntax, U+abc escaped, U+89 not)

See to L<UNICODE HANDLING ON PERLS>.

=head2 utf8

    $json = $json->utf8([$enable])
    
    $enabled = $json->get_utf8

If $enable is true (or missing), then the encode method will encode the JSON result
into UTF-8, as required by many protocols, while the decode method expects to be handled
an UTF-8-encoded string. Please note that UTF-8-encoded strings do not contain any
characters outside the range 0..255, they are thus useful for bytewise/binary I/O.

(In Perl 5.005, any character outside the range 0..255 does not exist.
See to L<UNICODE HANDLING ON PERLS>.)

In future versions, enabling this option might enable autodetection of the UTF-16 and UTF-32
encoding families, as described in RFC4627.

If $enable is false, then the encode method will return the JSON string as a (non-encoded)
Unicode string, while decode expects thus a Unicode string. Any decoding or encoding
(e.g. to UTF-8 or UTF-16) needs to be done yourself, e.g. using the Encode module.

Example, output UTF-16BE-encoded JSON:

  use Encode;
  $jsontext = encode "UTF-16BE", JSON::PP->new->encode ($object);

Example, decode UTF-32LE-encoded JSON:

  use Encode;
  $object = JSON::PP->new->decode (decode "UTF-32LE", $jsontext);


=head2 pretty

    $json = $json->pretty([$enable])

This enables (or disables) all of the C<indent>, C<space_before> and
C<space_after> flags in one call to generate the most readable
(or most compact) form possible.

Equivalent to:

   $json->indent->space_before->space_after

=head2 indent

    $json = $json->indent([$enable])
    
    $enabled = $json->get_indent

The default indent space length is three.
You can use C<indent_length> to change the length.

=head2 space_before

    $json = $json->space_before([$enable])
    
    $enabled = $json->get_space_before

If C<$enable> is true (or missing), then the C<encode> method will add an extra
optional space before the C<:> separating keys from values in JSON objects.

If C<$enable> is false, then the C<encode> method will not add any extra
space at those places.

This setting has no effect when decoding JSON texts.

Example, space_before enabled, space_after and indent disabled:

   {"key" :"value"}

=head2 space_after

    $json = $json->space_after([$enable])
    
    $enabled = $json->get_space_after

If C<$enable> is true (or missing), then the C<encode> method will add an extra
optional space after the C<:> separating keys from values in JSON objects
and extra whitespace after the C<,> separating key-value pairs and array
members.

If C<$enable> is false, then the C<encode> method will not add any extra
space at those places.

This setting has no effect when decoding JSON texts.

Example, space_before and indent disabled, space_after enabled:

   {"key": "value"}

=head2 relaxed

    $json = $json->relaxed([$enable])
    
    $enabled = $json->get_relaxed

If C<$enable> is true (or missing), then C<decode> will accept some
extensions to normal JSON syntax (see below). C<encode> will not be
affected in anyway. I<Be aware that this option makes you accept invalid
JSON texts as if they were valid!>. I suggest only to use this option to
parse application-specific files written by humans (configuration files,
resource files etc.)

If C<$enable> is false (the default), then C<decode> will only accept
valid JSON texts.

Currently accepted extensions are:

=over 4

=item * list items can have an end-comma

JSON I<separates> array elements and key-value pairs with commas. This
can be annoying if you write JSON texts manually and want to be able to
quickly append elements, so this extension accepts comma at the end of
such items not just between them:

   [
      1,
      2, <- this comma not normally allowed
   ]
   {
      "k1": "v1",
      "k2": "v2", <- this comma not normally allowed
   }

=item * shell-style '#'-comments

Whenever JSON allows whitespace, shell-style comments are additionally
allowed. They are terminated by the first carriage-return or line-feed
character, after which more white-space and comments are allowed.

  [
     1, # this comment not allowed in JSON
        # neither this one...
  ]

=back

=head2 canonical

    $json = $json->canonical([$enable])
    
    $enabled = $json->get_canonical

If C<$enable> is true (or missing), then the C<encode> method will output JSON objects
by sorting their keys. This is adding a comparatively high overhead.

If C<$enable> is false, then the C<encode> method will output key-value
pairs in the order Perl stores them (which will likely change between runs
of the same script).

This option is useful if you want the same data structure to be encoded as
the same JSON text (given the same overall settings). If it is disabled,
the same hash might be encoded differently even if contains the same data,
as key-value pairs have no inherent ordering in Perl.

This setting has no effect when decoding JSON texts.

If you want your own sorting routine, you can give a code referece
or a subroutine name to C<sort_by>. See to C<JSON::PP OWN METHODS>.

=head2 allow_nonref

    $json = $json->allow_nonref([$enable])
    
    $enabled = $json->get_allow_nonref

If C<$enable> is true (or missing), then the C<encode> method can convert a
non-reference into its corresponding string, number or null JSON value,
which is an extension to RFC4627. Likewise, C<decode> will accept those JSON
values instead of croaking.

If C<$enable> is false, then the C<encode> method will croak if it isn't
passed an arrayref or hashref, as JSON texts must either be an object
or array. Likewise, C<decode> will croak if given something that is not a
JSON object or array.

   JSON::PP->new->allow_nonref->encode ("Hello, World!")
   => "Hello, World!"

=head2 allow_unknown

    $json = $json->allow_unknown ([$enable])
    
    $enabled = $json->get_allow_unknown

If $enable is true (or missing), then "encode" will *not* throw an
exception when it encounters values it cannot represent in JSON (for
example, filehandles) but instead will encode a JSON "null" value.
Note that blessed objects are not included here and are handled
separately by c<allow_nonref>.

If $enable is false (the default), then "encode" will throw an
exception when it encounters anything it cannot encode as JSON.

This option does not affect "decode" in any way, and it is
recommended to leave it off unless you know your communications
partner.

=head2 allow_blessed

    $json = $json->allow_blessed([$enable])
    
    $enabled = $json->get_allow_blessed

If C<$enable> is true (or missing), then the C<encode> method will not
barf when it encounters a blessed reference. Instead, the value of the
B<convert_blessed> option will decide whether C<null> (C<convert_blessed>
disabled or no C<TO_JSON> method found) or a representation of the
object (C<convert_blessed> enabled and C<TO_JSON> method found) is being
encoded. Has no effect on C<decode>.

If C<$enable> is false (the default), then C<encode> will throw an
exception when it encounters a blessed object.

=head2 convert_blessed

    $json = $json->convert_blessed([$enable])
    
    $enabled = $json->get_convert_blessed

If C<$enable> is true (or missing), then C<encode>, upon encountering a
blessed object, will check for the availability of the C<TO_JSON> method
on the object's class. If found, it will be called in scalar context
and the resulting scalar will be encoded instead of the object. If no
C<TO_JSON> method is found, the value of C<allow_blessed> will decide what
to do.

The C<TO_JSON> method may safely call die if it wants. If C<TO_JSON>
returns other blessed objects, those will be handled in the same
way. C<TO_JSON> must take care of not causing an endless recursion cycle
(== crash) in this case. The name of C<TO_JSON> was chosen because other
methods called by the Perl core (== not by the user of the object) are
usually in upper case letters and to avoid collisions with the C<to_json>
function or method.

This setting does not yet influence C<decode> in any way.

If C<$enable> is false, then the C<allow_blessed> setting will decide what
to do when a blessed object is found.

=head2 filter_json_object

    $json = $json->filter_json_object([$coderef])

When C<$coderef> is specified, it will be called from C<decode> each
time it decodes a JSON object. The only argument passed to the coderef
is a reference to the newly-created hash. If the code references returns
a single scalar (which need not be a reference), this value
(i.e. a copy of that scalar to avoid aliasing) is inserted into the
deserialised data structure. If it returns an empty list
(NOTE: I<not> C<undef>, which is a valid scalar), the original deserialised
hash will be inserted. This setting can slow down decoding considerably.

When C<$coderef> is omitted or undefined, any existing callback will
be removed and C<decode> will not change the deserialised hash in any
way.

Example, convert all JSON objects into the integer 5:

   my $js = JSON::PP->new->filter_json_object (sub { 5 });
   # returns [5]
   $js->decode ('[{}]'); # the given subroutine takes a hash reference.
   # throw an exception because allow_nonref is not enabled
   # so a lone 5 is not allowed.
   $js->decode ('{"a":1, "b":2}');

=head2 filter_json_single_key_object

    $json = $json->filter_json_single_key_object($key [=> $coderef])

Works remotely similar to C<filter_json_object>, but is only called for
JSON objects having a single key named C<$key>.

This C<$coderef> is called before the one specified via
C<filter_json_object>, if any. It gets passed the single value in the JSON
object. If it returns a single value, it will be inserted into the data
structure. If it returns nothing (not even C<undef> but the empty list),
the callback from C<filter_json_object> will be called next, as if no
single-key callback were specified.

If C<$coderef> is omitted or undefined, the corresponding callback will be
disabled. There can only ever be one callback for a given key.

As this callback gets called less often then the C<filter_json_object>
one, decoding speed will not usually suffer as much. Therefore, single-key
objects make excellent targets to serialise Perl objects into, especially
as single-key JSON objects are as close to the type-tagged value concept
as JSON gets (it's basically an ID/VALUE tuple). Of course, JSON does not
support this in any way, so you need to make sure your data never looks
like a serialised Perl hash.

Typical names for the single object key are C<__class_whatever__>, or
C<$__dollars_are_rarely_used__$> or C<}ugly_brace_placement>, or even
things like C<__class_md5sum(classname)__>, to reduce the risk of clashing
with real hashes.

Example, decode JSON objects of the form C<< { "__widget__" => <id> } >>
into the corresponding C<< $WIDGET{<id>} >> object:

   # return whatever is in $WIDGET{5}:
   JSON::PP
      ->new
      ->filter_json_single_key_object (__widget__ => sub {
            $WIDGET{ $_[0] }
         })
      ->decode ('{"__widget__": 5')

   # this can be used with a TO_JSON method in some "widget" class
   # for serialisation to json:
   sub WidgetBase::TO_JSON {
      my ($self) = @_;

      unless ($self->{id}) {
         $self->{id} = ..get..some..id..;
         $WIDGET{$self->{id}} = $self;
      }

      { __widget__ => $self->{id} }
   }

=head2 shrink

    $json = $json->shrink([$enable])
    
    $enabled = $json->get_shrink

In JSON::XS, this flag resizes strings generated by either
C<encode> or C<decode> to their minimum size possible.
It will also try to downgrade any strings to octet-form if possible.

In JSON::PP, it is noop about resizing strings but tries
C<utf8::downgrade> to the returned string by C<encode>.
See to L<utf8>.

See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>

=head2 max_depth

    $json = $json->max_depth([$maximum_nesting_depth])
    
    $max_depth = $json->get_max_depth

Sets the maximum nesting level (default C<512>) accepted while encoding
or decoding. If a higher nesting level is detected in JSON text or a Perl
data structure, then the encoder and decoder will stop and croak at that
point.

Nesting level is defined by number of hash- or arrayrefs that the encoder
needs to traverse to reach a given point or the number of C<{> or C<[>
characters without their matching closing parenthesis crossed to reach a
given character in a string.

If no argument is given, the highest possible setting will be used, which
is rarely useful.

See L<JSON::XS/SSECURITY CONSIDERATIONS> for more info on why this is useful.

When a large value (100 or more) was set and it de/encodes a deep nested object/text,
it may raise a warning 'Deep recursion on subroutin' at the perl runtime phase.

=head2 max_size

    $json = $json->max_size([$maximum_string_size])
    
    $max_size = $json->get_max_size

Set the maximum length a JSON text may have (in bytes) where decoding is
being attempted. The default is C<0>, meaning no limit. When C<decode>
is called on a string that is longer then this many bytes, it will not
attempt to decode the string but throw an exception. This setting has no
effect on C<encode> (yet).

If no argument is given, the limit check will be deactivated (same as when
C<0> is specified).

See L<JSON::XS/SSECURITY CONSIDERATIONS> for more info on why this is useful.

=head2 encode

    $json_text = $json->encode($perl_scalar)

Converts the given Perl data structure (a simple scalar or a reference
to a hash or array) to its JSON representation. Simple scalars will be
converted into JSON string or number sequences, while references to arrays
become JSON arrays and references to hashes become JSON objects. Undefined
Perl values (e.g. C<undef>) become JSON C<null> values.
References to the integers C<0> and C<1> are converted into C<true> and C<false>.

=head2 decode

    $perl_scalar = $json->decode($json_text)

The opposite of C<encode>: expects a JSON text and tries to parse it,
returning the resulting simple scalar or reference. Croaks on error.

JSON numbers and strings become simple Perl scalars. JSON arrays become
Perl arrayrefs and JSON objects become Perl hashrefs. C<true> becomes
C<1> (C<JSON::true>), C<false> becomes C<0> (C<JSON::false>) and
C<null> becomes C<undef>.

=head2 decode_prefix

    ($perl_scalar, $characters) = $json->decode_prefix($json_text)

This works like the C<decode> method, but instead of raising an exception
when there is trailing garbage after the first JSON object, it will
silently stop parsing there and return the number of characters consumed
so far.

   JSON->new->decode_prefix ("[1] the tail")
   => ([], 3)

=head1 INCREMENTAL PARSING

Most of this section are copied and modified from L<JSON::XS/INCREMENTAL PARSING>.

In some cases, there is the need for incremental parsing of JSON texts.
This module does allow you to parse a JSON stream incrementally.
It does so by accumulating text until it has a full JSON object, which
it then can decode. This process is similar to using C<decode_prefix>
to see if a full JSON object is available, but is much more efficient
(and can be implemented with a minimum of method calls).

This module will only attempt to parse the JSON text once it is sure it
has enough text to get a decisive result, using a very simple but
truly incremental parser. This means that it sometimes won't stop as
early as the full parser, for example, it doesn't detect parenthese
mismatches. The only thing it guarantees is that it starts decoding as
soon as a syntactically valid JSON text has been seen. This means you need
to set resource limits (e.g. C<max_size>) to ensure the parser will stop
parsing in the presence if syntax errors.

The following methods implement this incremental parser.

=head2 incr_parse

    $json->incr_parse( [$string] ) # void context
    
    $obj_or_undef = $json->incr_parse( [$string] ) # scalar context
    
    @obj_or_empty = $json->incr_parse( [$string] ) # list context

This is the central parsing function. It can both append new text and
extract objects from the stream accumulated so far (both of these
functions are optional).

If C<$string> is given, then this string is appended to the already
existing JSON fragment stored in the C<$json> object.

After that, if the function is called in void context, it will simply
return without doing anything further. This can be used to add more text
in as many chunks as you want.

If the method is called in scalar context, then it will try to extract
exactly I<one> JSON object. If that is successful, it will return this
object, otherwise it will return C<undef>. If there is a parse error,
this method will croak just as C<decode> would do (one can then use
C<incr_skip> to skip the errornous part). This is the most common way of
using the method.

And finally, in list context, it will try to extract as many objects
from the stream as it can find and return them, or the empty list
otherwise. For this to work, there must be no separators between the JSON
objects or arrays, instead they must be concatenated back-to-back. If
an error occurs, an exception will be raised as in the scalar context
case. Note that in this case, any previously-parsed JSON texts will be
lost.

Example: Parse some JSON arrays/objects in a given string and return them.

    my @objs = JSON->new->incr_parse ("[5][7][1,2]");

=head2 incr_text

    $lvalue_string = $json->incr_text

This method returns the currently stored JSON fragment as an lvalue, that
is, you can manipulate it. This I<only> works when a preceding call to
C<incr_parse> in I<scalar context> successfully returned an object. Under
all other circumstances you must not call this function (I mean it.
although in simple tests it might actually work, it I<will> fail under
real world conditions). As a special exception, you can also call this
method before having parsed anything.

This function is useful in two cases: a) finding the trailing text after a
JSON object or b) parsing multiple JSON objects separated by non-JSON text
(such as commas).

    $json->incr_text =~ s/\s*,\s*//;

In Perl 5.005, C<lvalue> attribute is not available.
You must write codes like the below:

    $string = $json->incr_text;
    $string =~ s/\s*,\s*//;
    $json->incr_text( $string );

=head2 incr_skip

    $json->incr_skip

This will reset the state of the incremental parser and will remove the
parsed text from the input buffer. This is useful after C<incr_parse>
died, in which case the input buffer and incremental parser state is left
unchanged, to skip the text parsed so far and to reset the parse state.

=head2 incr_reset

    $json->incr_reset

This completely resets the incremental parser, that is, after this call,
it will be as if the parser had never parsed anything.

This is useful if you want ot repeatedly parse JSON objects and want to
ignore any trailing data, which means you have to reset the parser after
each successful decode.

See to L<JSON::XS/INCREMENTAL PARSING> for examples.


=head1 JSON::PP OWN METHODS

=head2 allow_singlequote

    $json = $json->allow_singlequote([$enable])

If C<$enable> is true (or missing), then C<decode> will accept
JSON strings quoted by single quotations that are invalid JSON
format.

    $json->allow_singlequote->decode({"foo":'bar'});
    $json->allow_singlequote->decode({'foo':"bar"});
    $json->allow_singlequote->decode({'foo':'bar'});

As same as the C<relaxed> option, this option may be used to parse
application-specific files written by humans.


=head2 allow_barekey

    $json = $json->allow_barekey([$enable])

If C<$enable> is true (or missing), then C<decode> will accept
bare keys of JSON object that are invalid JSON format.

As same as the C<relaxed> option, this option may be used to parse
application-specific files written by humans.

    $json->allow_barekey->decode('{foo:"bar"}');

=head2 allow_bignum

    $json = $json->allow_bignum([$enable])

If C<$enable> is true (or missing), then C<decode> will convert
the big integer Perl cannot handle as integer into a L<Math::BigInt>
object and convert a floating number (any) into a L<Math::BigFloat>.

On the contary, C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
objects into JSON numbers with C<allow_blessed> enable.

   $json->allow_nonref->allow_blessed->allow_bignum;
   $bigfloat = $json->decode('2.000000000000000000000000001');
   print $json->encode($bigfloat);
   # => 2.000000000000000000000000001

See to L<JSON::XS/MAPPING> aboout the normal conversion of JSON number.

=head2 loose

    $json = $json->loose([$enable])

The unescaped [\x00-\x1f\x22\x2f\x5c] strings are invalid in JSON strings
and the module doesn't allow to C<decode> to these (except for \x2f).
If C<$enable> is true (or missing), then C<decode>  will accept these
unescaped strings.

    $json->loose->decode(qq|["abc
                                   def"]|);

See L<JSON::XS/SSECURITY CONSIDERATIONS>.

=head2 escape_slash

    $json = $json->escape_slash([$enable])

According to JSON Grammar, I<slash> (U+002F) is escaped. But default
JSON::PP (as same as JSON::XS) encodes strings without escaping slash.

If C<$enable> is true (or missing), then C<encode> will escape slashes.

=head2 indent_length

    $json = $json->indent_length($length)

JSON::XS indent space length is 3 and cannot be changed.
JSON::PP set the indent space length with the given $length.
The default is 3. The acceptable range is 0 to 15.

=head2 sort_by

    $json = $json->sort_by($function_name)
    $json = $json->sort_by($subroutine_ref)

If $function_name or $subroutine_ref are set, its sort routine are used
in encoding JSON objects.

   $js = $pc->sort_by(sub { $JSON::PP::a cmp $JSON::PP::b })->encode($obj);
   # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);

   $js = $pc->sort_by('own_sort')->encode($obj);
   # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);

   sub JSON::PP::own_sort { $JSON::PP::a cmp $JSON::PP::b }

As the sorting routine runs in the JSON::PP scope, the given
subroutine name and the special variables C<$a>, C<$b> will begin
'JSON::PP::'.

If $integer is set, then the effect is same as C<canonical> on.

=head1 INTERNAL

For developers.

=over

=item PP_encode_box

Returns

        {
            depth        => $depth,
            indent_count => $indent_count,
        }


=item PP_decode_box

Returns

        {
            text    => $text,
            at      => $at,
            ch      => $ch,
            len     => $len,
            depth   => $depth,
            encoding      => $encoding,
            is_valid_utf8 => $is_valid_utf8,
        };

=back

=head1 MAPPING

This section is copied from JSON::XS and modified to C<JSON::PP>.
JSON::XS and JSON::PP mapping mechanisms are almost equivalent.

See to L<JSON::XS/MAPPING>.

=head2 JSON -> PERL

=over 4

=item object

A JSON object becomes a reference to a hash in Perl. No ordering of object
keys is preserved (JSON does not preserver object key ordering itself).

=item array

A JSON array becomes a reference to an array in Perl.

=item string

A JSON string becomes a string scalar in Perl - Unicode codepoints in JSON
are represented by the same codepoints in the Perl string, so no manual
decoding is necessary.

=item number

A JSON number becomes either an integer, numeric (floating point) or
string scalar in perl, depending on its range and any fractional parts. On
the Perl level, there is no difference between those as Perl handles all
the conversion details, but an integer may take slightly less memory and
might represent more values exactly than floating point numbers.

If the number consists of digits only, C<JSON> will try to represent
it as an integer value. If that fails, it will try to represent it as
a numeric (floating point) value if that is possible without loss of
precision. Otherwise it will preserve the number as a string value (in
which case you lose roundtripping ability, as the JSON number will be
re-encoded toa JSON string).

Numbers containing a fractional or exponential part will always be
represented as numeric (floating point) values, possibly at a loss of
precision (in which case you might lose perfect roundtripping ability, but
the JSON number will still be re-encoded as a JSON number).

Note that precision is not accuracy - binary floating point values cannot
represent most decimal fractions exactly, and when converting from and to
floating point, C<JSON> only guarantees precision up to but not including
the leats significant bit.

When C<allow_bignum> is enable, the big integers 
and the numeric can be optionally converted into L<Math::BigInt> and
L<Math::BigFloat> objects.

=item true, false

These JSON atoms become C<JSON::PP::true> and C<JSON::PP::false>,
respectively. They are overloaded to act almost exactly like the numbers
C<1> and C<0>. You can check wether a scalar is a JSON boolean by using
the C<JSON::is_bool> function.

   print JSON::PP::true . "\n";
    => true
   print JSON::PP::true + 1;
    => 1

   ok(JSON::true eq  '1');
   ok(JSON::true == 1);

C<JSON> will install these missing overloading features to the backend modules.


=item null

A JSON null atom becomes C<undef> in Perl.

C<JSON::PP::null> returns C<unddef>.

=back


=head2 PERL -> JSON

The mapping from Perl to JSON is slightly more difficult, as Perl is a
truly typeless language, so we can only guess which JSON type is meant by
a Perl value.

=over 4

=item hash references

Perl hash references become JSON objects. As there is no inherent ordering
in hash keys (or JSON objects), they will usually be encoded in a
pseudo-random order that can change between runs of the same program but
stays generally the same within a single run of a program. C<JSON>
optionally sort the hash keys (determined by the I<canonical> flag), so
the same datastructure will serialise to the same JSON text (given same
settings and version of JSON::XS), but this incurs a runtime overhead
and is only rarely useful, e.g. when you want to compare some JSON text
against another for equality.


=item array references

Perl array references become JSON arrays.

=item other references

Other unblessed references are generally not allowed and will cause an
exception to be thrown, except for references to the integers C<0> and
C<1>, which get turned into C<false> and C<true> atoms in JSON. You can
also use C<JSON::false> and C<JSON::true> to improve readability.

   to_json [\0,JSON::PP::true]      # yields [false,true]

=item JSON::PP::true, JSON::PP::false, JSON::PP::null

These special values become JSON true and JSON false values,
respectively. You can also use C<\1> and C<\0> directly if you want.

JSON::PP::null returns C<undef>.

=item blessed objects

Blessed objects are not directly representable in JSON. See the
C<allow_blessed> and C<convert_blessed> methods on various options on
how to deal with this: basically, you can choose between throwing an
exception, encoding the reference as if it weren't blessed, or provide
your own serialiser method.

See to L<convert_blessed>.

=item simple scalars

Simple Perl scalars (any scalar that is not a reference) are the most
difficult objects to encode: JSON::XS and JSON::PP will encode undefined scalars as
JSON C<null> values, scalars that have last been used in a string context
before encoding as JSON strings, and anything else as number value:

   # dump as number
   encode_json [2]                      # yields [2]
   encode_json [-3.0e17]                # yields [-3e+17]
   my $value = 5; encode_json [$value]  # yields [5]

   # used as string, so dump as string
   print $value;
   encode_json [$value]                 # yields ["5"]

   # undef becomes null
   encode_json [undef]                  # yields [null]

You can force the type to be a string by stringifying it:

   my $x = 3.1; # some variable containing a number
   "$x";        # stringified
   $x .= "";    # another, more awkward way to stringify
   print $x;    # perl does it for you, too, quite often

You can force the type to be a number by numifying it:

   my $x = "3"; # some variable containing a string
   $x += 0;     # numify it, ensuring it will be dumped as a number
   $x *= 1;     # same thing, the choise is yours.

You can not currently force the type in other, less obscure, ways.

Note that numerical precision has the same meaning as under Perl (so
binary to decimal conversion follows the same rules as in Perl, which
can differ to other languages). Also, your perl interpreter might expose
extensions to the floating point numbers of your platform, such as
infinities or NaN's - these cannot be represented in JSON, and it is an
error to pass those in.

=item Big Number

When C<allow_bignum> is enable, 
C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
objects into JSON numbers.


=back

=head1 UNICODE HANDLING ON PERLS

If you do not know about Unicode on Perl well,
please check L<JSON::XS/A FEW NOTES ON UNICODE AND PERL>.

=head2 Perl 5.8 and later

Perl can handle Unicode and the JSON::PP de/encode methods also work properly.

    $json->allow_nonref->encode(chr hex 3042);
    $json->allow_nonref->encode(chr hex 12345);

Reuturns C<"\u3042"> and C<"\ud808\udf45"> respectively.

    $json->allow_nonref->decode('"\u3042"');
    $json->allow_nonref->decode('"\ud808\udf45"');

Returns UTF-8 encoded strings with UTF8 flag, regarded as C<U+3042> and C<U+12345>.

Note that the versions from Perl 5.8.0 to 5.8.2, Perl built-in C<join> was broken,
so JSON::PP wraps the C<join> with a subroutine. Thus JSON::PP works slow in the versions.


=head2 Perl 5.6

Perl can handle Unicode and the JSON::PP de/encode methods also work.

=head2 Perl 5.005

Perl 5.005 is a byte sementics world -- all strings are sequences of bytes.
That means the unicode handling is not available.

In encoding,

    $json->allow_nonref->encode(chr hex 3042);  # hex 3042 is 12354.
    $json->allow_nonref->encode(chr hex 12345); # hex 12345 is 74565.

Returns C<B> and C<E>, as C<chr> takes a value more than 255, it treats
as C<$value % 256>, so the above codes are equivalent to :

    $json->allow_nonref->encode(chr 66);
    $json->allow_nonref->encode(chr 69);

In decoding,

    $json->decode('"\u00e3\u0081\u0082"');

The returned is a byte sequence C<0xE3 0x81 0x82> for UTF-8 encoded
japanese character (C<HIRAGANA LETTER A>).
And if it is represented in Unicode code point, C<U+3042>.

Next, 

    $json->decode('"\u3042"');

We ordinary expect the returned value is a Unicode character C<U+3042>.
But here is 5.005 world. This is C<0xE3 0x81 0x82>.

    $json->decode('"\ud808\udf45"');

This is not a character C<U+12345> but bytes - C<0xf0 0x92 0x8d 0x85>.


=head1 TODO

=over

=item speed

=item memory saving

=back


=head1 SEE ALSO

Most of the document are copied and modified from JSON::XS doc.

L<JSON::XS>

RFC4627 (L<http://www.ietf.org/rfc/rfc4627.txt>)

=head1 AUTHOR

Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>


=head1 COPYRIGHT AND LICENSE

Copyright 2007-2013 by Makamaka Hannyaharamitu

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

=cut
PK       ! �����  �    perl5/Test2.pmnu ��6�$        package Test2;
use strict;
use warnings;

our $VERSION = '1.302183';


1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2 - Framework for writing test tools that all work together.

=head1 DESCRIPTION

Test2 is a new testing framework produced by forking L<Test::Builder>,
completely refactoring it, adding many new features and capabilities.

=head2 WHAT IS NEW?

=over 4

=item Easier to test new testing tools.

From the beginning Test2 was built with introspection capabilities. With
Test::Builder it was difficult at best to capture test tool output for
verification. Test2 Makes it easy with C<Test2::API::intercept()>.

=item Better diagnostics capabilities.

Test2 uses an L<Test2::API::Context> object to track filename, line number, and
tool details. This object greatly simplifies tracking for where errors should
be reported.

=item Event driven.

Test2 based tools produce events which get passed through a processing system
before being output by a formatter. This event system allows for rich plugin
and extension support.

=item More complete API.

Test::Builder only provided a handful of methods for generating lines of TAP.
Test2 took inventory of everything people were doing with Test::Builder that
required hacking it up. Test2 made public API functions for nearly all the
desired functionality people didn't previously have.

=item Support for output other than TAP.

Test::Builder assumed everything would end up as TAP. Test2 makes no such
assumption. Test2 provides ways for you to specify alternative and custom
formatters.

=item Subtest implementation is more sane.

The Test::Builder implementation of subtests was certifiably insane. Test2 uses
a stacked event hub system that greatly improves how subtests are implemented.

=item Support for threading/forking.

Test2 support for forking and threading can be turned on using L<Test2::IPC>.
Once turned on threading and forking operate sanely and work as one would
expect.

=back

=head1 GETTING STARTED

If you are interested in writing tests using new tools then you should look at
L<Test2::Suite>. L<Test2::Suite> is a separate cpan distribution that contains
many tools implemented on Test2.

If you are interested in writing new tools you should take a look at
L<Test2::API> first.

=head1 NAMESPACE LAYOUT

This describes the namespace layout for the Test2 ecosystem. Not all the
namespaces listed here are part of the Test2 distribution, some are implemented
in L<Test2::Suite>.

=head2 Test2::Tools::

This namespace is for sets of tools. Modules in this namespace should export
tools like C<ok()> and C<is()>. Most things written for Test2 should go here.
Modules in this namespace B<MUST NOT> export subs from other tools. See the
L</Test2::Bundle::> namespace if you want to do that.

=head2 Test2::Plugin::

This namespace is for plugins. Plugins are modules that change or enhance the
behavior of Test2. An example of a plugin is a module that sets the encoding to
utf8 globally. Another example is a module that causes a bail-out event after
the first test failure.

=head2 Test2::Bundle::

This namespace is for bundles of tools and plugins. Loading one of these may
load multiple tools and plugins. Modules in this namespace should not implement
tools directly. In general modules in this namespace should load tools and
plugins, then re-export things into the consumers namespace.

=head2 Test2::Require::

This namespace is for modules that cause a test to be skipped when conditions
do not allow it to run. Examples would be modules that skip the test on older
perls, or when non-essential modules have not been installed.

=head2 Test2::Formatter::

Formatters live under this namespace. L<Test2::Formatter::TAP> is the only
formatter currently. It is acceptable for third party distributions to create
new formatters under this namespace.

=head2 Test2::Event::

Events live under this namespace. It is considered acceptable for third party
distributions to add new event types in this namespace.

=head2 Test2::Hub::

Hub subclasses (and some hub utility objects) live under this namespace. It is
perfectly reasonable for third party distributions to add new hub subclasses in
this namespace.

=head2 Test2::IPC::

The IPC subsystem lives in this namespace. There are not many good reasons to
add anything to this namespace, with exception of IPC drivers.

=head3 Test2::IPC::Driver::

IPC drivers live in this namespace. It is fine to create new IPC drivers and to
put them in this namespace.

=head2 Test2::Util::

This namespace is for general utilities used by testing tools. Please be
considerate when adding new modules to this namespace.

=head2 Test2::API::

This is for Test2 API and related packages.

=head2 Test2::

The Test2:: namespace is intended for extensions and frameworks. Tools,
Plugins, etc should not go directly into this namespace. However extensions
that are used to build tools and plugins may go here.

In short: If the module exports anything that should be run directly by a test
script it should probably NOT go directly into C<Test2::XXX>.

=head1 SEE ALSO

L<Test2::API> - Primary API functions.

L<Test2::API::Context> - Detailed documentation of the context object.

L<Test2::IPC> - The IPC system used for threading/fork support.

L<Test2::Formatter> - Formatters such as TAP live here.

L<Test2::Event> - Events live in this namespace.

L<Test2::Hub> - All events eventually funnel through a hub. Custom hubs are how
C<intercept()> and C<run_subtest()> are implemented.

=head1 CONTACTING US

Many Test2 developers and users lurk on L<irc://irc.perl.org/#perl-qa> and
L<irc://irc.perl.org/#toolchain>. We also have a slack team that can be joined
by anyone with an C<@cpan.org> email address L<https://perl-test2.slack.com/>
If you do not have an C<@cpan.org> email you can ask for a slack invite by
emailing Chad Granum E<lt>exodist@cpan.orgE<gt>.

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! ԋ͘�G �G   perl5/Getopt/Long.pmnu ��6�$        #! perl

# Getopt::Long.pm -- Universal options parsing
# Author          : Johan Vromans
# Created On      : Tue Sep 11 15:00:12 1990
# Last Modified By: Johan Vromans
# Last Modified On: Tue Aug 18 14:48:05 2020
# Update Count    : 1739
# Status          : Released

################ Module Preamble ################

use 5.004;

use strict;
use warnings;

package Getopt::Long;

use vars qw($VERSION);
$VERSION        =  2.52;
# For testing versions only.
use vars qw($VERSION_STRING);
$VERSION_STRING = "2.52";

use Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK);
@ISA = qw(Exporter);

# Exported subroutines.
sub GetOptions(@);		# always
sub GetOptionsFromArray(@);	# on demand
sub GetOptionsFromString(@);	# on demand
sub Configure(@);		# on demand
sub HelpMessage(@);		# on demand
sub VersionMessage(@);		# in demand

BEGIN {
    # Init immediately so their contents can be used in the 'use vars' below.
    @EXPORT    = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
    @EXPORT_OK = qw(&HelpMessage &VersionMessage &Configure
		    &GetOptionsFromArray &GetOptionsFromString);
}

# User visible variables.
use vars @EXPORT, @EXPORT_OK;
use vars qw($error $debug $major_version $minor_version);
# Deprecated visible variables.
use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
	    $passthrough);
# Official invisible variables.
use vars qw($genprefix $caller $gnu_compat $auto_help $auto_version $longprefix);

# Really invisible variables.
my $bundling_values;

# Public subroutines.
sub config(@);			# deprecated name

# Private subroutines.
sub ConfigDefaults();
sub ParseOptionSpec($$);
sub OptCtl($);
sub FindOption($$$$$);
sub ValidValue ($$$$$);

################ Local Variables ################

# $requested_version holds the version that was mentioned in the 'use'
# or 'require', if any. It can be used to enable or disable specific
# features.
my $requested_version = 0;

################ Resident subroutines ################

sub ConfigDefaults() {
    # Handle POSIX compliancy.
    if ( defined $ENV{"POSIXLY_CORRECT"} ) {
	$genprefix = "(--|-)";
	$autoabbrev = 0;		# no automatic abbrev of options
	$bundling = 0;			# no bundling of single letter switches
	$getopt_compat = 0;		# disallow '+' to start options
	$order = $REQUIRE_ORDER;
    }
    else {
	$genprefix = "(--|-|\\+)";
	$autoabbrev = 1;		# automatic abbrev of options
	$bundling = 0;			# bundling off by default
	$getopt_compat = 1;		# allow '+' to start options
	$order = $PERMUTE;
    }
    # Other configurable settings.
    $debug = 0;			# for debugging
    $error = 0;			# error tally
    $ignorecase = 1;		# ignore case when matching options
    $passthrough = 0;		# leave unrecognized options alone
    $gnu_compat = 0;		# require --opt=val if value is optional
    $longprefix = "(--)";       # what does a long prefix look like
    $bundling_values = 0;	# no bundling of values
}

# Override import.
sub import {
    my $pkg = shift;		# package
    my @syms = ();		# symbols to import
    my @config = ();		# configuration
    my $dest = \@syms;		# symbols first
    for ( @_ ) {
	if ( $_ eq ':config' ) {
	    $dest = \@config;	# config next
	    next;
	}
	push(@$dest, $_);	# push
    }
    # Hide one level and call super.
    local $Exporter::ExportLevel = 1;
    push(@syms, qw(&GetOptions)) if @syms; # always export GetOptions
    $requested_version = 0;
    $pkg->SUPER::import(@syms);
    # And configure.
    Configure(@config) if @config;
}

################ Initialization ################

# Values for $order. See GNU getopt.c for details.
($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2);
# Version major/minor numbers.
($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/;

ConfigDefaults();

################ OO Interface ################

package Getopt::Long::Parser;

# Store a copy of the default configuration. Since ConfigDefaults has
# just been called, what we get from Configure is the default.
my $default_config = do {
    Getopt::Long::Configure ()
};

sub new {
    my $that = shift;
    my $class = ref($that) || $that;
    my %atts = @_;

    # Register the callers package.
    my $self = { caller_pkg => (caller)[0] };

    bless ($self, $class);

    # Process config attributes.
    if ( defined $atts{config} ) {
	my $save = Getopt::Long::Configure ($default_config, @{$atts{config}});
	$self->{settings} = Getopt::Long::Configure ($save);
	delete ($atts{config});
    }
    # Else use default config.
    else {
	$self->{settings} = $default_config;
    }

    if ( %atts ) {		# Oops
	die(__PACKAGE__.": unhandled attributes: ".
	    join(" ", sort(keys(%atts)))."\n");
    }

    $self;
}

sub configure {
    my ($self) = shift;

    # Restore settings, merge new settings in.
    my $save = Getopt::Long::Configure ($self->{settings}, @_);

    # Restore orig config and save the new config.
    $self->{settings} = Getopt::Long::Configure ($save);
}

sub getoptions {
    my ($self) = shift;

    return $self->getoptionsfromarray(\@ARGV, @_);
}

sub getoptionsfromarray {
    my ($self) = shift;

    # Restore config settings.
    my $save = Getopt::Long::Configure ($self->{settings});

    # Call main routine.
    my $ret = 0;
    $Getopt::Long::caller = $self->{caller_pkg};

    eval {
	# Locally set exception handler to default, otherwise it will
	# be called implicitly here, and again explicitly when we try
	# to deliver the messages.
	local ($SIG{__DIE__}) = 'DEFAULT';
	$ret = Getopt::Long::GetOptionsFromArray (@_);
    };

    # Restore saved settings.
    Getopt::Long::Configure ($save);

    # Handle errors and return value.
    die ($@) if $@;
    return $ret;
}

package Getopt::Long;

################ Back to Normal ################

# Indices in option control info.
# Note that ParseOptions uses the fields directly. Search for 'hard-wired'.
use constant CTL_TYPE    => 0;
#use constant   CTL_TYPE_FLAG   => '';
#use constant   CTL_TYPE_NEG    => '!';
#use constant   CTL_TYPE_INCR   => '+';
#use constant   CTL_TYPE_INT    => 'i';
#use constant   CTL_TYPE_INTINC => 'I';
#use constant   CTL_TYPE_XINT   => 'o';
#use constant   CTL_TYPE_FLOAT  => 'f';
#use constant   CTL_TYPE_STRING => 's';

use constant CTL_CNAME   => 1;

use constant CTL_DEFAULT => 2;

use constant CTL_DEST    => 3;
 use constant   CTL_DEST_SCALAR => 0;
 use constant   CTL_DEST_ARRAY  => 1;
 use constant   CTL_DEST_HASH   => 2;
 use constant   CTL_DEST_CODE   => 3;

use constant CTL_AMIN    => 4;
use constant CTL_AMAX    => 5;

# FFU.
#use constant CTL_RANGE   => ;
#use constant CTL_REPEAT  => ;

# Rather liberal patterns to match numbers.
use constant PAT_INT   => "[-+]?_*[0-9][0-9_]*";
use constant PAT_XINT  =>
  "(?:".
	  "[-+]?_*[1-9][0-9_]*".
  "|".
	  "0x_*[0-9a-f][0-9a-f_]*".
  "|".
	  "0b_*[01][01_]*".
  "|".
	  "0[0-7_]*".
  ")";
use constant PAT_FLOAT =>
  "[-+]?".			# optional sign
  "(?=[0-9.])".			# must start with digit or dec.point
  "[0-9_]*".			# digits before the dec.point
  "(\.[0-9_]+)?".		# optional fraction
  "([eE][-+]?[0-9_]+)?";	# optional exponent

sub GetOptions(@) {
    # Shift in default array.
    unshift(@_, \@ARGV);
    # Try to keep caller() and Carp consistent.
    goto &GetOptionsFromArray;
}

sub GetOptionsFromString(@) {
    my ($string) = shift;
    require Text::ParseWords;
    my $args = [ Text::ParseWords::shellwords($string) ];
    $caller ||= (caller)[0];	# current context
    my $ret = GetOptionsFromArray($args, @_);
    return ( $ret, $args ) if wantarray;
    if ( @$args ) {
	$ret = 0;
	warn("GetOptionsFromString: Excess data \"@$args\" in string \"$string\"\n");
    }
    $ret;
}

sub GetOptionsFromArray(@) {

    my ($argv, @optionlist) = @_;	# local copy of the option descriptions
    my $argend = '--';		# option list terminator
    my %opctl = ();		# table of option specs
    my $pkg = $caller || (caller)[0];	# current context
				# Needed if linkage is omitted.
    my @ret = ();		# accum for non-options
    my %linkage;		# linkage
    my $userlinkage;		# user supplied HASH
    my $opt;			# current option
    my $prefix = $genprefix;	# current prefix

    $error = '';

    if ( $debug ) {
	# Avoid some warnings if debugging.
	local ($^W) = 0;
	print STDERR
	  ("Getopt::Long $Getopt::Long::VERSION_STRING ",
	   "called from package \"$pkg\".",
	   "\n  ",
	   "argv: ",
	   defined($argv)
	   ? UNIVERSAL::isa( $argv, 'ARRAY' ) ? "(@$argv)" : $argv
	   : "<undef>",
	   "\n  ",
	   "autoabbrev=$autoabbrev,".
	   "bundling=$bundling,",
	   "bundling_values=$bundling_values,",
	   "getopt_compat=$getopt_compat,",
	   "gnu_compat=$gnu_compat,",
	   "order=$order,",
	   "\n  ",
	   "ignorecase=$ignorecase,",
	   "requested_version=$requested_version,",
	   "passthrough=$passthrough,",
	   "genprefix=\"$genprefix\",",
	   "longprefix=\"$longprefix\".",
	   "\n");
    }

    # Check for ref HASH as first argument.
    # First argument may be an object. It's OK to use this as long
    # as it is really a hash underneath.
    $userlinkage = undef;
    if ( @optionlist && ref($optionlist[0]) and
	 UNIVERSAL::isa($optionlist[0],'HASH') ) {
	$userlinkage = shift (@optionlist);
	print STDERR ("=> user linkage: $userlinkage\n") if $debug;
    }

    # See if the first element of the optionlist contains option
    # starter characters.
    # Be careful not to interpret '<>' as option starters.
    if ( @optionlist && $optionlist[0] =~ /^\W+$/
	 && !($optionlist[0] eq '<>'
	      && @optionlist > 0
	      && ref($optionlist[1])) ) {
	$prefix = shift (@optionlist);
	# Turn into regexp. Needs to be parenthesized!
	$prefix =~ s/(\W)/\\$1/g;
	$prefix = "([" . $prefix . "])";
	print STDERR ("=> prefix=\"$prefix\"\n") if $debug;
    }

    # Verify correctness of optionlist.
    %opctl = ();
    while ( @optionlist ) {
	my $opt = shift (@optionlist);

	unless ( defined($opt) ) {
	    $error .= "Undefined argument in option spec\n";
	    next;
	}

	# Strip leading prefix so people can specify "--foo=i" if they like.
	$opt = $+ if $opt =~ /^$prefix+(.*)$/s;

	if ( $opt eq '<>' ) {
	    if ( (defined $userlinkage)
		&& !(@optionlist > 0 && ref($optionlist[0]))
		&& (exists $userlinkage->{$opt})
		&& ref($userlinkage->{$opt}) ) {
		unshift (@optionlist, $userlinkage->{$opt});
	    }
	    unless ( @optionlist > 0
		    && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) {
		$error .= "Option spec <> requires a reference to a subroutine\n";
		# Kill the linkage (to avoid another error).
		shift (@optionlist)
		  if @optionlist && ref($optionlist[0]);
		next;
	    }
	    $linkage{'<>'} = shift (@optionlist);
	    next;
	}

	# Parse option spec.
	my ($name, $orig) = ParseOptionSpec ($opt, \%opctl);
	unless ( defined $name ) {
	    # Failed. $orig contains the error message. Sorry for the abuse.
	    $error .= $orig;
	    # Kill the linkage (to avoid another error).
	    shift (@optionlist)
	      if @optionlist && ref($optionlist[0]);
	    next;
	}

	# If no linkage is supplied in the @optionlist, copy it from
	# the userlinkage if available.
	if ( defined $userlinkage ) {
	    unless ( @optionlist > 0 && ref($optionlist[0]) ) {
		if ( exists $userlinkage->{$orig} &&
		     ref($userlinkage->{$orig}) ) {
		    print STDERR ("=> found userlinkage for \"$orig\": ",
				  "$userlinkage->{$orig}\n")
			if $debug;
		    unshift (@optionlist, $userlinkage->{$orig});
		}
		else {
		    # Do nothing. Being undefined will be handled later.
		    next;
		}
	    }
	}

	# Copy the linkage. If omitted, link to global variable.
	if ( @optionlist > 0 && ref($optionlist[0]) ) {
	    print STDERR ("=> link \"$orig\" to $optionlist[0]\n")
		if $debug;
	    my $rl = ref($linkage{$orig} = shift (@optionlist));

	    if ( $rl eq "ARRAY" ) {
		$opctl{$name}[CTL_DEST] = CTL_DEST_ARRAY;
	    }
	    elsif ( $rl eq "HASH" ) {
		$opctl{$name}[CTL_DEST] = CTL_DEST_HASH;
	    }
	    elsif ( $rl eq "SCALAR" || $rl eq "REF" ) {
#		if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) {
#		    my $t = $linkage{$orig};
#		    $$t = $linkage{$orig} = [];
#		}
#		elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) {
#		}
#		else {
		    # Ok.
#		}
	    }
	    elsif ( $rl eq "CODE" ) {
		# Ok.
	    }
	    else {
		$error .= "Invalid option linkage for \"$opt\"\n";
	    }
	}
	else {
	    # Link to global $opt_XXX variable.
	    # Make sure a valid perl identifier results.
	    my $ov = $orig;
	    $ov =~ s/\W/_/g;
	    if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) {
		print STDERR ("=> link \"$orig\" to \@$pkg","::opt_$ov\n")
		    if $debug;
		eval ("\$linkage{\$orig} = \\\@".$pkg."::opt_$ov;");
	    }
	    elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) {
		print STDERR ("=> link \"$orig\" to \%$pkg","::opt_$ov\n")
		    if $debug;
		eval ("\$linkage{\$orig} = \\\%".$pkg."::opt_$ov;");
	    }
	    else {
		print STDERR ("=> link \"$orig\" to \$$pkg","::opt_$ov\n")
		    if $debug;
		eval ("\$linkage{\$orig} = \\\$".$pkg."::opt_$ov;");
	    }
	}

	if ( $opctl{$name}[CTL_TYPE] eq 'I'
	     && ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY
		  || $opctl{$name}[CTL_DEST] == CTL_DEST_HASH )
	   ) {
	    $error .= "Invalid option linkage for \"$opt\"\n";
	}

    }

    $error .= "GetOptionsFromArray: 1st parameter is not an array reference\n"
      unless $argv && UNIVERSAL::isa( $argv, 'ARRAY' );

    # Bail out if errors found.
    die ($error) if $error;
    $error = 0;

    # Supply --version and --help support, if needed and allowed.
    if ( defined($auto_version) ? $auto_version : ($requested_version >= 2.3203) ) {
	if ( !defined($opctl{version}) ) {
	    $opctl{version} = ['','version',0,CTL_DEST_CODE,undef];
	    $linkage{version} = \&VersionMessage;
	}
	$auto_version = 1;
    }
    if ( defined($auto_help) ? $auto_help : ($requested_version >= 2.3203) ) {
	if ( !defined($opctl{help}) && !defined($opctl{'?'}) ) {
	    $opctl{help} = $opctl{'?'} = ['','help',0,CTL_DEST_CODE,undef];
	    $linkage{help} = \&HelpMessage;
	}
	$auto_help = 1;
    }

    # Show the options tables if debugging.
    if ( $debug ) {
	my ($arrow, $k, $v);
	$arrow = "=> ";
	while ( ($k,$v) = each(%opctl) ) {
	    print STDERR ($arrow, "\$opctl{$k} = $v ", OptCtl($v), "\n");
	    $arrow = "   ";
	}
    }

    # Process argument list
    my $goon = 1;
    while ( $goon && @$argv > 0 ) {

	# Get next argument.
	$opt = shift (@$argv);
	print STDERR ("=> arg \"", $opt, "\"\n") if $debug;

	# Double dash is option list terminator.
	if ( defined($opt) && $opt eq $argend ) {
	  push (@ret, $argend) if $passthrough;
	  last;
	}

	# Look it up.
	my $tryopt = $opt;
	my $found;		# success status
	my $key;		# key (if hash type)
	my $arg;		# option argument
	my $ctl;		# the opctl entry

	($found, $opt, $ctl, $arg, $key) =
	  FindOption ($argv, $prefix, $argend, $opt, \%opctl);

	if ( $found ) {

	    # FindOption undefines $opt in case of errors.
	    next unless defined $opt;

	    my $argcnt = 0;
	    while ( defined $arg ) {

		# Get the canonical name.
		my $given = $opt;
		print STDERR ("=> cname for \"$opt\" is ") if $debug;
		$opt = $ctl->[CTL_CNAME];
		print STDERR ("\"$ctl->[CTL_CNAME]\"\n") if $debug;

		if ( defined $linkage{$opt} ) {
		    print STDERR ("=> ref(\$L{$opt}) -> ",
				  ref($linkage{$opt}), "\n") if $debug;

		    if ( ref($linkage{$opt}) eq 'SCALAR'
			 || ref($linkage{$opt}) eq 'REF' ) {
			if ( $ctl->[CTL_TYPE] eq '+' ) {
			    print STDERR ("=> \$\$L{$opt} += \"$arg\"\n")
			      if $debug;
			    if ( defined ${$linkage{$opt}} ) {
			        ${$linkage{$opt}} += $arg;
			    }
		            else {
			        ${$linkage{$opt}} = $arg;
			    }
			}
			elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) {
			    print STDERR ("=> ref(\$L{$opt}) auto-vivified",
					  " to ARRAY\n")
			      if $debug;
			    my $t = $linkage{$opt};
			    $$t = $linkage{$opt} = [];
			    print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
			      if $debug;
			    push (@{$linkage{$opt}}, $arg);
			}
			elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
			    print STDERR ("=> ref(\$L{$opt}) auto-vivified",
					  " to HASH\n")
			      if $debug;
			    my $t = $linkage{$opt};
			    $$t = $linkage{$opt} = {};
			    print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
			      if $debug;
			    $linkage{$opt}->{$key} = $arg;
			}
			else {
			    print STDERR ("=> \$\$L{$opt} = \"$arg\"\n")
			      if $debug;
			    ${$linkage{$opt}} = $arg;
		        }
		    }
		    elsif ( ref($linkage{$opt}) eq 'ARRAY' ) {
			print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
			    if $debug;
			push (@{$linkage{$opt}}, $arg);
		    }
		    elsif ( ref($linkage{$opt}) eq 'HASH' ) {
			print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
			    if $debug;
			$linkage{$opt}->{$key} = $arg;
		    }
		    elsif ( ref($linkage{$opt}) eq 'CODE' ) {
			print STDERR ("=> &L{$opt}(\"$opt\"",
				      $ctl->[CTL_DEST] == CTL_DEST_HASH ? ", \"$key\"" : "",
				      ", \"$arg\")\n")
			    if $debug;
			my $eval_error = do {
			    local $@;
			    local $SIG{__DIE__}  = 'DEFAULT';
			    eval {
				&{$linkage{$opt}}
				  (Getopt::Long::CallBack->new
				   (name    => $opt,
				    given   => $given,
				    ctl     => $ctl,
				    opctl   => \%opctl,
				    linkage => \%linkage,
				    prefix  => $prefix,
				   ),
				   $ctl->[CTL_DEST] == CTL_DEST_HASH ? ($key) : (),
				   $arg);
			    };
			    $@;
			};
			print STDERR ("=> die($eval_error)\n")
			  if $debug && $eval_error ne '';
			if ( $eval_error =~ /^!/ ) {
			    if ( $eval_error =~ /^!FINISH\b/ ) {
				$goon = 0;
			    }
			}
			elsif ( $eval_error ne '' ) {
			    warn ($eval_error);
			    $error++;
			}
		    }
		    else {
			print STDERR ("Invalid REF type \"", ref($linkage{$opt}),
				      "\" in linkage\n");
			die("Getopt::Long -- internal error!\n");
		    }
		}
		# No entry in linkage means entry in userlinkage.
		elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) {
		    if ( defined $userlinkage->{$opt} ) {
			print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n")
			    if $debug;
			push (@{$userlinkage->{$opt}}, $arg);
		    }
		    else {
			print STDERR ("=>\$L{$opt} = [\"$arg\"]\n")
			    if $debug;
			$userlinkage->{$opt} = [$arg];
		    }
		}
		elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
		    if ( defined $userlinkage->{$opt} ) {
			print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n")
			    if $debug;
			$userlinkage->{$opt}->{$key} = $arg;
		    }
		    else {
			print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n")
			    if $debug;
			$userlinkage->{$opt} = {$key => $arg};
		    }
		}
		else {
		    if ( $ctl->[CTL_TYPE] eq '+' ) {
			print STDERR ("=> \$L{$opt} += \"$arg\"\n")
			  if $debug;
			if ( defined $userlinkage->{$opt} ) {
			    $userlinkage->{$opt} += $arg;
			}
			else {
			    $userlinkage->{$opt} = $arg;
			}
		    }
		    else {
			print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug;
			$userlinkage->{$opt} = $arg;
		    }
		}

		$argcnt++;
		last if $argcnt >= $ctl->[CTL_AMAX] && $ctl->[CTL_AMAX] != -1;
		undef($arg);

		# Need more args?
		if ( $argcnt < $ctl->[CTL_AMIN] ) {
		    if ( @$argv ) {
			if ( ValidValue($ctl, $argv->[0], 1, $argend, $prefix) ) {
			    $arg = shift(@$argv);
			    if ( $ctl->[CTL_TYPE] =~ /^[iIo]$/ ) {
				$arg =~ tr/_//d;
				$arg = $ctl->[CTL_TYPE] eq 'o' && $arg =~ /^0/
				  ? oct($arg)
				  : 0+$arg
			    }
			    ($key,$arg) = $arg =~ /^([^=]+)=(.*)/
			      if $ctl->[CTL_DEST] == CTL_DEST_HASH;
			    next;
			}
			warn("Value \"$$argv[0]\" invalid for option $opt\n");
			$error++;
		    }
		    else {
			warn("Insufficient arguments for option $opt\n");
			$error++;
		    }
		}

		# Any more args?
		if ( @$argv && ValidValue($ctl, $argv->[0], 0, $argend, $prefix) ) {
		    $arg = shift(@$argv);
		    if ( $ctl->[CTL_TYPE] =~ /^[iIo]$/ ) {
			$arg =~ tr/_//d;
			$arg = $ctl->[CTL_TYPE] eq 'o' && $arg =~ /^0/
			  ? oct($arg)
			  : 0+$arg
		    }
		    ($key,$arg) = $arg =~ /^([^=]+)=(.*)/
		      if $ctl->[CTL_DEST] == CTL_DEST_HASH;
		    next;
		}
	    }
	}

	# Not an option. Save it if we $PERMUTE and don't have a <>.
	elsif ( $order == $PERMUTE ) {
	    # Try non-options call-back.
	    my $cb;
	    if ( defined ($cb = $linkage{'<>'}) ) {
		print STDERR ("=> &L{$tryopt}(\"$tryopt\")\n")
		  if $debug;
		my $eval_error = do {
		    local $@;
		    local $SIG{__DIE__}  = 'DEFAULT';
		    eval {
			# The arg to <> cannot be the CallBack object
			# since it may be passed to other modules that
			# get confused (e.g., Archive::Tar). Well,
			# it's not relevant for this callback anyway.
			&$cb($tryopt);
		    };
		    $@;
		};
		print STDERR ("=> die($eval_error)\n")
		  if $debug && $eval_error ne '';
		if ( $eval_error =~ /^!/ ) {
		    if ( $eval_error =~ /^!FINISH\b/ ) {
			$goon = 0;
		    }
		}
		elsif ( $eval_error ne '' ) {
		    warn ($eval_error);
		    $error++;
		}
	    }
	    else {
		print STDERR ("=> saving \"$tryopt\" ",
			      "(not an option, may permute)\n") if $debug;
		push (@ret, $tryopt);
	    }
	    next;
	}

	# ...otherwise, terminate.
	else {
	    # Push this one back and exit.
	    unshift (@$argv, $tryopt);
	    return ($error == 0);
	}

    }

    # Finish.
    if ( @ret && ( $order == $PERMUTE || $passthrough ) ) {
	#  Push back accumulated arguments
	print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
	    if $debug;
	unshift (@$argv, @ret);
    }

    return ($error == 0);
}

# A readable representation of what's in an optbl.
sub OptCtl ($) {
    my ($v) = @_;
    my @v = map { defined($_) ? ($_) : ("<undef>") } @$v;
    "[".
      join(",",
	   "\"$v[CTL_TYPE]\"",
	   "\"$v[CTL_CNAME]\"",
	   "\"$v[CTL_DEFAULT]\"",
	   ("\$","\@","\%","\&")[$v[CTL_DEST] || 0],
	   $v[CTL_AMIN] || '',
	   $v[CTL_AMAX] || '',
#	   $v[CTL_RANGE] || '',
#	   $v[CTL_REPEAT] || '',
	  ). "]";
}

# Parse an option specification and fill the tables.
sub ParseOptionSpec ($$) {
    my ($opt, $opctl) = @_;

    # Match option spec.
    if ( $opt !~ m;^
		   (
		     # Option name
		     (?: \w+[-\w]* )
		     # Aliases
		     (?: \| (?: . [^|!+=:]* )? )*
		   )?
		   (
		     # Either modifiers ...
		     [!+]
		     |
		     # ... or a value/dest/repeat specification
		     [=:] [ionfs] [@%]? (?: \{\d*,?\d*\} )?
		     |
		     # ... or an optional-with-default spec
		     : (?: -?\d+ | \+ ) [@%]?
		   )?
		   $;x ) {
	return (undef, "Error in option spec: \"$opt\"\n");
    }

    my ($names, $spec) = ($1, $2);
    $spec = '' unless defined $spec;

    # $orig keeps track of the primary name the user specified.
    # This name will be used for the internal or external linkage.
    # In other words, if the user specifies "FoO|BaR", it will
    # match any case combinations of 'foo' and 'bar', but if a global
    # variable needs to be set, it will be $opt_FoO in the exact case
    # as specified.
    my $orig;

    my @names;
    if ( defined $names ) {
	@names =  split (/\|/, $names);
	$orig = $names[0];
    }
    else {
	@names = ('');
	$orig = '';
    }

    # Construct the opctl entries.
    my $entry;
    if ( $spec eq '' || $spec eq '+' || $spec eq '!' ) {
	# Fields are hard-wired here.
	$entry = [$spec,$orig,undef,CTL_DEST_SCALAR,0,0];
    }
    elsif ( $spec =~ /^:(-?\d+|\+)([@%])?$/ ) {
	my $def = $1;
	my $dest = $2;
	my $type = $def eq '+' ? 'I' : 'i';
	$dest ||= '$';
	$dest = $dest eq '@' ? CTL_DEST_ARRAY
	  : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;
	# Fields are hard-wired here.
	$entry = [$type,$orig,$def eq '+' ? undef : $def,
		  $dest,0,1];
    }
    else {
	my ($mand, $type, $dest) =
	  $spec =~ /^([=:])([ionfs])([@%])?(\{(\d+)?(,)?(\d+)?\})?$/;
	return (undef, "Cannot repeat while bundling: \"$opt\"\n")
	  if $bundling && defined($4);
	my ($mi, $cm, $ma) = ($5, $6, $7);
	return (undef, "{0} is useless in option spec: \"$opt\"\n")
	  if defined($mi) && !$mi && !defined($ma) && !defined($cm);

	$type = 'i' if $type eq 'n';
	$dest ||= '$';
	$dest = $dest eq '@' ? CTL_DEST_ARRAY
	  : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;
	# Default minargs to 1/0 depending on mand status.
	$mi = $mand eq '=' ? 1 : 0 unless defined $mi;
	# Adjust mand status according to minargs.
	$mand = $mi ? '=' : ':';
	# Adjust maxargs.
	$ma = $mi ? $mi : 1 unless defined $ma || defined $cm;
	return (undef, "Max must be greater than zero in option spec: \"$opt\"\n")
	  if defined($ma) && !$ma;
	return (undef, "Max less than min in option spec: \"$opt\"\n")
	  if defined($ma) && $ma < $mi;

	# Fields are hard-wired here.
	$entry = [$type,$orig,undef,$dest,$mi,$ma||-1];
    }

    # Process all names. First is canonical, the rest are aliases.
    my $dups = '';
    foreach ( @names ) {

	$_ = lc ($_)
	  if $ignorecase > (($bundling && length($_) == 1) ? 1 : 0);

	if ( exists $opctl->{$_} ) {
	    $dups .= "Duplicate specification \"$opt\" for option \"$_\"\n";
	}

	if ( $spec eq '!' ) {
	    $opctl->{"no$_"} = $entry;
	    $opctl->{"no-$_"} = $entry;
	    $opctl->{$_} = [@$entry];
	    $opctl->{$_}->[CTL_TYPE] = '';
	}
	else {
	    $opctl->{$_} = $entry;
	}
    }

    if ( $dups && $^W ) {
	foreach ( split(/\n+/, $dups) ) {
	    warn($_."\n");
	}
    }
    ($names[0], $orig);
}

# Option lookup.
sub FindOption ($$$$$) {

    # returns (1, $opt, $ctl, $arg, $key) if okay,
    # returns (1, undef) if option in error,
    # returns (0) otherwise.

    my ($argv, $prefix, $argend, $opt, $opctl) = @_;

    print STDERR ("=> find \"$opt\"\n") if $debug;

    return (0) unless defined($opt);
    return (0) unless $opt =~ /^($prefix)(.*)$/s;
    return (0) if $opt eq "-" && !defined $opctl->{''};

    $opt = substr( $opt, length($1) ); # retain taintedness
    my $starter = $1;

    print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug;

    my $optarg;			# value supplied with --opt=value
    my $rest;			# remainder from unbundling

    # If it is a long option, it may include the value.
    # With getopt_compat, only if not bundling.
    if ( ($starter=~/^$longprefix$/
	  || ($getopt_compat && ($bundling == 0 || $bundling == 2)))
	 && (my $oppos = index($opt, '=', 1)) > 0) {
	my $optorg = $opt;
	$opt = substr($optorg, 0, $oppos);
	$optarg = substr($optorg, $oppos + 1); # retain tainedness
	print STDERR ("=> option \"", $opt,
		      "\", optarg = \"$optarg\"\n") if $debug;
    }

    #### Look it up ###

    my $tryopt = $opt;		# option to try

    if ( ( $bundling || $bundling_values ) && $starter eq '-' ) {

	# To try overrides, obey case ignore.
	$tryopt = $ignorecase ? lc($opt) : $opt;

	# If bundling == 2, long options can override bundles.
	if ( $bundling == 2 && length($tryopt) > 1
	     && defined ($opctl->{$tryopt}) ) {
	    print STDERR ("=> $starter$tryopt overrides unbundling\n")
	      if $debug;
	}

	# If bundling_values, option may be followed by the value.
	elsif ( $bundling_values ) {
	    $tryopt = $opt;
	    # Unbundle single letter option.
	    $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : '';
	    $tryopt = substr ($tryopt, 0, 1);
	    $tryopt = lc ($tryopt) if $ignorecase > 1;
	    print STDERR ("=> $starter$tryopt unbundled from ",
			  "$starter$tryopt$rest\n") if $debug;
	    # Whatever remains may not be considered an option.
	    $optarg = $rest eq '' ? undef : $rest;
	    $rest = undef;
	}

	# Split off a single letter and leave the rest for
	# further processing.
	else {
	    $tryopt = $opt;
	    # Unbundle single letter option.
	    $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : '';
	    $tryopt = substr ($tryopt, 0, 1);
	    $tryopt = lc ($tryopt) if $ignorecase > 1;
	    print STDERR ("=> $starter$tryopt unbundled from ",
			  "$starter$tryopt$rest\n") if $debug;
	    $rest = undef unless $rest ne '';
	}
    }

    # Try auto-abbreviation.
    elsif ( $autoabbrev && $opt ne "" ) {
	# Sort the possible long option names.
	my @names = sort(keys (%$opctl));
	# Downcase if allowed.
	$opt = lc ($opt) if $ignorecase;
	$tryopt = $opt;
	# Turn option name into pattern.
	my $pat = quotemeta ($opt);
	# Look up in option names.
	my @hits = grep (/^$pat/, @names);
	print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
		      "out of ", scalar(@names), "\n") if $debug;

	# Check for ambiguous results.
	unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
	    # See if all matches are for the same option.
	    my %hit;
	    foreach ( @hits ) {
		my $hit = $opctl->{$_}->[CTL_CNAME]
		  if defined $opctl->{$_}->[CTL_CNAME];
		$hit = "no" . $hit if $opctl->{$_}->[CTL_TYPE] eq '!';
		$hit{$hit} = 1;
	    }
	    # Remove auto-supplied options (version, help).
	    if ( keys(%hit) == 2 ) {
		if ( $auto_version && exists($hit{version}) ) {
		    delete $hit{version};
		}
		elsif ( $auto_help && exists($hit{help}) ) {
		    delete $hit{help};
		}
	    }
	    # Now see if it really is ambiguous.
	    unless ( keys(%hit) == 1 ) {
		return (0) if $passthrough;
		warn ("Option ", $opt, " is ambiguous (",
		      join(", ", @hits), ")\n");
		$error++;
		return (1, undef);
	    }
	    @hits = keys(%hit);
	}

	# Complete the option name, if appropriate.
	if ( @hits == 1 && $hits[0] ne $opt ) {
	    $tryopt = $hits[0];
	    $tryopt = lc ($tryopt)
	      if $ignorecase > (($bundling && length($tryopt) == 1) ? 1 : 0);
	    print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
		if $debug;
	}
    }

    # Map to all lowercase if ignoring case.
    elsif ( $ignorecase ) {
	$tryopt = lc ($opt);
    }

    # Check validity by fetching the info.
    my $ctl = $opctl->{$tryopt};
    unless  ( defined $ctl ) {
	return (0) if $passthrough;
	# Pretend one char when bundling.
	if ( $bundling == 1 && length($starter) == 1 ) {
	    $opt = substr($opt,0,1);
            unshift (@$argv, $starter.$rest) if defined $rest;
	}
	if ( $opt eq "" ) {
	    warn ("Missing option after ", $starter, "\n");
	}
	else {
	    warn ("Unknown option: ", $opt, "\n");
	}
	$error++;
	return (1, undef);
    }
    # Apparently valid.
    $opt = $tryopt;
    print STDERR ("=> found ", OptCtl($ctl),
		  " for \"", $opt, "\"\n") if $debug;

    #### Determine argument status ####

    # If it is an option w/o argument, we're almost finished with it.
    my $type = $ctl->[CTL_TYPE];
    my $arg;

    if ( $type eq '' || $type eq '!' || $type eq '+' ) {
	if ( defined $optarg ) {
	    return (0) if $passthrough;
	    warn ("Option ", $opt, " does not take an argument\n");
	    $error++;
	    undef $opt;
	    undef $optarg if $bundling_values;
	}
	elsif ( $type eq '' || $type eq '+' ) {
	    # Supply explicit value.
	    $arg = 1;
	}
	else {
	    $opt =~ s/^no-?//i;	# strip NO prefix
	    $arg = 0;		# supply explicit value
	}
	unshift (@$argv, $starter.$rest) if defined $rest;
	return (1, $opt, $ctl, $arg);
    }

    # Get mandatory status and type info.
    my $mand = $ctl->[CTL_AMIN];

    # Check if there is an option argument available.
    if ( $gnu_compat ) {
	my $optargtype = 0; # none, 1 = empty, 2 = nonempty, 3 = aux
	if ( defined($optarg) ) {
	    $optargtype = (length($optarg) == 0) ? 1 : 2;
	}
	elsif ( defined $rest || @$argv > 0 ) {
	    # GNU getopt_long() does not accept the (optional)
	    # argument to be passed to the option without = sign.
	    # We do, since not doing so breaks existing scripts.
	    $optargtype = 3;
	}
	if(($optargtype == 0) && !$mand) {
	    if ( $type eq 'I' ) {
		# Fake incremental type.
		my @c = @$ctl;
		$c[CTL_TYPE] = '+';
		return (1, $opt, \@c, 1);
	    }
	    my $val
	      = defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT]
	      : $type eq 's'                 ? ''
	      :                                0;
	    return (1, $opt, $ctl, $val);
	}
	return (1, $opt, $ctl, $type eq 's' ? '' : 0)
	  if $optargtype == 1;  # --foo=  -> return nothing
    }

    # Check if there is an option argument available.
    if ( defined $optarg
	 ? ($optarg eq '')
	 : !(defined $rest || @$argv > 0) ) {
	# Complain if this option needs an argument.
#	if ( $mand && !($type eq 's' ? defined($optarg) : 0) ) {
	if ( $mand || $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
	    return (0) if $passthrough;
	    warn ("Option ", $opt, " requires an argument\n");
	    $error++;
	    return (1, undef);
	}
	if ( $type eq 'I' ) {
	    # Fake incremental type.
	    my @c = @$ctl;
	    $c[CTL_TYPE] = '+';
	    return (1, $opt, \@c, 1);
	}
	return (1, $opt, $ctl,
		defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
		$type eq 's' ? '' : 0);
    }

    # Get (possibly optional) argument.
    $arg = (defined $rest ? $rest
	    : (defined $optarg ? $optarg : shift (@$argv)));

    # Get key if this is a "name=value" pair for a hash option.
    my $key;
    if ($ctl->[CTL_DEST] == CTL_DEST_HASH && defined $arg) {
	($key, $arg) = ($arg =~ /^([^=]*)=(.*)$/s) ? ($1, $2)
	  : ($arg, defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
	     ($mand ? undef : ($type eq 's' ? "" : 1)));
	if (! defined $arg) {
	    warn ("Option $opt, key \"$key\", requires a value\n");
	    $error++;
	    # Push back.
	    unshift (@$argv, $starter.$rest) if defined $rest;
	    return (1, undef);
	}
    }

    #### Check if the argument is valid for this option ####

    my $key_valid = $ctl->[CTL_DEST] == CTL_DEST_HASH ? "[^=]+=" : "";

    if ( $type eq 's' ) {	# string
	# A mandatory string takes anything.
	return (1, $opt, $ctl, $arg, $key) if $mand;

	# Same for optional string as a hash value
	return (1, $opt, $ctl, $arg, $key)
	  if $ctl->[CTL_DEST] == CTL_DEST_HASH;

	# An optional string takes almost anything.
	return (1, $opt, $ctl, $arg, $key)
	  if defined $optarg || defined $rest;
	return (1, $opt, $ctl, $arg, $key) if $arg eq "-"; # ??

	# Check for option or option list terminator.
	if ($arg eq $argend ||
	    $arg =~ /^$prefix.+/) {
	    # Push back.
	    unshift (@$argv, $arg);
	    # Supply empty value.
	    $arg = '';
	}
    }

    elsif ( $type eq 'i'	# numeric/integer
            || $type eq 'I'	# numeric/integer w/ incr default
	    || $type eq 'o' ) { # dec/oct/hex/bin value

	my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT;

	if ( $bundling && defined $rest
	     && $rest =~ /^($key_valid)($o_valid)(.*)$/si ) {
	    ($key, $arg, $rest) = ($1, $2, $+);
	    chop($key) if $key;
	    $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
	    unshift (@$argv, $starter.$rest) if defined $rest && $rest ne '';
	}
	elsif ( $arg =~ /^$o_valid$/si ) {
	    $arg =~ tr/_//d;
	    $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
	}
	else {
	    if ( defined $optarg || $mand ) {
		if ( $passthrough ) {
		    unshift (@$argv, defined $rest ? $starter.$rest : $arg)
		      unless defined $optarg;
		    return (0);
		}
		warn ("Value \"", $arg, "\" invalid for option ",
		      $opt, " (",
		      $type eq 'o' ? "extended " : '',
		      "number expected)\n");
		$error++;
		# Push back.
		unshift (@$argv, $starter.$rest) if defined $rest;
		return (1, undef);
	    }
	    else {
		# Push back.
		unshift (@$argv, defined $rest ? $starter.$rest : $arg);
		if ( $type eq 'I' ) {
		    # Fake incremental type.
		    my @c = @$ctl;
		    $c[CTL_TYPE] = '+';
		    return (1, $opt, \@c, 1);
		}
		# Supply default value.
		$arg = defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : 0;
	    }
	}
    }

    elsif ( $type eq 'f' ) { # real number, int is also ok
	my $o_valid = PAT_FLOAT;
	if ( $bundling && defined $rest &&
	     $rest =~ /^($key_valid)($o_valid)(.*)$/s ) {
	    $arg =~ tr/_//d;
	    ($key, $arg, $rest) = ($1, $2, $+);
	    chop($key) if $key;
	    unshift (@$argv, $starter.$rest) if defined $rest && $rest ne '';
	}
	elsif ( $arg =~ /^$o_valid$/ ) {
	    $arg =~ tr/_//d;
	}
	else {
	    if ( defined $optarg || $mand ) {
		if ( $passthrough ) {
		    unshift (@$argv, defined $rest ? $starter.$rest : $arg)
		      unless defined $optarg;
		    return (0);
		}
		warn ("Value \"", $arg, "\" invalid for option ",
		      $opt, " (real number expected)\n");
		$error++;
		# Push back.
		unshift (@$argv, $starter.$rest) if defined $rest;
		return (1, undef);
	    }
	    else {
		# Push back.
		unshift (@$argv, defined $rest ? $starter.$rest : $arg);
		# Supply default value.
		$arg = 0.0;
	    }
	}
    }
    else {
	die("Getopt::Long internal error (Can't happen)\n");
    }
    return (1, $opt, $ctl, $arg, $key);
}

sub ValidValue ($$$$$) {
    my ($ctl, $arg, $mand, $argend, $prefix) = @_;

    if ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
	return 0 unless $arg =~ /[^=]+=(.*)/;
	$arg = $1;
    }

    my $type = $ctl->[CTL_TYPE];

    if ( $type eq 's' ) {	# string
	# A mandatory string takes anything.
	return (1) if $mand;

	return (1) if $arg eq "-";

	# Check for option or option list terminator.
	return 0 if $arg eq $argend || $arg =~ /^$prefix.+/;
	return 1;
    }

    elsif ( $type eq 'i'	# numeric/integer
            || $type eq 'I'	# numeric/integer w/ incr default
	    || $type eq 'o' ) { # dec/oct/hex/bin value

	my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT;
	return $arg =~ /^$o_valid$/si;
    }

    elsif ( $type eq 'f' ) { # real number, int is also ok
	my $o_valid = PAT_FLOAT;
	return $arg =~ /^$o_valid$/;
    }
    die("ValidValue: Cannot happen\n");
}

# Getopt::Long Configuration.
sub Configure (@) {
    my (@options) = @_;

    my $prevconfig =
      [ $error, $debug, $major_version, $minor_version, $caller,
	$autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
	$gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
	$longprefix, $bundling_values ];

    if ( ref($options[0]) eq 'ARRAY' ) {
	( $error, $debug, $major_version, $minor_version, $caller,
	  $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
	  $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
	  $longprefix, $bundling_values ) = @{shift(@options)};
    }

    my $opt;
    foreach $opt ( @options ) {
	my $try = lc ($opt);
	my $action = 1;
	if ( $try =~ /^no_?(.*)$/s ) {
	    $action = 0;
	    $try = $+;
	}
	if ( ($try eq 'default' or $try eq 'defaults') && $action ) {
	    ConfigDefaults ();
	}
	elsif ( ($try eq 'posix_default' or $try eq 'posix_defaults') ) {
	    local $ENV{POSIXLY_CORRECT};
	    $ENV{POSIXLY_CORRECT} = 1 if $action;
	    ConfigDefaults ();
	}
	elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) {
	    $autoabbrev = $action;
	}
	elsif ( $try eq 'getopt_compat' ) {
	    $getopt_compat = $action;
            $genprefix = $action ? "(--|-|\\+)" : "(--|-)";
	}
	elsif ( $try eq 'gnu_getopt' ) {
	    if ( $action ) {
		$gnu_compat = 1;
		$bundling = 1;
		$getopt_compat = 0;
                $genprefix = "(--|-)";
		$order = $PERMUTE;
		$bundling_values = 0;
	    }
	}
	elsif ( $try eq 'gnu_compat' ) {
	    $gnu_compat = $action;
	    $bundling = 0;
	    $bundling_values = 1;
	}
	elsif ( $try =~ /^(auto_?)?version$/ ) {
	    $auto_version = $action;
	}
	elsif ( $try =~ /^(auto_?)?help$/ ) {
	    $auto_help = $action;
	}
	elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) {
	    $ignorecase = $action;
	}
	elsif ( $try eq 'ignorecase_always' or $try eq 'ignore_case_always' ) {
	    $ignorecase = $action ? 2 : 0;
	}
	elsif ( $try eq 'bundling' ) {
	    $bundling = $action;
	    $bundling_values = 0 if $action;
	}
	elsif ( $try eq 'bundling_override' ) {
	    $bundling = $action ? 2 : 0;
	    $bundling_values = 0 if $action;
	}
	elsif ( $try eq 'bundling_values' ) {
	    $bundling_values = $action;
	    $bundling = 0 if $action;
	}
	elsif ( $try eq 'require_order' ) {
	    $order = $action ? $REQUIRE_ORDER : $PERMUTE;
	}
	elsif ( $try eq 'permute' ) {
	    $order = $action ? $PERMUTE : $REQUIRE_ORDER;
	}
	elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) {
	    $passthrough = $action;
	}
	elsif ( $try =~ /^prefix=(.+)$/ && $action ) {
	    $genprefix = $1;
	    # Turn into regexp. Needs to be parenthesized!
	    $genprefix = "(" . quotemeta($genprefix) . ")";
	    eval { '' =~ /$genprefix/; };
	    die("Getopt::Long: invalid pattern \"$genprefix\"\n") if $@;
	}
	elsif ( $try =~ /^prefix_pattern=(.+)$/ && $action ) {
	    $genprefix = $1;
	    # Parenthesize if needed.
	    $genprefix = "(" . $genprefix . ")"
	      unless $genprefix =~ /^\(.*\)$/;
	    eval { '' =~ m"$genprefix"; };
	    die("Getopt::Long: invalid pattern \"$genprefix\"\n") if $@;
	}
	elsif ( $try =~ /^long_prefix_pattern=(.+)$/ && $action ) {
	    $longprefix = $1;
	    # Parenthesize if needed.
	    $longprefix = "(" . $longprefix . ")"
	      unless $longprefix =~ /^\(.*\)$/;
	    eval { '' =~ m"$longprefix"; };
	    die("Getopt::Long: invalid long prefix pattern \"$longprefix\"\n") if $@;
	}
	elsif ( $try eq 'debug' ) {
	    $debug = $action;
	}
	else {
	    die("Getopt::Long: unknown or erroneous config parameter \"$opt\"\n")
	}
    }
    $prevconfig;
}

# Deprecated name.
sub config (@) {
    Configure (@_);
}

# Issue a standard message for --version.
#
# The arguments are mostly the same as for Pod::Usage::pod2usage:
#
#  - a number (exit value)
#  - a string (lead in message)
#  - a hash with options. See Pod::Usage for details.
#
sub VersionMessage(@) {
    # Massage args.
    my $pa = setup_pa_args("version", @_);

    my $v = $main::VERSION;
    my $fh = $pa->{-output} ||
      ( ($pa->{-exitval} eq "NOEXIT" || $pa->{-exitval} < 2) ? \*STDOUT : \*STDERR );

    print $fh (defined($pa->{-message}) ? $pa->{-message} : (),
	       $0, defined $v ? " version $v" : (),
	       "\n",
	       "(", __PACKAGE__, "::", "GetOptions",
	       " version ",
	       defined($Getopt::Long::VERSION_STRING)
	         ? $Getopt::Long::VERSION_STRING : $VERSION, ";",
	       " Perl version ",
	       $] >= 5.006 ? sprintf("%vd", $^V) : $],
	       ")\n");
    exit($pa->{-exitval}) unless $pa->{-exitval} eq "NOEXIT";
}

# Issue a standard message for --help.
#
# The arguments are the same as for Pod::Usage::pod2usage:
#
#  - a number (exit value)
#  - a string (lead in message)
#  - a hash with options. See Pod::Usage for details.
#
sub HelpMessage(@) {
    eval {
	require Pod::Usage;
	import Pod::Usage;
	1;
    } || die("Cannot provide help: cannot load Pod::Usage\n");

    # Note that pod2usage will issue a warning if -exitval => NOEXIT.
    pod2usage(setup_pa_args("help", @_));

}

# Helper routine to set up a normalized hash ref to be used as
# argument to pod2usage.
sub setup_pa_args($@) {
    my $tag = shift;		# who's calling

    # If called by direct binding to an option, it will get the option
    # name and value as arguments. Remove these, if so.
    @_ = () if @_ == 2 && $_[0] eq $tag;

    my $pa;
    if ( @_ > 1 ) {
	$pa = { @_ };
    }
    else {
	$pa = shift || {};
    }

    # At this point, $pa can be a number (exit value), string
    # (message) or hash with options.

    if ( UNIVERSAL::isa($pa, 'HASH') ) {
	# Get rid of -msg vs. -message ambiguity.
	$pa->{-message} = $pa->{-msg};
	delete($pa->{-msg});
    }
    elsif ( $pa =~ /^-?\d+$/ ) {
	$pa = { -exitval => $pa };
    }
    else {
	$pa = { -message => $pa };
    }

    # These are _our_ defaults.
    $pa->{-verbose} = 0 unless exists($pa->{-verbose});
    $pa->{-exitval} = 0 unless exists($pa->{-exitval});
    $pa;
}

# Sneak way to know what version the user requested.
sub VERSION {
    $requested_version = $_[1] if @_ > 1;
    shift->SUPER::VERSION(@_);
}

package Getopt::Long::CallBack;

sub new {
    my ($pkg, %atts) = @_;
    bless { %atts }, $pkg;
}

sub name {
    my $self = shift;
    ''.$self->{name};
}

sub given {
    my $self = shift;
    $self->{given};
}

use overload
  # Treat this object as an ordinary string for legacy API.
  '""'	   => \&name,
  fallback => 1;

1;

################ Documentation ################

=head1 NAME

Getopt::Long - Extended processing of command line options

=head1 SYNOPSIS

  use Getopt::Long;
  my $data   = "file.dat";
  my $length = 24;
  my $verbose;
  GetOptions ("length=i" => \$length,    # numeric
              "file=s"   => \$data,      # string
              "verbose"  => \$verbose)   # flag
  or die("Error in command line arguments\n");

=head1 DESCRIPTION

The Getopt::Long module implements an extended getopt function called
GetOptions(). It parses the command line from C<@ARGV>, recognizing
and removing specified options and their possible values.

This function adheres to the POSIX syntax for command
line options, with GNU extensions. In general, this means that options
have long names instead of single letters, and are introduced with a
double dash "--". Support for bundling of command line options, as was
the case with the more traditional single-letter approach, is provided
but not enabled by default.

=head1 Command Line Options, an Introduction

Command line operated programs traditionally take their arguments from
the command line, for example filenames or other information that the
program needs to know. Besides arguments, these programs often take
command line I<options> as well. Options are not necessary for the
program to work, hence the name 'option', but are used to modify its
default behaviour. For example, a program could do its job quietly,
but with a suitable option it could provide verbose information about
what it did.

Command line options come in several flavours. Historically, they are
preceded by a single dash C<->, and consist of a single letter.

    -l -a -c

Usually, these single-character options can be bundled:

    -lac

Options can have values, the value is placed after the option
character. Sometimes with whitespace in between, sometimes not:

    -s 24 -s24

Due to the very cryptic nature of these options, another style was
developed that used long names. So instead of a cryptic C<-l> one
could use the more descriptive C<--long>. To distinguish between a
bundle of single-character options and a long one, two dashes are used
to precede the option name. Early implementations of long options used
a plus C<+> instead. Also, option values could be specified either
like

    --size=24

or

    --size 24

The C<+> form is now obsolete and strongly deprecated.

=head1 Getting Started with Getopt::Long

Getopt::Long is the Perl5 successor of C<newgetopt.pl>. This was the
first Perl module that provided support for handling the new style of
command line options, in particular long option names, hence the Perl5
name Getopt::Long. This module also supports single-character options
and bundling.

To use Getopt::Long from a Perl program, you must include the
following line in your Perl program:

    use Getopt::Long;

This will load the core of the Getopt::Long module and prepare your
program for using it. Most of the actual Getopt::Long code is not
loaded until you really call one of its functions.

In the default configuration, options names may be abbreviated to
uniqueness, case does not matter, and a single dash is sufficient,
even for long option names. Also, options may be placed between
non-option arguments. See L<Configuring Getopt::Long> for more
details on how to configure Getopt::Long.

=head2 Simple options

The most simple options are the ones that take no values. Their mere
presence on the command line enables the option. Popular examples are:

    --all --verbose --quiet --debug

Handling simple options is straightforward:

    my $verbose = '';	# option variable with default value (false)
    my $all = '';	# option variable with default value (false)
    GetOptions ('verbose' => \$verbose, 'all' => \$all);

The call to GetOptions() parses the command line arguments that are
present in C<@ARGV> and sets the option variable to the value C<1> if
the option did occur on the command line. Otherwise, the option
variable is not touched. Setting the option value to true is often
called I<enabling> the option.

The option name as specified to the GetOptions() function is called
the option I<specification>. Later we'll see that this specification
can contain more than just the option name. The reference to the
variable is called the option I<destination>.

GetOptions() will return a true value if the command line could be
processed successfully. Otherwise, it will write error messages using
die() and warn(), and return a false result.

=head2 A little bit less simple options

Getopt::Long supports two useful variants of simple options:
I<negatable> options and I<incremental> options.

A negatable option is specified with an exclamation mark C<!> after the
option name:

    my $verbose = '';	# option variable with default value (false)
    GetOptions ('verbose!' => \$verbose);

Now, using C<--verbose> on the command line will enable C<$verbose>,
as expected. But it is also allowed to use C<--noverbose>, which will
disable C<$verbose> by setting its value to C<0>. Using a suitable
default value, the program can find out whether C<$verbose> is false
by default, or disabled by using C<--noverbose>.

An incremental option is specified with a plus C<+> after the
option name:

    my $verbose = '';	# option variable with default value (false)
    GetOptions ('verbose+' => \$verbose);

Using C<--verbose> on the command line will increment the value of
C<$verbose>. This way the program can keep track of how many times the
option occurred on the command line. For example, each occurrence of
C<--verbose> could increase the verbosity level of the program.

=head2 Mixing command line option with other arguments

Usually programs take command line options as well as other arguments,
for example, file names. It is good practice to always specify the
options first, and the other arguments last. Getopt::Long will,
however, allow the options and arguments to be mixed and 'filter out'
all the options before passing the rest of the arguments to the
program. To stop Getopt::Long from processing further arguments,
insert a double dash C<--> on the command line:

    --size 24 -- --all

In this example, C<--all> will I<not> be treated as an option, but
passed to the program unharmed, in C<@ARGV>.

=head2 Options with values

For options that take values it must be specified whether the option
value is required or not, and what kind of value the option expects.

Three kinds of values are supported: integer numbers, floating point
numbers, and strings.

If the option value is required, Getopt::Long will take the
command line argument that follows the option and assign this to the
option variable. If, however, the option value is specified as
optional, this will only be done if that value does not look like a
valid command line option itself.

    my $tag = '';	# option variable with default value
    GetOptions ('tag=s' => \$tag);

In the option specification, the option name is followed by an equals
sign C<=> and the letter C<s>. The equals sign indicates that this
option requires a value. The letter C<s> indicates that this value is
an arbitrary string. Other possible value types are C<i> for integer
values, and C<f> for floating point values. Using a colon C<:> instead
of the equals sign indicates that the option value is optional. In
this case, if no suitable value is supplied, string valued options get
an empty string C<''> assigned, while numeric options are set to C<0>.

=head2 Options with multiple values

Options sometimes take several values. For example, a program could
use multiple directories to search for library files:

    --library lib/stdlib --library lib/extlib

To accomplish this behaviour, simply specify an array reference as the
destination for the option:

    GetOptions ("library=s" => \@libfiles);

Alternatively, you can specify that the option can have multiple
values by adding a "@", and pass a reference to a scalar as the
destination:

    GetOptions ("library=s@" => \$libfiles);

Used with the example above, C<@libfiles> c.q. C<@$libfiles> would
contain two strings upon completion: C<"lib/stdlib"> and
C<"lib/extlib">, in that order. It is also possible to specify that
only integer or floating point numbers are acceptable values.

Often it is useful to allow comma-separated lists of values as well as
multiple occurrences of the options. This is easy using Perl's split()
and join() operators:

    GetOptions ("library=s" => \@libfiles);
    @libfiles = split(/,/,join(',',@libfiles));

Of course, it is important to choose the right separator string for
each purpose.

Warning: What follows is an experimental feature.

Options can take multiple values at once, for example

    --coordinates 52.2 16.4 --rgbcolor 255 255 149

This can be accomplished by adding a repeat specifier to the option
specification. Repeat specifiers are very similar to the C<{...}>
repeat specifiers that can be used with regular expression patterns.
For example, the above command line would be handled as follows:

    GetOptions('coordinates=f{2}' => \@coor, 'rgbcolor=i{3}' => \@color);

The destination for the option must be an array or array reference.

It is also possible to specify the minimal and maximal number of
arguments an option takes. C<foo=s{2,4}> indicates an option that
takes at least two and at most 4 arguments. C<foo=s{1,}> indicates one
or more values; C<foo:s{,}> indicates zero or more option values.

=head2 Options with hash values

If the option destination is a reference to a hash, the option will
take, as value, strings of the form I<key>C<=>I<value>. The value will
be stored with the specified key in the hash.

    GetOptions ("define=s" => \%defines);

Alternatively you can use:

    GetOptions ("define=s%" => \$defines);

When used with command line options:

    --define os=linux --define vendor=redhat

the hash C<%defines> (or C<%$defines>) will contain two keys, C<"os">
with value C<"linux"> and C<"vendor"> with value C<"redhat">. It is
also possible to specify that only integer or floating point numbers
are acceptable values. The keys are always taken to be strings.

=head2 User-defined subroutines to handle options

Ultimate control over what should be done when (actually: each time)
an option is encountered on the command line can be achieved by
designating a reference to a subroutine (or an anonymous subroutine)
as the option destination. When GetOptions() encounters the option, it
will call the subroutine with two or three arguments. The first
argument is the name of the option. (Actually, it is an object that
stringifies to the name of the option.) For a scalar or array destination,
the second argument is the value to be stored. For a hash destination,
the second argument is the key to the hash, and the third argument
the value to be stored. It is up to the subroutine to store the value,
or do whatever it thinks is appropriate.

A trivial application of this mechanism is to implement options that
are related to each other. For example:

    my $verbose = '';	# option variable with default value (false)
    GetOptions ('verbose' => \$verbose,
	        'quiet'   => sub { $verbose = 0 });

Here C<--verbose> and C<--quiet> control the same variable
C<$verbose>, but with opposite values.

If the subroutine needs to signal an error, it should call die() with
the desired error message as its argument. GetOptions() will catch the
die(), issue the error message, and record that an error result must
be returned upon completion.

If the text of the error message starts with an exclamation mark C<!>
it is interpreted specially by GetOptions(). There is currently one
special command implemented: C<die("!FINISH")> will cause GetOptions()
to stop processing options, as if it encountered a double dash C<-->.

Here is an example of how to access the option name and value from within
a subroutine:

    GetOptions ('opt=i' => \&handler);
    sub handler {
        my ($opt_name, $opt_value) = @_;
        print("Option name is $opt_name and value is $opt_value\n");
    }

=head2 Options with multiple names

Often it is user friendly to supply alternate mnemonic names for
options. For example C<--height> could be an alternate name for
C<--length>. Alternate names can be included in the option
specification, separated by vertical bar C<|> characters. To implement
the above example:

    GetOptions ('length|height=f' => \$length);

The first name is called the I<primary> name, the other names are
called I<aliases>. When using a hash to store options, the key will
always be the primary name.

Multiple alternate names are possible.

=head2 Case and abbreviations

Without additional configuration, GetOptions() will ignore the case of
option names, and allow the options to be abbreviated to uniqueness.

    GetOptions ('length|height=f' => \$length, "head" => \$head);

This call will allow C<--l> and C<--L> for the length option, but
requires a least C<--hea> and C<--hei> for the head and height options.

=head2 Summary of Option Specifications

Each option specifier consists of two parts: the name specification
and the argument specification.

The name specification contains the name of the option, optionally
followed by a list of alternative names separated by vertical bar
characters.

    length	      option name is "length"
    length|size|l     name is "length", aliases are "size" and "l"

The argument specification is optional. If omitted, the option is
considered boolean, a value of 1 will be assigned when the option is
used on the command line.

The argument specification can be

=over 4

=item !

The option does not take an argument and may be negated by prefixing
it with "no" or "no-". E.g. C<"foo!"> will allow C<--foo> (a value of
1 will be assigned) as well as C<--nofoo> and C<--no-foo> (a value of
0 will be assigned). If the option has aliases, this applies to the
aliases as well.

Using negation on a single letter option when bundling is in effect is
pointless and will result in a warning.

=item +

The option does not take an argument and will be incremented by 1
every time it appears on the command line. E.g. C<"more+">, when used
with C<--more --more --more>, will increment the value three times,
resulting in a value of 3 (provided it was 0 or undefined at first).

The C<+> specifier is ignored if the option destination is not a scalar.

=item = I<type> [ I<desttype> ] [ I<repeat> ]

The option requires an argument of the given type. Supported types
are:

=over 4

=item s

String. An arbitrary sequence of characters. It is valid for the
argument to start with C<-> or C<-->.

=item i

Integer. An optional leading plus or minus sign, followed by a
sequence of digits.

=item o

Extended integer, Perl style. This can be either an optional leading
plus or minus sign, followed by a sequence of digits, or an octal
string (a zero, optionally followed by '0', '1', .. '7'), or a
hexadecimal string (C<0x> followed by '0' .. '9', 'a' .. 'f', case
insensitive), or a binary string (C<0b> followed by a series of '0'
and '1').

=item f

Real number. For example C<3.14>, C<-6.23E24> and so on.

=back

The I<desttype> can be C<@> or C<%> to specify that the option is
list or a hash valued. This is only needed when the destination for
the option value is not otherwise specified. It should be omitted when
not needed.

The I<repeat> specifies the number of values this option takes per
occurrence on the command line. It has the format C<{> [ I<min> ] [ C<,> [ I<max> ] ] C<}>.

I<min> denotes the minimal number of arguments. It defaults to 1 for
options with C<=> and to 0 for options with C<:>, see below. Note that
I<min> overrules the C<=> / C<:> semantics.

I<max> denotes the maximum number of arguments. It must be at least
I<min>. If I<max> is omitted, I<but the comma is not>, there is no
upper bound to the number of argument values taken.

=item : I<type> [ I<desttype> ]

Like C<=>, but designates the argument as optional.
If omitted, an empty string will be assigned to string values options,
and the value zero to numeric options.

Note that if a string argument starts with C<-> or C<-->, it will be
considered an option on itself.

=item : I<number> [ I<desttype> ]

Like C<:i>, but if the value is omitted, the I<number> will be assigned.

=item : + [ I<desttype> ]

Like C<:i>, but if the value is omitted, the current value for the
option will be incremented.

=back

=head1 Advanced Possibilities

=head2 Object oriented interface

Getopt::Long can be used in an object oriented way as well:

    use Getopt::Long;
    $p = Getopt::Long::Parser->new;
    $p->configure(...configuration options...);
    if ($p->getoptions(...options descriptions...)) ...
    if ($p->getoptionsfromarray( \@array, ...options descriptions...)) ...

Configuration options can be passed to the constructor:

    $p = new Getopt::Long::Parser
             config => [...configuration options...];

=head2 Callback object

In version 2.37 the first argument to the callback function was
changed from string to object. This was done to make room for
extensions and more detailed control. The object stringifies to the
option name so this change should not introduce compatibility
problems.

The callback object has the following methods:

=over

=item name

The name of the option, unabbreviated. For an option with multiple
names it return the first (canonical) name.

=item given

The name of the option as actually used, unabbreveated.

=back

=head2 Thread Safety

Getopt::Long is thread safe when using ithreads as of Perl 5.8.  It is
I<not> thread safe when using the older (experimental and now
obsolete) threads implementation that was added to Perl 5.005.

=head2 Documentation and help texts

Getopt::Long encourages the use of Pod::Usage to produce help
messages. For example:

    use Getopt::Long;
    use Pod::Usage;

    my $man = 0;
    my $help = 0;

    GetOptions('help|?' => \$help, man => \$man) or pod2usage(2);
    pod2usage(1) if $help;
    pod2usage(-exitval => 0, -verbose => 2) if $man;

    __END__

    =head1 NAME

    sample - Using Getopt::Long and Pod::Usage

    =head1 SYNOPSIS

    sample [options] [file ...]

     Options:
       -help            brief help message
       -man             full documentation

    =head1 OPTIONS

    =over 8

    =item B<-help>

    Print a brief help message and exits.

    =item B<-man>

    Prints the manual page and exits.

    =back

    =head1 DESCRIPTION

    B<This program> will read the given input file(s) and do something
    useful with the contents thereof.

    =cut

See L<Pod::Usage> for details.

=head2 Parsing options from an arbitrary array

By default, GetOptions parses the options that are present in the
global array C<@ARGV>. A special entry C<GetOptionsFromArray> can be
used to parse options from an arbitrary array.

    use Getopt::Long qw(GetOptionsFromArray);
    $ret = GetOptionsFromArray(\@myopts, ...);

When used like this, options and their possible values are removed
from C<@myopts>, the global C<@ARGV> is not touched at all.

The following two calls behave identically:

    $ret = GetOptions( ... );
    $ret = GetOptionsFromArray(\@ARGV, ... );

This also means that a first argument hash reference now becomes the
second argument:

    $ret = GetOptions(\%opts, ... );
    $ret = GetOptionsFromArray(\@ARGV, \%opts, ... );

=head2 Parsing options from an arbitrary string

A special entry C<GetOptionsFromString> can be used to parse options
from an arbitrary string.

    use Getopt::Long qw(GetOptionsFromString);
    $ret = GetOptionsFromString($string, ...);

The contents of the string are split into arguments using a call to
C<Text::ParseWords::shellwords>. As with C<GetOptionsFromArray>, the
global C<@ARGV> is not touched.

It is possible that, upon completion, not all arguments in the string
have been processed. C<GetOptionsFromString> will, when called in list
context, return both the return status and an array reference to any
remaining arguments:

    ($ret, $args) = GetOptionsFromString($string, ... );

If any arguments remain, and C<GetOptionsFromString> was not called in
list context, a message will be given and C<GetOptionsFromString> will
return failure.

As with GetOptionsFromArray, a first argument hash reference now
becomes the second argument. See the next section.

=head2 Storing options values in a hash

Sometimes, for example when there are a lot of options, having a
separate variable for each of them can be cumbersome. GetOptions()
supports, as an alternative mechanism, storing options values in a
hash.

To obtain this, a reference to a hash must be passed I<as the first
argument> to GetOptions(). For each option that is specified on the
command line, the option value will be stored in the hash with the
option name as key. Options that are not actually used on the command
line will not be put in the hash, on other words,
C<exists($h{option})> (or defined()) can be used to test if an option
was used. The drawback is that warnings will be issued if the program
runs under C<use strict> and uses C<$h{option}> without testing with
exists() or defined() first.

    my %h = ();
    GetOptions (\%h, 'length=i');	# will store in $h{length}

For options that take list or hash values, it is necessary to indicate
this by appending an C<@> or C<%> sign after the type:

    GetOptions (\%h, 'colours=s@');	# will push to @{$h{colours}}

To make things more complicated, the hash may contain references to
the actual destinations, for example:

    my $len = 0;
    my %h = ('length' => \$len);
    GetOptions (\%h, 'length=i');	# will store in $len

This example is fully equivalent with:

    my $len = 0;
    GetOptions ('length=i' => \$len);	# will store in $len

Any mixture is possible. For example, the most frequently used options
could be stored in variables while all other options get stored in the
hash:

    my $verbose = 0;			# frequently referred
    my $debug = 0;			# frequently referred
    my %h = ('verbose' => \$verbose, 'debug' => \$debug);
    GetOptions (\%h, 'verbose', 'debug', 'filter', 'size=i');
    if ( $verbose ) { ... }
    if ( exists $h{filter} ) { ... option 'filter' was specified ... }

=head2 Bundling

With bundling it is possible to set several single-character options
at once. For example if C<a>, C<v> and C<x> are all valid options,

    -vax

will set all three.

Getopt::Long supports three styles of bundling. To enable bundling, a
call to Getopt::Long::Configure is required.

The simplest style of bundling can be enabled with:

    Getopt::Long::Configure ("bundling");

Configured this way, single-character options can be bundled but long
options (and any of their auto-abbreviated shortened forms) B<must>
always start with a double dash C<--> to avoid ambiguity. For example,
when C<vax>, C<a>, C<v> and C<x> are all valid options,

    -vax

will set C<a>, C<v> and C<x>, but

    --vax

will set C<vax>.

The second style of bundling lifts this restriction. It can be enabled
with:

    Getopt::Long::Configure ("bundling_override");

Now, C<-vax> will set the option C<vax>.

In all of the above cases, option values may be inserted in the
bundle. For example:

    -h24w80

is equivalent to

    -h 24 -w 80

A third style of bundling allows only values to be bundled with
options. It can be enabled with:

    Getopt::Long::Configure ("bundling_values");

Now, C<-h24> will set the option C<h> to C<24>, but option bundles
like C<-vxa> and C<-h24w80> are flagged as errors.

Enabling C<bundling_values> will disable the other two styles of
bundling.

When configured for bundling, single-character options are matched
case sensitive while long options are matched case insensitive. To
have the single-character options matched case insensitive as well,
use:

    Getopt::Long::Configure ("bundling", "ignorecase_always");

It goes without saying that bundling can be quite confusing.

=head2 The lonesome dash

Normally, a lone dash C<-> on the command line will not be considered
an option. Option processing will terminate (unless "permute" is
configured) and the dash will be left in C<@ARGV>.

It is possible to get special treatment for a lone dash. This can be
achieved by adding an option specification with an empty name, for
example:

    GetOptions ('' => \$stdio);

A lone dash on the command line will now be a legal option, and using
it will set variable C<$stdio>.

=head2 Argument callback

A special option 'name' C<< <> >> can be used to designate a subroutine
to handle non-option arguments. When GetOptions() encounters an
argument that does not look like an option, it will immediately call this
subroutine and passes it one parameter: the argument name.

For example:

    my $width = 80;
    sub process { ... }
    GetOptions ('width=i' => \$width, '<>' => \&process);

When applied to the following command line:

    arg1 --width=72 arg2 --width=60 arg3

This will call
C<process("arg1")> while C<$width> is C<80>,
C<process("arg2")> while C<$width> is C<72>, and
C<process("arg3")> while C<$width> is C<60>.

This feature requires configuration option B<permute>, see section
L<Configuring Getopt::Long>.

=head1 Configuring Getopt::Long

Getopt::Long can be configured by calling subroutine
Getopt::Long::Configure(). This subroutine takes a list of quoted
strings, each specifying a configuration option to be enabled, e.g.
C<ignore_case>. To disable, prefix with C<no> or C<no_>, e.g.
C<no_ignore_case>. Case does not matter. Multiple calls to Configure()
are possible.

Alternatively, as of version 2.24, the configuration options may be
passed together with the C<use> statement:

    use Getopt::Long qw(:config no_ignore_case bundling);

The following options are available:

=over 12

=item default

This option causes all configuration options to be reset to their
default values.

=item posix_default

This option causes all configuration options to be reset to their
default values as if the environment variable POSIXLY_CORRECT had
been set.

=item auto_abbrev

Allow option names to be abbreviated to uniqueness.
Default is enabled unless environment variable
POSIXLY_CORRECT has been set, in which case C<auto_abbrev> is disabled.

=item getopt_compat

Allow C<+> to start options.
Default is enabled unless environment variable
POSIXLY_CORRECT has been set, in which case C<getopt_compat> is disabled.

=item gnu_compat

C<gnu_compat> controls whether C<--opt=> is allowed, and what it should
do. Without C<gnu_compat>, C<--opt=> gives an error. With C<gnu_compat>,
C<--opt=> will give option C<opt> and empty value.
This is the way GNU getopt_long() does it.

Note that C<--opt value> is still accepted, even though GNU
getopt_long() doesn't.

=item gnu_getopt

This is a short way of setting C<gnu_compat> C<bundling> C<permute>
C<no_getopt_compat>. With C<gnu_getopt>, command line handling should be
reasonably compatible with GNU getopt_long().

=item require_order

Whether command line arguments are allowed to be mixed with options.
Default is disabled unless environment variable
POSIXLY_CORRECT has been set, in which case C<require_order> is enabled.

See also C<permute>, which is the opposite of C<require_order>.

=item permute

Whether command line arguments are allowed to be mixed with options.
Default is enabled unless environment variable
POSIXLY_CORRECT has been set, in which case C<permute> is disabled.
Note that C<permute> is the opposite of C<require_order>.

If C<permute> is enabled, this means that

    --foo arg1 --bar arg2 arg3

is equivalent to

    --foo --bar arg1 arg2 arg3

If an argument callback routine is specified, C<@ARGV> will always be
empty upon successful return of GetOptions() since all options have been
processed. The only exception is when C<--> is used:

    --foo arg1 --bar arg2 -- arg3

This will call the callback routine for arg1 and arg2, and then
terminate GetOptions() leaving C<"arg3"> in C<@ARGV>.

If C<require_order> is enabled, options processing
terminates when the first non-option is encountered.

    --foo arg1 --bar arg2 arg3

is equivalent to

    --foo -- arg1 --bar arg2 arg3

If C<pass_through> is also enabled, options processing will terminate
at the first unrecognized option, or non-option, whichever comes
first.

=item bundling (default: disabled)

Enabling this option will allow single-character options to be
bundled. To distinguish bundles from long option names, long options
(and any of their auto-abbreviated shortened forms) I<must> be
introduced with C<--> and bundles with C<->.

Note that, if you have options C<a>, C<l> and C<all>, and
auto_abbrev enabled, possible arguments and option settings are:

    using argument               sets option(s)
    ------------------------------------------
    -a, --a                      a
    -l, --l                      l
    -al, -la, -ala, -all,...     a, l
    --al, --all                  all

The surprising part is that C<--a> sets option C<a> (due to auto
completion), not C<all>.

Note: disabling C<bundling> also disables C<bundling_override>.

=item bundling_override (default: disabled)

If C<bundling_override> is enabled, bundling is enabled as with
C<bundling> but now long option names override option bundles.

Note: disabling C<bundling_override> also disables C<bundling>.

B<Note:> Using option bundling can easily lead to unexpected results,
especially when mixing long options and bundles. Caveat emptor.

=item ignore_case  (default: enabled)

If enabled, case is ignored when matching option names. If, however,
bundling is enabled as well, single character options will be treated
case-sensitive.

With C<ignore_case>, option specifications for options that only
differ in case, e.g., C<"foo"> and C<"Foo">, will be flagged as
duplicates.

Note: disabling C<ignore_case> also disables C<ignore_case_always>.

=item ignore_case_always (default: disabled)

When bundling is in effect, case is ignored on single-character
options also.

Note: disabling C<ignore_case_always> also disables C<ignore_case>.

=item auto_version (default:disabled)

Automatically provide support for the B<--version> option if
the application did not specify a handler for this option itself.

Getopt::Long will provide a standard version message that includes the
program name, its version (if $main::VERSION is defined), and the
versions of Getopt::Long and Perl. The message will be written to
standard output and processing will terminate.

C<auto_version> will be enabled if the calling program explicitly
specified a version number higher than 2.32 in the C<use> or
C<require> statement.

=item auto_help (default:disabled)

Automatically provide support for the B<--help> and B<-?> options if
the application did not specify a handler for this option itself.

Getopt::Long will provide a help message using module L<Pod::Usage>. The
message, derived from the SYNOPSIS POD section, will be written to
standard output and processing will terminate.

C<auto_help> will be enabled if the calling program explicitly
specified a version number higher than 2.32 in the C<use> or
C<require> statement.

=item pass_through (default: disabled)

With C<pass_through> anything that is unknown, ambiguous or supplied with
an invalid option will not be flagged as an error. Instead the unknown
option(s) will be passed to the catchall C<< <> >> if present, otherwise
through to C<@ARGV>. This makes it possible to write wrapper scripts that
process only part of the user supplied command line arguments, and pass the
remaining options to some other program.

If C<require_order> is enabled, options processing will terminate at the
first unrecognized option, or non-option, whichever comes first and all
remaining arguments are passed to C<@ARGV> instead of the catchall
C<< <> >> if present.  However, if C<permute> is enabled instead, results
can become confusing.

Note that the options terminator (default C<-->), if present, will
also be passed through in C<@ARGV>.

=item prefix

The string that starts options. If a constant string is not
sufficient, see C<prefix_pattern>.

=item prefix_pattern

A Perl pattern that identifies the strings that introduce options.
Default is C<--|-|\+> unless environment variable
POSIXLY_CORRECT has been set, in which case it is C<--|->.

=item long_prefix_pattern

A Perl pattern that allows the disambiguation of long and short
prefixes. Default is C<-->.

Typically you only need to set this if you are using nonstandard
prefixes and want some or all of them to have the same semantics as
'--' does under normal circumstances.

For example, setting prefix_pattern to C<--|-|\+|\/> and
long_prefix_pattern to C<--|\/> would add Win32 style argument
handling.

=item debug (default: disabled)

Enable debugging output.

=back

=head1 Exportable Methods

=over

=item VersionMessage

This subroutine provides a standard version message. Its argument can be:

=over 4

=item *

A string containing the text of a message to print I<before> printing
the standard message.

=item *

A numeric value corresponding to the desired exit status.

=item *

A reference to a hash.

=back

If more than one argument is given then the entire argument list is
assumed to be a hash.  If a hash is supplied (either as a reference or
as a list) it should contain one or more elements with the following
keys:

=over 4

=item C<-message>

=item C<-msg>

The text of a message to print immediately prior to printing the
program's usage message.

=item C<-exitval>

The desired exit status to pass to the B<exit()> function.
This should be an integer, or else the string "NOEXIT" to
indicate that control should simply be returned without
terminating the invoking process.

=item C<-output>

A reference to a filehandle, or the pathname of a file to which the
usage message should be written. The default is C<\*STDERR> unless the
exit value is less than 2 (in which case the default is C<\*STDOUT>).

=back

You cannot tie this routine directly to an option, e.g.:

    GetOptions("version" => \&VersionMessage);

Use this instead:

    GetOptions("version" => sub { VersionMessage() });

=item HelpMessage

This subroutine produces a standard help message, derived from the
program's POD section SYNOPSIS using L<Pod::Usage>. It takes the same
arguments as VersionMessage(). In particular, you cannot tie it
directly to an option, e.g.:

    GetOptions("help" => \&HelpMessage);

Use this instead:

    GetOptions("help" => sub { HelpMessage() });

=back

=head1 Return values and Errors

Configuration errors and errors in the option definitions are
signalled using die() and will terminate the calling program unless
the call to Getopt::Long::GetOptions() was embedded in C<eval { ...
}>, or die() was trapped using C<$SIG{__DIE__}>.

GetOptions returns true to indicate success.
It returns false when the function detected one or more errors during
option parsing. These errors are signalled using warn() and can be
trapped with C<$SIG{__WARN__}>.

=head1 Legacy

The earliest development of C<newgetopt.pl> started in 1990, with Perl
version 4. As a result, its development, and the development of
Getopt::Long, has gone through several stages. Since backward
compatibility has always been extremely important, the current version
of Getopt::Long still supports a lot of constructs that nowadays are
no longer necessary or otherwise unwanted. This section describes
briefly some of these 'features'.

=head2 Default destinations

When no destination is specified for an option, GetOptions will store
the resultant value in a global variable named C<opt_>I<XXX>, where
I<XXX> is the primary name of this option. When a program executes
under C<use strict> (recommended), these variables must be
pre-declared with our() or C<use vars>.

    our $opt_length = 0;
    GetOptions ('length=i');	# will store in $opt_length

To yield a usable Perl variable, characters that are not part of the
syntax for variables are translated to underscores. For example,
C<--fpp-struct-return> will set the variable
C<$opt_fpp_struct_return>. Note that this variable resides in the
namespace of the calling program, not necessarily C<main>. For
example:

    GetOptions ("size=i", "sizes=i@");

with command line "-size 10 -sizes 24 -sizes 48" will perform the
equivalent of the assignments

    $opt_size = 10;
    @opt_sizes = (24, 48);

=head2 Alternative option starters

A string of alternative option starter characters may be passed as the
first argument (or the first argument after a leading hash reference
argument).

    my $len = 0;
    GetOptions ('/', 'length=i' => $len);

Now the command line may look like:

    /length 24 -- arg

Note that to terminate options processing still requires a double dash
C<-->.

GetOptions() will not interpret a leading C<< "<>" >> as option starters
if the next argument is a reference. To force C<< "<" >> and C<< ">" >> as
option starters, use C<< "><" >>. Confusing? Well, B<using a starter
argument is strongly deprecated> anyway.

=head2 Configuration variables

Previous versions of Getopt::Long used variables for the purpose of
configuring. Although manipulating these variables still work, it is
strongly encouraged to use the C<Configure> routine that was introduced
in version 2.17. Besides, it is much easier.

=head1 Tips and Techniques

=head2 Pushing multiple values in a hash option

Sometimes you want to combine the best of hashes and arrays. For
example, the command line:

  --list add=first --list add=second --list add=third

where each successive 'list add' option will push the value of add
into array ref $list->{'add'}. The result would be like

  $list->{add} = [qw(first second third)];

This can be accomplished with a destination routine:

  GetOptions('list=s%' =>
               sub { push(@{$list{$_[1]}}, $_[2]) });

=head1 Troubleshooting

=head2 GetOptions does not return a false result when an option is not supplied

That's why they're called 'options'.

=head2 GetOptions does not split the command line correctly

The command line is not split by GetOptions, but by the command line
interpreter (CLI). On Unix, this is the shell. On Windows, it is
COMMAND.COM or CMD.EXE. Other operating systems have other CLIs.

It is important to know that these CLIs may behave different when the
command line contains special characters, in particular quotes or
backslashes. For example, with Unix shells you can use single quotes
(C<'>) and double quotes (C<">) to group words together. The following
alternatives are equivalent on Unix:

    "two words"
    'two words'
    two\ words

In case of doubt, insert the following statement in front of your Perl
program:

    print STDERR (join("|",@ARGV),"\n");

to verify how your CLI passes the arguments to the program.

=head2 Undefined subroutine &main::GetOptions called

Are you running Windows, and did you write

    use GetOpt::Long;

(note the capital 'O')?

=head2 How do I put a "-?" option into a Getopt::Long?

You can only obtain this using an alias, and Getopt::Long of at least
version 2.13.

    use Getopt::Long;
    GetOptions ("help|?");    # -help and -? will both set $opt_help

Other characters that can't appear in Perl identifiers are also
supported in aliases with Getopt::Long of at version 2.39. Note that
the characters C<!>, C<|>, C<+>, C<=>, and C<:> can only appear as the
first (or only) character of an alias.

As of version 2.32 Getopt::Long provides auto-help, a quick and easy way
to add the options --help and -? to your program, and handle them.

See C<auto_help> in section L<Configuring Getopt::Long>.

=head1 AUTHOR

Johan Vromans <jvromans@squirrel.nl>

=head1 COPYRIGHT AND DISCLAIMER

This program is Copyright 1990,2015 by Johan Vromans.
This program is free software; you can redistribute it and/or
modify it under the terms of the Perl Artistic License or the
GNU General Public License as published by the Free Software
Foundation; either version 2 of the License, or (at your option) any
later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

If you do not have a copy of the GNU General Public License write to
the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
MA 02139, USA.

=cut

PK       ! ~�Լ�5  �5    perl5/Test2/Formatter/TAP.pmnu ��6�$        package Test2::Formatter::TAP;
use strict;
use warnings;

our $VERSION = '1.302183';

use Test2::Util qw/clone_io/;

use Test2::Util::HashBase qw{
    no_numbers handles _encoding _last_fh
    -made_assertion
};

sub OUT_STD() { 0 }
sub OUT_ERR() { 1 }

BEGIN { require Test2::Formatter; our @ISA = qw(Test2::Formatter) }

my $supports_tables;
sub supports_tables {
    if (!defined $supports_tables) {
        local $SIG{__DIE__} = 'DEFAULT';
        local $@;
        $supports_tables
            = ($INC{'Term/Table.pm'} && $INC{'Term/Table/Util.pm'})
            || eval { require Term::Table; require Term::Table::Util; 1 }
            || 0;
    }
    return $supports_tables;
}

sub _autoflush {
    my($fh) = pop;
    my $old_fh = select $fh;
    $| = 1;
    select $old_fh;
}

_autoflush(\*STDOUT);
_autoflush(\*STDERR);

sub hide_buffered { 1 }

sub init {
    my $self = shift;

    $self->{+HANDLES} ||= $self->_open_handles;
    if(my $enc = delete $self->{encoding}) {
        $self->encoding($enc);
    }
}

sub _open_handles {
    my $self = shift;

    require Test2::API;
    my $out = clone_io(Test2::API::test2_stdout());
    my $err = clone_io(Test2::API::test2_stderr());

    _autoflush($out);
    _autoflush($err);

    return [$out, $err];
}

sub encoding {
    my $self = shift;

    if ($] ge "5.007003" and @_) {
        my ($enc) = @_;
        my $handles = $self->{+HANDLES};

        # https://rt.perl.org/Public/Bug/Display.html?id=31923
        # If utf8 is requested we use ':utf8' instead of ':encoding(utf8)' in
        # order to avoid the thread segfault.
        if ($enc =~ m/^utf-?8$/i) {
            binmode($_, ":utf8") for @$handles;
        }
        else {
            binmode($_, ":encoding($enc)") for @$handles;
        }
        $self->{+_ENCODING} = $enc;
    }

    return $self->{+_ENCODING};
}

if ($^C) {
    no warnings 'redefine';
    *write = sub {};
}
sub write {
    my ($self, $e, $num, $f) = @_;

    # The most common case, a pass event with no amnesty and a normal name.
    return if $self->print_optimal_pass($e, $num);

    $f ||= $e->facet_data;

    $self->encoding($f->{control}->{encoding}) if $f->{control}->{encoding};

    my @tap = $self->event_tap($f, $num) or return;

    $self->{+MADE_ASSERTION} = 1 if $f->{assert};

    my $nesting = $f->{trace}->{nested} || 0;
    my $handles = $self->{+HANDLES};
    my $indent = '    ' x $nesting;

    # Local is expensive! Only do it if we really need to.
    local($\, $,) = (undef, '') if $\ || $,;
    for my $set (@tap) {
        no warnings 'uninitialized';
        my ($hid, $msg) = @$set;
        next unless $msg;
        my $io = $handles->[$hid] or next;

        print $io "\n"
            if $ENV{HARNESS_ACTIVE}
            && $hid == OUT_ERR
            && $self->{+_LAST_FH} != $io
            && $msg =~ m/^#\s*Failed( \(TODO\))? test /;

        $msg =~ s/^/$indent/mg if $nesting;
        print $io $msg;
        $self->{+_LAST_FH} = $io;
    }
}

sub print_optimal_pass {
    my ($self, $e, $num) = @_;

    my $type = ref($e);

    # Only optimal if this is a Pass or a passing Ok
    return unless $type eq 'Test2::Event::Pass' || ($type eq 'Test2::Event::Ok' && $e->{pass});

    # Amnesty requires further processing (todo is a form of amnesty)
    return if ($e->{amnesty} && @{$e->{amnesty}}) || defined($e->{todo});

    # A name with a newline or hash symbol needs extra processing
    return if defined($e->{name}) && (-1 != index($e->{name}, "\n") || -1 != index($e->{name}, '#'));

    my $ok = 'ok';
    $ok .= " $num" if $num && !$self->{+NO_NUMBERS};
    $ok .= defined($e->{name}) ? " - $e->{name}\n" : "\n";

    if (my $nesting = $e->{trace}->{nested}) {
        my $indent = '    ' x $nesting;
        $ok = "$indent$ok";
    }

    my $io = $self->{+HANDLES}->[OUT_STD];

    local($\, $,) = (undef, '') if $\ || $,;
    print $io $ok;
    $self->{+_LAST_FH} = $io;

    return 1;
}

sub event_tap {
    my ($self, $f, $num) = @_;

    my @tap;

    # If this IS the first event the plan should come first
    # (plan must be before or after assertions, not in the middle)
    push @tap => $self->plan_tap($f) if $f->{plan} && !$self->{+MADE_ASSERTION};

    # The assertion is most important, if present.
    if ($f->{assert}) {
        push @tap => $self->assert_tap($f, $num);
        push @tap => $self->debug_tap($f, $num) unless $f->{assert}->{no_debug} || $f->{assert}->{pass};
    }

    # Almost as important as an assertion
    push @tap => $self->error_tap($f) if $f->{errors};

    # Now lets see the diagnostics messages
    push @tap => $self->info_tap($f) if $f->{info};

    # If this IS NOT the first event the plan should come last
    # (plan must be before or after assertions, not in the middle)
    push @tap => $self->plan_tap($f) if $self->{+MADE_ASSERTION} && $f->{plan};

    # Bail out
    push @tap => $self->halt_tap($f) if $f->{control}->{halt};

    return @tap if @tap;
    return @tap if $f->{control}->{halt};
    return @tap if grep { $f->{$_} } qw/assert plan info errors/;

    # Use the summary as a fallback if nothing else is usable.
    return $self->summary_tap($f, $num);
}

sub error_tap {
    my $self = shift;
    my ($f) = @_;

    my $IO = ($f->{amnesty} && @{$f->{amnesty}}) ? OUT_STD : OUT_ERR;

    return map {
        my $details = $_->{details};

        my $msg;
        if (ref($details)) {
            require Data::Dumper;
            my $dumper = Data::Dumper->new([$details])->Indent(2)->Terse(1)->Pad('# ')->Useqq(1)->Sortkeys(1);
            chomp($msg = $dumper->Dump);
        }
        else {
            chomp($msg = $details);
            $msg =~ s/^/# /;
            $msg =~ s/\n/\n# /g;
        }

        [$IO, "$msg\n"];
    } @{$f->{errors}};
}

sub plan_tap {
    my $self = shift;
    my ($f) = @_;
    my $plan = $f->{plan} or return;

    return if $plan->{none};

    if ($plan->{skip}) {
        my $reason = $plan->{details} or return [OUT_STD, "1..0 # SKIP\n"];
        chomp($reason);
        return [OUT_STD, '1..0 # SKIP ' . $reason . "\n"];
    }

    return [OUT_STD, "1.." . $plan->{count} . "\n"];
}

sub no_subtest_space { 0 }
sub assert_tap {
    my $self = shift;
    my ($f, $num) = @_;

    my $assert = $f->{assert} or return;
    my $pass = $assert->{pass};
    my $name = $assert->{details};

    my $ok = $pass ? 'ok' : 'not ok';
    $ok .= " $num" if $num && !$self->{+NO_NUMBERS};

    # The regex form is ~250ms, the index form is ~50ms
    my @extra;
    defined($name) && (
        (index($name, "\n") != -1 && (($name, @extra) = split(/\n\r?/, $name, -1))),
        ((index($name, "#" ) != -1  || substr($name, -1) eq '\\') && (($name =~ s|\\|\\\\|g), ($name =~ s|#|\\#|g)))
    );

    my $extra_space = @extra ? ' ' x (length($ok) + 2) : '';
    my $extra_indent = '';

    my ($directives, $reason, $is_skip);
    if ($f->{amnesty}) {
        my %directives;

        for my $am (@{$f->{amnesty}}) {
            next if $am->{inherited};
            my $tag = $am->{tag} or next;
            $is_skip = 1 if $tag eq 'skip';

            $directives{$tag} ||= $am->{details};
        }

        my %seen;

        # Sort so that TODO comes before skip even on systems where lc sorts
        # before uc, as other code depends on that ordering.
        my @order = grep { !$seen{$_}++ } sort { lc $b cmp lc $a } keys %directives;

        $directives = ' # ' . join ' & ' => @order;

        for my $tag ('skip', @order) {
            next unless defined($directives{$tag}) && length($directives{$tag});
            $reason = $directives{$tag};
            last;
        }
    }

    $ok .= " - $name" if defined $name && !($is_skip && !$name);

    my @subtap;
    if ($f->{parent} && $f->{parent}->{buffered}) {
        $ok .= ' {';

        # In a verbose harness we indent the extra since they will appear
        # inside the subtest braces. This helps readability. In a non-verbose
        # harness we do not do this because it is less readable.
        if ($ENV{HARNESS_IS_VERBOSE} || !$ENV{HARNESS_ACTIVE}) {
            $extra_indent = "    ";
            $extra_space = ' ';
        }

        # Render the sub-events, we use our own counter for these.
        my $count = 0;
        @subtap = map {
            my $f2 = $_;

            # Bump the count for any event that should bump it.
            $count++ if $f2->{assert};

            # This indents all output lines generated for the sub-events.
            # index 0 is the filehandle, index 1 is the message we want to indent.
            map { $_->[1] =~ s/^(.*\S.*)$/    $1/mg; $_ } $self->event_tap($f2, $count);
        } @{$f->{parent}->{children}};

        push @subtap => [OUT_STD, "}\n"];
    }

    if ($directives) {
        $directives = ' # TODO & SKIP' if $directives eq ' # TODO & skip';
        $ok .= $directives;
        $ok .= " $reason" if defined($reason);
    }

    $extra_space = ' ' if $self->no_subtest_space;

    my @out = ([OUT_STD, "$ok\n"]);
    push @out => map {[OUT_STD, "${extra_indent}#${extra_space}$_\n"]} @extra if @extra;
    push @out => @subtap;

    return @out;
}

sub debug_tap {
    my ($self, $f, $num) = @_;

    # Figure out the debug info, this is typically the file name and line
    # number, but can also be a custom message. If no trace object is provided
    # then we have nothing useful to display.
    my $name  = $f->{assert}->{details};
    my $trace = $f->{trace};

    my $debug = "[No trace info available]";
    if ($trace->{details}) {
        $debug = $trace->{details};
    }
    elsif ($trace->{frame}) {
        my ($pkg, $file, $line) = @{$trace->{frame}};
        $debug = "at $file line $line." if $file && $line;
    }

    my $amnesty = $f->{amnesty} && @{$f->{amnesty}}
        ? ' (with amnesty)'
        : '';

    # Create the initial diagnostics. If the test has a name we put the debug
    # info on a second line, this behavior is inherited from Test::Builder.
    my $msg = defined($name)
        ? qq[# Failed test${amnesty} '$name'\n# $debug\n]
        : qq[# Failed test${amnesty} $debug\n];

    my $IO = $f->{amnesty} && @{$f->{amnesty}} ? OUT_STD : OUT_ERR;

    return [$IO, $msg];
}

sub halt_tap {
    my ($self, $f) = @_;

    return if $f->{trace}->{nested} && !$f->{trace}->{buffered};
    my $details = $f->{control}->{details};

    return [OUT_STD, "Bail out!\n"] unless defined($details) && length($details);
    return [OUT_STD, "Bail out!  $details\n"];
}

sub info_tap {
    my ($self, $f) = @_;

    return map {
        my $details = $_->{details};
        my $table   = $_->{table};

        my $IO = $_->{debug} && !($f->{amnesty} && @{$f->{amnesty}}) ? OUT_ERR : OUT_STD;

        my $msg;
        if ($table && $self->supports_tables) {
            $msg = join "\n" => map { "# $_" } Term::Table->new(
                header      => $table->{header},
                rows        => $table->{rows},
                collapse    => $table->{collapse},
                no_collapse => $table->{no_collapse},
                sanitize    => 1,
                mark_tail   => 1,
                max_width   => $self->calc_table_size($f),
            )->render();
        }
        elsif (ref($details)) {
            require Data::Dumper;
            my $dumper = Data::Dumper->new([$details])->Indent(2)->Terse(1)->Pad('# ')->Useqq(1)->Sortkeys(1);
            chomp($msg = $dumper->Dump);
        }
        else {
            chomp($msg = $details);
            $msg =~ s/^/# /;
            $msg =~ s/\n/\n# /g;
        }

        [$IO, "$msg\n"];
    } @{$f->{info}};
}

sub summary_tap {
    my ($self, $f, $num) = @_;

    return if $f->{about}->{no_display};

    my $summary = $f->{about}->{details} or return;
    chomp($summary);
    $summary =~ s/^/# /smg;

    return [OUT_STD, "$summary\n"];
}

sub calc_table_size {
    my $self = shift;
    my ($f) = @_;

    my $term = Term::Table::Util::term_size();
    my $nesting = 2 + (($f->{trace}->{nested} || 0) * 4); # 4 spaces per level, also '# ' prefix
    my $total = $term - $nesting;

    # Sane minimum width, any smaller and we are asking for pain
    return 50 if $total < 50;

    return $total;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::Formatter::TAP - Standard TAP formatter

=head1 DESCRIPTION

This is what takes events and turns them into TAP.

=head1 SYNOPSIS

    use Test2::Formatter::TAP;
    my $tap = Test2::Formatter::TAP->new();

    # Switch to utf8
    $tap->encoding('utf8');

    $tap->write($event, $number); # Output an event

=head1 METHODS

=over 4

=item $bool = $tap->no_numbers

=item $tap->set_no_numbers($bool)

Use to turn numbers on and off.

=item $arrayref = $tap->handles

=item $tap->set_handles(\@handles);

Can be used to get/set the filehandles. Indexes are identified by the
C<OUT_STD> and C<OUT_ERR> constants.

=item $encoding = $tap->encoding

=item $tap->encoding($encoding)

Get or set the encoding. By default no encoding is set, the original settings
of STDOUT and STDERR are used.

This directly modifies the stored filehandles, it does not create new ones.

=item $tap->write($e, $num)

Write an event to the console.

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=item Kent Fredric E<lt>kentnl@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! ��.)  )    perl5/Test2/Util.pmnu ��6�$        package Test2::Util;
use strict;
use warnings;

our $VERSION = '1.302183';

use POSIX();
use Config qw/%Config/;
use Carp qw/croak/;

BEGIN {
    local ($@, $!, $SIG{__DIE__});
    *HAVE_PERLIO = eval { require PerlIO; PerlIO->VERSION(1.02); } ? sub() { 1 } : sub() { 0 };
}

our @EXPORT_OK = qw{
    try

    pkg_to_file

    get_tid USE_THREADS
    CAN_THREAD
    CAN_REALLY_FORK
    CAN_FORK

    CAN_SIGSYS

    IS_WIN32

    ipc_separator

    gen_uid

    do_rename do_unlink

    try_sig_mask

    clone_io
};
BEGIN { require Exporter; our @ISA = qw(Exporter) }

BEGIN {
    *IS_WIN32 = ($^O eq 'MSWin32') ? sub() { 1 } : sub() { 0 };
}

sub _can_thread {
    return 0 unless $] >= 5.008001;
    return 0 unless $Config{'useithreads'};

    # Threads are broken on perl 5.10.0 built with gcc 4.8+
    if ($] == 5.010000 && $Config{'ccname'} eq 'gcc' && $Config{'gccversion'}) {
        my @parts = split /\./, $Config{'gccversion'};
        return 0 if $parts[0] > 4 || ($parts[0] == 4 && $parts[1] >= 8);
    }

    # Change to a version check if this ever changes
    return 0 if $INC{'Devel/Cover.pm'};
    return 1;
}

sub _can_fork {
    return 1 if $Config{d_fork};
    return 0 unless IS_WIN32 || $^O eq 'NetWare';
    return 0 unless $Config{useithreads};
    return 0 unless $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/;

    return _can_thread();
}

BEGIN {
    no warnings 'once';
    *CAN_THREAD      = _can_thread()   ? sub() { 1 } : sub() { 0 };
}
my $can_fork;
sub CAN_FORK () {
    return $can_fork
        if defined $can_fork;
    $can_fork = !!_can_fork();
    no warnings 'redefine';
    *CAN_FORK = $can_fork ? sub() { 1 } : sub() { 0 };
    $can_fork;
}
my $can_really_fork;
sub CAN_REALLY_FORK () {
    return $can_really_fork
        if defined $can_really_fork;
    $can_really_fork = !!$Config{d_fork};
    no warnings 'redefine';
    *CAN_REALLY_FORK = $can_really_fork ? sub() { 1 } : sub() { 0 };
    $can_really_fork;
}

sub _manual_try(&;@) {
    my $code = shift;
    my $args = \@_;
    my $err;

    my $die = delete $SIG{__DIE__};

    eval { $code->(@$args); 1 } or $err = $@ || "Error was squashed!\n";

    $die ? $SIG{__DIE__} = $die : delete $SIG{__DIE__};

    return (!defined($err), $err);
}

sub _local_try(&;@) {
    my $code = shift;
    my $args = \@_;
    my $err;

    no warnings;
    local $SIG{__DIE__};
    eval { $code->(@$args); 1 } or $err = $@ || "Error was squashed!\n";

    return (!defined($err), $err);
}

# Older versions of perl have a nasty bug on win32 when localizing a variable
# before forking or starting a new thread. So for those systems we use the
# non-local form. When possible though we use the faster 'local' form.
BEGIN {
    if (IS_WIN32 && $] < 5.020002) {
        *try = \&_manual_try;
    }
    else {
        *try = \&_local_try;
    }
}

BEGIN {
    if (CAN_THREAD) {
        if ($INC{'threads.pm'}) {
            # Threads are already loaded, so we do not need to check if they
            # are loaded each time
            *USE_THREADS = sub() { 1 };
            *get_tid     = sub() { threads->tid() };
        }
        else {
            # :-( Need to check each time to see if they have been loaded.
            *USE_THREADS = sub() { $INC{'threads.pm'} ? 1 : 0 };
            *get_tid     = sub() { $INC{'threads.pm'} ? threads->tid() : 0 };
        }
    }
    else {
        # No threads, not now, not ever!
        *USE_THREADS = sub() { 0 };
        *get_tid     = sub() { 0 };
    }
}

sub pkg_to_file {
    my $pkg = shift;
    my $file = $pkg;
    $file =~ s{(::|')}{/}g;
    $file .= '.pm';
    return $file;
}

sub ipc_separator() { "~" }

my $UID = 1;
sub gen_uid() { join ipc_separator() => ($$, get_tid(), time, $UID++) }

sub _check_for_sig_sys {
    my $sig_list = shift;
    return $sig_list =~ m/\bSYS\b/;
}

BEGIN {
    if (_check_for_sig_sys($Config{sig_name})) {
        *CAN_SIGSYS = sub() { 1 };
    }
    else {
        *CAN_SIGSYS = sub() { 0 };
    }
}

my %PERLIO_SKIP = (
    unix => 1,
    via  => 1,
);

sub clone_io {
    my ($fh) = @_;
    my $fileno = eval { fileno($fh) };

    return $fh if !defined($fileno) || !length($fileno) || $fileno < 0;

    open(my $out, '>&' . $fileno) or die "Can't dup fileno $fileno: $!";

    my %seen;
    my @layers = HAVE_PERLIO ? grep { !$PERLIO_SKIP{$_} and !$seen{$_}++ } PerlIO::get_layers($fh) : ();
    binmode($out, join(":", "", "raw", @layers));

    my $old = select $fh;
    my $af  = $|;
    select $out;
    $| = $af;
    select $old;

    return $out;
}

BEGIN {
    if (IS_WIN32) {
        my $max_tries = 5;

        *do_rename = sub {
            my ($from, $to) = @_;

            my $err;
            for (1 .. $max_tries) {
                return (1) if rename($from, $to);
                $err = "$!";
                last if $_ == $max_tries;
                sleep 1;
            }

            return (0, $err);
        };
        *do_unlink = sub {
            my ($file) = @_;

            my $err;
            for (1 .. $max_tries) {
                return (1) if unlink($file);
                $err = "$!";
                last if $_ == $max_tries;
                sleep 1;
            }

            return (0, "$!");
        };
    }
    else {
        *do_rename = sub {
            my ($from, $to) = @_;
            return (1) if rename($from, $to);
            return (0, "$!");
        };
        *do_unlink = sub {
            my ($file) = @_;
            return (1) if unlink($file);
            return (0, "$!");
        };
    }
}

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

    my ($old, $blocked);
    unless(IS_WIN32) {
        my $to_block = POSIX::SigSet->new(
            POSIX::SIGINT(),
            POSIX::SIGALRM(),
            POSIX::SIGHUP(),
            POSIX::SIGTERM(),
            POSIX::SIGUSR1(),
            POSIX::SIGUSR2(),
        );
        $old = POSIX::SigSet->new;
        $blocked = POSIX::sigprocmask(POSIX::SIG_BLOCK(), $to_block, $old);
        # Silently go on if we failed to log signals, not much we can do.
    }

    my ($ok, $err) = &try($code);

    # If our block was successful we want to restore the old mask.
    POSIX::sigprocmask(POSIX::SIG_SETMASK(), $old, POSIX::SigSet->new()) if defined $blocked;

    return ($ok, $err);
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::Util - Tools used by Test2 and friends.

=head1 DESCRIPTION

Collection of tools used by L<Test2> and friends.

=head1 EXPORTS

All exports are optional. You must specify subs to import.

=over 4

=item ($success, $error) = try { ... }

Eval the codeblock, return success or failure, and the error message. This code
protects $@ and $!, they will be restored by the end of the run. This code also
temporarily blocks $SIG{DIE} handlers.

=item protect { ... }

Similar to try, except that it does not catch exceptions. The idea here is to
protect $@ and $! from changes. $@ and $! will be restored to whatever they
were before the run so long as it is successful. If the run fails $! will still
be restored, but $@ will contain the exception being thrown.

=item CAN_FORK

True if this system is capable of true or pseudo-fork.

=item CAN_REALLY_FORK

True if the system can really fork. This will be false for systems where fork
is emulated.

=item CAN_THREAD

True if this system is capable of using threads.

=item USE_THREADS

Returns true if threads are enabled, false if they are not.

=item get_tid

This will return the id of the current thread when threads are enabled,
otherwise it returns 0.

=item my $file = pkg_to_file($package)

Convert a package name to a filename.

=item $string = ipc_separator()

Get the IPC separator. Currently this is always the string C<'~'>.

=item $string = gen_uid()

Generate a unique id (NOT A UUID). This will typically be the process id, the
thread id, the time, and an incrementing integer all joined with the
C<ipc_separator()>.

These ID's are unique enough for most purposes. For identical ids to be
generated you must have 2 processes with the same PID generate IDs at the same
time with the same current state of the incrementing integer. This is a
perfectly reasonable thing to expect to happen across multiple machines, but is
quite unlikely to happen on one machine.

This can fail to be unique if a process generates an id, calls exec, and does
it again after the exec and it all happens in less than a second. It can also
happen if the systems process id's cycle in less than a second allowing 2
different programs that use this generator to run with the same PID in less
than a second. Both these cases are sufficiently unlikely. If you need
universally unique ids, or ids that are unique in these conditions, look at
L<Data::UUID>.

=item ($ok, $err) = do_rename($old_name, $new_name)

Rename a file, this wraps C<rename()> in a way that makes it more reliable
cross-platform when trying to rename files you recently altered.

=item ($ok, $err) = do_unlink($filename)

Unlink a file, this wraps C<unlink()> in a way that makes it more reliable
cross-platform when trying to unlink files you recently altered.

=item ($ok, $err) = try_sig_mask { ... }

Complete an action with several signals masked, they will be unmasked at the
end allowing any signals that were intercepted to get handled.

This is primarily used when you need to make several actions atomic (against
some signals anyway).

Signals that are intercepted:

=over 4

=item SIGINT

=item SIGALRM

=item SIGHUP

=item SIGTERM

=item SIGUSR1

=item SIGUSR2

=back

=back

=head1 NOTES && CAVEATS

=over 4

=item 5.10.0

Perl 5.10.0 has a bug when compiled with newer gcc versions. This bug causes a
segfault whenever a new thread is launched. Test2 will attempt to detect
this, and note that the system is not capable of forking when it is detected.

=item Devel::Cover

Devel::Cover does not support threads. CAN_THREAD will return false if
Devel::Cover is loaded before the check is first run.

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=item Kent Fredric E<lt>kentnl@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! �5�z  z    perl5/Test2/IPC/Driver.pmnu ��6�$        package Test2::IPC::Driver;
use strict;
use warnings;

our $VERSION = '1.302183';


use Carp qw/confess/;
use Test2::Util::HashBase qw{no_fatal no_bail};

use Test2::API qw/test2_ipc_add_driver/;

my %ADDED;
sub import {
    my $class = shift;
    return if $class eq __PACKAGE__;
    return if $ADDED{$class}++;
    test2_ipc_add_driver($class);
}

sub pending { -1 }
sub set_pending { -1 }

for my $meth (qw/send cull add_hub drop_hub waiting is_viable/) {
    no strict 'refs';
    *$meth = sub {
        my $thing = shift;
        confess "'$thing' did not define the required method '$meth'."
    };
}

# Print the error and call exit. We are not using 'die' cause this is a
# catastrophic error that should never be caught. If we get here it
# means some serious shit has happened in a child process, the only way
# to inform the parent may be to exit false.

sub abort {
    my $self = shift;
    chomp(my ($msg) = @_);

    $self->driver_abort($msg) if $self->can('driver_abort');

    print STDERR "IPC Fatal Error: $msg\n";
    print STDOUT "Bail out! IPC Fatal Error: $msg\n" unless $self->no_bail;

    CORE::exit(255) unless $self->no_fatal;
}

sub abort_trace {
    my $self = shift;
    my ($msg) = @_;
    # Older versions of Carp do not export longmess() function, so it needs to be called with package name
    $self->abort(Carp::longmess($msg));
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::IPC::Driver - Base class for Test2 IPC drivers.

=head1 SYNOPSIS

    package Test2::IPC::Driver::MyDriver;

    use base 'Test2::IPC::Driver';

    ...

=head1 METHODS

=over 4

=item $self->abort($msg)

If an IPC encounters a fatal error it should use this. This will print the
message to STDERR with C<'IPC Fatal Error: '> prefixed to it, then it will
forcefully exit 255. IPC errors may occur in threads or processes other than
the main one, this method provides the best chance of the harness noticing the
error.

=item $self->abort_trace($msg)

This is the same as C<< $ipc->abort($msg) >> except that it uses
C<Carp::longmess> to add a stack trace to the message.

=back

=head1 LOADING DRIVERS

Test2::IPC::Driver has an C<import()> method. All drivers inherit this import
method. This import method registers the driver.

In most cases you just need to load the desired IPC driver to make it work. You
should load this driver as early as possible. A warning will be issued if you
load it too late for it to be effective.

    use Test2::IPC::Driver::MyDriver;
    ...

=head1 WRITING DRIVERS

    package Test2::IPC::Driver::MyDriver;
    use strict;
    use warnings;

    use base 'Test2::IPC::Driver';

    sub is_viable {
        return 0 if $^O eq 'win32'; # Will not work on windows.
        return 1;
    }

    sub add_hub {
        my $self = shift;
        my ($hid) = @_;

        ... # Make it possible to contact the hub
    }

    sub drop_hub {
        my $self = shift;
        my ($hid) = @_;

        ... # Nothing should try to reach the hub anymore.
    }

    sub send {
        my $self = shift;
        my ($hid, $e, $global) = @_;

        ... # Send the event to the proper hub.

        # This may notify other procs/threads that there is a pending event.
        Test2::API::test2_ipc_set_pending($uniq_val);
    }

    sub cull {
        my $self = shift;
        my ($hid) = @_;

        my @events = ...; # Here is where you get the events for the hub

        return @events;
    }

    sub waiting {
        my $self = shift;

        ... # Notify all listening procs and threads that the main
        ... # process/thread is waiting for them to finish.
    }

    1;

=head2 METHODS SUBCLASSES MUST IMPLEMENT

=over 4

=item $ipc->is_viable

This should return true if the driver works in the current environment. This
should return false if it does not. This is a CLASS method.

=item $ipc->add_hub($hid)

This is used to alert the driver that a new hub is expecting events. The driver
should keep track of the process and thread ids, the hub should only be dropped
by the proc+thread that started it.

    sub add_hub {
        my $self = shift;
        my ($hid) = @_;

        ... # Make it possible to contact the hub
    }

=item $ipc->drop_hub($hid)

This is used to alert the driver that a hub is no longer accepting events. The
driver should keep track of the process and thread ids, the hub should only be
dropped by the proc+thread that started it (This is the drivers responsibility
to enforce).

    sub drop_hub {
        my $self = shift;
        my ($hid) = @_;

        ... # Nothing should try to reach the hub anymore.
    }

=item $ipc->send($hid, $event);

=item $ipc->send($hid, $event, $global);

Used to send events from the current process/thread to the specified hub in its
process+thread.

    sub send {
        my $self = shift;
        my ($hid, $e) = @_;

        ... # Send the event to the proper hub.

        # This may notify other procs/threads that there is a pending event.
        Test2::API::test2_ipc_set_pending($uniq_val);
    }

If C<$global> is true then the driver should send the event to all hubs in all
processes and threads.

=item @events = $ipc->cull($hid)

Used to collect events that have been sent to the specified hub.

    sub cull {
        my $self = shift;
        my ($hid) = @_;

        my @events = ...; # Here is where you get the events for the hub

        return @events;
    }

=item $ipc->waiting()

This is called in the parent process when it is complete and waiting for all
child processes and threads to complete.

    sub waiting {
        my $self = shift;

        ... # Notify all listening procs and threads that the main
        ... # process/thread is waiting for them to finish.
    }

=back

=head2 METHODS SUBCLASSES MAY IMPLEMENT OR OVERRIDE

=over 4

=item $ipc->driver_abort($msg)

This is a hook called by C<< Test2::IPC::Driver->abort() >>. This is your
chance to cleanup when an abort happens. You cannot prevent the abort, but you
can gracefully except it.

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! U�\�4  �4    perl5/Test2/IPC/Driver/Files.pmnu ��6�$        package Test2::IPC::Driver::Files;
use strict;
use warnings;

our $VERSION = '1.302183';

BEGIN { require Test2::IPC::Driver; our @ISA = qw(Test2::IPC::Driver) }

use Test2::Util::HashBase qw{tempdir event_ids read_ids timeouts tid pid globals};

use Scalar::Util qw/blessed/;
use File::Temp();
use Storable();
use File::Spec();
use POSIX();

use Test2::Util qw/try get_tid pkg_to_file IS_WIN32 ipc_separator do_rename do_unlink try_sig_mask/;
use Test2::API qw/test2_ipc_set_pending/;

sub is_viable { 1 }

sub init {
    my $self = shift;

    my $tmpdir = File::Temp::tempdir(
        $ENV{T2_TEMPDIR_TEMPLATE} || "test2" . ipc_separator . $$ . ipc_separator . "XXXXXX",
        CLEANUP => 0,
        TMPDIR => 1,
    );

    $self->abort_trace("Could not get a temp dir") unless $tmpdir;

    $self->{+TEMPDIR} = File::Spec->canonpath($tmpdir);

    print STDERR "\nIPC Temp Dir: $tmpdir\n\n"
        if $ENV{T2_KEEP_TEMPDIR};

    $self->{+EVENT_IDS} = {};
    $self->{+READ_IDS} = {};
    $self->{+TIMEOUTS} = {};

    $self->{+TID} = get_tid();
    $self->{+PID} = $$;

    $self->{+GLOBALS} = {};

    return $self;
}

sub hub_file {
    my $self = shift;
    my ($hid) = @_;
    my $tdir = $self->{+TEMPDIR};
    return File::Spec->catfile($tdir, "HUB" . ipc_separator . $hid);
}

sub event_file {
    my $self = shift;
    my ($hid, $e) = @_;

    my $tempdir = $self->{+TEMPDIR};
    my $type = blessed($e) or $self->abort("'$e' is not a blessed object!");

    $self->abort("'$e' is not an event object!")
        unless $type->isa('Test2::Event');

    my $tid = get_tid();
    my $eid = $self->{+EVENT_IDS}->{$hid}->{$$}->{$tid} += 1;

    my @type = split '::', $type;
    my $name = join(ipc_separator, $hid, $$, $tid, $eid, @type);

    return File::Spec->catfile($tempdir, $name);
}

sub add_hub {
    my $self = shift;
    my ($hid) = @_;

    my $hfile = $self->hub_file($hid);

    $self->abort_trace("File for hub '$hid' already exists")
        if -e $hfile;

    open(my $fh, '>', $hfile) or $self->abort_trace("Could not create hub file '$hid': $!");
    print $fh "$$\n" . get_tid() . "\n";
    close($fh);
}

sub drop_hub {
    my $self = shift;
    my ($hid) = @_;

    my $tdir = $self->{+TEMPDIR};
    my $hfile = $self->hub_file($hid);

    $self->abort_trace("File for hub '$hid' does not exist")
        unless -e $hfile;

    open(my $fh, '<', $hfile) or $self->abort_trace("Could not open hub file '$hid': $!");
    my ($pid, $tid) = <$fh>;
    close($fh);

    $self->abort_trace("A hub file can only be closed by the process that started it\nExpected $pid, got $$")
        unless $pid == $$;

    $self->abort_trace("A hub file can only be closed by the thread that started it\nExpected $tid, got " . get_tid())
        unless get_tid() == $tid;

    if ($ENV{T2_KEEP_TEMPDIR}) {
        my ($ok, $err) = do_rename($hfile, File::Spec->canonpath("$hfile.complete"));
        $self->abort_trace("Could not rename file '$hfile' -> '$hfile.complete': $err") unless $ok
    }
    else {
        my ($ok, $err) = do_unlink($hfile);
        $self->abort_trace("Could not remove file for hub '$hid': $err") unless $ok
    }

    opendir(my $dh, $tdir) or $self->abort_trace("Could not open temp dir!");

    my %bad;
    for my $file (readdir($dh)) {
        next if $file =~ m{\.complete$};
        next unless $file =~ m{^$hid};

        eval { $bad{$file} = $self->read_event_file(File::Spec->catfile($tdir, $file)); 1 } or $bad{$file} = $@ || "Unknown error reading file";
    }
    closedir($dh);

    return unless keys %bad;

    my $data;
    my $ok = eval {
        require JSON::PP;
        local *UNIVERSAL::TO_JSON = sub { +{ %{$_[0]} } };
        my $json = JSON::PP->new->ascii->pretty->canonical->allow_unknown->allow_blessed->convert_blessed;
        $data = $json->encode(\%bad);
        1;
    };
    $ok ||= eval {
        require Data::Dumper;
        local $Data::Dumper::Sortkeys = 1;
        $data = Data::Dumper::Dumper(\%bad);
        1;
    };

    $data = "Could not dump data... sorry." unless defined $data;

    $self->abort_trace("Not all files from hub '$hid' have been collected!\nHere is the leftover data:\n========================\n$data\n===================\n");
}

sub send {
    my $self = shift;
    my ($hid, $e, $global) = @_;

    my $tempdir = $self->{+TEMPDIR};
    my $hfile = $self->hub_file($hid);
    my $dest = $global ? 'GLOBAL' : $hid;

    $self->abort(<<"    EOT") unless $global || -f $hfile;
hub '$hid' is not available, failed to send event!

There was an attempt to send an event to a hub in a parent process or thread,
but that hub appears to be gone. This can happen if you fork, or start a new
thread from inside subtest, and the parent finishes the subtest before the
child returns.

This can also happen if the parent process is done testing before the child
finishes. Test2 normally waits automatically in the root process, but will not
do so if Test::Builder is loaded for legacy reasons.
    EOT

    my $file = $self->event_file($dest, $e);
    my $ready = File::Spec->canonpath("$file.ready");

    if ($global) {
        my $name = $ready;
        $name =~ s{^.*(GLOBAL)}{GLOBAL};
        $self->{+GLOBALS}->{$hid}->{$name}++;
    }

    # Write and rename the file.
    my ($ren_ok, $ren_err);
    my ($ok, $err) = try_sig_mask(sub {
        Storable::store($e, $file);
        ($ren_ok, $ren_err) = do_rename("$file", $ready);
    });

    if ($ok) {
        $self->abort("Could not rename file '$file' -> '$ready': $ren_err") unless $ren_ok;
        test2_ipc_set_pending($file);
    }
    else {
        my $src_file = __FILE__;
        $err =~ s{ at \Q$src_file\E.*$}{};
        chomp($err);
        my $tid = get_tid();
        my $trace = $e->trace->debug;
        my $type = blessed($e);

        $self->abort(<<"        EOT");

*******************************************************************************
There was an error writing an event:
Destination: $dest
Origin PID:  $$
Origin TID:  $tid
Event Type:  $type
Event Trace: $trace
File Name:   $file
Ready Name:  $ready
Error: $err
*******************************************************************************

        EOT
    }

    return 1;
}

sub driver_abort {
    my $self = shift;
    my ($msg) = @_;

    local ($@, $!, $?, $^E);
    eval {
        my $abort = File::Spec->catfile($self->{+TEMPDIR}, "ABORT");
        open(my $fh, '>>', $abort) or die "Could not open abort file: $!";
        print $fh $msg, "\n";
        close($fh) or die "Could not close abort file: $!";
        1;
    } or warn $@;
}

sub cull {
    my $self = shift;
    my ($hid) = @_;

    my $tempdir = $self->{+TEMPDIR};

    opendir(my $dh, $tempdir) or $self->abort("could not open IPC temp dir ($tempdir)!");

    my $read = $self->{+READ_IDS};
    my $timeouts = $self->{+TIMEOUTS};

    my @out;
    for my $info (sort cmp_events map { $self->should_read_event($hid, $_) } readdir($dh)) {
        unless ($info->{global}) {
            my $next = $self->{+READ_IDS}->{$info->{hid}}->{$info->{pid}}->{$info->{tid}} ||= 1;

            $timeouts->{$info->{file}} ||= time;

            if ($next != $info->{eid}) {
                # Wait up to N seconds for missing events
                next unless 5 < time - $timeouts->{$info->{file}};
                $self->abort("Missing event HID: $info->{hid}, PID: $info->{pid}, TID: $info->{tid}, EID: $info->{eid}.");
            }

            $self->{+READ_IDS}->{$info->{hid}}->{$info->{pid}}->{$info->{tid}} = $info->{eid} + 1;
        }

        my $full = $info->{full_path};
        my $obj = $self->read_event_file($full);
        push @out => $obj;

        # Do not remove global events
        next if $info->{global};

        if ($ENV{T2_KEEP_TEMPDIR}) {
            my $complete = File::Spec->canonpath("$full.complete");
            my ($ok, $err) = do_rename($full, $complete);
            $self->abort("Could not rename IPC file '$full', '$complete': $err") unless $ok;
        }
        else {
            my ($ok, $err) = do_unlink("$full");
            $self->abort("Could not unlink IPC file '$full': $err") unless $ok;
        }
    }

    closedir($dh);
    return @out;
}

sub parse_event_filename {
    my $self = shift;
    my ($file) = @_;

    # The || is to force 0 in false
    my $complete = substr($file, -9, 9) eq '.complete' || 0 and substr($file, -9, 9, "");
    my $ready    = substr($file, -6, 6) eq '.ready'    || 0 and substr($file, -6, 6, "");

    my @parts = split ipc_separator, $file;
    my ($global, $hid) = $parts[0] eq 'GLOBAL' ? (1, shift @parts) : (0, join ipc_separator, splice(@parts, 0, 4));
    my ($pid, $tid, $eid) = splice(@parts, 0, 3);
    my $type = join '::' => @parts;

    return {
        file     => $file,
        ready    => $ready,
        complete => $complete,
        global   => $global,
        type     => $type,
        hid      => $hid,
        pid      => $pid,
        tid      => $tid,
        eid      => $eid,
    };
}

sub should_read_event {
    my $self = shift;
    my ($hid, $file) = @_;

    return if substr($file, 0, 1) eq '.';
    return if substr($file, 0, 3) eq 'HUB';
    CORE::exit(255) if $file eq 'ABORT';

    my $parsed = $self->parse_event_filename($file);

    return if $parsed->{complete};
    return unless $parsed->{ready};
    return unless $parsed->{global} || $parsed->{hid} eq $hid;

    return if $parsed->{global} && $self->{+GLOBALS}->{$hid}->{$file}++;

    # Untaint the path.
    my $full = File::Spec->catfile($self->{+TEMPDIR}, $file);
    ($full) = ($full =~ m/^(.*)$/gs) if ${^TAINT};

    $parsed->{full_path} = $full;

    return $parsed;
}

sub cmp_events {
    # Globals first
    return -1 if $a->{global} && !$b->{global};
    return  1 if $b->{global} && !$a->{global};

    return $a->{pid} <=> $b->{pid}
        || $a->{tid} <=> $b->{tid}
        || $a->{eid} <=> $b->{eid};
}

sub read_event_file {
    my $self = shift;
    my ($file) = @_;

    my $obj = Storable::retrieve($file);
    $self->abort("Got an unblessed object: '$obj'")
        unless blessed($obj);

    unless ($obj->isa('Test2::Event')) {
        my $pkg  = blessed($obj);
        my $mod_file = pkg_to_file($pkg);
        my ($ok, $err) = try { require $mod_file };

        $self->abort("Event has unknown type ($pkg), tried to load '$mod_file' but failed: $err")
            unless $ok;

        $self->abort("'$obj' is not a 'Test2::Event' object")
            unless $obj->isa('Test2::Event');
    }

    return $obj;
}

sub waiting {
    my $self = shift;
    require Test2::Event::Waiting;
    $self->send(
        GLOBAL => Test2::Event::Waiting->new(
            trace => Test2::EventFacet::Trace->new(frame => [caller()]),
        ),
        'GLOBAL'
    );
    return;
}

sub DESTROY {
    my $self = shift;

    return unless defined $self->pid;
    return unless defined $self->tid;

    return unless $$        == $self->pid;
    return unless get_tid() == $self->tid;

    my $tempdir = $self->{+TEMPDIR};

    my $aborted = 0;
    my $abort_file = File::Spec->catfile($self->{+TEMPDIR}, "ABORT");
    if (-e $abort_file) {
        $aborted = 1;
        my ($ok, $err) = do_unlink($abort_file);
        warn $err unless $ok;
    }

    opendir(my $dh, $tempdir) or $self->abort("Could not open temp dir! ($tempdir)");
    while(my $file = readdir($dh)) {
        next if $file =~ m/^\.+$/;
        next if $file =~ m/\.complete$/;
        my $full = File::Spec->catfile($tempdir, $file);

        my $sep = ipc_separator;
        if ($aborted || $file =~ m/^(GLOBAL|HUB$sep)/) {
            $full =~ m/^(.*)$/;
            $full = $1; # Untaint it
            next if $ENV{T2_KEEP_TEMPDIR};
            my ($ok, $err) = do_unlink($full);
            $self->abort("Could not unlink IPC file '$full': $err") unless $ok;
            next;
        }

        $self->abort("Leftover files in the directory ($full)!\n");
    }
    closedir($dh);

    if ($ENV{T2_KEEP_TEMPDIR}) {
        print STDERR "# Not removing temp dir: $tempdir\n";
        return;
    }

    my $abort = File::Spec->catfile($self->{+TEMPDIR}, "ABORT");
    unlink($abort) if -e $abort;
    rmdir($tempdir) or warn "Could not remove IPC temp dir ($tempdir)";
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::IPC::Driver::Files - Temp dir + Files concurrency model.

=head1 DESCRIPTION

This is the default, and fallback concurrency model for L<Test2>. This
sends events between processes and threads using serialized files in a
temporary directory. This is not particularly fast, but it works everywhere.

=head1 SYNOPSIS

    use Test2::IPC::Driver::Files;

    # IPC is now enabled

=head1 ENVIRONMENT VARIABLES

=over 4

=item T2_KEEP_TEMPDIR=0

When true, the tempdir used by the IPC driver will not be deleted when the test
is done.

=item T2_TEMPDIR_TEMPLATE='test2-XXXXXX'

This can be used to set the template for the IPC temp dir. The template should
follow template specifications from L<File::Temp>.

=back

=head1 SEE ALSO

See L<Test2::IPC::Driver> for methods.

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! ��Ry�  �    perl5/Test2/Event/Waiting.pmnu ��6�$        package Test2::Event::Waiting;
use strict;
use warnings;

our $VERSION = '1.302183';


BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use Test2::Util::HashBase;

sub global { 1 };

sub summary { "IPC is waiting for children to finish..." }

sub facet_data {
    my $self = shift;

    my $out = $self->common_facet_data;

    push @{$out->{info}} => {
        tag     => 'INFO',
        debug   => 0,
        details => $self->summary,
    };

    return $out;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::Event::Waiting - Tell all procs/threads it is time to be done

=head1 DESCRIPTION

This event has no data of its own. This event is sent out by the IPC system
when the main process/thread is ready to end.

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! �#���  �    perl5/Test2/Event/Bail.pmnu ��6�$        package Test2::Event::Bail;
use strict;
use warnings;

our $VERSION = '1.302183';


BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use Test2::Util::HashBase qw{reason buffered};

# Make sure the tests terminate
sub terminate { 255 };

sub global { 1 };

sub causes_fail { 1 }

sub summary {
    my $self = shift;
    return "Bail out!  " . $self->{+REASON}
        if $self->{+REASON};

    return "Bail out!";
}

sub diagnostics { 1 }

sub facet_data {
    my $self = shift;
    my $out = $self->common_facet_data;

    $out->{control} = {
        global    => 1,
        halt      => 1,
        details   => $self->{+REASON},
        terminate => 255,
    };

    return $out;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::Event::Bail - Bailout!

=head1 DESCRIPTION

The bailout event is generated when things go horribly wrong and you need to
halt all testing in the current file.

=head1 SYNOPSIS

    use Test2::API qw/context/;
    use Test2::Event::Bail;

    my $ctx = context();
    my $event = $ctx->bail('Stuff is broken');

=head1 METHODS

Inherits from L<Test2::Event>. Also defines:

=over 4

=item $reason = $e->reason

The reason for the bailout.

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! 8���  �    perl5/Test2/Event/Encoding.pmnu ��6�$        package Test2::Event::Encoding;
use strict;
use warnings;

our $VERSION = '1.302183';

use Carp qw/croak/;

BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use Test2::Util::HashBase qw/encoding/;

sub init {
    my $self = shift;
    defined $self->{+ENCODING} or croak "'encoding' is a required attribute";
}

sub summary { 'Encoding set to ' . $_[0]->{+ENCODING} }

sub facet_data {
    my $self = shift;
    my $out = $self->common_facet_data;
    $out->{control}->{encoding} = $self->{+ENCODING};
    $out->{about}->{details} = $self->summary;
    return $out;
}


1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::Event::Encoding - Set the encoding for the output stream

=head1 DESCRIPTION

The encoding event is generated when a test file wants to specify the encoding
to be used when formatting its output. This event is intended to be produced
by formatter classes and used for interpreting test names, message contents,
etc.

=head1 SYNOPSIS

    use Test2::API qw/context/;
    use Test2::Event::Encoding;

    my $ctx = context();
    my $event = $ctx->send_event('Encoding', encoding => 'UTF-8');

=head1 METHODS

Inherits from L<Test2::Event>. Also defines:

=over 4

=item $encoding = $e->encoding

The encoding being specified.

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! Dڑ��  �    perl5/Test2/Event/Exception.pmnu ��6�$        package Test2::Event::Exception;
use strict;
use warnings;

our $VERSION = '1.302183';


BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use Test2::Util::HashBase qw{error};

sub init {
    my $self = shift;
    $self->{+ERROR} = "$self->{+ERROR}";
}

sub causes_fail { 1 }

sub summary {
    my $self = shift;
    chomp(my $msg = "Exception: " . $self->{+ERROR});
    return $msg;
}

sub diagnostics { 1 }

sub facet_data {
    my $self = shift;
    my $out = $self->common_facet_data;

    $out->{errors} = [
        {
            tag     => 'ERROR',
            fail    => 1,
            details => $self->{+ERROR},
        }
    ];

    return $out;
}


1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::Event::Exception - Exception event

=head1 DESCRIPTION

An exception event will display to STDERR, and will prevent the overall test
file from passing.

=head1 SYNOPSIS

    use Test2::API qw/context/;
    use Test2::Event::Exception;

    my $ctx = context();
    my $event = $ctx->send_event('Exception', error => 'Stuff is broken');

=head1 METHODS

Inherits from L<Test2::Event>. Also defines:

=over 4

=item $reason = $e->error

The reason for the exception.

=back

=head1 CAVEATS

Be aware that all exceptions are stringified during construction.

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! H9��      perl5/Test2/Event/Generic.pmnu ��6�$        package Test2::Event::Generic;
use strict;
use warnings;

use Carp qw/croak/;
use Scalar::Util qw/reftype/;

our $VERSION = '1.302183';

BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use Test2::Util::HashBase;

my @FIELDS = qw{
    causes_fail increments_count diagnostics no_display callback terminate
    global sets_plan summary facet_data
};
my %DEFAULTS = (
    causes_fail      => 0,
    increments_count => 0,
    diagnostics      => 0,
    no_display       => 0,
);

sub init {
    my $self = shift;

    for my $field (@FIELDS) {
        my $val = defined $self->{$field} ? delete $self->{$field} : $DEFAULTS{$field};
        next unless defined $val;

        my $set = "set_$field";
        $self->$set($val);
    }
}

for my $field (@FIELDS) {
    no strict 'refs';

    *$field = sub { exists $_[0]->{$field} ? $_[0]->{$field} : () }
        unless exists &{$field};

    *{"set_$field"} = sub { $_[0]->{$field} = $_[1] }
        unless exists &{"set_$field"};
}

sub can {
    my $self = shift;
    my ($name) = @_;
    return $self->SUPER::can($name) unless $name eq 'callback';
    return $self->{callback} || \&Test2::Event::callback;
}

sub facet_data {
    my $self = shift;
    return $self->{facet_data} || $self->SUPER::facet_data();
}

sub summary {
    my $self = shift;
    return $self->{summary} if defined $self->{summary};
    $self->SUPER::summary();
}

sub sets_plan {
    my $self = shift;
    return unless $self->{sets_plan};
    return @{$self->{sets_plan}};
}

sub callback {
    my $self = shift;
    my $cb = $self->{callback} || return;
    $self->$cb(@_);
}

sub set_global {
    my $self = shift;
    my ($bool) = @_;

    if(!defined $bool) {
        delete $self->{global};
        return undef;
    }

    $self->{global} = $bool;
}

sub set_callback {
    my $self = shift;
    my ($cb) = @_;

    if(!defined $cb) {
        delete $self->{callback};
        return undef;
    }

    croak "callback must be a code reference"
        unless ref($cb) && reftype($cb) eq 'CODE';

    $self->{callback} = $cb;
}

sub set_terminate {
    my $self = shift;
    my ($exit) = @_;

    if(!defined $exit) {
        delete $self->{terminate};
        return undef;
    }

    croak "terminate must be a positive integer"
       unless $exit =~ m/^\d+$/;

    $self->{terminate} = $exit;
}

sub set_sets_plan {
    my $self = shift;
    my ($plan) = @_;

    if(!defined $plan) {
        delete $self->{sets_plan};
        return undef;
    }

    croak "'sets_plan' must be an array reference"
        unless ref($plan) && reftype($plan) eq 'ARRAY';

    $self->{sets_plan} = $plan;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::Event::Generic - Generic event type.

=head1 DESCRIPTION

This is a generic event that lets you customize all fields in the event API.
This is useful if you have need for a custom event that does not make sense as
a published reusable event subclass.

=head1 SYNOPSIS

    use Test2::API qw/context/;

    sub send_custom_fail {
        my $ctx = shift;

        $ctx->send_event('Generic', causes_fail => 1, summary => 'The sky is falling');

        $ctx->release;
    }

    send_custom_fail();

=head1 METHODS

=over 4

=item $e->facet_data($data)

=item $data = $e->facet_data

Get or set the facet data (see L<Test2::Event>). If no facet_data is set then
C<< Test2::Event->facet_data >> will be called to produce facets from the other
data.

=item $e->callback($hub)

Call the custom callback if one is set, otherwise this does nothing.

=item $e->set_callback(sub { ... })

Set the custom callback. The custom callback must be a coderef. The first
argument to your callback will be the event itself, the second will be the
L<Test2::Event::Hub> that is using the callback.

=item $bool = $e->causes_fail

=item $e->set_causes_fail($bool)

Get/Set the C<causes_fail> attribute. This defaults to C<0>.

=item $bool = $e->diagnostics

=item $e->set_diagnostics($bool)

Get/Set the C<diagnostics> attribute. This defaults to C<0>.

=item $bool_or_undef = $e->global

=item @bool_or_empty = $e->global

=item $e->set_global($bool_or_undef)

Get/Set the C<diagnostics> attribute. This defaults to an empty list which is
undef in scalar context.

=item $bool = $e->increments_count

=item $e->set_increments_count($bool)

Get/Set the C<increments_count> attribute. This defaults to C<0>.

=item $bool = $e->no_display

=item $e->set_no_display($bool)

Get/Set the C<no_display> attribute. This defaults to C<0>.

=item @plan = $e->sets_plan

Get the plan if this event sets one. The plan is a list of up to 3 items:
C<($count, $directive, $reason)>. C<$count> must be defined, the others may be
undef, or may not exist at all.

=item $e->set_sets_plan(\@plan)

Set the plan. You must pass in an arrayref with up to 3 elements.

=item $summary = $e->summary

=item $e->set_summary($summary_or_undef)

Get/Set the summary. This will default to the event package
C<'Test2::Event::Generic'>. You can set it to any value. Setting this to
C<undef> will reset it to the default.

=item $int_or_undef = $e->terminate

=item @int_or_empty = $e->terminate

=item $e->set_terminate($int_or_undef)

This will get/set the C<terminate> attribute. This defaults to undef in scalar
context, or an empty list in list context. Setting this to undef will clear it
completely. This must be set to a positive integer (0 or larger).

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! v]_�<  <    perl5/Test2/Event/Plan.pmnu ��6�$        package Test2::Event::Plan;
use strict;
use warnings;

our $VERSION = '1.302183';


BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use Test2::Util::HashBase qw{max directive reason};

use Carp qw/confess/;

my %ALLOWED = (
    'SKIP'    => 1,
    'NO PLAN' => 1,
);

sub init {
    if ($_[0]->{+DIRECTIVE}) {
        $_[0]->{+DIRECTIVE} = 'SKIP'    if $_[0]->{+DIRECTIVE} eq 'skip_all';
        $_[0]->{+DIRECTIVE} = 'NO PLAN' if $_[0]->{+DIRECTIVE} eq 'no_plan';

        confess "'" . $_[0]->{+DIRECTIVE} . "' is not a valid plan directive"
            unless $ALLOWED{$_[0]->{+DIRECTIVE}};
    }
    else {
        confess "Cannot have a reason without a directive!"
            if defined $_[0]->{+REASON};

        confess "No number of tests specified"
            unless defined $_[0]->{+MAX};

        confess "Plan test count '" . $_[0]->{+MAX}  . "' does not appear to be a valid positive integer"
            unless $_[0]->{+MAX} =~ m/^\d+$/;

        $_[0]->{+DIRECTIVE} = '';
    }
}

sub sets_plan {
    my $self = shift;
    return (
        $self->{+MAX},
        $self->{+DIRECTIVE},
        $self->{+REASON},
    );
}

sub terminate {
    my $self = shift;
    # On skip_all we want to terminate the hub
    return 0 if $self->{+DIRECTIVE} && $self->{+DIRECTIVE} eq 'SKIP';
    return undef;
}

sub summary {
    my $self = shift;
    my $max = $self->{+MAX};
    my $directive = $self->{+DIRECTIVE};
    my $reason = $self->{+REASON};

    return "Plan is $max assertions"
        if $max || !$directive;

    return "Plan is '$directive', $reason"
        if $reason;

    return "Plan is '$directive'";
}

sub facet_data {
    my $self = shift;

    my $out = $self->common_facet_data;

    $out->{control}->{terminate} = $self->{+DIRECTIVE} eq 'SKIP' ? 0 : undef
        unless defined $out->{control}->{terminate};

    $out->{plan} = {count => $self->{+MAX}};
    $out->{plan}->{details} = $self->{+REASON} if defined $self->{+REASON};

    if (my $dir = $self->{+DIRECTIVE}) {
        $out->{plan}->{skip} = 1 if $dir eq 'SKIP';
        $out->{plan}->{none} = 1 if $dir eq 'NO PLAN';
    }

    return $out;
}


1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::Event::Plan - The event of a plan

=head1 DESCRIPTION

Plan events are fired off whenever a plan is declared, done testing is called,
or a subtext completes.

=head1 SYNOPSIS

    use Test2::API qw/context/;
    use Test2::Event::Plan;

    my $ctx = context();

    # Plan for 10 tests to run
    my $event = $ctx->plan(10);

    # Plan to skip all tests (will exit 0)
    $ctx->plan(0, skip_all => "These tests need to be skipped");

=head1 ACCESSORS

=over 4

=item $num = $plan->max

Get the number of expected tests

=item $dir = $plan->directive

Get the directive (such as TODO, skip_all, or no_plan).

=item $reason = $plan->reason

Get the reason for the directive.

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! +��~�  �    perl5/Test2/Event/Skip.pmnu ��6�$        package Test2::Event::Skip;
use strict;
use warnings;

our $VERSION = '1.302183';


BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) }
use Test2::Util::HashBase qw{reason};

sub init {
    my $self = shift;
    $self->SUPER::init;
    $self->{+EFFECTIVE_PASS} = 1;
}

sub causes_fail { 0 }

sub summary {
    my $self = shift;
    my $out = $self->SUPER::summary(@_);

    if (my $reason = $self->reason) {
        $out .= " (SKIP: $reason)";
    }
    else {
        $out .= " (SKIP)";
    }

    return $out;
}

sub extra_amnesty {
    my $self = shift;

    my @out;

    push @out => {
        tag       => 'TODO',
        details   => $self->{+TODO},
    } if defined $self->{+TODO};

    push @out => {
        tag       => 'skip',
        details   => $self->{+REASON},
        inherited => 0,
    };

    return @out;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::Event::Skip - Skip event type

=head1 DESCRIPTION

Skip events bump test counts just like L<Test2::Event::Ok> events, but
they can never fail.

=head1 SYNOPSIS

    use Test2::API qw/context/;
    use Test2::Event::Skip;

    my $ctx = context();
    my $event = $ctx->skip($name, $reason);

or:

    my $ctx   = context();
    my $event = $ctx->send_event(
        'Skip',
        name   => $name,
        reason => $reason,
    );

=head1 ACCESSORS

=over 4

=item $reason = $e->reason

The original true/false value of whatever was passed into the event (but
reduced down to 1 or 0).

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://www.perl.com/perl/misc/Artistic.html>

=cut
PK       ! ���U�  �    perl5/Test2/Event/Pass.pmnu ��6�$        package Test2::Event::Pass;
use strict;
use warnings;

our $VERSION = '1.302183';

use Test2::EventFacet::Info;

BEGIN {
    require Test2::Event;
    our @ISA = qw(Test2::Event);
    *META_KEY = \&Test2::Util::ExternalMeta::META_KEY;
}

use Test2::Util::HashBase qw{ -name -info };

##############
# Old API
sub summary          { "pass" }
sub increments_count { 1 }
sub causes_fail      { 0 }
sub diagnostics      { 0 }
sub no_display       { 0 }
sub subtest_id       { undef }
sub terminate        { () }
sub global           { () }
sub sets_plan        { () }

##############
# New API

sub add_info {
    my $self = shift;

    for my $in (@_) {
        $in = {%$in} if ref($in) ne 'ARRAY';
        $in = Test2::EventFacet::Info->new($in);

        push @{$self->{+INFO}} => $in;
    }
}

sub facet_data {
    my $self = shift;

    my $out = $self->common_facet_data;

    $out->{about}->{details} = 'pass';

    $out->{assert} = {pass => 1, details => $self->{+NAME}};

    $out->{info} = [map {{ %{$_} }} @{$self->{+INFO}}] if $self->{+INFO};

    return $out;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::Event::Pass - Event for a simple passing assertion

=head1 DESCRIPTION

This is an optimal representation of a passing assertion.

=head1 SYNOPSIS

    use Test2::API qw/context/;

    sub pass {
        my ($name) = @_;
        my $ctx = context();
        $ctx->pass($name);
        $ctx->release;
    }

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! ���Ll  l     perl5/Test2/Event/TAP/Version.pmnu ��6�$        package Test2::Event::TAP::Version;
use strict;
use warnings;

our $VERSION = '1.302183';

use Carp qw/croak/;

BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use Test2::Util::HashBase qw/version/;

sub init {
    my $self = shift;
    defined $self->{+VERSION} or croak "'version' is a required attribute";
}

sub summary { 'TAP version ' . $_[0]->{+VERSION} }

sub facet_data {
    my $self = shift;

    my $out = $self->common_facet_data;

    $out->{about}->{details} = $self->summary;

    push @{$out->{info}} => {
        tag     => 'INFO',
        debug   => 0,
        details => $self->summary,
    };

    return $out;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::Event::TAP::Version - Event for TAP version.

=head1 DESCRIPTION

This event is used if a TAP formatter wishes to set a version.

=head1 SYNOPSIS

    use Test2::API qw/context/;
    use Test2::Event::Encoding;

    my $ctx = context();
    my $event = $ctx->send_event('TAP::Version', version => 42);

=head1 METHODS

Inherits from L<Test2::Event>. Also defines:

=over 4

=item $version = $e->version

The TAP version being parsed.

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! QAx�  �    perl5/Test2/Event/Diag.pmnu ��6�$        package Test2::Event::Diag;
use strict;
use warnings;

our $VERSION = '1.302183';


BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use Test2::Util::HashBase qw/message/;

sub init {
    $_[0]->{+MESSAGE} = 'undef' unless defined $_[0]->{+MESSAGE};
}

sub summary { $_[0]->{+MESSAGE} }

sub diagnostics { 1 }

sub facet_data {
    my $self = shift;

    my $out = $self->common_facet_data;

    $out->{info} = [
        {
            tag     => 'DIAG',
            debug   => 1,
            details => $self->{+MESSAGE},
        }
    ];

    return $out;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::Event::Diag - Diag event type

=head1 DESCRIPTION

Diagnostics messages, typically rendered to STDERR.

=head1 SYNOPSIS

    use Test2::API qw/context/;
    use Test2::Event::Diag;

    my $ctx = context();
    my $event = $ctx->diag($message);

=head1 ACCESSORS

=over 4

=item $diag->message

The message for the diag.

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! [����  �    perl5/Test2/Event/Fail.pmnu ��6�$        package Test2::Event::Fail;
use strict;
use warnings;

our $VERSION = '1.302183';

use Test2::EventFacet::Info;

BEGIN {
    require Test2::Event;
    our @ISA = qw(Test2::Event);
    *META_KEY = \&Test2::Util::ExternalMeta::META_KEY;
}

use Test2::Util::HashBase qw{ -name -info };

#############
# Old API
sub summary          { "fail" }
sub increments_count { 1 }
sub diagnostics      { 0 }
sub no_display       { 0 }
sub subtest_id       { undef }
sub terminate        { () }
sub global           { () }
sub sets_plan        { () }

sub causes_fail {
    my $self = shift;
    return 0 if $self->{+AMNESTY} && @{$self->{+AMNESTY}};
    return 1;
}

#############
# New API

sub add_info {
    my $self = shift;

    for my $in (@_) {
        $in = {%$in} if ref($in) ne 'ARRAY';
        $in = Test2::EventFacet::Info->new($in);

        push @{$self->{+INFO}} => $in;
    }
}

sub facet_data {
    my $self = shift;
    my $out = $self->common_facet_data;

    $out->{about}->{details} = 'fail';

    $out->{assert} = {pass => 0, details => $self->{+NAME}};

    $out->{info} = [map {{ %{$_} }} @{$self->{+INFO}}] if $self->{+INFO};

    return $out;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::Event::Fail - Event for a simple failed assertion

=head1 DESCRIPTION

This is an optimal representation of a failed assertion.

=head1 SYNOPSIS

    use Test2::API qw/context/;

    sub fail {
        my ($name) = @_;
        my $ctx = context();
        $ctx->fail($name);
        $ctx->release;
    }

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! ���}  }    perl5/Test2/Event/Subtest.pmnu ��6�$        package Test2::Event::Subtest;
use strict;
use warnings;

our $VERSION = '1.302183';

BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) }
use Test2::Util::HashBase qw{subevents buffered subtest_id subtest_uuid};

sub init {
    my $self = shift;
    $self->SUPER::init();
    $self->{+SUBEVENTS} ||= [];
    if ($self->{+EFFECTIVE_PASS}) {
        $_->set_effective_pass(1) for grep { $_->can('effective_pass') } @{$self->{+SUBEVENTS}};
    }
}

{
    no warnings 'redefine';

    sub set_subevents {
        my $self      = shift;
        my @subevents = @_;

        if ($self->{+EFFECTIVE_PASS}) {
            $_->set_effective_pass(1) for grep { $_->can('effective_pass') } @subevents;
        }

        $self->{+SUBEVENTS} = \@subevents;
    }

    sub set_effective_pass {
        my $self = shift;
        my ($pass) = @_;

        if ($pass) {
            $_->set_effective_pass(1) for grep { $_->can('effective_pass') } @{$self->{+SUBEVENTS}};
        }
        elsif ($self->{+EFFECTIVE_PASS} && !$pass) {
            for my $s (grep { $_->can('effective_pass') } @{$self->{+SUBEVENTS}}) {
                $_->set_effective_pass(0) unless $s->can('todo') && defined $s->todo;
            }
        }

        $self->{+EFFECTIVE_PASS} = $pass;
    }
}

sub summary {
    my $self = shift;

    my $name = $self->{+NAME} || "Nameless Subtest";

    my $todo = $self->{+TODO};
    if ($todo) {
        $name .= " (TODO: $todo)";
    }
    elsif (defined $todo) {
        $name .= " (TODO)";
    }

    return $name;
}

sub facet_data {
    my $self = shift;

    my $out = $self->SUPER::facet_data();

    $out->{parent} = {
        hid      => $self->subtest_id,
        children => [map {$_->facet_data} @{$self->{+SUBEVENTS}}],
        buffered => $self->{+BUFFERED},
    };

    return $out;
}

sub add_amnesty {
    my $self = shift;

    for my $am (@_) {
        $am = {%$am} if ref($am) ne 'ARRAY';
        $am = Test2::EventFacet::Amnesty->new($am);

        push @{$self->{+AMNESTY}} => $am;

        for my $e (@{$self->{+SUBEVENTS}}) {
            $e->add_amnesty($am->clone(inherited => 1));
        }
    }
}


1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::Event::Subtest - Event for subtest types

=head1 DESCRIPTION

This class represents a subtest. This class is a subclass of
L<Test2::Event::Ok>.

=head1 ACCESSORS

This class inherits from L<Test2::Event::Ok>.

=over 4

=item $arrayref = $e->subevents

Returns the arrayref containing all the events from the subtest

=item $bool = $e->buffered

True if the subtest is buffered, that is all subevents render at once. If this
is false it means all subevents render as they are produced.

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! 7øډ  �    perl5/Test2/Event/Note.pmnu ��6�$        package Test2::Event::Note;
use strict;
use warnings;

our $VERSION = '1.302183';


BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use Test2::Util::HashBase qw/message/;

sub init {
    $_[0]->{+MESSAGE} = 'undef' unless defined $_[0]->{+MESSAGE};
}

sub summary { $_[0]->{+MESSAGE} }

sub facet_data {
    my $self = shift;

    my $out = $self->common_facet_data;

    $out->{info} = [
        {
            tag     => 'NOTE',
            debug   => 0,
            details => $self->{+MESSAGE},
        }
    ];

    return $out;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::Event::Note - Note event type

=head1 DESCRIPTION

Notes, typically rendered to STDOUT.

=head1 SYNOPSIS

    use Test2::API qw/context/;
    use Test2::Event::Note;

    my $ctx = context();
    my $event = $ctx->Note($message);

=head1 ACCESSORS

=over 4

=item $note->message

The message for the note.

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! p�i�Z  Z    perl5/Test2/Event/Ok.pmnu ��6�$        package Test2::Event::Ok;
use strict;
use warnings;

our $VERSION = '1.302183';


BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use Test2::Util::HashBase qw{
    pass effective_pass name todo
};

sub init {
    my $self = shift;

    # Do not store objects here, only true or false
    $self->{+PASS} = $self->{+PASS} ? 1 : 0;
    $self->{+EFFECTIVE_PASS} = $self->{+PASS} || (defined($self->{+TODO}) ? 1 : 0);
}

{
    no warnings 'redefine';
    sub set_todo {
        my $self = shift;
        my ($todo) = @_;
        $self->{+TODO} = $todo;
        $self->{+EFFECTIVE_PASS} = defined($todo) ? 1 : $self->{+PASS};
    }
}

sub increments_count { 1 };

sub causes_fail { !$_[0]->{+EFFECTIVE_PASS} }

sub summary {
    my $self = shift;

    my $name = $self->{+NAME} || "Nameless Assertion";

    my $todo = $self->{+TODO};
    if ($todo) {
        $name .= " (TODO: $todo)";
    }
    elsif (defined $todo) {
        $name .= " (TODO)"
    }

    return $name;
}

sub extra_amnesty {
    my $self = shift;
    return unless defined($self->{+TODO}) || ($self->{+EFFECTIVE_PASS} && !$self->{+PASS});
    return {
        tag       => 'TODO',
        details   => $self->{+TODO},
    };
}

sub facet_data {
    my $self = shift;

    my $out = $self->common_facet_data;

    $out->{assert}  = {
        no_debug => 1,                # Legacy behavior
        pass     => $self->{+PASS},
        details  => $self->{+NAME},
    };

    if (my @exra_amnesty = $self->extra_amnesty) {
        my %seen;

        # It is possible the extra amnesty can be a duplicate, so filter it.
        $out->{amnesty} = [
            grep { !$seen{defined($_->{tag}) ? $_->{tag} : ''}->{defined($_->{details}) ? $_->{details} : ''}++ }
                @exra_amnesty,
                @{$out->{amnesty}},
        ];
    }

    return $out;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::Event::Ok - Ok event type

=head1 DESCRIPTION

Ok events are generated whenever you run a test that produces a result.
Examples are C<ok()>, and C<is()>.

=head1 SYNOPSIS

    use Test2::API qw/context/;
    use Test2::Event::Ok;

    my $ctx = context();
    my $event = $ctx->ok($bool, $name, \@diag);

or:

    my $ctx   = context();
    my $event = $ctx->send_event(
        'Ok',
        pass => $bool,
        name => $name,
    );

=head1 ACCESSORS

=over 4

=item $rb = $e->pass

The original true/false value of whatever was passed into the event (but
reduced down to 1 or 0).

=item $name = $e->name

Name of the test.

=item $b = $e->effective_pass

This is the true/false value of the test after TODO and similar modifiers are
taken into account.

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! ���H+  +    perl5/Test2/Event/V2.pmnu ��6�$        package Test2::Event::V2;
use strict;
use warnings;

our $VERSION = '1.302183';

use Scalar::Util qw/reftype/;
use Carp qw/croak/;

BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }

use Test2::Util::Facets2Legacy qw{
    causes_fail diagnostics global increments_count no_display sets_plan
    subtest_id summary terminate
};

use Test2::Util::HashBase qw/-about/;

sub non_facet_keys {
    return (
        +UUID,
        Test2::Util::ExternalMeta::META_KEY(),
    );
}

sub init {
    my $self = shift;

    my $uuid;
    if ($uuid = $self->{+UUID}) {
        croak "uuid '$uuid' passed to constructor, but uuid '$self->{+ABOUT}->{uuid}' is already set in the 'about' facet"
            if $self->{+ABOUT}->{uuid} && $self->{+ABOUT}->{uuid} ne $uuid;

        $self->{+ABOUT}->{uuid} = $uuid;
    }
    elsif ($self->{+ABOUT} && $self->{+ABOUT}->{uuid}) {
        $uuid = $self->{+ABOUT}->{uuid};
        $self->SUPER::set_uuid($uuid);
    }

    # Clone the trace, make sure it is blessed
    if (my $trace = $self->{+TRACE}) {
        $self->{+TRACE} = Test2::EventFacet::Trace->new(%$trace);
    }
}

sub set_uuid {
    my $self = shift;
    my ($uuid) = @_;
    $self->{+ABOUT}->{uuid} = $uuid;
    $self->SUPER::set_uuid($uuid);
}

sub facet_data {
    my $self = shift;
    my $f = { %{$self} };

    delete $f->{$_} for $self->non_facet_keys;

    my %out;
    for my $k (keys %$f) {
        next if substr($k, 0, 1) eq '_';

        my $data = $f->{$k} or next; # Key is there, but no facet
        my $is_list = 'ARRAY' eq (reftype($data) || '');
        $out{$k} = $is_list ? [ map { {%{$_}} } @$data ] : {%$data};
    }

    if (my $meta = $self->meta_facet_data) {
        $out{meta} = {%$meta, %{$out{meta} || {}}};
    }

    return \%out;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::Event::V2 - Second generation event.

=head1 DESCRIPTION

This is the event type that should be used instead of L<Test2::Event> or its
legacy subclasses.

=head1 SYNOPSIS

=head2 USING A CONTEXT

    use Test2::API qw/context/;

    sub my_tool {
        my $ctx = context();

        my $event = $ctx->send_ev2(info => [{tag => 'NOTE', details => "This is a note"}]);

        $ctx->release;

        return $event;
    }

=head2 USING THE CONSTRUCTOR

    use Test2::Event::V2;

    my $e = Test2::Event::V2->new(
        trace => {frame => [$PKG, $FILE, $LINE, $SUBNAME]},
        info  => [{tag => 'NOTE', details => "This is a note"}],
    );

=head1 METHODS

This class inherits from L<Test2::Event>.

=over 4

=item $fd = $e->facet_data()

This will return a hashref of facet data. Each facet hash will be a shallow
copy of the original.

=item $about = $e->about()

This will return the 'about' facet hashref.

B<NOTE:> This will return the internal hashref, not a copy.

=item $trace = $e->trace()

This will return the 'trace' facet, normally blessed (but this is not enforced
when the trace is set using C<set_trace()>.

B<NOTE:> This will return the internal trace, not a copy.

=back

=head2 MUTATION

=over 4

=item $e->add_amnesty({...})

Inherited from L<Test2::Event>. This can be used to add 'amnesty' facets to an
existing event. Each new item is added to the B<END> of the list.

B<NOTE:> Items B<ARE> blessed when added.

=item $e->add_hub({...})

Inherited from L<Test2::Event>. This is used by hubs to stamp events as they
pass through. New items are added to the B<START> of the list.

B<NOTE:> Items B<ARE NOT> blessed when added.

=item $e->set_uuid($UUID)

Inherited from L<Test2::Event>, overridden to also vivify/mutate the 'about'
facet.

=item $e->set_trace($trace)

Inherited from L<Test2::Event> which allows you to change the trace.

B<Note:> This method does not bless/clone the trace for you. Many things will
expect the trace to be blessed, so you should probably do that.

=back

=head2 LEGACY SUPPORT METHODS

These are all imported from L<Test2::Util::Facets2Legacy>, see that module or
L<Test2::Event> for documentation on what they do.

=over 4

=item causes_fail

=item diagnostics

=item global

=item increments_count

=item no_display

=item sets_plan

=item subtest_id

=item summary

=item terminate

=back

=head1 THIRD PARTY META-DATA

This object consumes L<Test2::Util::ExternalMeta> which provides a consistent
way for you to attach meta-data to instances of this class. This is useful for
tools, plugins, and other extensions.

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! �?0q�  �    perl5/Test2/EventFacet.pmnu ��6�$        package Test2::EventFacet;
use strict;
use warnings;

our $VERSION = '1.302183';

use Test2::Util::HashBase qw/-details/;
use Carp qw/croak/;

my $SUBLEN = length(__PACKAGE__ . '::');
sub facet_key {
    my $key = ref($_[0]) || $_[0];
    substr($key, 0, $SUBLEN, '');
    return lc($key);
}

sub is_list { 0 }

sub clone {
    my $self = shift;
    my $type = ref($self);
    return bless {%$self, @_}, $type;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::EventFacet - Base class for all event facets.

=head1 DESCRIPTION

Base class for all event facets.

=head1 METHODS

=over 4

=item $key = $facet_class->facet_key()

This will return the key for the facet in the facet data hash.

=item $bool = $facet_class->is_list()

This will return true if the facet should be in a list instead of a single
item.

=item $clone = $facet->clone()

=item $clone = $facet->clone(%replace)

This will make a shallow clone of the facet. You may specify fields to override
as arguments.

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! �E�ص  �    perl5/Test2/EventFacet/Trace.pmnu ��6�$        package Test2::EventFacet::Trace;
use strict;
use warnings;

our $VERSION = '1.302183';

BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }

use Test2::Util qw/get_tid pkg_to_file gen_uid/;
use Carp qw/confess/;

use Test2::Util::HashBase qw{^frame ^pid ^tid ^cid -hid -nested details -buffered -uuid -huuid <full_caller};

{
    no warnings 'once';
    *DETAIL = \&DETAILS;
    *detail = \&details;
    *set_detail = \&set_details;
}

sub init {
    confess "The 'frame' attribute is required"
        unless $_[0]->{+FRAME};

    $_[0]->{+DETAILS} = delete $_[0]->{detail} if $_[0]->{detail};

    unless (defined($_[0]->{+PID}) || defined($_[0]->{+TID}) || defined($_[0]->{+CID})) {
        $_[0]->{+PID} = $$        unless defined $_[0]->{+PID};
        $_[0]->{+TID} = get_tid() unless defined $_[0]->{+TID};
    }
}

sub snapshot {
    my ($orig, @override) = @_;
    bless {%$orig, @override}, __PACKAGE__;
}

sub signature {
    my $self = shift;

    # Signature is only valid if all of these fields are defined, there is no
    # signature if any is missing. '0' is ok, but '' is not.
    return join ':' => map { (defined($_) && length($_)) ? $_ : return undef } (
        $self->{+CID},
        $self->{+PID},
        $self->{+TID},
        $self->{+FRAME}->[1],
        $self->{+FRAME}->[2],
    );
}

sub debug {
    my $self = shift;
    return $self->{+DETAILS} if $self->{+DETAILS};
    my ($pkg, $file, $line) = $self->call;
    return "at $file line $line";
}

sub alert {
    my $self = shift;
    my ($msg) = @_;
    warn $msg . ' ' . $self->debug . ".\n";
}

sub throw {
    my $self = shift;
    my ($msg) = @_;
    die $msg . ' ' . $self->debug . ".\n";
}

sub call { @{$_[0]->{+FRAME}} }

sub full_call { @{$_[0]->{+FULL_CALLER}} }

sub package { $_[0]->{+FRAME}->[0] }
sub file    { $_[0]->{+FRAME}->[1] }
sub line    { $_[0]->{+FRAME}->[2] }
sub subname { $_[0]->{+FRAME}->[3] }

sub warning_bits { $_[0]->{+FULL_CALLER} ? $_[0]->{+FULL_CALLER}->[9] : undef }

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::EventFacet::Trace - Debug information for events

=head1 DESCRIPTION

The L<Test2::API::Context> object, as well as all L<Test2::Event> types need to
have access to information about where they were created.  This object
represents that information.

=head1 SYNOPSIS

    use Test2::EventFacet::Trace;

    my $trace = Test2::EventFacet::Trace->new(
        frame => [$package, $file, $line, $subname],
    );

=head1 FACET FIELDS

=over 4

=item $string = $trace->{details}

=item $string = $trace->details()

Used as a custom trace message that will be used INSTEAD of
C<< at <FILE> line <LINE> >> when calling C<< $trace->debug >>.

=item $frame = $trace->{frame}

=item $frame = $trace->frame()

Get the call frame arrayref.

    [$package, $file, $line, $subname]

=item $int = $trace->{pid}

=item $int = $trace->pid()

The process ID in which the event was generated.

=item $int = $trace->{tid}

=item $int = $trace->tid()

The thread ID in which the event was generated.

=item $id = $trace->{cid}

=item $id = $trace->cid()

The ID of the context that was used to create the event.

=item $uuid = $trace->{uuid}

=item $uuid = $trace->uuid()

The UUID of the context that was used to create the event. (If uuid tagging was
enabled)

=item ($pkg, $file, $line, $subname) = $trace->call

Get the basic call info as a list.

=item @caller = $trace->full_call

Get the full caller(N) results.

=item $warning_bits = $trace->warning_bits

Get index 9 from the full caller info. This is the warnings_bits field.

The value of this is not portable across perl versions or even processes.
However it can be used in the process that generated it to reproduce the
warnings settings in a new scope.

    eval <<EOT;
    BEGIN { ${^WARNING_BITS} = $trace->warning_bits };
    ... context's warning settings apply here ...
    EOT

=back

=head2 DISCOURAGED HUB RELATED FIELDS

These fields were not always set properly by tools. These are B<MOSTLY>
deprecated by the L<Test2::EventFacet::Hub> facets. These fields are not
required, and may only reflect the hub that was current when the event was
created, which is not necessarily the same as the hub the event was sent
through.

Some tools did do a good job setting these to the correct hub, but you cannot
always rely on that. Use the 'hubs' facet list instead.

=over 4

=item $hid = $trace->{hid}

=item $hid = $trace->hid()

The ID of the hub that was current when the event was created.

=item $huuid = $trace->{huuid}

=item $huuid = $trace->huuid()

The UUID of the hub that was current when the event was created. (If uuid
tagging was enabled).

=item $int = $trace->{nested}

=item $int = $trace->nested()

How deeply nested the event is.

=item $bool = $trace->{buffered}

=item $bool = $trace->buffered()

True if the event was buffered and not sent to the formatter independent of a
parent (This should never be set when nested is C<0> or C<undef>).

=back

=head1 METHODS

B<Note:> All facet frames are also methods.

=over 4

=item $trace->set_detail($msg)

=item $msg = $trace->detail

Used to get/set a custom trace message that will be used INSTEAD of
C<< at <FILE> line <LINE> >> when calling C<< $trace->debug >>.

C<detail()> is an alias to the C<details> facet field for backwards
compatibility.

=item $str = $trace->debug

Typically returns the string C<< at <FILE> line <LINE> >>. If C<detail> is set
then its value will be returned instead.

=item $trace->alert($MESSAGE)

This issues a warning at the frame (filename and line number where
errors should be reported).

=item $trace->throw($MESSAGE)

This throws an exception at the frame (filename and line number where
errors should be reported).

=item ($package, $file, $line, $subname) = $trace->call()

Get the caller details for the debug-info. This is where errors should be
reported.

=item $pkg = $trace->package

Get the debug-info package.

=item $file = $trace->file

Get the debug-info filename.

=item $line = $trace->line

Get the debug-info line number.

=item $subname = $trace->subname

Get the debug-info subroutine name.

=item $sig = trace->signature

Get a signature string that identifies this trace. This is used to check if
multiple events are related. The signature includes pid, tid, file, line
number, and the cid.

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! :vO�'  '  $  perl5/Test2/EventFacet/Info/Table.pmnu ��6�$        package Test2::EventFacet::Info::Table;
use strict;
use warnings;

our $VERSION = '1.302183';

use Carp qw/confess/;

use Test2::Util::HashBase qw{-header -rows -collapse -no_collapse -as_string};

sub init {
    my $self = shift;

    confess "Table may not be empty" unless ref($self->{+ROWS}) eq 'ARRAY' && @{$self->{+ROWS}};

    $self->{+AS_STRING} ||= '<TABLE NOT DISPLAYED>';
}

sub as_hash { my $out = +{%{$_[0]}}; delete $out->{as_string}; $out }

sub info_args {
    my $self = shift;

    my $hash = $self->as_hash;
    my $desc = $self->as_string;

    return (table => $hash, details => $desc);
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::EventFacet::Info::Table - Intermediary representation of a table.

=head1 DESCRIPTION

Intermediary representation of a table for use in specialized
L<Test::API::Context> methods which generate L<Test2::EventFacet::Info> facets.

=head1 SYNOPSIS

    use Test2::EventFacet::Info::Table;
    use Test2::API qw/context/;

    sub my_tool {
        my $ctx = context();

        ...

        $ctx->fail(
            $name,
            "failure diag message",
            Test2::EventFacet::Info::Table->new(
                # Required
                rows => [['a', 'b'], ['c', 'd'], ...],

                # Strongly Recommended
                as_string => "... string to print when table cannot be rendered ...",

                # Optional
                header => ['col1', 'col2'],
                collapse => $bool,
                no_collapse => ['col1', ...],
            ),
        );

        ...

        $ctx->release;
    }

    my_tool();

=head1 ATTRIBUTES

=over 4

=item $header_aref = $t->header()

=item $rows_aref = $t->rows()

=item $bool = $t->collapse()

=item $aref = $t->no_collapse()

The above are all directly tied to the table hashref structure described in
L<Test2::EventFacet::Info>.

=item $str = $t->as_string()

This returns the string form of the table if it was set, otherwise it returns
the string C<< "<TABLE NOT DISPLAYED>" >>.

=item $href = $t->as_hash()

This returns the data structure used for tables by L<Test2::EventFacet::Info>.

=item %args = $t->info_args()

This returns the arguments that should be used to construct the proper
L<Test2::EventFacet::Info> structure.

    return (table => $t->as_hash(), details => $t->as_string());

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! JF�      perl5/Test2/EventFacet/Error.pmnu ��6�$        package Test2::EventFacet::Error;
use strict;
use warnings;

our $VERSION = '1.302183';

sub facet_key { 'errors' }
sub is_list { 1 }

BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
use Test2::Util::HashBase qw{ -tag -fail };

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::EventFacet::Error - Facet for errors that need to be shown.

=head1 DESCRIPTION

This facet is used when an event needs to convey errors.

=head1 NOTES

This facet has the hash key C<'errors'>, and is a list of facets instead of a
single item.

=head1 FIELDS

=over 4

=item $string = $error->{details}

=item $string = $error->details()

Explanation of the error, or the error itself (such as an exception). In perl
exceptions may be blessed objects, so this field may contain a blessed object.

=item $short_string = $error->{tag}

=item $short_string = $error->tag()

Short tag to categorize the error. This is usually 10 characters or less,
formatters may truncate longer tags.

=item $bool = $error->{fail}

=item $bool = $error->fail()

Not all errors are fatal, some are displayed having already been handled. Set
this to true if you want the error to cause the test to fail. Without this the
error is simply a diagnostics message that has no effect on the overall
pass/fail result.

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! �
�^  ^    perl5/Test2/EventFacet/Plan.pmnu ��6�$        package Test2::EventFacet::Plan;
use strict;
use warnings;

our $VERSION = '1.302183';

BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
use Test2::Util::HashBase qw{ -count -skip -none };

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::EventFacet::Plan - Facet for setting the plan

=head1 DESCRIPTION

Events use this facet when they need to set the plan.

=head1 FIELDS

=over 4

=item $string = $plan->{details}

=item $string = $plan->details()

Human readable explanation for the plan being set. This is normally not
rendered by most formatters except when the C<skip> field is also set.

=item $positive_int = $plan->{count}

=item $positive_int = $plan->count()

Set the number of expected assertions. This should usually be set to C<0> when
C<skip> or C<none> are also set.

=item $bool = $plan->{skip}

=item $bool = $plan->skip()

When true the entire test should be skipped. This is usually paired with an
explanation in the C<details> field, and a C<control> facet that has
C<terminate> set to C<0>.

=item $bool = $plan->{none}

=item $bool = $plan->none()

This is mainly used by legacy L<Test::Builder> tests which set the plan to C<no
plan>, a construct that predates the much better C<done_testing()>.

If you are using this in non-legacy code you may need to reconsider the course
of your life, maybe a hermitage would suite you?

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! �O9h�  �     perl5/Test2/EventFacet/Render.pmnu ��6�$        package Test2::EventFacet::Render;
use strict;
use warnings;

our $VERSION = '1.302183';

sub is_list { 1 }

BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
use Test2::Util::HashBase qw{ -tag -facet -mode };

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::EventFacet::Render - Facet that dictates how to render an event.

=head1 DESCRIPTION

This facet is used to dictate how the event should be rendered by the standard
test2 rendering tools. If this facet is present then ONLY what is specified by
it will be rendered. It is assumed that anything important or note-worthy will
be present here, no other facets will be considered for rendering/display.

This facet is a list type, you can add as many items as needed.

=head1 FIELDS

=over 4

=item $string = $render->[#]->{details}

=item $string = $render->[#]->details()

Human readable text for display.

=item $string = $render->[#]->{tag}

=item $string = $render->[#]->tag()

Tag that should prefix/identify the main text.

=item $string = $render->[#]->{facet}

=item $string = $render->[#]->facet()

Optional, if the display text was generated from another facet this should
state what facet it was.

=item $mode = $render->[#]->{mode}

=item $mode = $render->[#]->mode()

=over 4

=item calculated

Calculated means the facet was generated from another facet. Calculated facets
may be cleared and regenerated whenever the event state changes.

=item replace

Replace means the facet is intended to replace the normal rendering of the
event.

=back

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! ~$��F  F    perl5/Test2/EventFacet/Meta.pmnu ��6�$        package Test2::EventFacet::Meta;
use strict;
use warnings;

our $VERSION = '1.302183';

BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
use vars qw/$AUTOLOAD/;

# replace set_details
{
    no warnings 'redefine';
    sub set_details { $_[0]->{'set_details'} }
}

sub can {
    my $self = shift;
    my ($name) = @_;

    my $existing = $self->SUPER::can($name);
    return $existing if $existing;

    # Only vivify when called on an instance, do not vivify for a class. There
    # are a lot of magic class methods used in things like serialization (or
    # the forks.pm module) which cause problems when vivified.
    return undef unless ref($self);

    my $sub = sub { $_[0]->{$name} };
    {
        no strict 'refs';
        *$name = $sub;
    }

    return $sub;
}

sub AUTOLOAD {
    my $name = $AUTOLOAD;
    $name =~ s/^.*:://g;
    my $sub = $_[0]->can($name);
    goto &$sub;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::EventFacet::Meta - Facet for meta-data

=head1 DESCRIPTION

This facet can contain any random meta-data that has been attached to the
event.

=head1 METHODS AND FIELDS

Any/all fields and accessors are autovivified into existence. There is no way
to know what metadata may be added, so any is allowed.

=over 4

=item $anything = $meta->{anything}

=item $anything = $meta->anything()

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! �D�O�  �    perl5/Test2/EventFacet/About.pmnu ��6�$        package Test2::EventFacet::About;
use strict;
use warnings;

our $VERSION = '1.302183';

BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
use Test2::Util::HashBase qw{ -package -no_display -uuid -eid };

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::EventFacet::About - Facet with event details.

=head1 DESCRIPTION

This facet has information about the event, such as event package.

=head1 FIELDS

=over 4

=item $string = $about->{details}

=item $string = $about->details()

Summary about the event.

=item $package = $about->{package}

=item $package = $about->package()

Event package name.

=item $bool = $about->{no_display}

=item $bool = $about->no_display()

True if the event should be skipped by formatters.

=item $uuid = $about->{uuid}

=item $uuid = $about->uuid()

Will be set to a uuid if uuid tagging was enabled.

=item $uuid = $about->{eid}

=item $uuid = $about->eid()

A unique (for the test job) identifier for the event.

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! 19�6  6    perl5/Test2/EventFacet/Info.pmnu ��6�$        package Test2::EventFacet::Info;
use strict;
use warnings;

our $VERSION = '1.302183';

sub is_list { 1 }

BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
use Test2::Util::HashBase qw{-tag -debug -important -table};

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::EventFacet::Info - Facet for information a developer might care about.

=head1 DESCRIPTION

This facet represents messages intended for humans that will help them either
understand a result, or diagnose a failure.

=head1 NOTES

This facet appears in a list instead of being a single item.

=head1 FIELDS

=over 4

=item $string_or_structure = $info->{details}

=item $string_or_structure = $info->details()

Human readable string or data structure, this is the information to display.
Formatters are free to render the structures however they please. This may
contain a blessed object.

If the C<table> attribute (see below) is set then a renderer may choose to
display the table instead of the details.

=item $structure = $info->{table}

=item $structure = $info->table()

If the data the C<info> facet needs to convey can be represented as a table
then the data may be placed in this attribute in a more raw form for better
display. The data must also be represented in the C<details> attribute for
renderers which do not support rendering tables directly.

The table structure:

    my %table = {
        header => [ 'column 1 header', 'column 2 header', ... ], # Optional

        rows => [
            ['row 1 column 1', 'row 1, column 2', ... ],
            ['row 2 column 1', 'row 2, column 2', ... ],
            ...
        ],

        # Allow the renderer to hide empty columns when true, Optional
        collapse => $BOOL,

        # List by name or number columns that should never be collapsed
        no_collapse => \@LIST,
    }

=item $short_string = $info->{tag}

=item $short_string = $info->tag()

Short tag to categorize the info. This is usually 10 characters or less,
formatters may truncate longer tags.

=item $bool = $info->{debug}

=item $bool = $info->debug()

Set this to true if the message is critical, or explains a failure. This is
info that should be displayed by formatters even in less-verbose modes.

When false the information is not considered critical and may not be rendered
in less-verbose modes.

=item $bool = $info->{important}

=item $bool = $info->important

This should be set for non debug messages that are still important enough to
show when a formatter is in quiet mode. A formatter should send these to STDOUT
not STDERR, but should show them even in non-verbose mode.

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! �&���  �  !  perl5/Test2/EventFacet/Control.pmnu ��6�$        package Test2::EventFacet::Control;
use strict;
use warnings;

our $VERSION = '1.302183';

BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
use Test2::Util::HashBase qw{ -global -terminate -halt -has_callback -encoding -phase };

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::EventFacet::Control - Facet for hub actions and behaviors.

=head1 DESCRIPTION

This facet is used when the event needs to give instructions to the Test2
internals.

=head1 FIELDS

=over 4

=item $string = $control->{details}

=item $string = $control->details()

Human readable explanation for the special behavior.

=item $bool = $control->{global}

=item $bool = $control->global()

True if the event is global in nature and should be seen by all hubs.

=item $exit = $control->{terminate}

=item $exit = $control->terminate()

Defined if the test should immediately exit, the value is the exit code and may
be C<0>.

=item $bool = $control->{halt}

=item $bool = $control->halt()

True if all testing should be halted immediately.

=item $bool = $control->{has_callback}

=item $bool = $control->has_callback()

True if the C<callback($hub)> method on the event should be called.

=item $encoding = $control->{encoding}

=item $encoding = $control->encoding()

This can be used to change the encoding from this event onward.

=item $phase = $control->{phase}

=item $phase = $control->phase()

Used to signal that a phase change has occurred. Currently only the perl END
phase is signaled.

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! ,��U  U    perl5/Test2/EventFacet/Hub.pmnu ��6�$        package Test2::EventFacet::Hub;
use strict;
use warnings;

our $VERSION = '1.302183';

sub is_list { 1 }
sub facet_key { 'hubs' }

BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
use Test2::Util::HashBase qw{-pid -tid -hid -nested -buffered -uuid -ipc};

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::EventFacet::Hub - Facet for the hubs an event passes through.

=head1 DESCRIPTION

These are a record of the hubs an event passes through. Most recent hub is the
first one in the list.

=head1 FACET FIELDS

=over 4

=item $string = $trace->{details}

=item $string = $trace->details()

The hub class or subclass

=item $int = $trace->{pid}

=item $int = $trace->pid()

PID of the hub this event was sent to.

=item $int = $trace->{tid}

=item $int = $trace->tid()

The thread ID of the hub the event was sent to.

=item $hid = $trace->{hid}

=item $hid = $trace->hid()

The ID of the hub that the event was send to.

=item $huuid = $trace->{huuid}

=item $huuid = $trace->huuid()

The UUID of the hub that the event was sent to.

=item $int = $trace->{nested}

=item $int = $trace->nested()

How deeply nested the hub was.

=item $bool = $trace->{buffered}

=item $bool = $trace->buffered()

True if the event was buffered and not sent to the formatter independent of a
parent (This should never be set when nested is C<0> or C<undef>).

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! n�*�  �     perl5/Test2/EventFacet/Assert.pmnu ��6�$        package Test2::EventFacet::Assert;
use strict;
use warnings;

our $VERSION = '1.302183';

BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
use Test2::Util::HashBase qw{ -pass -no_debug -number };

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::EventFacet::Assert - Facet representing an assertion.

=head1 DESCRIPTION

The assertion facet is provided by any event representing an assertion that was
made.

=head1 FIELDS

=over 4

=item $string = $assert->{details}

=item $string = $assert->details()

Human readable description of the assertion.

=item $bool = $assert->{pass}

=item $bool = $assert->pass()

True if the assertion passed.

=item $bool = $assert->{no_debug}

=item $bool = $assert->no_debug()

Set this to true if you have provided custom diagnostics and do not want the
defaults to be displayed.

=item $int = $assert->{number}

=item $int = $assert->number()

(Optional) assertion number. This may be omitted or ignored. This is usually
only useful when parsing/processing TAP.

B<Note>: This is not set by the Test2 system, assertion number is not known
until AFTER the assertion has been processed. This attribute is part of the
spec only for harnesses.

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! ]zՑ�  �     perl5/Test2/EventFacet/Parent.pmnu ��6�$        package Test2::EventFacet::Parent;
use strict;
use warnings;

our $VERSION = '1.302183';

use Carp qw/confess/;

BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
use Test2::Util::HashBase qw{ -hid -children -buffered };

sub init {
    confess "Attribute 'hid' must be set"
        unless defined $_[0]->{+HID};

    $_[0]->{+CHILDREN} ||= [];
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::EventFacet::Parent - Facet for events contains other events

=head1 DESCRIPTION

This facet is used when an event contains other events, such as a subtest.

=head1 FIELDS

=over 4

=item $string = $parent->{details}

=item $string = $parent->details()

Human readable description of the event.

=item $hid = $parent->{hid}

=item $hid = $parent->hid()

Hub ID of the hub that is represented in the parent-child relationship.

=item $arrayref = $parent->{children}

=item $arrayref = $parent->children()

Arrayref containing the facet-data hashes of events nested under this one.

I<To get the actual events you need to get them from the parent event directly>

=item $bool = $parent->{buffered}

=item $bool = $parent->buffered()

True if the subtest is buffered (meaning the formatter has probably not seen
them yet).

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! Ј�Pk  k  !  perl5/Test2/EventFacet/Amnesty.pmnu ��6�$        package Test2::EventFacet::Amnesty;
use strict;
use warnings;

our $VERSION = '1.302183';

sub is_list { 1 }

BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
use Test2::Util::HashBase qw{ -tag -inherited };

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::EventFacet::Amnesty - Facet for assertion amnesty.

=head1 DESCRIPTION

This package represents what is expected in units of amnesty.

=head1 NOTES

This facet appears in a list instead of being a single item.

=head1 FIELDS

=over 4

=item $string = $amnesty->{details}

=item $string = $amnesty->details()

Human readable explanation of why amnesty was granted.

Example: I<Not implemented yet, will fix>

=item $short_string = $amnesty->{tag}

=item $short_string = $amnesty->tag()

Short string (usually 10 characters or less, not enforced, but may be truncated
by renderers) categorizing the amnesty.

=item $bool = $amnesty->{inherited}

=item $bool = $amnesty->inherited()

This will be true if the amnesty was granted to a parent event and inherited by
this event, which is a child, such as an assertion within a subtest that is
marked todo.

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! �a��#  �#    perl5/Test2/Tools/Tiny.pmnu ��6�$        package Test2::Tools::Tiny;
use strict;
use warnings;

BEGIN {
    if ($] lt "5.008") {
        require Test::Builder::IO::Scalar;
    }
}

use Scalar::Util qw/blessed/;

use Test2::Util qw/try/;
use Test2::API qw/context run_subtest test2_stack/;

use Test2::Hub::Interceptor();
use Test2::Hub::Interceptor::Terminator();

our $VERSION = '1.302183';

BEGIN { require Exporter; our @ISA = qw(Exporter) }
our @EXPORT = qw{
    ok is isnt like unlike is_deeply diag note skip_all todo plan done_testing
    warnings exception tests capture
};

sub ok($;$@) {
    my ($bool, $name, @diag) = @_;
    my $ctx = context();

    return $ctx->pass_and_release($name) if $bool;
    return $ctx->fail_and_release($name, @diag);
}

sub is($$;$@) {
    my ($got, $want, $name, @diag) = @_;
    my $ctx = context();

    my $bool;
    if (defined($got) && defined($want)) {
        $bool = "$got" eq "$want";
    }
    elsif (defined($got) xor defined($want)) {
        $bool = 0;
    }
    else {    # Both are undef
        $bool = 1;
    }

    return $ctx->pass_and_release($name) if $bool;

    $got  = '*NOT DEFINED*' unless defined $got;
    $want = '*NOT DEFINED*' unless defined $want;
    unshift @diag => (
        "GOT:      $got",
        "EXPECTED: $want",
    );

    return $ctx->fail_and_release($name, @diag);
}

sub isnt($$;$@) {
    my ($got, $want, $name, @diag) = @_;
    my $ctx = context();

    my $bool;
    if (defined($got) && defined($want)) {
        $bool = "$got" ne "$want";
    }
    elsif (defined($got) xor defined($want)) {
        $bool = 1;
    }
    else {    # Both are undef
        $bool = 0;
    }

    return $ctx->pass_and_release($name) if $bool;

    unshift @diag => "Strings are the same (they should not be)"
        unless $bool;

    return $ctx->fail_and_release($name, @diag);
}

sub like($$;$@) {
    my ($thing, $pattern, $name, @diag) = @_;
    my $ctx = context();

    my $bool;
    if (defined($thing)) {
        $bool = "$thing" =~ $pattern;
        unshift @diag => (
            "Value: $thing",
            "Does not match: $pattern"
        ) unless $bool;
    }
    else {
        $bool = 0;
        unshift @diag => "Got an undefined value.";
    }

    return $ctx->pass_and_release($name) if $bool;
    return $ctx->fail_and_release($name, @diag);
}

sub unlike($$;$@) {
    my ($thing, $pattern, $name, @diag) = @_;
    my $ctx = context();

    my $bool;
    if (defined($thing)) {
        $bool = "$thing" !~ $pattern;
        unshift @diag => (
            "Unexpected pattern match (it should not match)",
            "Value:   $thing",
            "Matches: $pattern"
        ) unless $bool;
    }
    else {
        $bool = 0;
        unshift @diag => "Got an undefined value.";
    }

    return $ctx->pass_and_release($name) if $bool;
    return $ctx->fail_and_release($name, @diag);
}

sub is_deeply($$;$@) {
    my ($got, $want, $name, @diag) = @_;
    my $ctx = context();

    no warnings 'once';
    require Data::Dumper;

    # Otherwise numbers might be unquoted
    local $Data::Dumper::Useperl  = 1;

    local $Data::Dumper::Sortkeys = 1;
    local $Data::Dumper::Deparse  = 1;
    local $Data::Dumper::Freezer  = 'XXX';
    local *UNIVERSAL::XXX         = sub {
        my ($thing) = @_;
        if (ref($thing)) {
            $thing = {%$thing}  if "$thing" =~ m/=HASH/;
            $thing = [@$thing]  if "$thing" =~ m/=ARRAY/;
            $thing = \"$$thing" if "$thing" =~ m/=SCALAR/;
        }
        $_[0] = $thing;
    };

    my $g = Data::Dumper::Dumper($got);
    my $w = Data::Dumper::Dumper($want);

    my $bool = $g eq $w;

    return $ctx->pass_and_release($name) if $bool;
    return $ctx->fail_and_release($name, $g, $w, @diag);
}

sub diag {
    my $ctx = context();
    $ctx->diag(join '', @_);
    $ctx->release;
}

sub note {
    my $ctx = context();
    $ctx->note(join '', @_);
    $ctx->release;
}

sub skip_all {
    my ($reason) = @_;
    my $ctx = context();
    $ctx->plan(0, SKIP => $reason);
    $ctx->release if $ctx;
}

sub todo {
    my ($reason, $sub) = @_;
    my $ctx = context();

    # This code is mostly copied from Test2::Todo in the Test2-Suite
    # distribution.
    my $hub    = test2_stack->top;
    my $filter = $hub->pre_filter(
        sub {
            my ($active_hub, $event) = @_;
            if ($active_hub == $hub) {
                $event->set_todo($reason) if $event->can('set_todo');
                $event->add_amnesty({tag => 'TODO', details => $reason});
            }
            else {
                $event->add_amnesty({tag => 'TODO', details => $reason, inherited => 1});
            }
            return $event;
        },
        inherit => 1,
        todo    => $reason,
    );
    $sub->();
    $hub->pre_unfilter($filter);

    $ctx->release if $ctx;
}

sub plan {
    my ($max) = @_;
    my $ctx = context();
    $ctx->plan($max);
    $ctx->release;
}

sub done_testing {
    my $ctx = context();
    $ctx->done_testing;
    $ctx->release;
}

sub warnings(&) {
    my $code = shift;
    my @warnings;
    local $SIG{__WARN__} = sub { push @warnings => @_ };
    $code->();
    return \@warnings;
}

sub exception(&) {
    my $code = shift;
    local ($@, $!, $SIG{__DIE__});
    my $ok = eval { $code->(); 1 };
    my $error = $@ || 'SQUASHED ERROR';
    return $ok ? undef : $error;
}

sub tests {
    my ($name, $code) = @_;
    my $ctx = context();

    my $be = caller->can('before_each');

    $be->($name) if $be;

    my $bool = run_subtest($name, $code, 1);

    $ctx->release;

    return $bool;
}

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

    my ($err, $out) = ("", "");

    my $handles = test2_stack->top->format->handles;
    my ($ok, $e);
    {
        my ($out_fh, $err_fh);

        ($ok, $e) = try {
          # Scalar refs as filehandles were added in 5.8.
          if ($] ge "5.008") {
            open($out_fh, '>', \$out) or die "Failed to open a temporary STDOUT: $!";
            open($err_fh, '>', \$err) or die "Failed to open a temporary STDERR: $!";
          }
          # Emulate scalar ref filehandles with a tie.
          else {
            $out_fh = Test::Builder::IO::Scalar->new(\$out) or die "Failed to open a temporary STDOUT";
            $err_fh = Test::Builder::IO::Scalar->new(\$err) or die "Failed to open a temporary STDERR";
          }

            test2_stack->top->format->set_handles([$out_fh, $err_fh, $out_fh]);

            $code->();
        };
    }
    test2_stack->top->format->set_handles($handles);

    die $e unless $ok;

    $err =~ s/ $/_/mg;
    $out =~ s/ $/_/mg;

    return {
        STDOUT => $out,
        STDERR => $err,
    };
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::Tools::Tiny - Tiny set of tools for unfortunate souls who cannot use
L<Test2::Suite>.

=head1 DESCRIPTION

You should really look at L<Test2::Suite>. This package is some very basic
essential tools implemented using L<Test2>. This exists only so that L<Test2>
and other tools required by L<Test2::Suite> can be tested. This is the package
L<Test2> uses to test itself.

=head1 USE Test2::Suite INSTEAD

Use L<Test2::Suite> if at all possible.

=head1 EXPORTS

=over 4

=item ok($bool, $name)

=item ok($bool, $name, @diag)

Run a simple assertion.

=item is($got, $want, $name)

=item is($got, $want, $name, @diag)

Assert that 2 strings are the same.

=item isnt($got, $do_not_want, $name)

=item isnt($got, $do_not_want, $name, @diag)

Assert that 2 strings are not the same.

=item like($got, $regex, $name)

=item like($got, $regex, $name, @diag)

Check that the input string matches the regex.

=item unlike($got, $regex, $name)

=item unlike($got, $regex, $name, @diag)

Check that the input string does not match the regex.

=item is_deeply($got, $want, $name)

=item is_deeply($got, $want, $name, @diag)

Check 2 data structures. Please note that this is a I<DUMB> implementation that
compares the output of L<Data::Dumper> against both structures.

=item diag($msg)

Issue a diagnostics message to STDERR.

=item note($msg)

Issue a diagnostics message to STDOUT.

=item skip_all($reason)

Skip all tests.

=item todo $reason => sub { ... }

Run a block in TODO mode.

=item plan($count)

Set the plan.

=item done_testing()

Set the plan to the current test count.

=item $warnings = warnings { ... }

Capture an arrayref of warnings from the block.

=item $exception = exception { ... }

Capture an exception.

=item tests $name => sub { ... }

Run a subtest.

=item $output = capture { ... }

Capture STDOUT and STDERR output.

Result looks like this:

    {
        STDOUT => "...",
        STDERR => "...",
    }

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! g�s  s    perl5/Test2/Util/Trace.pmnu ��6�$        package Test2::Util::Trace;
require Test2::EventFacet::Trace;

use warnings;
use strict;

our @ISA = ('Test2::EventFacet::Trace');

our $VERSION = '1.302183';

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::Util::Trace - Legacy wrapper fro L<Test2::EventFacet::Trace>.

=head1 DESCRIPTION

All the functionality for this class has been moved to
L<Test2::EventFacet::Trace>.

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! �z5��  �     perl5/Test2/Util/ExternalMeta.pmnu ��6�$        package Test2::Util::ExternalMeta;
use strict;
use warnings;

our $VERSION = '1.302183';


use Carp qw/croak/;

sub META_KEY() { '_meta' }

our @EXPORT = qw/meta set_meta get_meta delete_meta/;
BEGIN { require Exporter; our @ISA = qw(Exporter) }

sub set_meta {
    my $self = shift;
    my ($key, $value) = @_;

    validate_key($key);

    $self->{+META_KEY} ||= {};
    $self->{+META_KEY}->{$key} = $value;
}

sub get_meta {
    my $self = shift;
    my ($key) = @_;

    validate_key($key);

    my $meta = $self->{+META_KEY} or return undef;
    return $meta->{$key};
}

sub delete_meta {
    my $self = shift;
    my ($key) = @_;

    validate_key($key);

    my $meta = $self->{+META_KEY} or return undef;
    delete $meta->{$key};
}

sub meta {
    my $self = shift;
    my ($key, $default) = @_;

    validate_key($key);

    my $meta = $self->{+META_KEY};
    return undef unless $meta || defined($default);

    unless($meta) {
        $meta = {};
        $self->{+META_KEY} = $meta;
    }

    $meta->{$key} = $default
        if defined($default) && !defined($meta->{$key});

    return $meta->{$key};
}

sub validate_key {
    my $key = shift;

    return if $key && !ref($key);

    my $render_key = defined($key) ? "'$key'" : 'undef';
    croak "Invalid META key: $render_key, keys must be true, and may not be references";
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::Util::ExternalMeta - Allow third party tools to safely attach meta-data
to your instances.

=head1 DESCRIPTION

This package lets you define a clear, and consistent way to allow third party
tools to attach meta-data to your instances. If your object consumes this
package, and imports its methods, then third party meta-data has a safe place
to live.

=head1 SYNOPSIS

    package My::Object;
    use strict;
    use warnings;

    use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/;

    ...

Now to use it:

    my $inst = My::Object->new;

    $inst->set_meta(foo => 'bar');
    my $val = $inst->get_meta('foo');

=head1 WHERE IS THE DATA STORED?

This package assumes your instances are blessed hashrefs, it will not work if
that is not true. It will store all meta-data in the C<_meta> key on your
objects hash. If your object makes use of the C<_meta> key in its underlying
hash, then there is a conflict and you cannot use this package.

=head1 EXPORTS

=over 4

=item $val = $obj->meta($key)

=item $val = $obj->meta($key, $default)

This will get the value for a specified meta C<$key>. Normally this will return
C<undef> when there is no value for the C<$key>, however you can specify a
C<$default> value to set when no value is already set.

=item $val = $obj->get_meta($key)

This will get the value for a specified meta C<$key>. This does not have the
C<$default> overhead that C<meta()> does.

=item $val = $obj->delete_meta($key)

This will remove the value of a specified meta C<$key>. The old C<$val> will be
returned.

=item $obj->set_meta($key, $val)

Set the value of a specified meta C<$key>.

=back

=head1 META-KEY RESTRICTIONS

Meta keys must be defined, and must be true when used as a boolean. Keys may
not be references. You are free to stringify a reference C<"$ref"> for use as a
key, but this package will not stringify it for you.

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! �%�d�3  �3    perl5/Test2/Util/HashBase.pmnu ��6�$        package Test2::Util::HashBase;
use strict;
use warnings;

our $VERSION = '1.302183';

#################################################################
#                                                               #
#  This is a generated file! Do not modify this file directly!  #
#  Use hashbase_inc.pl script to regenerate this file.          #
#  The script is part of the Object::HashBase distribution.     #
#  Note: You can modify the version number above this comment   #
#  if needed, that is fine.                                     #
#                                                               #
#################################################################

{
    no warnings 'once';
    $Test2::Util::HashBase::HB_VERSION = '0.009';
    *Test2::Util::HashBase::ATTR_SUBS = \%Object::HashBase::ATTR_SUBS;
    *Test2::Util::HashBase::ATTR_LIST = \%Object::HashBase::ATTR_LIST;
    *Test2::Util::HashBase::VERSION   = \%Object::HashBase::VERSION;
    *Test2::Util::HashBase::CAN_CACHE = \%Object::HashBase::CAN_CACHE;
}


require Carp;
{
    no warnings 'once';
    $Carp::Internal{+__PACKAGE__} = 1;
}

BEGIN {
    # these are not strictly equivalent, but for out use we don't care
    # about order
    *_isa = ($] >= 5.010 && require mro) ? \&mro::get_linear_isa : sub {
        no strict 'refs';
        my @packages = ($_[0]);
        my %seen;
        for my $package (@packages) {
            push @packages, grep !$seen{$_}++, @{"$package\::ISA"};
        }
        return \@packages;
    }
}

my %SPEC = (
    '^' => {reader => 1, writer => 0, dep_writer => 1, read_only => 0, strip => 1},
    '-' => {reader => 1, writer => 0, dep_writer => 0, read_only => 1, strip => 1},
    '>' => {reader => 0, writer => 1, dep_writer => 0, read_only => 0, strip => 1},
    '<' => {reader => 1, writer => 0, dep_writer => 0, read_only => 0, strip => 1},
    '+' => {reader => 0, writer => 0, dep_writer => 0, read_only => 0, strip => 1},
);

sub import {
    my $class = shift;
    my $into  = caller;

    # Make sure we list the OLDEST version used to create this class.
    my $ver = $Test2::Util::HashBase::HB_VERSION || $Test2::Util::HashBase::VERSION;
    $Test2::Util::HashBase::VERSION{$into} = $ver if !$Test2::Util::HashBase::VERSION{$into} || $Test2::Util::HashBase::VERSION{$into} > $ver;

    my $isa = _isa($into);
    my $attr_list = $Test2::Util::HashBase::ATTR_LIST{$into} ||= [];
    my $attr_subs = $Test2::Util::HashBase::ATTR_SUBS{$into} ||= {};

    my %subs = (
        ($into->can('new') ? () : (new => \&_new)),
        (map %{$Test2::Util::HashBase::ATTR_SUBS{$_} || {}}, @{$isa}[1 .. $#$isa]),
        (
            map {
                my $p = substr($_, 0, 1);
                my $x = $_;

                my $spec = $SPEC{$p} || {reader => 1, writer => 1};

                substr($x, 0, 1) = '' if $spec->{strip};
                push @$attr_list => $x;
                my ($sub, $attr) = (uc $x, $x);

                $attr_subs->{$sub} = sub() { $attr };
                my %out = ($sub => $attr_subs->{$sub});

                $out{$attr}       = sub { $_[0]->{$attr} }                                                  if $spec->{reader};
                $out{"set_$attr"} = sub { $_[0]->{$attr} = $_[1] }                                          if $spec->{writer};
                $out{"set_$attr"} = sub { Carp::croak("'$attr' is read-only") }                             if $spec->{read_only};
                $out{"set_$attr"} = sub { Carp::carp("set_$attr() is deprecated"); $_[0]->{$attr} = $_[1] } if $spec->{dep_writer};

                %out;
            } @_
        ),
    );

    no strict 'refs';
    *{"$into\::$_"} = $subs{$_} for keys %subs;
}

sub attr_list {
    my $class = shift;

    my $isa = _isa($class);

    my %seen;
    my @list = grep { !$seen{$_}++ } map {
        my @out;

        if (0.004 > ($Test2::Util::HashBase::VERSION{$_} || 0)) {
            Carp::carp("$_ uses an inlined version of Test2::Util::HashBase too old to support attr_list()");
        }
        else {
            my $list = $Test2::Util::HashBase::ATTR_LIST{$_};
            @out = $list ? @$list : ()
        }

        @out;
    } reverse @$isa;

    return @list;
}

sub _new {
    my $class = shift;

    my $self;

    if (@_ == 1) {
        my $arg = shift;
        my $type = ref($arg);

        if ($type eq 'HASH') {
            $self = bless({%$arg}, $class)
        }
        else {
            Carp::croak("Not sure what to do with '$type' in $class constructor")
                unless $type eq 'ARRAY';

            my %proto;
            my @attributes = attr_list($class);
            while (@$arg) {
                my $val = shift @$arg;
                my $key = shift @attributes or Carp::croak("Too many arguments for $class constructor");
                $proto{$key} = $val;
            }

            $self = bless(\%proto, $class);
        }
    }
    else {
        $self = bless({@_}, $class);
    }

    $Test2::Util::HashBase::CAN_CACHE{$class} = $self->can('init')
        unless exists $Test2::Util::HashBase::CAN_CACHE{$class};

    $self->init if $Test2::Util::HashBase::CAN_CACHE{$class};

    $self;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::Util::HashBase - Build hash based classes.

=head1 SYNOPSIS

A class:

    package My::Class;
    use strict;
    use warnings;

    # Generate 3 accessors
    use Test2::Util::HashBase qw/foo -bar ^baz <bat >ban +boo/;

    # Chance to initialize defaults
    sub init {
        my $self = shift;    # No other args
        $self->{+FOO} ||= "foo";
        $self->{+BAR} ||= "bar";
        $self->{+BAZ} ||= "baz";
        $self->{+BAT} ||= "bat";
        $self->{+BAN} ||= "ban";
        $self->{+BOO} ||= "boo";
    }

    sub print {
        print join ", " => map { $self->{$_} } FOO, BAR, BAZ, BAT, BAN, BOO;
    }

Subclass it

    package My::Subclass;
    use strict;
    use warnings;

    # Note, you should subclass before loading HashBase.
    use base 'My::Class';
    use Test2::Util::HashBase qw/bub/;

    sub init {
        my $self = shift;

        # We get the constants from the base class for free.
        $self->{+FOO} ||= 'SubFoo';
        $self->{+BUB} ||= 'bub';

        $self->SUPER::init();
    }

use it:

    package main;
    use strict;
    use warnings;
    use My::Class;

    # These are all functionally identical
    my $one   = My::Class->new(foo => 'MyFoo', bar => 'MyBar');
    my $two   = My::Class->new({foo => 'MyFoo', bar => 'MyBar'});
    my $three = My::Class->new(['MyFoo', 'MyBar']);

    # Readers!
    my $foo = $one->foo;    # 'MyFoo'
    my $bar = $one->bar;    # 'MyBar'
    my $baz = $one->baz;    # Defaulted to: 'baz'
    my $bat = $one->bat;    # Defaulted to: 'bat'
    # '>ban' means setter only, no reader
    # '+boo' means no setter or reader, just the BOO constant

    # Setters!
    $one->set_foo('A Foo');

    #'-bar' means read-only, so the setter will throw an exception (but is defined).
    $one->set_bar('A bar');

    # '^baz' means deprecated setter, this will warn about the setter being
    # deprecated.
    $one->set_baz('A Baz');

    # '<bat' means no setter defined at all
    # '+boo' means no setter or reader, just the BOO constant

    $one->{+FOO} = 'xxx';

=head1 DESCRIPTION

This package is used to generate classes based on hashrefs. Using this class
will give you a C<new()> method, as well as generating accessors you request.
Generated accessors will be getters, C<set_ACCESSOR> setters will also be
generated for you. You also get constants for each accessor (all caps) which
return the key into the hash for that accessor. Single inheritance is also
supported.

=head1 THIS IS A BUNDLED COPY OF HASHBASE

This is a bundled copy of L<Object::HashBase>. This file was generated using
the
C</home/exodist/perl5/perlbrew/perls/main/bin/hashbase_inc.pl>
script.

=head1 METHODS

=head2 PROVIDED BY HASH BASE

=over 4

=item $it = $class->new(%PAIRS)

=item $it = $class->new(\%PAIRS)

=item $it = $class->new(\@ORDERED_VALUES)

Create a new instance.

HashBase will not export C<new()> if there is already a C<new()> method in your
packages inheritance chain.

B<If you do not want this method you can define your own> you just have to
declare it before loading L<Test2::Util::HashBase>.

    package My::Package;

    # predeclare new() so that HashBase does not give us one.
    sub new;

    use Test2::Util::HashBase qw/foo bar baz/;

    # Now we define our own new method.
    sub new { ... }

This makes it so that HashBase sees that you have your own C<new()> method.
Alternatively you can define the method before loading HashBase instead of just
declaring it, but that scatters your use statements.

The most common way to create an object is to pass in key/value pairs where
each key is an attribute and each value is what you want assigned to that
attribute. No checking is done to verify the attributes or values are valid,
you may do that in C<init()> if desired.

If you would like, you can pass in a hashref instead of pairs. When you do so
the hashref will be copied, and the copy will be returned blessed as an object.
There is no way to ask HashBase to bless a specific hashref.

In some cases an object may only have 1 or 2 attributes, in which case a
hashref may be too verbose for your liking. In these cases you can pass in an
arrayref with only values. The values will be assigned to attributes in the
order the attributes were listed. When there is inheritance involved the
attributes from parent classes will come before subclasses.

=back

=head2 HOOKS

=over 4

=item $self->init()

This gives you the chance to set some default values to your fields. The only
argument is C<$self> with its indexes already set from the constructor.

B<Note:> Test2::Util::HashBase checks for an init using C<< $class->can('init') >>
during construction. It DOES NOT call C<can()> on the created object. Also note
that the result of the check is cached, it is only ever checked once, the first
time an instance of your class is created. This means that adding an C<init()>
method AFTER the first construction will result in it being ignored.

=back

=head1 ACCESSORS

=head2 READ/WRITE

To generate accessors you list them when using the module:

    use Test2::Util::HashBase qw/foo/;

This will generate the following subs in your namespace:

=over 4

=item foo()

Getter, used to get the value of the C<foo> field.

=item set_foo()

Setter, used to set the value of the C<foo> field.

=item FOO()

Constant, returns the field C<foo>'s key into the class hashref. Subclasses will
also get this function as a constant, not simply a method, that means it is
copied into the subclass namespace.

The main reason for using these constants is to help avoid spelling mistakes
and similar typos. It will not help you if you forget to prefix the '+' though.

=back

=head2 READ ONLY

    use Test2::Util::HashBase qw/-foo/;

=over 4

=item set_foo()

Throws an exception telling you the attribute is read-only. This is exported to
override any active setters for the attribute in a parent class.

=back

=head2 DEPRECATED SETTER

    use Test2::Util::HashBase qw/^foo/;

=over 4

=item set_foo()

This will set the value, but it will also warn you that the method is
deprecated.

=back

=head2 NO SETTER

    use Test2::Util::HashBase qw/<foo/;

Only gives you a reader, no C<set_foo> method is defined at all.

=head2 NO READER

    use Test2::Util::HashBase qw/>foo/;

Only gives you a write (C<set_foo>), no C<foo> method is defined at all.

=head2 CONSTANT ONLY

    use Test2::Util::HashBase qw/+foo/;

This does not create any methods for you, it just adds the C<FOO> constant.

=head1 SUBCLASSING

You can subclass an existing HashBase class.

    use base 'Another::HashBase::Class';
    use Test2::Util::HashBase qw/foo bar baz/;

The base class is added to C<@ISA> for you, and all constants from base classes
are added to subclasses automatically.

=head1 GETTING A LIST OF ATTRIBUTES FOR A CLASS

Test2::Util::HashBase provides a function for retrieving a list of attributes for an
Test2::Util::HashBase class.

=over 4

=item @list = Test2::Util::HashBase::attr_list($class)

=item @list = $class->Test2::Util::HashBase::attr_list()

Either form above will work. This will return a list of attributes defined on
the object. This list is returned in the attribute definition order, parent
class attributes are listed before subclass attributes. Duplicate attributes
will be removed before the list is returned.

B<Note:> This list is used in the C<< $class->new(\@ARRAY) >> constructor to
determine the attribute to which each value will be paired.

=back

=head1 SOURCE

The source code repository for HashBase can be found at
F<http://github.com/Test-More/HashBase/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! }��  �  !  perl5/Test2/Util/Facets2Legacy.pmnu ��6�$        package Test2::Util::Facets2Legacy;
use strict;
use warnings;

our $VERSION = '1.302183';

use Carp qw/croak confess/;
use Scalar::Util qw/blessed/;

use base 'Exporter';
our @EXPORT_OK = qw{
    causes_fail
    diagnostics
    global
    increments_count
    no_display
    sets_plan
    subtest_id
    summary
    terminate
    uuid
};
our %EXPORT_TAGS = ( ALL => \@EXPORT_OK );

our $CYCLE_DETECT = 0;
sub _get_facet_data {
    my $in = shift;

    if (blessed($in) && $in->isa('Test2::Event')) {
        confess "Cycle between Facets2Legacy and $in\->facet_data() (Did you forget to override the facet_data() method?)"
            if $CYCLE_DETECT;

        local $CYCLE_DETECT = 1;
        return $in->facet_data;
    }

    return $in if ref($in) eq 'HASH';

    croak "'$in' Does not appear to be either a Test::Event or an EventFacet hashref";
}

sub causes_fail {
    my $facet_data = _get_facet_data(shift @_);

    return 1 if $facet_data->{errors} && grep { $_->{fail} } @{$facet_data->{errors}};

    if (my $control = $facet_data->{control}) {
        return 1 if $control->{halt};
        return 1 if $control->{terminate};
    }

    return 0 if $facet_data->{amnesty} && @{$facet_data->{amnesty}};
    return 1 if $facet_data->{assert} && !$facet_data->{assert}->{pass};
    return 0;
}

sub diagnostics {
    my $facet_data = _get_facet_data(shift @_);
    return 1 if $facet_data->{errors} && @{$facet_data->{errors}};
    return 0 unless $facet_data->{info} && @{$facet_data->{info}};
    return (grep { $_->{debug} } @{$facet_data->{info}}) ? 1 : 0;
}

sub global {
    my $facet_data = _get_facet_data(shift @_);
    return 0 unless $facet_data->{control};
    return $facet_data->{control}->{global};
}

sub increments_count {
    my $facet_data = _get_facet_data(shift @_);
    return $facet_data->{assert} ? 1 : 0;
}

sub no_display {
    my $facet_data = _get_facet_data(shift @_);
    return 0 unless $facet_data->{about};
    return $facet_data->{about}->{no_display};
}

sub sets_plan {
    my $facet_data = _get_facet_data(shift @_);
    my $plan = $facet_data->{plan} or return;
    my @out = ($plan->{count} || 0);

    if ($plan->{skip}) {
        push @out => 'SKIP';
        push @out => $plan->{details} if defined $plan->{details};
    }
    elsif ($plan->{none}) {
        push @out => 'NO PLAN'
    }

    return @out;
}

sub subtest_id {
    my $facet_data = _get_facet_data(shift @_);
    return undef unless $facet_data->{parent};
    return $facet_data->{parent}->{hid};
}

sub summary {
    my $facet_data = _get_facet_data(shift @_);
    return '' unless $facet_data->{about} && $facet_data->{about}->{details};
    return $facet_data->{about}->{details};
}

sub terminate {
    my $facet_data = _get_facet_data(shift @_);
    return undef unless $facet_data->{control};
    return $facet_data->{control}->{terminate};
}

sub uuid {
    my $in = shift;

    if ($CYCLE_DETECT) {
        if (blessed($in) && $in->isa('Test2::Event')) {
            my $meth = $in->can('uuid');
            $meth = $in->can('SUPER::uuid') if $meth == \&uuid;
            my $uuid = $in->$meth if $meth && $meth != \&uuid;
            return $uuid if $uuid;
        }

        return undef;
    }

    my $facet_data = _get_facet_data($in);
    return $facet_data->{about}->{uuid} if $facet_data->{about} && $facet_data->{about}->{uuid};

    return undef;
}

1;

=pod

=encoding UTF-8

=head1 NAME

Test2::Util::Facets2Legacy - Convert facet data to the legacy event API.

=head1 DESCRIPTION

This module exports several subroutines from the older event API (see
L<Test2::Event>). These subroutines can be used as methods on any object that
provides a custom C<facet_data()> method. These subroutines can also be used as
functions that take a facet data hashref as arguments.

=head1 SYNOPSIS

=head2 AS METHODS

    package My::Event;

    use Test2::Util::Facets2Legacy ':ALL';

    sub facet_data { return { ... } }

Then to use it:

    my $e = My::Event->new(...);

    my $causes_fail = $e->causes_fail;
    my $summary     = $e->summary;
    ....

=head2 AS FUNCTIONS

    use Test2::Util::Facets2Legacy ':ALL';

    my $f = {
        assert => { ... },
        info => [{...}, ...],
        control => {...},
        ...
    };

    my $causes_fail = causes_fail($f);
    my $summary     = summary($f);

=head1 NOTE ON CYCLES

When used as methods, all these subroutines call C<< $e->facet_data() >>. The
default C<facet_data()> method in L<Test2::Event> relies on the legacy methods
this module emulates in order to work. As a result of this it is very easy to
create infinite recursion bugs.

These methods have cycle detection and will throw an exception early if a cycle
is detected. C<uuid()> is currently the only subroutine in this library that
has a fallback behavior when cycles are detected.

=head1 EXPORTS

Nothing is exported by default. You must specify which methods to import, or
use the ':ALL' tag.

=over 4

=item $bool = $e->causes_fail()

=item $bool = causes_fail($f)

Check if the event or facets result in a failing state.

=item $bool = $e->diagnostics()

=item $bool = diagnostics($f)

Check if the event or facets contain any diagnostics information.

=item $bool = $e->global()

=item $bool = global($f)

Check if the event or facets need to be globally processed.

=item $bool = $e->increments_count()

=item $bool = increments_count($f)

Check if the event or facets make an assertion.

=item $bool = $e->no_display()

=item $bool = no_display($f)

Check if the event or facets should be rendered or hidden.

=item ($max, $directive, $reason) = $e->sets_plan()

=item ($max, $directive, $reason) = sets_plan($f)

Check if the event or facets set a plan, and return the plan details.

=item $id = $e->subtest_id()

=item $id = subtest_id($f)

Get the subtest id, if any.

=item $string = $e->summary()

=item $string = summary($f)

Get the summary of the event or facets hash, if any.

=item $undef_or_int = $e->terminate()

=item $undef_or_int = terminate($f)

Check if the event or facets should result in process termination, if so the
exit code is returned (which could be 0). undef is returned if no termination
is requested.

=item $uuid = $e->uuid()

=item $uuid = uuid($f)

Get the UUID of the facets or event.

B<Note:> This will fall back to C<< $e->SUPER::uuid() >> if a cycle is
detected and an event is used as the argument.

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! ^>��4  �4    perl5/Test2/Transition.podnu ��6�$        =pod

=head1 NAME

Test2::Transition - Transition notes when upgrading to Test2

=head1 DESCRIPTION

This is where gotchas and breakages related to the Test2 upgrade are
documented. The upgrade causes Test::Builder to defer to Test2 under the hood.
This transition is mostly transparent, but there are a few cases that can trip
you up.

=head1 THINGS THAT BREAK

This is the list of scenarios that break with the new internals.

=head2 Test::Builder1.5/2 conditionals

=head3 The Problem

a few years back there were two attempts to upgrade/replace Test::Builder.
Confusingly these were called Test::Builder2 and Test::Builder1.5, in that
order. Many people put conditionals in their code to check the Test::Builder
version number and adapt their code accordingly.

The Test::Builder2/1.5 projects both died out. Now the conditional code people
added has become a mine field. A vast majority of modules broken by Test2 fall
into this category.

=head3 The Fix

The fix is to remove all Test::Builder1.5/2 related code. Either use the
legacy Test::Builder API, or use Test2 directly.

=head2 Replacing the Test::Builder singleton

=head3 The Problem

Some test modules would replace the Test::Builder singleton instance with their
own instance or subclass. This was usually done to intercept or modify results
as they happened.

The Test::Builder singleton is now a simple compatibility wrapper around
Test2. The Test::Builder singleton is no longer the central place for
results. Many results bypass the Test::Builder singleton completely, which
breaks and behavior intended when replacing the singleton.

=head3 The Fix

If you simply want to intercept all results instead of letting them go to TAP,
you should look at the L<Test2::API> docs and read about pushing a new hub onto
the hub stack. Replacing the hub temporarily is now the correct way to
intercept results.

If your goal is purely monitoring of events use the C<< Test2::Hub->listen() >>
method exported by Test::More to watch events as they are fired. If you wish to
modify results before they go to TAP look at the C<< Test2::Hub->filter() >>
method.

=head2 Directly Accessing Hash Elements

=head3 The Problem

Some modules look directly at hash keys on the Test::Builder singleton. The
problem here is that the Test::Builder singleton no longer holds anything
important.

=head3 The Fix

The fix is to use the API specified in L<Test2::API> to look at or modify state
as needed.

=head2 Subtest indentation

=head3 The Problem

An early change, in fact the change that made Test2 an idea, was a change to
the indentation of the subtest note. It was decided it would be more readable
to outdent the subtest note instead of having it inline with the subtest:

    # subtest foo
        ok 1 - blah
        1..1
    ok 1 - subtest foo

The old style indented the note:

        # subtest foo
        ok 1 - blah
        1..1
    ok 1 - subtest foo

This breaks tests that do string comparison of TAP output.

=head3 The Fix

    my $indent = $INC{'Test2/API.pm'} ? '' : '    ';

    is(
        $subtest_output,
        "${indent}# subtest foo",
        "Got subtest note"
    );

Check if C<$INC{'Test2/API.pm'}> is set, if it is then no indentation should be
expected. If it is not set, then the old Test::Builder is in use, indentation
should be expected.

=head1 DISTRIBUTIONS THAT BREAK OR NEED TO BE UPGRADED

This is a list of cpan modules that have been known to have been broken by the
upgrade at one point.

=head2 WORKS BUT TESTS WILL FAIL

These modules still function correctly, but their test suites will not pass. If
you already have these modules installed then you can continue to use them. If
you are trying to install them after upgrading Test::Builder you will need to
force installation, or bypass the broken tests.

=over 4

=item Test::DBIx::Class::Schema

This module has a test that appears to work around a Test::Builder bug. The bug
appears to have been fixed by Test2, which means the workaround causes a
failure. This can be easily updated, but nobody has done so yet.

Known broken in versions: 1.0.9 and older

=item Device::Chip

Tests break due to subtest indentation.

Known broken in version 0.07. Apparently works fine in 0.06 though. Patch has
been submitted to fix the issue.

=back

=head2 UPGRADE SUGGESTED

These are modules that did not break, but had broken test suites that have
since been fixed.

=over 4

=item Test::Exception

Old versions work fine, but have a minor test name behavior that breaks with
Test2. Old versions will no longer install because of this. The latest version
on CPAN will install just fine. Upgrading is not required, but is recommended.

Fixed in version: 0.43

=item Data::Peek

Some tests depended on C<$!> and C<$?> being modified in subtle ways. A patch
was applied to correct things that changed.

The module itself works fine, there is no need to upgrade.

Fixed in version: 0.45

=item circular::require

Some tests were fragile and required base.pm to be loaded at a late stage.
Test2 was loading base.pm too early. The tests were updated to fix this.

The module itself never broke, you do not need to upgrade.

Fixed in version: 0.12

=item Test::Module::Used

A test worked around a now-fixed planning bug. There is no need to upgrade if
you have an old version installed. New versions install fine if you want them.

Fixed in version: 0.2.5

=item Test::Moose::More

Some tests were fragile, but have been fixed. The actual breakage was from the
subtest comment indentation change.

No need to upgrade, old versions work fine. Only new versions will install.

Fixed in version: 0.025

=item Test::FITesque

This was broken by a bugfix to how planning is done. The test was updated after
the bugfix.

Fixed in version: 0.04

=item Test::Kit

Old versions work fine, but would not install because L<Test::Aggregate> was in
the dependency chain. An upgrade should not be needed.

Fixed in version: 2.15

=item autouse

A test broke because it depended on Scalar::Util not being loaded. Test2 loads
Scalar::Util. The test was updated to load Test2 after checking Scalar::Util's
load status.

There is no need to upgrade if you already have it installed.

Fixed in version: 1.11

=back

=head2 NEED TO UPGRADE

=over 4

=item Test::SharedFork

Old versions need to directly access Test::Builder singleton hash elements. The
latest version on CPAN will still do this on old Test::Builder, but will defer
to L<Test2::IPC> on Test2.

Fixed in version: 0.35

=item Test::Builder::Clutch

This works by doing overriding methods on the singleton, and directly accessing
hash values on the singleton. A new version has been released that uses the
Test2 API to accomplish the same result in a saner way.

Fixed in version: 0.07

=item Test::Dist::VersionSync

This had Test::Builder2 conditionals. This was fixed by removing the
conditionals.

Fixed in version: 1.1.4

=item Test::Modern

This relied on C<< Test::Builder->_try() >> which was a private method,
documented as something nobody should use. This was fixed by using a different
tool.

Fixed in version: 0.012

=item Test::UseAllModules

Version 0.14 relied on C<< Test::Builder->history >> which was available in
Test::Builder 1.5. Versions 0.12 and 0.13 relied on other Test::Builder
internals.

Fixed in version: 0.15

=item Test::More::Prefix

Worked by applying a role that wrapped C<< Test::Builder->_print_comment >>.
Fixed by adding an event filter that modifies the message instead when running
under Test2.

Fixed in version: 0.007

=back

=head2 STILL BROKEN

=over 4

=item Test::Aggregate

This distribution directly accesses the hash keys in the L<Test::Builder>
singleton. It also approaches the problem from the wrong angle, please consider
using L<Test2::Aggregate> for similar functionality and L<Test2::Harness>
which allows module preloading at the harness level.

Still broken as of version: 0.373

=item Test::Wrapper

This module directly uses hash keys in the L<Test::Builder> singleton. This
module is also obsolete thanks to the benefits of L<Test2>. Use C<intercept()>
from L<Test2::API> to achieve a similar result.

Still broken as of version: 0.3.0

=item Test::ParallelSubtest

This module overrides C<Test::Builder::subtest()> and
C<Test::Builder::done_testing()>. It also directly accesses hash elements of
the singleton. It has not yet been fixed.

Alternatives: L<Test2::AsyncSubtest> and L<Test2::Workflow> (not stable).

Still broken as of version: 0.05

=item Test::Pretty

See https://github.com/tokuhirom/Test-Pretty/issues/25

The author admits the module is crazy, and he is awaiting a stable release of
something new (Test2) to completely rewrite it in a sane way.

Still broken as of version: 0.32

=item Net::BitTorrent

The tests for this module directly access L<Test::Builder> hash keys. Most, if
not all of these hash keys have public API methods that could be used instead
to avoid the problem.

Still broken in version: 0.052

=item Test::Group

It monkeypatches Test::Builder, and calls it "black magic" in the code.

Still broken as of version: 0.20

=item Test::Flatten

This modifies the Test::Builder internals in many ways. A better was to
accomplish the goal of this module is to write your own subtest function.

Still broken as of version: 0.11

=item Log::Dispatch::Config::TestLog

Modifies Test::Builder internals.

Still broken as of version: 0.02

=item Test::Able

Modifies Test::Builder internals.

Still broken as of version: 0.11

=back

=head1 MAKE ASSERTIONS -> SEND EVENTS

=head2 LEGACY

    use Test::Builder;

    # A majority of tools out there do this:
    # my $TB = Test::Builder->new;
    # This works, but has always been wrong, forcing Test::Builder to implement
    # subtests as a horrific hack. It also causes problems for tools that try
    # to replace the singleton (also discouraged).

    sub my_ok($;$) {
        my ($bool, $name) = @_;
        my $TB = Test::Builder->new;
        $TB->ok($bool, $name);
    }

    sub my_diag($) {
        my ($msg) = @_;
        my $TB = Test::Builder->new;
        $TB->diag($msg);
    }

=head2 TEST2

    use Test2::API qw/context/;

    sub my_ok($;$) {
        my ($bool, $name) = @_;
        my $ctx = context();
        $ctx->ok($bool, $name);
        $ctx->release;
    }

    sub my_diag($) {
        my ($msg) = @_;
        my $ctx = context();
        $ctx->diag($msg);
        $ctx->release;
    }

The context object has API compatible implementations of the following methods:

=over 4

=item ok($bool, $name)

=item diag(@messages)

=item note(@messages)

=item subtest($name, $code)

=back

If you are looking for helpers with C<is>, C<like>, and others, see
L<Test2::Suite>.

=head1 WRAP EXISTING TOOLS

=head2 LEGACY

    use Test::More;

    sub exclusive_ok {
        my ($bool1, $bool2, $name) = @_;

        # Ensure errors are reported 1 level higher
        local $Test::Builder::Level = $Test::Builder::Level + 1;

        $ok = $bool1 || $bool2;
        $ok &&= !($bool1 && $bool2);
        ok($ok, $name);

        return $bool;
    }

Every single tool in the chain from this, to C<ok>, to anything C<ok> calls
needs to increment the C<$Level> variable. When an error occurs Test::Builder
will do a trace to the stack frame determined by C<$Level>, and report that
file+line as the one where the error occurred. If you or any other tool you use
forgets to set C<$Level> then errors will be reported to the wrong place.

=head2 TEST2

    use Test::More;

    sub exclusive_ok {
        my ($bool1, $bool2, $name) = @_;

        # Grab and store the context, even if you do not need to use it
        # directly.
        my $ctx = context();

        $ok = $bool1 || $bool2;
        $ok &&= !($bool1 && $bool2);
        ok($ok, $name);

        $ctx->release;
        return $bool;
    }

Instead of using C<$Level> to perform a backtrace, Test2 uses a context
object. In this sample you create a context object and store it. This locks the
context (errors report 1 level up from here) for all wrapped tools to find. You
do not need to use the context object, but you do need to store it in a
variable. Once the sub ends the C<$ctx> variable is destroyed which lets future
tools find their own.

=head1 USING UTF8

=head2 LEGACY

    # Set the mode BEFORE anything loads Test::Builder
    use open ':std', ':encoding(utf8)';
    use Test::More;

Or

    # Modify the filehandles
    my $builder = Test::More->builder;
    binmode $builder->output,         ":encoding(utf8)";
    binmode $builder->failure_output, ":encoding(utf8)";
    binmode $builder->todo_output,    ":encoding(utf8)";

=head2 TEST2

    use Test2::API qw/test2_stack/;

    test2_stack->top->format->encoding('utf8');

Though a much better way is to use the L<Test2::Plugin::UTF8> plugin, which is
part of L<Test2::Suite>.

=head1 AUTHORS, CONTRIBUTORS AND REVIEWERS

The following people have all contributed to this document in some way, even if
only for review.

=over 4

=item Chad Granum (EXODIST) E<lt>exodist@cpan.orgE<gt>

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINER

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://www.perl.com/perl/misc/Artistic.html>

=cut
PK       ! ag�o�  �    perl5/Test2/API.pmnu ��6�$        package Test2::API;
use strict;
use warnings;

use Test2::Util qw/USE_THREADS/;

BEGIN {
    $ENV{TEST_ACTIVE} ||= 1;
    $ENV{TEST2_ACTIVE} = 1;
}

our $VERSION = '1.302183';


my $INST;
my $ENDING = 0;
sub test2_unset_is_end { $ENDING = 0 }
sub test2_get_is_end { $ENDING }

sub test2_set_is_end {
    my $before = $ENDING;
    ($ENDING) = @_ ? @_ : (1);

    # Only send the event in a transition from false to true
    return if $before;
    return unless $ENDING;

    return unless $INST;
    my $stack = $INST->stack or return;
    my $root = $stack->root or return;

    return unless $root->count;

    return unless $$ == $INST->pid;
    return unless get_tid() == $INST->tid;

    my $trace = Test2::EventFacet::Trace->new(
        frame  => [__PACKAGE__, __FILE__, __LINE__, __PACKAGE__ . '::test2_set_is_end'],
    );
    my $ctx = Test2::API::Context->new(
        trace => $trace,
        hub   => $root,
    );

    $ctx->send_ev2(control => { phase => 'END', details => 'Transition to END phase' });

    1;
}

use Test2::API::Instance(\$INST);

# Set the exit status
END {
    test2_set_is_end(); # See gh #16
    $INST->set_exit();
}

sub CLONE {
    my $init = test2_init_done();
    my $load = test2_load_done();

    return if $init && $load;

    require Carp;
    Carp::croak "Test2 must be fully loaded before you start a new thread!\n";
}

# See gh #16
{
    no warnings;
    INIT { eval 'END { test2_set_is_end() }; 1' or die $@ }
}

BEGIN {
    no warnings 'once';
    if($] ge '5.014' || $ENV{T2_CHECK_DEPTH} || $Test2::API::DO_DEPTH_CHECK) {
        *DO_DEPTH_CHECK = sub() { 1 };
    }
    else {
        *DO_DEPTH_CHECK = sub() { 0 };
    }
}

use Test2::EventFacet::Trace();
use Test2::Util::Trace(); # Legacy

use Test2::Hub::Subtest();
use Test2::Hub::Interceptor();
use Test2::Hub::Interceptor::Terminator();

use Test2::Event::Ok();
use Test2::Event::Diag();
use Test2::Event::Note();
use Test2::Event::Plan();
use Test2::Event::Bail();
use Test2::Event::Exception();
use Test2::Event::Waiting();
use Test2::Event::Skip();
use Test2::Event::Subtest();

use Carp qw/carp croak confess/;
use Scalar::Util qw/blessed weaken/;
use Test2::Util qw/get_tid clone_io pkg_to_file gen_uid/;

our @EXPORT_OK = qw{
    context release
    context_do
    no_context
    intercept intercept_deep
    run_subtest

    test2_init_done
    test2_load_done
    test2_load
    test2_start_preload
    test2_stop_preload
    test2_in_preload
    test2_is_testing_done

    test2_set_is_end
    test2_unset_is_end
    test2_get_is_end

    test2_pid
    test2_tid
    test2_stack
    test2_no_wait
    test2_ipc_wait_enable
    test2_ipc_wait_disable
    test2_ipc_wait_enabled

    test2_add_uuid_via

    test2_add_callback_testing_done

    test2_add_callback_context_aquire
    test2_add_callback_context_acquire
    test2_add_callback_context_init
    test2_add_callback_context_release
    test2_add_callback_exit
    test2_add_callback_post_load
    test2_add_callback_pre_subtest
    test2_list_context_aquire_callbacks
    test2_list_context_acquire_callbacks
    test2_list_context_init_callbacks
    test2_list_context_release_callbacks
    test2_list_exit_callbacks
    test2_list_post_load_callbacks
    test2_list_pre_subtest_callbacks

    test2_ipc
    test2_has_ipc
    test2_ipc_disable
    test2_ipc_disabled
    test2_ipc_drivers
    test2_ipc_add_driver
    test2_ipc_polling
    test2_ipc_disable_polling
    test2_ipc_enable_polling
    test2_ipc_get_pending
    test2_ipc_set_pending
    test2_ipc_get_timeout
    test2_ipc_set_timeout

    test2_formatter
    test2_formatters
    test2_formatter_add
    test2_formatter_set

    test2_stdout
    test2_stderr
    test2_reset_io
};
BEGIN { require Exporter; our @ISA = qw(Exporter) }

my $STACK       = $INST->stack;
my $CONTEXTS    = $INST->contexts;
my $INIT_CBS    = $INST->context_init_callbacks;
my $ACQUIRE_CBS = $INST->context_acquire_callbacks;

my $STDOUT = clone_io(\*STDOUT);
my $STDERR = clone_io(\*STDERR);
sub test2_stdout { $STDOUT ||= clone_io(\*STDOUT) }
sub test2_stderr { $STDERR ||= clone_io(\*STDERR) }

sub test2_post_preload_reset {
    test2_reset_io();
    $INST->post_preload_reset;
}

sub test2_reset_io {
    $STDOUT = clone_io(\*STDOUT);
    $STDERR = clone_io(\*STDERR);
}

sub test2_init_done { $INST->finalized }
sub test2_load_done { $INST->loaded }

sub test2_load          { $INST->load }
sub test2_start_preload { $ENV{T2_IN_PRELOAD} = 1; $INST->start_preload }
sub test2_stop_preload  { $ENV{T2_IN_PRELOAD} = 0; $INST->stop_preload }
sub test2_in_preload    { $INST->preload }

sub test2_pid              { $INST->pid }
sub test2_tid              { $INST->tid }
sub test2_stack            { $INST->stack }
sub test2_ipc_wait_enable  { $INST->set_no_wait(0) }
sub test2_ipc_wait_disable { $INST->set_no_wait(1) }
sub test2_ipc_wait_enabled { !$INST->no_wait }

sub test2_is_testing_done {
    # No instance? VERY DONE!
    return 1 unless $INST;

    # No stack? tests must be done, it is created pretty early
    my $stack = $INST->stack or return 1;

    # Nothing on the stack, no root hub yet, likely have not started testing
    return 0 unless @$stack;

    # Stack has a slot for the root hub (see above) but it is undefined, likely
    # garbage collected, test is done
    my $root_hub = $stack->[0] or return 1;

    # If the root hub is ended than testing is done.
    return 1 if $root_hub->ended;

    # Looks like we are still testing!
    return 0;
}

sub test2_no_wait {
    $INST->set_no_wait(@_) if @_;
    $INST->no_wait;
}

sub test2_add_callback_testing_done {
    my $cb = shift;

    test2_add_callback_post_load(sub {
        my $stack = test2_stack();
        $stack->top; # Insure we have a hub
        my ($hub) = Test2::API::test2_stack->all;

        $hub->set_active(1);

        $hub->follow_up($cb);
    });

    return;
}

sub test2_add_callback_context_acquire   { $INST->add_context_acquire_callback(@_) }
sub test2_add_callback_context_aquire    { $INST->add_context_acquire_callback(@_) }
sub test2_add_callback_context_init      { $INST->add_context_init_callback(@_) }
sub test2_add_callback_context_release   { $INST->add_context_release_callback(@_) }
sub test2_add_callback_exit              { $INST->add_exit_callback(@_) }
sub test2_add_callback_post_load         { $INST->add_post_load_callback(@_) }
sub test2_add_callback_pre_subtest       { $INST->add_pre_subtest_callback(@_) }
sub test2_list_context_aquire_callbacks  { @{$INST->context_acquire_callbacks} }
sub test2_list_context_acquire_callbacks { @{$INST->context_acquire_callbacks} }
sub test2_list_context_init_callbacks    { @{$INST->context_init_callbacks} }
sub test2_list_context_release_callbacks { @{$INST->context_release_callbacks} }
sub test2_list_exit_callbacks            { @{$INST->exit_callbacks} }
sub test2_list_post_load_callbacks       { @{$INST->post_load_callbacks} }
sub test2_list_pre_subtest_callbacks     { @{$INST->pre_subtest_callbacks} }

sub test2_add_uuid_via {
    $INST->set_add_uuid_via(@_) if @_;
    $INST->add_uuid_via();
}

sub test2_ipc                 { $INST->ipc }
sub test2_has_ipc             { $INST->has_ipc }
sub test2_ipc_disable         { $INST->ipc_disable }
sub test2_ipc_disabled        { $INST->ipc_disabled }
sub test2_ipc_add_driver      { $INST->add_ipc_driver(@_) }
sub test2_ipc_drivers         { @{$INST->ipc_drivers} }
sub test2_ipc_polling         { $INST->ipc_polling }
sub test2_ipc_enable_polling  { $INST->enable_ipc_polling }
sub test2_ipc_disable_polling { $INST->disable_ipc_polling }
sub test2_ipc_get_pending     { $INST->get_ipc_pending }
sub test2_ipc_set_pending     { $INST->set_ipc_pending(@_) }
sub test2_ipc_set_timeout     { $INST->set_ipc_timeout(@_) }
sub test2_ipc_get_timeout     { $INST->ipc_timeout() }
sub test2_ipc_enable_shm      { 0 }

sub test2_formatter     {
    if ($ENV{T2_FORMATTER} && $ENV{T2_FORMATTER} =~ m/^(\+)?(.*)$/) {
        my $formatter = $1 ? $2 : "Test2::Formatter::$2";
        my $file = pkg_to_file($formatter);
        require $file;
        return $formatter;
    }

    return $INST->formatter;
}

sub test2_formatters    { @{$INST->formatters} }
sub test2_formatter_add { $INST->add_formatter(@_) }
sub test2_formatter_set {
    my ($formatter) = @_;
    croak "No formatter specified" unless $formatter;
    croak "Global Formatter already set" if $INST->formatter_set;
    $INST->set_formatter($formatter);
}

# Private, for use in Test2::API::Context
sub _contexts_ref                  { $INST->contexts }
sub _context_acquire_callbacks_ref { $INST->context_acquire_callbacks }
sub _context_init_callbacks_ref    { $INST->context_init_callbacks }
sub _context_release_callbacks_ref { $INST->context_release_callbacks }
sub _add_uuid_via_ref              { \($INST->{Test2::API::Instance::ADD_UUID_VIA()}) }

# Private, for use in Test2::IPC
sub _set_ipc { $INST->set_ipc(@_) }

sub context_do(&;@) {
    my $code = shift;
    my @args = @_;

    my $ctx = context(level => 1);

    my $want = wantarray;

    my @out;
    my $ok = eval {
        $want          ? @out    = $code->($ctx, @args) :
        defined($want) ? $out[0] = $code->($ctx, @args) :
                                   $code->($ctx, @args) ;
        1;
    };
    my $err = $@;

    $ctx->release;

    die $err unless $ok;

    return @out    if $want;
    return $out[0] if defined $want;
    return;
}

sub no_context(&;$) {
    my ($code, $hid) = @_;
    $hid ||= $STACK->top->hid;

    my $ctx = $CONTEXTS->{$hid};
    delete $CONTEXTS->{$hid};
    my $ok = eval { $code->(); 1 };
    my $err = $@;

    $CONTEXTS->{$hid} = $ctx;
    weaken($CONTEXTS->{$hid});

    die $err unless $ok;

    return;
};

my $UUID_VIA = _add_uuid_via_ref();
sub context {
    # We need to grab these before anything else to ensure they are not
    # changed.
    my ($errno, $eval_error, $child_error, $extended_error) = (0 + $!, $@, $?, $^E);

    my %params = (level => 0, wrapped => 0, @_);

    # If something is getting a context then the sync system needs to be
    # considered loaded...
    $INST->load unless $INST->{loaded};

    croak "context() called, but return value is ignored"
        unless defined wantarray;

    my $stack   = $params{stack} || $STACK;
    my $hub     = $params{hub}   || (@$stack ? $stack->[-1] : $stack->top);

    # Catch an edge case where we try to get context after the root hub has
    # been garbage collected resulting in a stack that has a single undef
    # hub
    if (!$hub && !exists($params{hub}) && @$stack) {
        my $msg = Carp::longmess("Attempt to get Test2 context after testing has completed (did you attempt a testing event after done_testing?)");

        # The error message is usually masked by the global destruction, so we have to print to STDER
        print STDERR $msg;

        # Make sure this is a failure, we are probably already in END, so set $? to change the exit code
        $? = 1;

        # Now we actually die to interrupt the program flow and avoid undefined his warnings
        die $msg;
    }

    my $hid     = $hub->{hid};
    my $current = $CONTEXTS->{$hid};

    $_->(\%params) for @$ACQUIRE_CBS;
    map $_->(\%params), @{$hub->{_context_acquire}} if $hub->{_context_acquire};

    # This is for https://github.com/Test-More/test-more/issues/16
    # and https://rt.perl.org/Public/Bug/Display.html?id=127774
    my $phase = ${^GLOBAL_PHASE} || 'NA';
    my $end_phase = $ENDING || $phase eq 'END' || $phase eq 'DESTRUCT';

    my $level = 1 + $params{level};
    my ($pkg, $file, $line, $sub, @other) = $end_phase ? caller(0) : caller($level);
    unless ($pkg || $end_phase) {
        confess "Could not find context at depth $level" unless $params{fudge};
        ($pkg, $file, $line, $sub, @other) = caller(--$level) while ($level >= 0 && !$pkg);
    }

    my $depth = $level;
    $depth++ while DO_DEPTH_CHECK && !$end_phase && (!$current || $depth <= $current->{_depth} + $params{wrapped}) && caller($depth + 1);
    $depth -= $params{wrapped};
    my $depth_ok = !DO_DEPTH_CHECK || $end_phase || !$current || $current->{_depth} < $depth;

    if ($current && $params{on_release} && $depth_ok) {
        $current->{_on_release} ||= [];
        push @{$current->{_on_release}} => $params{on_release};
    }

    # I know this is ugly....
    ($!, $@, $?, $^E) = ($errno, $eval_error, $child_error, $extended_error) and return bless(
        {
            %$current,
            _is_canon   => undef,
            errno       => $errno,
            eval_error  => $eval_error,
            child_error => $child_error,
            _is_spawn   => [$pkg, $file, $line, $sub],
        },
        'Test2::API::Context'
    ) if $current && $depth_ok;

    # Handle error condition of bad level
    if ($current) {
        unless (${$current->{_aborted}}) {
            _canon_error($current, [$pkg, $file, $line, $sub, $depth])
                unless $current->{_is_canon};

            _depth_error($current, [$pkg, $file, $line, $sub, $depth])
                unless $depth_ok;
        }

        $current->release if $current->{_is_canon};

        delete $CONTEXTS->{$hid};
    }

    # Directly bless the object here, calling new is a noticeable performance
    # hit with how often this needs to be called.
    my $trace = bless(
        {
            frame  => [$pkg, $file, $line, $sub],
            pid    => $$,
            tid    => get_tid(),
            cid    => gen_uid(),
            hid    => $hid,
            nested => $hub->{nested},
            buffered => $hub->{buffered},

            full_caller => [$pkg, $file, $line, $sub, @other],

            $$UUID_VIA ? (
                huuid => $hub->{uuid},
                uuid  => ${$UUID_VIA}->('context'),
            ) : (),
        },
        'Test2::EventFacet::Trace'
    );

    # Directly bless the object here, calling new is a noticeable performance
    # hit with how often this needs to be called.
    my $aborted = 0;
    $current = bless(
        {
            _aborted     => \$aborted,
            stack        => $stack,
            hub          => $hub,
            trace        => $trace,
            _is_canon    => 1,
            _depth       => $depth,
            errno        => $errno,
            eval_error   => $eval_error,
            child_error  => $child_error,
            $params{on_release} ? (_on_release => [$params{on_release}]) : (),
        },
        'Test2::API::Context'
    );

    $CONTEXTS->{$hid} = $current;
    weaken($CONTEXTS->{$hid});

    $_->($current) for @$INIT_CBS;
    map $_->($current), @{$hub->{_context_init}} if $hub->{_context_init};

    $params{on_init}->($current) if $params{on_init};

    ($!, $@, $?, $^E) = ($errno, $eval_error, $child_error, $extended_error);

    return $current;
}

sub _depth_error {
    _existing_error(@_, <<"    EOT");
context() was called to retrieve an existing context, however the existing
context was created in a stack frame at the same, or deeper level. This usually
means that a tool failed to release the context when it was finished.
    EOT
}

sub _canon_error {
    _existing_error(@_, <<"    EOT");
context() was called to retrieve an existing context, however the existing
context has an invalid internal state (!_canon_count). This should not normally
happen unless something is mucking about with internals...
    EOT
}

sub _existing_error {
    my ($ctx, $details, $msg) = @_;
    my ($pkg, $file, $line, $sub, $depth) = @$details;

    my $oldframe = $ctx->{trace}->frame;
    my $olddepth = $ctx->{_depth};

    # Older versions of Carp do not export longmess() function, so it needs to be called with package name
    my $mess = Carp::longmess();

    warn <<"    EOT";
$msg
Old context details:
   File: $oldframe->[1]
   Line: $oldframe->[2]
   Tool: $oldframe->[3]
  Depth: $olddepth

New context details:
   File: $file
   Line: $line
   Tool: $sub
  Depth: $depth

Trace: $mess

Removing the old context and creating a new one...
    EOT
}

sub release($;$) {
    $_[0]->release;
    return $_[1];
}

sub intercept(&) {
    my $code = shift;
    my $ctx = context();

    my $events = _intercept($code, deep => 0);

    $ctx->release;

    return $events;
}

sub intercept_deep(&) {
    my $code = shift;
    my $ctx = context();

    my $events = _intercept($code, deep => 1);

    $ctx->release;

    return $events;
}

sub _intercept {
    my $code = shift;
    my %params = @_;
    my $ctx = context();

    my $ipc;
    if (my $global_ipc = test2_ipc()) {
        my $driver = blessed($global_ipc);
        $ipc = $driver->new;
    }

    my $hub = Test2::Hub::Interceptor->new(
        ipc => $ipc,
        no_ending => 1,
    );

    my @events;
    $hub->listen(sub { push @events => $_[1] }, inherit => $params{deep});

    $ctx->stack->top; # Make sure there is a top hub before we begin.
    $ctx->stack->push($hub);

    my $trace = $ctx->trace;
    my $state = {};
    $hub->clean_inherited(trace => $trace, state => $state);

    my ($ok, $err) = (1, undef);
    T2_SUBTEST_WRAPPER: {
        # Do not use 'try' cause it localizes __DIE__
        $ok = eval { $code->(hub => $hub, context => $ctx->snapshot); 1 };
        $err = $@;

        # They might have done 'BEGIN { skip_all => "whatever" }'
        if (!$ok && $err =~ m/Label not found for "last T2_SUBTEST_WRAPPER"/ || (blessed($err) && $err->isa('Test2::Hub::Interceptor::Terminator'))) {
            $ok  = 1;
            $err = undef;
        }
    }

    $hub->cull;
    $ctx->stack->pop($hub);

    $hub->restore_inherited(trace => $trace, state => $state);

    $ctx->release;

    die $err unless $ok;

    $hub->finalize($trace, 1)
        if $ok
        && !$hub->no_ending
        && !$hub->ended;

    require Test2::API::InterceptResult;
    return Test2::API::InterceptResult->new_from_ref(\@events);
}

sub run_subtest {
    my ($name, $code, $params, @args) = @_;

    $_->($name,$code,@args)
        for Test2::API::test2_list_pre_subtest_callbacks();

    $params = {buffered => $params} unless ref $params;
    my $inherit_trace = delete $params->{inherit_trace};

    my $ctx = context();

    my $parent = $ctx->hub;

    # If a parent is buffered then the child must be as well.
    my $buffered = $params->{buffered} || $parent->{buffered};

    $ctx->note($name) unless $buffered;

    my $stack = $ctx->stack || $STACK;
    my $hub = $stack->new_hub(
        class => 'Test2::Hub::Subtest',
        %$params,
        buffered => $buffered,
    );

    my @events;
    $hub->listen(sub { push @events => $_[1] });

    if ($buffered) {
        if (my $format = $hub->format) {
            my $hide = $format->can('hide_buffered') ? $format->hide_buffered : 1;
            $hub->format(undef) if $hide;
        }
    }

    if ($inherit_trace) {
        my $orig = $code;
        $code = sub {
            my $base_trace = $ctx->trace;
            my $trace = $base_trace->snapshot(nested => 1 + $base_trace->nested);
            my $st_ctx = Test2::API::Context->new(
                trace  => $trace,
                hub    => $hub,
            );
            $st_ctx->do_in_context($orig, @args);
        };
    }

    my ($ok, $err, $finished);
    T2_SUBTEST_WRAPPER: {
        # Do not use 'try' cause it localizes __DIE__
        $ok = eval { $code->(@args); 1 };
        $err = $@;

        # They might have done 'BEGIN { skip_all => "whatever" }'
        if (!$ok && $err =~ m/Label not found for "last T2_SUBTEST_WRAPPER"/ || (blessed($err) && blessed($err) eq 'Test::Builder::Exception')) {
            $ok  = undef;
            $err = undef;
        }
        else {
            $finished = 1;
        }
    }

    if ($params->{no_fork}) {
        if ($$ != $ctx->trace->pid) {
            warn $ok ? "Forked inside subtest, but subtest never finished!\n" : $err;
            exit 255;
        }

        if (get_tid() != $ctx->trace->tid) {
            warn $ok ? "Started new thread inside subtest, but thread never finished!\n" : $err;
            exit 255;
        }
    }
    elsif (!$parent->is_local && !$parent->ipc) {
        warn $ok ? "A new process or thread was started inside subtest, but IPC is not enabled!\n" : $err;
        exit 255;
    }

    $stack->pop($hub);

    my $trace = $ctx->trace;

    my $bailed = $hub->bailed_out;

    if (!$finished) {
        if ($bailed && !$buffered) {
            $ctx->bail($bailed->reason);
        }
        elsif ($bailed && $buffered) {
            $ok = 1;
        }
        else {
            my $code = $hub->exit_code;
            $ok = !$code;
            $err = "Subtest ended with exit code $code" if $code;
        }
    }

    $hub->finalize($trace->snapshot(huuid => $hub->uuid, hid => $hub->hid, nested => $hub->nested, buffered => $buffered), 1)
        if $ok
        && !$hub->no_ending
        && !$hub->ended;

    my $pass = $ok && $hub->is_passing;
    my $e = $ctx->build_event(
        'Subtest',
        pass         => $pass,
        name         => $name,
        subtest_id   => $hub->id,
        subtest_uuid => $hub->uuid,
        buffered     => $buffered,
        subevents    => \@events,
    );

    my $plan_ok = $hub->check_plan;

    $ctx->hub->send($e);

    $ctx->failure_diag($e) unless $e->pass;

    $ctx->diag("Caught exception in subtest: $err") unless $ok;

    $ctx->diag("Bad subtest plan, expected " . $hub->plan . " but ran " . $hub->count)
        if defined($plan_ok) && !$plan_ok;

    $ctx->bail($bailed->reason) if $bailed && $buffered;

    $ctx->release;
    return $pass;
}

# There is a use-cycle between API and API/Context. Context needs to use some
# API functions as the package is compiling. Test2::API::context() needs
# Test2::API::Context to be loaded, but we cannot 'require' the module there as
# it causes a very noticeable performance impact with how often context() is
# called.
require Test2::API::Context;

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::API - Primary interface for writing Test2 based testing tools.

=head1 ***INTERNALS NOTE***

B<The internals of this package are subject to change at any time!> The public
methods provided will not change in backwards-incompatible ways (once there is
a stable release), but the underlying implementation details might.
B<Do not break encapsulation here!>

Currently the implementation is to create a single instance of the
L<Test2::API::Instance> Object. All class methods defer to the single
instance. There is no public access to the singleton, and that is intentional.
The class methods provided by this package provide the only functionality
publicly exposed.

This is done primarily to avoid the problems Test::Builder had by exposing its
singleton. We do not want anyone to replace this singleton, rebless it, or
directly muck with its internals. If you need to do something and cannot
because of the restrictions placed here, then please report it as an issue. If
possible, we will create a way for you to implement your functionality without
exposing things that should not be exposed.

=head1 DESCRIPTION

This package exports all the functions necessary to write and/or verify testing
tools. Using these building blocks you can begin writing test tools very
quickly. You are also provided with tools that help you to test the tools you
write.

=head1 SYNOPSIS

=head2 WRITING A TOOL

The C<context()> method is your primary interface into the Test2 framework.

    package My::Ok;
    use Test2::API qw/context/;

    our @EXPORT = qw/my_ok/;
    use base 'Exporter';

    # Just like ok() from Test::More
    sub my_ok($;$) {
        my ($bool, $name) = @_;
        my $ctx = context(); # Get a context
        $ctx->ok($bool, $name);
        $ctx->release; # Release the context
        return $bool;
    }

See L<Test2::API::Context> for a list of methods available on the context object.

=head2 TESTING YOUR TOOLS

The C<intercept { ... }> tool lets you temporarily intercept all events
generated by the test system:

    use Test2::API qw/intercept/;

    use My::Ok qw/my_ok/;

    my $events = intercept {
        # These events are not displayed
        my_ok(1, "pass");
        my_ok(0, "fail");
    };

As of version 1.302178 this now returns an arrayref that is also an instance of
L<Test2::API::InterceptResult>. See the L<Test2::API::InterceptResult>
documentation for details on how to best use it.

=head2 OTHER API FUNCTIONS

    use Test2::API qw{
        test2_init_done
        test2_stack
        test2_set_is_end
        test2_get_is_end
        test2_ipc
        test2_formatter_set
        test2_formatter
        test2_is_testing_done
    };

    my $init  = test2_init_done();
    my $stack = test2_stack();
    my $ipc   = test2_ipc();

    test2_formatter_set($FORMATTER)
    my $formatter = test2_formatter();

    ... And others ...

=head1 MAIN API EXPORTS

All exports are optional. You must specify subs to import.

    use Test2::API qw/context intercept run_subtest/;

This is the list of exports that are most commonly needed. If you are simply
writing a tool, then this is probably all you need. If you need something and
you cannot find it here, then you can also look at L</OTHER API EXPORTS>.

These exports lack the 'test2_' prefix because of how important/common they
are. Exports in the L</OTHER API EXPORTS> section have the 'test2_' prefix to
ensure they stand out.

=head2 context(...)

Usage:

=over 4

=item $ctx = context()

=item $ctx = context(%params)

=back

The C<context()> function will always return the current context. If
there is already a context active, it will be returned. If there is not an
active context, one will be generated. When a context is generated it will
default to using the file and line number where the currently running sub was
called from.

Please see L<Test2::API::Context/"CRITICAL DETAILS"> for important rules about
what you can and cannot do with a context once it is obtained.

B<Note> This function will throw an exception if you ignore the context object
it returns.

B<Note> On perls 5.14+ a depth check is used to insure there are no context
leaks. This cannot be safely done on older perls due to
L<https://rt.perl.org/Public/Bug/Display.html?id=127774>
You can forcefully enable it either by setting C<$ENV{T2_CHECK_DEPTH} = 1> or
C<$Test2::API::DO_DEPTH_CHECK = 1> B<BEFORE> loading L<Test2::API>.

=head3 OPTIONAL PARAMETERS

All parameters to C<context> are optional.

=over 4

=item level => $int

If you must obtain a context in a sub deeper than your entry point you can use
this to tell it how many EXTRA stack frames to look back. If this option is not
provided the default of C<0> is used.

    sub third_party_tool {
        my $sub = shift;
        ... # Does not obtain a context
        $sub->();
        ...
    }

    third_party_tool(sub {
        my $ctx = context(level => 1);
        ...
        $ctx->release;
    });

=item wrapped => $int

Use this if you need to write your own tool that wraps a call to C<context()>
with the intent that it should return a context object.

    sub my_context {
        my %params = ( wrapped => 0, @_ );
        $params{wrapped}++;
        my $ctx = context(%params);
        ...
        return $ctx;
    }

    sub my_tool {
        my $ctx = my_context();
        ...
        $ctx->release;
    }

If you do not do this, then tools you call that also check for a context will
notice that the context they grabbed was created at the same stack depth, which
will trigger protective measures that warn you and destroy the existing
context.

=item stack => $stack

Normally C<context()> looks at the global hub stack. If you are maintaining
your own L<Test2::API::Stack> instance you may pass it in to be used
instead of the global one.

=item hub => $hub

Use this parameter if you want to obtain the context for a specific hub instead
of whatever one happens to be at the top of the stack.

=item on_init => sub { ... }

This lets you provide a callback sub that will be called B<ONLY> if your call
to C<context()> generated a new context. The callback B<WILL NOT> be called if
C<context()> is returning an existing context. The only argument passed into
the callback will be the context object itself.

    sub foo {
        my $ctx = context(on_init => sub { 'will run' });

        my $inner = sub {
            # This callback is not run since we are getting the existing
            # context from our parent sub.
            my $ctx = context(on_init => sub { 'will NOT run' });
            $ctx->release;
        }
        $inner->();

        $ctx->release;
    }

=item on_release => sub { ... }

This lets you provide a callback sub that will be called when the context
instance is released. This callback will be added to the returned context even
if an existing context is returned. If multiple calls to context add callbacks,
then all will be called in reverse order when the context is finally released.

    sub foo {
        my $ctx = context(on_release => sub { 'will run second' });

        my $inner = sub {
            my $ctx = context(on_release => sub { 'will run first' });

            # Neither callback runs on this release
            $ctx->release;
        }
        $inner->();

        # Both callbacks run here.
        $ctx->release;
    }

=back

=head2 release($;$)

Usage:

=over 4

=item release $ctx;

=item release $ctx, ...;

=back

This is intended as a shortcut that lets you release your context and return a
value in one statement. This function will get your context, and an optional
return value. It will release your context, then return your value. Scalar
context is always assumed.

    sub tool {
        my $ctx = context();
        ...

        return release $ctx, 1;
    }

This tool is most useful when you want to return the value you get from calling
a function that needs to see the current context:

    my $ctx = context();
    my $out = some_tool(...);
    $ctx->release;
    return $out;

We can combine the last 3 lines of the above like so:

    my $ctx = context();
    release $ctx, some_tool(...);

=head2 context_do(&;@)

Usage:

    sub my_tool {
        context_do {
            my $ctx = shift;

            my (@args) = @_;

            $ctx->ok(1, "pass");

            ...

            # No need to call $ctx->release, done for you on scope exit.
        } @_;
    }

Using this inside your test tool takes care of a lot of boilerplate for you. It
will ensure a context is acquired. It will capture and rethrow any exception. It
will insure the context is released when you are done. It preserves the
subroutine call context (array, scalar, void).

This is the safest way to write a test tool. The only two downsides to this are a
slight performance decrease, and some extra indentation in your source. If the
indentation is a problem for you then you can take a peek at the next section.

=head2 no_context(&;$)

Usage:

=over 4

=item no_context { ... };

=item no_context { ... } $hid;

    sub my_tool(&) {
        my $code = shift;
        my $ctx = context();
        ...

        no_context {
            # Things in here will not see our current context, they get a new
            # one.

            $code->();
        };

        ...
        $ctx->release;
    };

=back

This tool will hide a context for the provided block of code. This means any
tools run inside the block will get a completely new context if they acquire
one. The new context will be inherited by tools nested below the one that
acquired it.

This will normally hide the current context for the top hub. If you need to
hide the context for a different hub you can pass in the optional C<$hid>
parameter.

=head2 intercept(&)

Usage:

    my $events = intercept {
        ok(1, "pass");
        ok(0, "fail");
        ...
    };

This function takes a codeblock as its only argument, and it has a prototype.
It will execute the codeblock, intercepting any generated events in the
process. It will return an array reference with all the generated event
objects. All events should be subclasses of L<Test2::Event>.

As of version 1.302178 the events array that is returned is blssed as an
L<Test2::API::InterceptResult> instance. L<Test2::API::InterceptResult>
Provides a helpful interface for filtering and/or inspecting the events list
overall, or individual events within the list.

This is intended to help you test your test code. This is not intended for
people simply writing tests.

=head2 run_subtest(...)

Usage:

    run_subtest($NAME, \&CODE, $BUFFERED, @ARGS)

    # or

    run_subtest($NAME, \&CODE, \%PARAMS, @ARGS)

This will run the provided codeblock with the args in C<@args>. This codeblock
will be run as a subtest. A subtest is an isolated test state that is condensed
into a single L<Test2::Event::Subtest> event, which contains all events
generated inside the subtest.

=head3 ARGUMENTS:

=over 4

=item $NAME

The name of the subtest.

=item \&CODE

The code to run inside the subtest.

=item $BUFFERED or \%PARAMS

If this is a simple scalar then it will be treated as a boolean for the
'buffered' setting. If this is a hash reference then it will be used as a
parameters hash. The param hash will be used for hub construction (with the
specified keys removed).

Keys that are removed and used by run_subtest:

=over 4

=item 'buffered' => $bool

Toggle buffered status.

=item 'inherit_trace' => $bool

Normally the subtest hub is pushed and the sub is allowed to generate its own
root context for the hub. When this setting is turned on a root context will be
created for the hub that shares the same trace as the current context.

Set this to true if your tool is producing subtests without user-specified
subs.

=item 'no_fork' => $bool

Defaults to off. Normally forking inside a subtest will actually fork the
subtest, resulting in 2 final subtest events. This parameter will turn off that
behavior, only the original process/thread will return a final subtest event.

=back

=item @ARGS

Any extra arguments you want passed into the subtest code.

=back

=head3 BUFFERED VS UNBUFFERED (OR STREAMED)

Normally all events inside and outside a subtest are sent to the formatter
immediately by the hub. Sometimes it is desirable to hold off sending events
within a subtest until the subtest is complete. This usually depends on the
formatter being used.

=over 4

=item Things not effected by this flag

In both cases events are generated and stored in an array. This array is
eventually used to populate the C<subevents> attribute on the
L<Test2::Event::Subtest> event that is generated at the end of the subtest.
This flag has no effect on this part, it always happens.

At the end of the subtest, the final L<Test2::Event::Subtest> event is sent to
the formatter.

=item Things that are effected by this flag

The C<buffered> attribute of the L<Test2::Event::Subtest> event will be set to
the value of this flag. This means any formatter, listener, etc which looks at
the event will know if it was buffered.

=item Things that are formatter dependant

Events within a buffered subtest may or may not be sent to the formatter as
they happen. If a formatter fails to specify then the default is to B<NOT SEND>
the events as they are generated, instead the formatter can pull them from the
C<subevents> attribute.

A formatter can specify by implementing the C<hide_buffered()> method. If this
method returns true then events generated inside a buffered subtest will not be
sent independently of the final subtest event.

=back

An example of how this is used is the L<Test2::Formatter::TAP> formatter. For
unbuffered subtests the events are rendered as they are generated. At the end
of the subtest, the final subtest event is rendered, but the C<subevents>
attribute is ignored. For buffered subtests the opposite occurs, the events are
NOT rendered as they are generated, instead the C<subevents> attribute is used
to render them all at once. This is useful when running subtests tests in
parallel, since without it the output from subtests would be interleaved
together.

=head1 OTHER API EXPORTS

Exports in this section are not commonly needed. These all have the 'test2_'
prefix to help ensure they stand out. You should look at the L</MAIN API
EXPORTS> section before looking here. This section is one where "Great power
comes with great responsibility". It is possible to break things badly if you
are not careful with these.

All exports are optional. You need to list which ones you want at import time:

    use Test2::API qw/test2_init_done .../;

=head2 STATUS AND INITIALIZATION STATE

These provide access to internal state and object instances.

=over 4

=item $bool = test2_init_done()

This will return true if the stack and IPC instances have already been
initialized. It will return false if they have not. Init happens as late as
possible. It happens as soon as a tool requests the IPC instance, the
formatter, or the stack.

=item $bool = test2_load_done()

This will simply return the boolean value of the loaded flag. If Test2 has
finished loading this will be true, otherwise false. Loading is considered
complete the first time a tool requests a context.

=item test2_set_is_end()

=item test2_set_is_end($bool)

This is used to toggle Test2's belief that the END phase has already started.
With no arguments this will set it to true. With arguments it will set it to
the first argument's value.

This is used to prevent the use of C<caller()> in END blocks which can cause
segfaults. This is only necessary in some persistent environments that may have
multiple END phases.

=item $bool = test2_get_is_end()

Check if Test2 believes it is the END phase.

=item $stack = test2_stack()

This will return the global L<Test2::API::Stack> instance. If this has not
yet been initialized it will be initialized now.

=item $bool = test2_is_testing_done()

This will return true if testing is complete and no other events should be
sent. This is useful in things like warning handlers where you might want to
turn warnings into events, but need them to start acting like normal warnings
when testing is done.

    $SIG{__WARN__} = sub {
        my ($warning) = @_;

        if (test2_is_testing_done()) {
            warn @_;
        }
        else {
            my $ctx = context();
            ...
            $ctx->release
        }
    }

=item test2_ipc_disable

Disable IPC.

=item $bool = test2_ipc_diabled

Check if IPC is disabled.

=item test2_ipc_wait_enable()

=item test2_ipc_wait_disable()

=item $bool = test2_ipc_wait_enabled()

These can be used to turn IPC waiting on and off, or check the current value of
the flag.

Waiting is turned on by default. Waiting will cause the parent process/thread
to wait until all child processes and threads are finished before exiting. You
will almost never want to turn this off.

=item $bool = test2_no_wait()

=item test2_no_wait($bool)

B<DISCOURAGED>: This is a confusing interface, it is better to use
C<test2_ipc_wait_enable()>, C<test2_ipc_wait_disable()> and
C<test2_ipc_wait_enabled()>.

This can be used to get/set the no_wait status. Waiting is turned on by
default. Waiting will cause the parent process/thread to wait until all child
processes and threads are finished before exiting. You will almost never want
to turn this off.

=item $fh = test2_stdout()

=item $fh = test2_stderr()

These functions return the filehandles that test output should be written to.
They are primarily useful when writing a custom formatter and code that turns
events into actual output (TAP, etc.).  They will return a dupe of the original
filehandles that formatted output can be sent to regardless of whatever state
the currently running test may have left STDOUT and STDERR in.

=item test2_reset_io()

Re-dupe the internal filehandles returned by C<test2_stdout()> and
C<test2_stderr()> from the current STDOUT and STDERR.  You shouldn't need to do
this except in very peculiar situations (for example, you're testing a new
formatter and you need control over where the formatter is sending its output.)

=back

=head2 BEHAVIOR HOOKS

These are hooks that allow you to add custom behavior to actions taken by Test2
and tools built on top of it.

=over 4

=item test2_add_callback_exit(sub { ... })

This can be used to add a callback that is called after all testing is done. This
is too late to add additional results, the main use of this callback is to set the
exit code.

    test2_add_callback_exit(
        sub {
            my ($context, $exit, \$new_exit) = @_;
            ...
        }
    );

The C<$context> passed in will be an instance of L<Test2::API::Context>. The
C<$exit> argument will be the original exit code before anything modified it.
C<$$new_exit> is a reference to the new exit code. You may modify this to
change the exit code. Please note that C<$$new_exit> may already be different
from C<$exit>

=item test2_add_callback_post_load(sub { ... })

Add a callback that will be called when Test2 is finished loading. This
means the callback will be run once, the first time a context is obtained.
If Test2 has already finished loading then the callback will be run immediately.

=item test2_add_callback_testing_done(sub { ... })

This adds your coderef as a follow-up to the root hub after Test2 is finished loading.

This is essentially a helper to do the following:

    test2_add_callback_post_load(sub {
        my $stack = test2_stack();
        $stack->top; # Insure we have a hub
        my ($hub) = Test2::API::test2_stack->all;

        $hub->set_active(1);

        $hub->follow_up(sub { ... }); # <-- Your coderef here
    });

=item test2_add_callback_context_acquire(sub { ... })

Add a callback that will be called every time someone tries to acquire a
context. This will be called on EVERY call to C<context()>. It gets a single
argument, a reference to the hash of parameters being used the construct the
context. This is your chance to change the parameters by directly altering the
hash.

    test2_add_callback_context_acquire(sub {
        my $params = shift;
        $params->{level}++;
    });

This is a very scary API function. Please do not use this unless you need to.
This is here for L<Test::Builder> and backwards compatibility. This has you
directly manipulate the hash instead of returning a new one for performance
reasons.

=item test2_add_callback_context_init(sub { ... })

Add a callback that will be called every time a new context is created. The
callback will receive the newly created context as its only argument.

=item test2_add_callback_context_release(sub { ... })

Add a callback that will be called every time a context is released. The
callback will receive the released context as its only argument.

=item test2_add_callback_pre_subtest(sub { ... })

Add a callback that will be called every time a subtest is going to be
run. The callback will receive the subtest name, coderef, and any
arguments.

=item @list = test2_list_context_acquire_callbacks()

Return all the context acquire callback references.

=item @list = test2_list_context_init_callbacks()

Returns all the context init callback references.

=item @list = test2_list_context_release_callbacks()

Returns all the context release callback references.

=item @list = test2_list_exit_callbacks()

Returns all the exit callback references.

=item @list = test2_list_post_load_callbacks()

Returns all the post load callback references.

=item @list = test2_list_pre_subtest_callbacks()

Returns all the pre-subtest callback references.

=item test2_add_uuid_via(sub { ... })

=item $sub = test2_add_uuid_via()

This allows you to provide a UUID generator. If provided UUIDs will be attached
to all events, hubs, and contexts. This is useful for storing, tracking, and
linking these objects.

The sub you provide should always return a unique identifier. Most things will
expect a proper UUID string, however nothing in Test2::API enforces this.

The sub will receive exactly 1 argument, the type of thing being tagged
'context', 'hub', or 'event'. In the future additional things may be tagged, in
which case new strings will be passed in. These are purely informative, you can
(and usually should) ignore them.

=back

=head2 IPC AND CONCURRENCY

These let you access, or specify, the IPC system internals.

=over 4

=item $bool = test2_has_ipc()

Check if IPC is enabled.

=item $ipc = test2_ipc()

This will return the global L<Test2::IPC::Driver> instance. If this has not yet
been initialized it will be initialized now.

=item test2_ipc_add_driver($DRIVER)

Add an IPC driver to the list. This will add the driver to the start of the
list.

=item @drivers = test2_ipc_drivers()

Get the list of IPC drivers.

=item $bool = test2_ipc_polling()

Check if polling is enabled.

=item test2_ipc_enable_polling()

Turn on polling. This will cull events from other processes and threads every
time a context is created.

=item test2_ipc_disable_polling()

Turn off IPC polling.

=item test2_ipc_enable_shm()

Legacy, this is currently a no-op that returns 0;

=item test2_ipc_set_pending($uniq_val)

Tell other processes and events that an event is pending. C<$uniq_val> should
be a unique value no other thread/process will generate.

B<Note:> After calling this C<test2_ipc_get_pending()> will return 1. This is
intentional, and not avoidable.

=item $pending = test2_ipc_get_pending()

This returns -1 if there is no way to check (assume yes)

This returns 0 if there are (most likely) no pending events.

This returns 1 if there are (likely) pending events. Upon return it will reset,
nothing else will be able to see that there were pending events.

=item $timeout = test2_ipc_get_timeout()

=item test2_ipc_set_timeout($timeout)

Get/Set the timeout value for the IPC system. This timeout is how long the IPC
system will wait for child processes and threads to finish before aborting.

The default value is C<30> seconds.

=back

=head2 MANAGING FORMATTERS

These let you access, or specify, the formatters that can/should be used.

=over 4

=item $formatter = test2_formatter

This will return the global formatter class. This is not an instance. By
default the formatter is set to L<Test2::Formatter::TAP>.

You can override this default using the C<T2_FORMATTER> environment variable.

Normally 'Test2::Formatter::' is prefixed to the value in the
environment variable:

    $ T2_FORMATTER='TAP' perl test.t     # Use the Test2::Formatter::TAP formatter
    $ T2_FORMATTER='Foo' perl test.t     # Use the Test2::Formatter::Foo formatter

If you want to specify a full module name you use the '+' prefix:

    $ T2_FORMATTER='+Foo::Bar' perl test.t     # Use the Foo::Bar formatter

=item test2_formatter_set($class_or_instance)

Set the global formatter class. This can only be set once. B<Note:> This will
override anything specified in the 'T2_FORMATTER' environment variable.

=item @formatters = test2_formatters()

Get a list of all loaded formatters.

=item test2_formatter_add($class_or_instance)

Add a formatter to the list. Last formatter added is used at initialization. If
this is called after initialization a warning will be issued.

=back

=head1 OTHER EXAMPLES

See the C</Examples/> directory included in this distribution.

=head1 SEE ALSO

L<Test2::API::Context> - Detailed documentation of the context object.

L<Test2::IPC> - The IPC system used for threading/fork support.

L<Test2::Formatter> - Formatters such as TAP live here.

L<Test2::Event> - Events live in this namespace.

L<Test2::Hub> - All events eventually funnel through a hub. Custom hubs are how
C<intercept()> and C<run_subtest()> are implemented.

=head1 MAGIC

This package has an END block. This END block is responsible for setting the
exit code based on the test results. This end block also calls the callbacks that
can be added to this package.

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! ���q  q    perl5/Test2/Formatter.pmnu ��6�$        package Test2::Formatter;
use strict;
use warnings;

our $VERSION = '1.302183';


my %ADDED;
sub import {
    my $class = shift;
    return if $class eq __PACKAGE__;
    return if $ADDED{$class}++;
    require Test2::API;
    Test2::API::test2_formatter_add($class);
}

sub new_root {
    my $class = shift;
    return $class->new(@_);
}

sub supports_tables { 0 }

sub hide_buffered { 1 }

sub terminate { }

sub finalize { }

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::Formatter - Namespace for formatters.

=head1 DESCRIPTION

This is the namespace for formatters. This is an empty package.

=head1 CREATING FORMATTERS

A formatter is any package or object with a C<write($event, $num)> method.

    package Test2::Formatter::Foo;
    use strict;
    use warnings;

    sub write {
        my $self_or_class = shift;
        my ($event, $assert_num) = @_;
        ...
    }

    sub hide_buffered { 1 }

    sub terminate { }

    sub finalize { }

    sub supports_tables { return $BOOL }

    sub new_root {
        my $class = shift;
        ...
        $class->new(@_);
    }

    1;

The C<write> method is a method, so it either gets a class or instance. The two
arguments are the C<$event> object it should record, and the C<$assert_num>
which is the number of the current assertion (ok), or the last assertion if
this event is not itself an assertion. The assertion number may be any integer 0
or greater, and may be undefined in some cases.

The C<hide_buffered()> method must return a boolean. This is used to tell
buffered subtests whether or not to send it events as they are being buffered.
See L<Test2::API/"run_subtest(...)"> for more information.

The C<terminate> and C<finalize> methods are optional methods called that you
can implement if the format you're generating needs to handle these cases, for
example if you are generating XML and need close open tags.

The C<terminate> method is called when an event's C<terminate> method returns
true, for example when a L<Test2::Event::Plan> has a C<'skip_all'> plan, or
when a L<Test2::Event::Bail> event is sent. The C<terminate> method is passed
a single argument, the L<Test2::Event> object which triggered the terminate.

The C<finalize> method is always the last thing called on the formatter, I<<
except when C<terminate> is called for a Bail event >>. It is passed the
following arguments:

The C<supports_tables> method should be true if the formatter supports directly
rendering table data from the C<info> facets. This is a newer feature and many
older formatters may not support it. When not supported the formatter falls
back to rendering C<detail> instead of the C<table> data.

The C<new_root> method is used when constructing a root formatter. The default
is to just delegate to the regular C<new()> method, most formatters can ignore
this.

=over 4

=item * The number of tests that were planned

=item * The number of tests actually seen

=item * The number of tests which failed

=item * A boolean indicating whether or not the test suite passed

=item * A boolean indicating whether or not this call is for a subtest

=back

The C<new_root> method is called when C<Test2::API::Stack> Initializes the root
hub for the first time. Most formatters will simply have this call C<<
$class->new >>, which is the default behavior. Some formatters however may want
to take extra action during construction of the root formatter, this is where
they can do that.

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! ��Tݦ
  �
    perl5/Test2/Hub/Interceptor.pmnu ��6�$        package Test2::Hub::Interceptor;
use strict;
use warnings;

our $VERSION = '1.302183';


use Test2::Hub::Interceptor::Terminator();

BEGIN { require Test2::Hub; our @ISA = qw(Test2::Hub) }
use Test2::Util::HashBase;

sub init {
    my $self = shift;
    $self->SUPER::init();
    $self->{+NESTED} = 0;
}

sub inherit {
    my $self = shift;
    my ($from, %params) = @_;

    $self->{+NESTED} = 0;

    if ($from->{+IPC} && !$self->{+IPC} && !exists($params{ipc})) {
        my $ipc = $from->{+IPC};
        $self->{+IPC} = $ipc;
        $ipc->add_hub($self->{+HID});
    }

    if (my $ls = $from->{+_LISTENERS}) {
        push @{$self->{+_LISTENERS}} => grep { $_->{intercept_inherit} } @$ls;
    }

    if (my $pfs = $from->{+_PRE_FILTERS}) {
        push @{$self->{+_PRE_FILTERS}} => grep { $_->{intercept_inherit} } @$pfs;
    }

    if (my $fs = $from->{+_FILTERS}) {
        push @{$self->{+_FILTERS}} => grep { $_->{intercept_inherit} } @$fs;
    }
}

sub clean_inherited {
    my $self = shift;
    my %params = @_;

    my @sets = (
        $self->{+_LISTENERS},
        $self->{+_PRE_FILTERS},
        $self->{+_FILTERS},
    );

    for my $set (@sets) {
        next unless $set;

        for my $i (@$set) {
            my $cbs = $i->{intercept_inherit} or next;
            next unless ref($cbs) eq 'HASH';
            my $cb = $cbs->{clean} or next;
            $cb->(%params);
        }
    }
}

sub restore_inherited {
    my $self = shift;
    my %params = @_;

    my @sets = (
        $self->{+_FILTERS},
        $self->{+_PRE_FILTERS},
        $self->{+_LISTENERS},
    );

    for my $set (@sets) {
        next unless $set;

        for my $i (@$set) {
            my $cbs = $i->{intercept_inherit} or next;
            next unless ref($cbs) eq 'HASH';
            my $cb = $cbs->{restore} or next;
            $cb->(%params);
        }
    }
}

sub terminate {
    my $self = shift;
    my ($code) = @_;

    eval {
        no warnings 'exiting';
        last T2_SUBTEST_WRAPPER;
    };
    my $err = $@;

    # Fallback
    die bless(\$err, 'Test2::Hub::Interceptor::Terminator');
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::Hub::Interceptor - Hub used by interceptor to grab results.

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! .4�=P
  P
    perl5/Test2/Hub/Subtest.pmnu ��6�$        package Test2::Hub::Subtest;
use strict;
use warnings;

our $VERSION = '1.302183';

BEGIN { require Test2::Hub; our @ISA = qw(Test2::Hub) }
use Test2::Util::HashBase qw/nested exit_code manual_skip_all/;
use Test2::Util qw/get_tid/;

sub is_subtest { 1 }

sub inherit {
    my $self = shift;
    my ($from) = @_;

    $self->SUPER::inherit($from);

    $self->{+NESTED} = $from->nested + 1;
}

{
    # Legacy
    no warnings 'once';
    *ID = \&Test2::Hub::HID;
    *id = \&Test2::Hub::hid;
    *set_id = \&Test2::Hub::set_hid;
}

sub send {
    my $self = shift;
    my ($e) = @_;

    my $out = $self->SUPER::send($e);

    return $out if $self->{+MANUAL_SKIP_ALL};

    my $f = $e->facet_data;

    my $plan = $f->{plan} or return $out;
    return $out unless $plan->{skip};

    my $trace = $f->{trace} or die "Missing Trace!";
    return $out unless $trace->{pid} != $self->pid
                    || $trace->{tid} != $self->tid;

    no warnings 'exiting';
    last T2_SUBTEST_WRAPPER;
}

sub terminate {
    my $self = shift;
    my ($code, $e, $f) = @_;
    $self->set_exit_code($code);

    return if $self->{+MANUAL_SKIP_ALL};

    $f ||= $e->facet_data;

    if(my $plan = $f->{plan}) {
        my $trace = $f->{trace} or die "Missing Trace!";
        return if $plan->{skip}
               && ($trace->{pid} != $$ || $trace->{tid} != get_tid);
    }

    no warnings 'exiting';
    last T2_SUBTEST_WRAPPER;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::Hub::Subtest - Hub used by subtests

=head1 DESCRIPTION

Subtests make use of this hub to route events.

=head1 TOGGLES

=over 4

=item $bool = $hub->manual_skip_all

=item $hub->set_manual_skip_all($bool)

The default is false.

Normally a skip-all plan event will cause a subtest to stop executing. This is
accomplished via C<last LABEL> to a label inside the subtest code. Most of the
time this is perfectly fine. There are times however where this flow control
causes bad things to happen.

This toggle lets you turn off the abort logic for the hub. When this is toggled
to true B<you> are responsible for ensuring no additional events are generated.

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! Cd�I�  �  )  perl5/Test2/Hub/Interceptor/Terminator.pmnu ��6�$        package Test2::Hub::Interceptor::Terminator;
use strict;
use warnings;

our $VERSION = '1.302183';


1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::Hub::Interceptor::Terminator - Exception class used by
Test2::Hub::Interceptor

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! �Xv�,Y  ,Y    perl5/Test2/Hub.pmnu ��6�$        package Test2::Hub;
use strict;
use warnings;

our $VERSION = '1.302183';


use Carp qw/carp croak confess/;
use Test2::Util qw/get_tid gen_uid/;

use Scalar::Util qw/weaken/;
use List::Util qw/first/;

use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/;
use Test2::Util::HashBase qw{
    pid tid hid ipc
    nested buffered
    no_ending
    _filters
    _pre_filters
    _listeners
    _follow_ups
    _formatter
    _context_acquire
    _context_init
    _context_release

    uuid
    active
    count
    failed
    ended
    bailed_out
    _passing
    _plan
    skip_reason
};

my $UUID_VIA;

sub init {
    my $self = shift;

    $self->{+PID} = $$;
    $self->{+TID} = get_tid();
    $self->{+HID} = gen_uid();

    $UUID_VIA ||= Test2::API::_add_uuid_via_ref();
    $self->{+UUID} = ${$UUID_VIA}->('hub') if $$UUID_VIA;

    $self->{+NESTED}   = 0 unless defined $self->{+NESTED};
    $self->{+BUFFERED} = 0 unless defined $self->{+BUFFERED};

    $self->{+COUNT}    = 0;
    $self->{+FAILED}   = 0;
    $self->{+_PASSING} = 1;

    if (my $formatter = delete $self->{formatter}) {
        $self->format($formatter);
    }

    if (my $ipc = $self->{+IPC}) {
        $ipc->add_hub($self->{+HID});
    }
}

sub is_subtest { 0 }

sub _tb_reset {
    my $self = shift;

    # Nothing to do
    return if $self->{+PID} == $$ && $self->{+TID} == get_tid();

    $self->{+PID} = $$;
    $self->{+TID} = get_tid();
    $self->{+HID} = gen_uid();

    if (my $ipc = $self->{+IPC}) {
        $ipc->add_hub($self->{+HID});
    }
}

sub reset_state {
    my $self = shift;

    $self->{+COUNT} = 0;
    $self->{+FAILED} = 0;
    $self->{+_PASSING} = 1;

    delete $self->{+_PLAN};
    delete $self->{+ENDED};
    delete $self->{+BAILED_OUT};
    delete $self->{+SKIP_REASON};
}

sub inherit {
    my $self = shift;
    my ($from, %params) = @_;

    $self->{+NESTED} ||= 0;

    $self->{+_FORMATTER} = $from->{+_FORMATTER}
        unless $self->{+_FORMATTER} || exists($params{formatter});

    if ($from->{+IPC} && !$self->{+IPC} && !exists($params{ipc})) {
        my $ipc = $from->{+IPC};
        $self->{+IPC} = $ipc;
        $ipc->add_hub($self->{+HID});
    }

    if (my $ls = $from->{+_LISTENERS}) {
        push @{$self->{+_LISTENERS}} => grep { $_->{inherit} } @$ls;
    }

    if (my $pfs = $from->{+_PRE_FILTERS}) {
        push @{$self->{+_PRE_FILTERS}} => grep { $_->{inherit} } @$pfs;
    }

    if (my $fs = $from->{+_FILTERS}) {
        push @{$self->{+_FILTERS}} => grep { $_->{inherit} } @$fs;
    }
}

sub format {
    my $self = shift;

    my $old = $self->{+_FORMATTER};
    ($self->{+_FORMATTER}) = @_ if @_;

    return $old;
}

sub is_local {
    my $self = shift;
    return $$ == $self->{+PID}
        && get_tid() == $self->{+TID};
}

sub listen {
    my $self = shift;
    my ($sub, %params) = @_;

    carp "Useless addition of a listener in a child process or thread!"
        if $$ != $self->{+PID} || get_tid() != $self->{+TID};

    croak "listen only takes coderefs for arguments, got '$sub'"
        unless ref $sub && ref $sub eq 'CODE';

    push @{$self->{+_LISTENERS}} => { %params, code => $sub };

    $sub; # Intentional return.
}

sub unlisten {
    my $self = shift;

    carp "Useless removal of a listener in a child process or thread!"
        if $$ != $self->{+PID} || get_tid() != $self->{+TID};

    my %subs = map {$_ => $_} @_;

    @{$self->{+_LISTENERS}} = grep { !$subs{$_->{code}} } @{$self->{+_LISTENERS}};
}

sub filter {
    my $self = shift;
    my ($sub, %params) = @_;

    carp "Useless addition of a filter in a child process or thread!"
        if $$ != $self->{+PID} || get_tid() != $self->{+TID};

    croak "filter only takes coderefs for arguments, got '$sub'"
        unless ref $sub && ref $sub eq 'CODE';

    push @{$self->{+_FILTERS}} => { %params, code => $sub };

    $sub; # Intentional Return
}

sub unfilter {
    my $self = shift;
    carp "Useless removal of a filter in a child process or thread!"
        if $$ != $self->{+PID} || get_tid() != $self->{+TID};
    my %subs = map {$_ => $_} @_;
    @{$self->{+_FILTERS}} = grep { !$subs{$_->{code}} } @{$self->{+_FILTERS}};
}

sub pre_filter {
    my $self = shift;
    my ($sub, %params) = @_;

    croak "pre_filter only takes coderefs for arguments, got '$sub'"
        unless ref $sub && ref $sub eq 'CODE';

    push @{$self->{+_PRE_FILTERS}} => { %params, code => $sub };

    $sub; # Intentional Return
}

sub pre_unfilter {
    my $self = shift;
    my %subs = map {$_ => $_} @_;
    @{$self->{+_PRE_FILTERS}} = grep { !$subs{$_->{code}} } @{$self->{+_PRE_FILTERS}};
}

sub follow_up {
    my $self = shift;
    my ($sub) = @_;

    carp "Useless addition of a follow-up in a child process or thread!"
        if $$ != $self->{+PID} || get_tid() != $self->{+TID};

    croak "follow_up only takes coderefs for arguments, got '$sub'"
        unless ref $sub && ref $sub eq 'CODE';

    push @{$self->{+_FOLLOW_UPS}} => $sub;
}

*add_context_aquire = \&add_context_acquire;
sub add_context_acquire {
    my $self = shift;
    my ($sub) = @_;

    croak "add_context_acquire only takes coderefs for arguments, got '$sub'"
        unless ref $sub && ref $sub eq 'CODE';

    push @{$self->{+_CONTEXT_ACQUIRE}} => $sub;

    $sub; # Intentional return.
}

*remove_context_aquire = \&remove_context_acquire;
sub remove_context_acquire {
    my $self = shift;
    my %subs = map {$_ => $_} @_;
    @{$self->{+_CONTEXT_ACQUIRE}} = grep { !$subs{$_} == $_ } @{$self->{+_CONTEXT_ACQUIRE}};
}

sub add_context_init {
    my $self = shift;
    my ($sub) = @_;

    croak "add_context_init only takes coderefs for arguments, got '$sub'"
        unless ref $sub && ref $sub eq 'CODE';

    push @{$self->{+_CONTEXT_INIT}} => $sub;

    $sub; # Intentional return.
}

sub remove_context_init {
    my $self = shift;
    my %subs = map {$_ => $_} @_;
    @{$self->{+_CONTEXT_INIT}} = grep { !$subs{$_} == $_ } @{$self->{+_CONTEXT_INIT}};
}

sub add_context_release {
    my $self = shift;
    my ($sub) = @_;

    croak "add_context_release only takes coderefs for arguments, got '$sub'"
        unless ref $sub && ref $sub eq 'CODE';

    push @{$self->{+_CONTEXT_RELEASE}} => $sub;

    $sub; # Intentional return.
}

sub remove_context_release {
    my $self = shift;
    my %subs = map {$_ => $_} @_;
    @{$self->{+_CONTEXT_RELEASE}} = grep { !$subs{$_} == $_ } @{$self->{+_CONTEXT_RELEASE}};
}

sub send {
    my $self = shift;
    my ($e) = @_;

    $e->eid;

    $e->add_hub(
        {
            details => ref($self),

            buffered => $self->{+BUFFERED},
            hid      => $self->{+HID},
            nested   => $self->{+NESTED},
            pid      => $self->{+PID},
            tid      => $self->{+TID},
            uuid     => $self->{+UUID},

            ipc => $self->{+IPC} ? 1 : 0,
        }
    );

    $e->set_uuid(${$UUID_VIA}->('event')) if $$UUID_VIA;

    if ($self->{+_PRE_FILTERS}) {
        for (@{$self->{+_PRE_FILTERS}}) {
            $e = $_->{code}->($self, $e);
            return unless $e;
        }
    }

    my $ipc = $self->{+IPC} || return $self->process($e);

    if($e->global) {
        $ipc->send($self->{+HID}, $e, 'GLOBAL');
        return $self->process($e);
    }

    return $ipc->send($self->{+HID}, $e)
        if $$ != $self->{+PID} || get_tid() != $self->{+TID};

    $self->process($e);
}

sub process {
    my $self = shift;
    my ($e) = @_;

    if ($self->{+_FILTERS}) {
        for (@{$self->{+_FILTERS}}) {
            $e = $_->{code}->($self, $e);
            return unless $e;
        }
    }

    # Optimize the most common case
    my $type = ref($e);
    if ($type eq 'Test2::Event::Pass' || ($type eq 'Test2::Event::Ok' && $e->{pass})) {
        my $count = ++($self->{+COUNT});
        $self->{+_FORMATTER}->write($e, $count) if $self->{+_FORMATTER};

        if ($self->{+_LISTENERS}) {
            $_->{code}->($self, $e, $count) for @{$self->{+_LISTENERS}};
        }

        return $e;
    }

    my $f = $e->facet_data;

    my $fail = 0;
    $fail = 1 if $f->{assert} && !$f->{assert}->{pass};
    $fail = 1 if $f->{errors} && grep { $_->{fail} } @{$f->{errors}};
    $fail = 0 if $f->{amnesty};

    $self->{+COUNT}++ if $f->{assert};
    $self->{+FAILED}++ if $fail && $f->{assert};
    $self->{+_PASSING} = 0 if $fail;

    my $code = $f->{control} ? $f->{control}->{terminate} : undef;
    my $count = $self->{+COUNT};

    if (my $plan = $f->{plan}) {
        if ($plan->{skip}) {
            $self->plan('SKIP');
            $self->set_skip_reason($plan->{details} || 1);
            $code ||= 0;
        }
        elsif ($plan->{none}) {
            $self->plan('NO PLAN');
        }
        else {
            $self->plan($plan->{count});
        }
    }

    $e->callback($self) if $f->{control} && $f->{control}->{has_callback};

    $self->{+_FORMATTER}->write($e, $count, $f) if $self->{+_FORMATTER};

    if ($self->{+_LISTENERS}) {
        $_->{code}->($self, $e, $count, $f) for @{$self->{+_LISTENERS}};
    }

    if ($f->{control} && $f->{control}->{halt}) {
        $code ||= 255;
        $self->set_bailed_out($e);
    }

    if (defined $code) {
        $self->{+_FORMATTER}->terminate($e, $f) if $self->{+_FORMATTER};
        $self->terminate($code, $e, $f);
    }

    return $e;
}

sub terminate {
    my $self = shift;
    my ($code) = @_;
    exit($code);
}

sub cull {
    my $self = shift;

    my $ipc = $self->{+IPC} || return;
    return if $self->{+PID} != $$ || $self->{+TID} != get_tid();

    # No need to do IPC checks on culled events
    $self->process($_) for $ipc->cull($self->{+HID});
}

sub finalize {
    my $self = shift;
    my ($trace, $do_plan) = @_;

    $self->cull();

    my $plan   = $self->{+_PLAN};
    my $count  = $self->{+COUNT};
    my $failed = $self->{+FAILED};
    my $active = $self->{+ACTIVE};

    # return if NOTHING was done.
    unless ($active || $do_plan || defined($plan) || $count || $failed) {
        $self->{+_FORMATTER}->finalize($plan, $count, $failed, 0, $self->is_subtest) if $self->{+_FORMATTER};
        return;
    }

    unless ($self->{+ENDED}) {
        if ($self->{+_FOLLOW_UPS}) {
            $_->($trace, $self) for reverse @{$self->{+_FOLLOW_UPS}};
        }

        # These need to be refreshed now
        $plan   = $self->{+_PLAN};
        $count  = $self->{+COUNT};
        $failed = $self->{+FAILED};

        if (($plan && $plan eq 'NO PLAN') || ($do_plan && !$plan)) {
            $self->send(
                Test2::Event::Plan->new(
                    trace => $trace,
                    max => $count,
                )
            );
        }
        $plan = $self->{+_PLAN};
    }

    my $frame = $trace->frame;
    if($self->{+ENDED}) {
        my (undef, $ffile, $fline) = @{$self->{+ENDED}};
        my (undef, $sfile, $sline) = @$frame;

        die <<"        EOT"
Test already ended!
First End:  $ffile line $fline
Second End: $sfile line $sline
        EOT
    }

    $self->{+ENDED} = $frame;
    my $pass = $self->is_passing(); # Generate the final boolean.

    $self->{+_FORMATTER}->finalize($plan, $count, $failed, $pass, $self->is_subtest) if $self->{+_FORMATTER};

    return $pass;
}

sub is_passing {
    my $self = shift;

    ($self->{+_PASSING}) = @_ if @_;

    # If we already failed just return 0.
    my $pass = $self->{+_PASSING} or return 0;
    return $self->{+_PASSING} = 0 if $self->{+FAILED};

    my $count = $self->{+COUNT};
    my $ended = $self->{+ENDED};
    my $plan = $self->{+_PLAN};

    return $pass if !$count && $plan && $plan =~ m/^SKIP$/;

    return $self->{+_PASSING} = 0
        if $ended && (!$count || !$plan);

    return $pass unless $plan && $plan =~ m/^\d+$/;

    if ($ended) {
        return $self->{+_PASSING} = 0 if $count != $plan;
    }
    else {
        return $self->{+_PASSING} = 0 if $count > $plan;
    }

    return $pass;
}

sub plan {
    my $self = shift;

    return $self->{+_PLAN} unless @_;

    my ($plan) = @_;

    confess "You cannot unset the plan"
        unless defined $plan;

    confess "You cannot change the plan"
        if $self->{+_PLAN} && $self->{+_PLAN} !~ m/^NO PLAN$/;

    confess "'$plan' is not a valid plan! Plan must be an integer greater than 0, 'NO PLAN', or 'SKIP'"
        unless $plan =~ m/^(\d+|NO PLAN|SKIP)$/;

    $self->{+_PLAN} = $plan;
}

sub check_plan {
    my $self = shift;

    return undef unless $self->{+ENDED};
    my $plan = $self->{+_PLAN} || return undef;

    return 1 if $plan !~ m/^\d+$/;

    return 1 if $plan == $self->{+COUNT};
    return 0;
}

sub DESTROY {
    my $self = shift;
    my $ipc = $self->{+IPC} || return;
    return unless $$ == $self->{+PID};
    return unless get_tid() == $self->{+TID};
    $ipc->drop_hub($self->{+HID});
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::Hub - The conduit through which all events flow.

=head1 SYNOPSIS

    use Test2::Hub;

    my $hub = Test2::Hub->new();
    $hub->send(...);

=head1 DESCRIPTION

The hub is the place where all events get processed and handed off to the
formatter. The hub also tracks test state, and provides several hooks into the
event pipeline.

=head1 COMMON TASKS

=head2 SENDING EVENTS

    $hub->send($event)

The C<send()> method is used to issue an event to the hub. This method will
handle thread/fork sync, filters, listeners, TAP output, etc.

=head2 ALTERING OR REMOVING EVENTS

You can use either C<filter()> or C<pre_filter()>, depending on your
needs. Both have identical syntax, so only C<filter()> is shown here.

    $hub->filter(sub {
        my ($hub, $event) = @_;

        my $action = get_action($event);

        # No action should be taken
        return $event if $action eq 'none';

        # You want your filter to remove the event
        return undef if $action eq 'delete';

        if ($action eq 'do_it') {
            my $new_event = copy_event($event);
            ... Change your copy of the event ...
            return $new_event;
        }

        die "Should not happen";
    });

By default, filters are not inherited by child hubs. That means if you start a
subtest, the subtest will not inherit the filter. You can change this behavior
with the C<inherit> parameter:

    $hub->filter(sub { ... }, inherit => 1);

=head2 LISTENING FOR EVENTS

    $hub->listen(sub {
        my ($hub, $event, $number) = @_;

        ... do whatever you want with the event ...

        # return is ignored
    });

By default listeners are not inherited by child hubs. That means if you start a
subtest, the subtest will not inherit the listener. You can change this behavior
with the C<inherit> parameter:

    $hub->listen(sub { ... }, inherit => 1);


=head2 POST-TEST BEHAVIORS

    $hub->follow_up(sub {
        my ($trace, $hub) = @_;

        ... do whatever you need to ...

        # Return is ignored
    });

follow_up subs are called only once, either when done_testing is called, or in
an END block.

=head2 SETTING THE FORMATTER

By default an instance of L<Test2::Formatter::TAP> is created and used.

    my $old = $hub->format(My::Formatter->new);

Setting the formatter will REPLACE any existing formatter. You may set the
formatter to undef to prevent output. The old formatter will be returned if one
was already set. Only one formatter is allowed at a time.

=head1 METHODS

=over 4

=item $hub->send($event)

This is where all events enter the hub for processing.

=item $hub->process($event)

This is called by send after it does any IPC handling. You can use this to
bypass the IPC process, but in general you should avoid using this.

=item $old = $hub->format($formatter)

Replace the existing formatter instance with a new one. Formatters must be
objects that implement a C<< $formatter->write($event) >> method.

=item $sub = $hub->listen(sub { ... }, %optional_params)

You can use this to record all events AFTER they have been sent to the
formatter. No changes made here will be meaningful, except possibly to other
listeners.

    $hub->listen(sub {
        my ($hub, $event, $number) = @_;

        ... do whatever you want with the event ...

        # return is ignored
    });

Normally listeners are not inherited by child hubs such as subtests. You can
add the C<< inherit => 1 >> parameter to allow a listener to be inherited.

=item $hub->unlisten($sub)

You can use this to remove a listen callback. You must pass in the coderef
returned by the C<listen()> method.

=item $sub = $hub->filter(sub { ... }, %optional_params)

=item $sub = $hub->pre_filter(sub { ... }, %optional_params)

These can be used to add filters. Filters can modify, replace, or remove events
before anything else can see them.

    $hub->filter(
        sub {
            my ($hub, $event) = @_;

            return $event;    # No Changes
            return;           # Remove the event

            # Or you can modify an event before returning it.
            $event->modify;
            return $event;
        }
    );

If you are not using threads, forking, or IPC then the only difference between
a C<filter> and a C<pre_filter> is that C<pre_filter> subs run first. When you
are using threads, forking, or IPC, pre_filters happen to events before they
are sent to their destination proc/thread, ordinary filters happen only in the
destination hub/thread.

You cannot add a regular filter to a hub if the hub was created in another
process or thread. You can always add a pre_filter.

=item $hub->unfilter($sub)

=item $hub->pre_unfilter($sub)

These can be used to remove filters and pre_filters. The C<$sub> argument is
the reference returned by C<filter()> or C<pre_filter()>.

=item $hub->follow_op(sub { ... })

Use this to add behaviors that are called just before the hub is finalized. The
only argument to your codeblock will be a L<Test2::EventFacet::Trace> instance.

    $hub->follow_up(sub {
        my ($trace, $hub) = @_;

        ... do whatever you need to ...

        # Return is ignored
    });

follow_up subs are called only once, ether when done_testing is called, or in
an END block.

=item $sub = $hub->add_context_acquire(sub { ... });

Add a callback that will be called every time someone tries to acquire a
context. It gets a single argument, a reference of the hash of parameters
being used the construct the context. This is your chance to change the
parameters by directly altering the hash.

    test2_add_callback_context_acquire(sub {
        my $params = shift;
        $params->{level}++;
    });

This is a very scary API function. Please do not use this unless you need to.
This is here for L<Test::Builder> and backwards compatibility. This has you
directly manipulate the hash instead of returning a new one for performance
reasons.

B<Note> Using this hook could have a huge performance impact.

The coderef you provide is returned and can be used to remove the hook later.

=item $hub->remove_context_acquire($sub);

This can be used to remove a context acquire hook.

=item $sub = $hub->add_context_init(sub { ... });

This allows you to add callbacks that will trigger every time a new context is
created for the hub. The only argument to the sub will be the
L<Test2::API::Context> instance that was created.

B<Note> Using this hook could have a huge performance impact.

The coderef you provide is returned and can be used to remove the hook later.

=item $hub->remove_context_init($sub);

This can be used to remove a context init hook.

=item $sub = $hub->add_context_release(sub { ... });

This allows you to add callbacks that will trigger every time a context for
this hub is released. The only argument to the sub will be the
L<Test2::API::Context> instance that was released. These will run in reverse
order.

B<Note> Using this hook could have a huge performance impact.

The coderef you provide is returned and can be used to remove the hook later.

=item $hub->remove_context_release($sub);

This can be used to remove a context release hook.

=item $hub->cull()

Cull any IPC events (and process them).

=item $pid = $hub->pid()

Get the process id under which the hub was created.

=item $tid = $hub->tid()

Get the thread id under which the hub was created.

=item $hud = $hub->hid()

Get the identifier string of the hub.

=item $uuid = $hub->uuid()

If UUID tagging is enabled (see L<Test2::API>) then the hub will have a UUID.

=item $ipc = $hub->ipc()

Get the IPC object used by the hub.

=item $hub->set_no_ending($bool)

=item $bool = $hub->no_ending

This can be used to disable auto-ending behavior for a hub. The auto-ending
behavior is triggered by an end block and is used to cull IPC events, and
output the final plan if the plan was 'NO PLAN'.

=item $bool = $hub->active

=item $hub->set_active($bool)

These are used to get/set the 'active' attribute. When true this attribute will
force C<< hub->finalize() >> to take action even if there is no plan, and no
tests have been run. This flag is useful for plugins that add follow-up
behaviors that need to run even if no events are seen.

=back

=head2 STATE METHODS

=over 4

=item $hub->reset_state()

Reset all state to the start. This sets the test count to 0, clears the plan,
removes the failures, etc.

=item $num = $hub->count

Get the number of tests that have been run.

=item $num = $hub->failed

Get the number of failures (Not all failures come from a test fail, so this
number can be larger than the count).

=item $bool = $hub->ended

True if the testing has ended. This MAY return the stack frame of the tool that
ended the test, but that is not guaranteed.

=item $bool = $hub->is_passing

=item $hub->is_passing($bool)

Check if the overall test run is a failure. Can also be used to set the
pass/fail status.

=item $hub->plan($plan)

=item $plan = $hub->plan

Get or set the plan. The plan must be an integer larger than 0, the string
'NO PLAN', or the string 'SKIP'.

=item $bool = $hub->check_plan

Check if the plan and counts match, but only if the tests have ended. If tests
have not ended this will return undef, otherwise it will be a true/false.

=back

=head1 THIRD PARTY META-DATA

This object consumes L<Test2::Util::ExternalMeta> which provides a consistent
way for you to attach meta-data to instances of this class. This is useful for
tools, plugins, and other extensions.

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! c�.�oX  oX    perl5/Test2/Event.pmnu ��6�$        package Test2::Event;
use strict;
use warnings;

our $VERSION = '1.302183';

use Scalar::Util qw/blessed reftype/;
use Carp qw/croak/;

use Test2::Util::HashBase qw/trace -amnesty uuid -_eid -hubs/;
use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/;
use Test2::Util qw/pkg_to_file gen_uid/;

use Test2::EventFacet::About();
use Test2::EventFacet::Amnesty();
use Test2::EventFacet::Assert();
use Test2::EventFacet::Control();
use Test2::EventFacet::Error();
use Test2::EventFacet::Info();
use Test2::EventFacet::Meta();
use Test2::EventFacet::Parent();
use Test2::EventFacet::Plan();
use Test2::EventFacet::Trace();
use Test2::EventFacet::Hub();

# Legacy tools will expect this to be loaded now
require Test2::Util::Trace;

my %LOADED_FACETS = (
    'about'   => 'Test2::EventFacet::About',
    'amnesty' => 'Test2::EventFacet::Amnesty',
    'assert'  => 'Test2::EventFacet::Assert',
    'control' => 'Test2::EventFacet::Control',
    'errors'  => 'Test2::EventFacet::Error',
    'info'    => 'Test2::EventFacet::Info',
    'meta'    => 'Test2::EventFacet::Meta',
    'parent'  => 'Test2::EventFacet::Parent',
    'plan'    => 'Test2::EventFacet::Plan',
    'trace'   => 'Test2::EventFacet::Trace',
    'hubs'    => 'Test2::EventFacet::Hub',
);

sub FACET_TYPES { sort values %LOADED_FACETS }

sub load_facet {
    my $class = shift;
    my ($facet) = @_;

    return $LOADED_FACETS{$facet} if exists $LOADED_FACETS{$facet};

    my @check = ($facet);
    if ('s' eq substr($facet, -1, 1)) {
        push @check => substr($facet, 0, -1);
    }
    else {
        push @check => $facet . 's';
    }

    my $found;
    for my $check (@check) {
        my $mod  = "Test2::EventFacet::" . ucfirst($facet);
        my $file = pkg_to_file($mod);
        next unless eval { require $file; 1 };
        $found = $mod;
        last;
    }

    return undef unless $found;
    $LOADED_FACETS{$facet} = $found;
}

sub causes_fail      { 0 }
sub increments_count { 0 }
sub diagnostics      { 0 }
sub no_display       { 0 }
sub subtest_id       { undef }

sub callback { }

sub terminate { () }
sub global    { () }
sub sets_plan { () }

sub summary { ref($_[0]) }

sub related {
    my $self = shift;
    my ($event) = @_;

    my $tracea = $self->trace  or return undef;
    my $traceb = $event->trace or return undef;

    my $uuida = $tracea->uuid;
    my $uuidb = $traceb->uuid;
    if ($uuida && $uuidb) {
        return 1 if $uuida eq $uuidb;
        return 0;
    }

    my $siga = $tracea->signature or return undef;
    my $sigb = $traceb->signature or return undef;

    return 1 if $siga eq $sigb;
    return 0;
}

sub add_hub {
    my $self = shift;
    unshift @{$self->{+HUBS}} => @_;
}

sub add_amnesty {
    my $self = shift;

    for my $am (@_) {
        $am = {%$am} if ref($am) ne 'ARRAY';
        $am = Test2::EventFacet::Amnesty->new($am);

        push @{$self->{+AMNESTY}} => $am;
    }
}

sub eid { $_[0]->{+_EID} ||= gen_uid() }

sub common_facet_data {
    my $self = shift;

    my %out;

    $out{about} = {package => ref($self) || undef};
    if (my $uuid = $self->uuid) {
        $out{about}->{uuid} = $uuid;
    }

    $out{about}->{eid} = $self->{+_EID} || $self->eid;

    if (my $trace = $self->trace) {
        $out{trace} = { %$trace };
    }

    if (my $hubs = $self->hubs) {
        $out{hubs} = $hubs;
    }

    $out{amnesty} = [map {{ %{$_} }} @{$self->{+AMNESTY}}]
        if $self->{+AMNESTY};

    if (my $meta = $self->meta_facet_data) {
        $out{meta} = $meta;
    }

    return \%out;
}

sub meta_facet_data {
    my $self = shift;

    my $key = Test2::Util::ExternalMeta::META_KEY();

    my $hash = $self->{$key} or return undef;
    return {%$hash};
}

sub facet_data {
    my $self = shift;

    my $out = $self->common_facet_data;

    $out->{about}->{details}    = $self->summary    || undef;
    $out->{about}->{no_display} = $self->no_display || undef;

    # Might be undef, we want to preserve that
    my $terminate = $self->terminate;
    $out->{control} = {
        global    => $self->global    || 0,
        terminate => $terminate,
        has_callback => $self->can('callback') == \&callback ? 0 : 1,
    };

    $out->{assert} = {
        no_debug => 1,                     # Legacy behavior
        pass     => $self->causes_fail ? 0 : 1,
        details  => $self->summary,
    } if $self->increments_count;

    $out->{parent} = {hid => $self->subtest_id} if $self->subtest_id;

    if (my @plan = $self->sets_plan) {
        $out->{plan} = {};

        $out->{plan}->{count}   = $plan[0] if defined $plan[0];
        $out->{plan}->{details} = $plan[2] if defined $plan[2];

        if ($plan[1]) {
            $out->{plan}->{skip} = 1 if $plan[1] eq 'SKIP';
            $out->{plan}->{none} = 1 if $plan[1] eq 'NO PLAN';
        }

        $out->{control}->{terminate} ||= 0 if $out->{plan}->{skip};
    }

    if ($self->causes_fail && !$out->{assert}) {
        $out->{errors} = [
            {
                tag     => 'FAIL',
                fail    => 1,
                details => $self->summary,
            }
        ];
    }

    my %IGNORE = (trace => 1, about => 1, control => 1);
    my $do_info = !grep { !$IGNORE{$_} } keys %$out;

    if ($do_info && !$self->no_display && $self->diagnostics) {
        $out->{info} = [
            {
                tag     => 'DIAG',
                debug   => 1,
                details => $self->summary,
            }
        ];
    }

    return $out;
}

sub facets {
    my $self = shift;
    my %out;

    my $data = $self->facet_data;
    my @errors = $self->validate_facet_data($data);
    die join "\n" => @errors if @errors;

    for my $facet (keys %$data) {
        my $class = $self->load_facet($facet);
        my $val = $data->{$facet};

        unless($class) {
            $out{$facet} = $val;
            next;
        }

        my $is_list = reftype($val) eq 'ARRAY' ? 1 : 0;
        if ($is_list) {
            $out{$facet} = [map { $class->new($_) } @$val];
        }
        else {
            $out{$facet} = $class->new($val);
        }
    }

    return \%out;
}

sub validate_facet_data {
    my $class_or_self = shift;
    my ($f, %params);

    $f = shift if @_ && (reftype($_[0]) || '') eq 'HASH';
    %params = @_;

    $f ||= $class_or_self->facet_data if blessed($class_or_self);
    croak "No facet data" unless $f;

    my @errors;

    for my $k (sort keys %$f) {
        my $fclass = $class_or_self->load_facet($k);

        push @errors => "Could not find a facet class for facet '$k'"
            if $params{require_facet_class} && !$fclass;

        next unless $fclass;

        my $v = $f->{$k};
        next unless defined($v); # undef is always fine

        my $is_list = $fclass->is_list();
        my $got_list = reftype($v) eq 'ARRAY' ? 1 : 0;

        push @errors => "Facet '$k' should be a list, but got a single item ($v)"
            if $is_list && !$got_list;

        push @errors => "Facet '$k' should not be a list, but got a a list ($v)"
            if $got_list && !$is_list;
    }

    return @errors;
}

sub nested {
    my $self = shift;

    Carp::cluck("Use of Test2::Event->nested() is deprecated, use Test2::Event->trace->nested instead")
        if $ENV{AUTHOR_TESTING};

    if (my $hubs = $self->{+HUBS}) {
        return $hubs->[0]->{nested} if @$hubs;
    }

    my $trace = $self->{+TRACE} or return undef;
    return $trace->{nested};
}

sub in_subtest {
    my $self = shift;

    Carp::cluck("Use of Test2::Event->in_subtest() is deprecated, use Test2::Event->trace->hid instead")
        if $ENV{AUTHOR_TESTING};

    my $hubs = $self->{+HUBS};
    if ($hubs && @$hubs) {
        return undef unless $hubs->[0]->{nested};
        return $hubs->[0]->{hid}
    }

    my $trace = $self->{+TRACE} or return undef;
    return undef unless $trace->{nested};
    return $trace->{hid};
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::Event - Base class for events

=head1 DESCRIPTION

Base class for all event objects that get passed through
L<Test2>.

=head1 SYNOPSIS

    package Test2::Event::MyEvent;
    use strict;
    use warnings;

    # This will make our class an event subclass (required)
    use base 'Test2::Event';

    # Add some accessors (optional)
    # You are not obligated to use HashBase, you can use any object tool you
    # want, or roll your own accessors.
    use Test2::Util::HashBase qw/foo bar baz/;

    # Use this if you want the legacy API to be written for you, for this to
    # work you will need to implement a facet_data() method.
    use Test2::Util::Facets2Legacy;

    # Chance to initialize some defaults
    sub init {
        my $self = shift;
        # no other args in @_

        $self->set_foo('xxx') unless defined $self->foo;

        ...
    }

    # This is the new way for events to convey data to the Test2 system
    sub facet_data {
        my $self = shift;

        # Get common facets such as 'about', 'trace' 'amnesty', and 'meta'
        my $facet_data = $self->common_facet_data();

        # Are you making an assertion?
        $facet_data->{assert} = {pass => 1, details => 'my assertion'};
        ...

        return $facet_data;
    }

    1;

=head1 METHODS

=head2 GENERAL

=over 4

=item $trace = $e->trace

Get a snapshot of the L<Test2::EventFacet::Trace> as it was when this event was
generated

=item $bool_or_undef = $e->related($e2)

Check if 2 events are related. In this case related means their traces share a
signature meaning they were created with the same context (or at the very least
by contexts which share an id, which is the same thing unless someone is doing
something very bad).

This can be used to reliably link multiple events created by the same tool. For
instance a failing test like C<ok(0, "fail"> will generate 2 events, one being
a L<Test2::Event::Ok>, the other being a L<Test2::Event::Diag>, both of these
events are related having been created under the same context and by the same
initial tool (though multiple tools may have been nested under the initial
one).

This will return C<undef> if the relationship cannot be checked, which happens
if either event has an incomplete or missing trace. This will return C<0> if
the traces are complete, but do not match. C<1> will be returned if there is a
match.

=item $e->add_amnesty({tag => $TAG, details => $DETAILS});

This can be used to add amnesty to this event. Amnesty only effects failing
assertions in most cases, but some formatters may display them for passing
assertions, or even non-assertions as well.

Amnesty will prevent a failed assertion from causing the overall test to fail.
In other words it marks a failure as expected and allowed.

B<Note:> This is how 'TODO' is implemented under the hood. TODO is essentially
amnesty with the 'TODO' tag. The details are the reason for the TODO.

=item $uuid = $e->uuid

If UUID tagging is enabled (See L<Test::API>) then any event that has made its
way through a hub will be tagged with a UUID. A newly created event will not
yet be tagged in most cases.

=item $class = $e->load_facet($name)

This method is used to load a facet by name (or key). It will attempt to load
the facet class, if it succeeds it will return the class it loaded. If it fails
it will return C<undef>. This caches the result at the class level so that
future calls will be faster.

The C<$name> variable should be the key used to access the facet in a facets
hashref. For instance the assertion facet has the key 'assert', the information
facet has the 'info' key, and the error facet has the key 'errors'. You may
include or omit the 's' at the end of the name, the method is smart enough to
try both the 's' and no-'s' forms, it will check what you provided first, and
if that is not found it will add or strip the 's and try again.

=item @classes = $e->FACET_TYPES()

=item @classes = Test2::Event->FACET_TYPES()

This returns a list of all facets that have been loaded using the
C<load_facet()> method. This will not return any classes that have not been
loaded, or have been loaded directly without a call to C<load_facet()>.

B<Note:> The core facet types are automatically loaded and populated in this
list.

=back

=head2 NEW API

=over 4

=item $hashref = $e->common_facet_data();

This can be used by subclasses to generate a starting facet data hashref. This
will populate the hashref with the trace, meta, amnesty, and about facets.
These facets are nearly always produced the same way for all events.

=item $hashref = $e->facet_data()

If you do not override this then the default implementation will attempt to
generate facets from the legacy API. This generation is limited only to what
the legacy API can provide. It is recommended that you override this method and
write out explicit facet data.

=item $hashref = $e->facets()

This takes the hashref from C<facet_data()> and blesses each facet into the
proper C<Test2::EventFacet::*> subclass. If no class can be found for any given
facet it will be passed along unchanged.

=item @errors = $e->validate_facet_data();

=item @errors = $e->validate_facet_data(%params);

=item @errors = $e->validate_facet_data(\%facets, %params);

=item @errors = Test2::Event->validate_facet_data(%params);

=item @errors = Test2::Event->validate_facet_data(\%facets, %params);

This method will validate facet data and return a list of errors. If no errors
are found this will return an empty list.

This can be called as an object method with no arguments, in which case the
C<facet_data()> method will be called to get the facet data to be validated.

When used as an object method the C<\%facet_data> argument may be omitted.

When used as a class method the C<\%facet_data> argument is required.

Remaining arguments will be slurped into a C<%params> hash.

Currently only 1 parameter is defined:

=over 4

=item require_facet_class => $BOOL

When set to true (default is false) this will reject any facets where a facet
class cannot be found. Normally facets without classes are assumed to be custom
and are ignored.

=back

=back

=head3 WHAT ARE FACETS?

Facets are how events convey their purpose to the Test2 internals and
formatters. An event without facets will have no intentional effect on the
overall test state, and will not be displayed at all by most formatters, except
perhaps to say that an event of an unknown type was seen.

Facets are produced by the C<facet_data()> subroutine, which you should
nearly-always override. C<facet_data()> is expected to return a hashref where
each key is the facet type, and the value is either a hashref with the data for
that facet, or an array of hashrefs. Some facets must be defined as single
hashrefs, some must be defined as an array of hashrefs, No facets allow both.

C<facet_data()> B<MUST NOT> bless the data it returns, the main hashref, and
nested facet hashrefs B<MUST> be bare, though items contained within each
facet may be blessed. The data returned by this method B<should> also be copies
of the internal data in order to prevent accidental state modification.

C<facets()> takes the data from C<facet_data()> and blesses it into the
C<Test2::EventFacet::*> packages. This is rarely used however, the EventFacet
packages are primarily for convenience and documentation. The EventFacet
classes are not used at all internally, instead the raw data is used.

Here is a list of facet types by package. The packages are not used internally,
but are where the documentation for each type is kept.

B<Note:> Every single facet type has the C<'details'> field. This field is
always intended for human consumption, and when provided, should explain the
'why' for the facet. All other fields are facet specific.

=over 4

=item about => {...}

L<Test2::EventFacet::About>

This contains information about the event itself such as the event package
name. The C<details> field for this facet is an overall summary of the event.

=item assert => {...}

L<Test2::EventFacet::Assert>

This facet is used if an assertion was made. The C<details> field of this facet
is the description of the assertion.

=item control => {...}

L<Test2::EventFacet::Control>

This facet is used to tell the L<Test2::Event::Hub> about special actions the
event causes. Things like halting all testing, terminating the current test,
etc. In this facet the C<details> field explains why any special action was
taken.

B<Note:> This is how bail-out is implemented.

=item meta => {...}

L<Test2::EventFacet::Meta>

The meta facet contains all the meta-data attached to the event. In this case
the C<details> field has no special meaning, but may be present if something
sets the 'details' meta-key on the event.

=item parent => {...}

L<Test2::EventFacet::Parent>

This facet contains nested events and similar details for subtests. In this
facet the C<details> field will typically be the name of the subtest.

=item plan => {...}

L<Test2::EventFacet::Plan>

This facet tells the system that a plan has been set. The C<details> field of
this is usually left empty, but when present explains why the plan is what it
is, this is most useful if the plan is to skip-all.

=item trace => {...}

L<Test2::EventFacet::Trace>

This facet contains information related to when and where the event was
generated. This is how the test file and line number of a failure is known.
This facet can also help you to tell if tests are related.

In this facet the C<details> field overrides the "failed at test_file.t line
42." message provided on assertion failure.

=item amnesty => [{...}, ...]

L<Test2::EventFacet::Amnesty>

The amnesty facet is a list instead of a single item, this is important as
amnesty can come from multiple places at once.

For each instance of amnesty the C<details> field explains why amnesty was
granted.

B<Note:> Outside of formatters amnesty only acts to forgive a failing
assertion.

=item errors => [{...}, ...]

L<Test2::EventFacet::Error>

The errors facet is a list instead of a single item, any number of errors can
be listed. In this facet C<details> describes the error, or may contain the raw
error message itself (such as an exception). In perl exception may be blessed
objects, as such the raw data for this facet may contain nested items which are
blessed.

Not all errors are considered fatal, there is a C<fail> field that must be set
for an error to cause the test to fail.

B<Note:> This facet is unique in that the field name is 'errors' while the
package is 'Error'. This is because this is the only facet type that is both a
list, and has a name where the plural is not the same as the singular. This may
cause some confusion, but I feel it will be less confusing than the
alternative.

=item info => [{...}, ...]

L<Test2::EventFacet::Info>

The 'info' facet is a list instead of a single item, any quantity of extra
information can be attached to an event. Some information may be critical
diagnostics, others may be simply commentary in nature, this is determined by
the C<debug> flag.

For this facet the C<details> flag is the info itself. This info may be a
string, or it may be a data structure to display. This is one of the few facet
types that may contain blessed items.

=back

=head2 LEGACY API

=over 4

=item $bool = $e->causes_fail

Returns true if this event should result in a test failure. In general this
should be false.

=item $bool = $e->increments_count

Should be true if this event should result in a test count increment.

=item $e->callback($hub)

If your event needs to have extra effects on the L<Test2::Hub> you can override
this method.

This is called B<BEFORE> your event is passed to the formatter.

=item $num = $e->nested

If this event is nested inside of other events, this should be the depth of
nesting. (This is mainly for subtests)

=item $bool = $e->global

Set this to true if your event is global, that is ALL threads and processes
should see it no matter when or where it is generated. This is not a common
thing to want, it is used by bail-out and skip_all to end testing.

=item $code = $e->terminate

This is called B<AFTER> your event has been passed to the formatter. This
should normally return undef, only change this if your event should cause the
test to exit immediately.

If you want this event to cause the test to exit you should return the exit
code here. Exit code of 0 means exit success, any other integer means exit with
failure.

This is used by L<Test2::Event::Plan> to exit 0 when the plan is
'skip_all'. This is also used by L<Test2::Event:Bail> to force the test
to exit with a failure.

This is called after the event has been sent to the formatter in order to
ensure the event is seen and understood.

=item $msg = $e->summary

This is intended to be a human readable summary of the event. This should
ideally only be one line long, but you can use multiple lines if necessary. This
is intended for human consumption. You do not need to make it easy for machines
to understand.

The default is to simply return the event package name.

=item ($count, $directive, $reason) = $e->sets_plan()

Check if this event sets the testing plan. It will return an empty list if it
does not. If it does set the plan it will return a list of 1 to 3 items in
order: Expected Test Count, Test Directive, Reason for directive.

=item $bool = $e->diagnostics

True if the event contains diagnostics info. This is useful because a
non-verbose harness may choose to hide events that are not in this category.
Some formatters may choose to send these to STDERR instead of STDOUT to ensure
they are seen.

=item $bool = $e->no_display

False by default. This will return true on events that should not be displayed
by formatters.

=item $id = $e->in_subtest

If the event is inside a subtest this should have the subtest ID.

=item $id = $e->subtest_id

If the event is a final subtest event, this should contain the subtest ID.

=back

=head1 THIRD PARTY META-DATA

This object consumes L<Test2::Util::ExternalMeta> which provides a consistent
way for you to attach meta-data to instances of this class. This is useful for
tools, plugins, and other extensions.

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! R�SH�k  �k    perl5/Test2/API/Context.pmnu ��6�$        package Test2::API::Context;
use strict;
use warnings;

our $VERSION = '1.302183';


use Carp qw/confess croak/;
use Scalar::Util qw/weaken blessed/;
use Test2::Util qw/get_tid try pkg_to_file get_tid/;

use Test2::EventFacet::Trace();
use Test2::API();

# Preload some key event types
my %LOADED = (
    map {
        my $pkg  = "Test2::Event::$_";
        my $file = "Test2/Event/$_.pm";
        require $file unless $INC{$file};
        ( $pkg => $pkg, $_ => $pkg )
    } qw/Ok Diag Note Plan Bail Exception Waiting Skip Subtest Pass Fail V2/
);

use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/;
use Test2::Util::HashBase qw{
    stack hub trace _on_release _depth _is_canon _is_spawn _aborted
    errno eval_error child_error thrown
};

# Private, not package vars
# It is safe to cache these.
my $ON_RELEASE = Test2::API::_context_release_callbacks_ref();
my $CONTEXTS   = Test2::API::_contexts_ref();

sub init {
    my $self = shift;

    confess "The 'trace' attribute is required"
        unless $self->{+TRACE};

    confess "The 'hub' attribute is required"
        unless $self->{+HUB};

    $self->{+_DEPTH} = 0 unless defined $self->{+_DEPTH};

    $self->{+ERRNO}       = $! unless exists $self->{+ERRNO};
    $self->{+EVAL_ERROR}  = $@ unless exists $self->{+EVAL_ERROR};
    $self->{+CHILD_ERROR} = $? unless exists $self->{+CHILD_ERROR};
}

sub snapshot { bless {%{$_[0]}, _is_canon => undef, _is_spawn => undef, _aborted => undef}, __PACKAGE__ }

sub restore_error_vars {
    my $self = shift;
    ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR};
}

sub DESTROY {
    return unless $_[0]->{+_IS_CANON} || $_[0]->{+_IS_SPAWN};
    return if $_[0]->{+_ABORTED} && ${$_[0]->{+_ABORTED}};
    my ($self) = @_;

    my $hub = $self->{+HUB};
    my $hid = $hub->{hid};

    # Do not show the warning if it looks like an exception has been thrown, or
    # if the context is not local to this process or thread.
    {
        # Sometimes $@ is uninitialized, not a problem in this case so do not
        # show the warning about using eq.
        no warnings 'uninitialized';
        if($self->{+EVAL_ERROR} eq $@ && $hub->is_local) {
            require Carp;
            my $mess = Carp::longmess("Context destroyed");
            my $frame = $self->{+_IS_SPAWN} || $self->{+TRACE}->frame;
            warn <<"            EOT";
A context appears to have been destroyed without first calling release().
Based on \$@ it does not look like an exception was thrown (this is not always
a reliable test)

This is a problem because the global error variables (\$!, \$@, and \$?) will
not be restored. In addition some release callbacks will not work properly from
inside a DESTROY method.

Here are the context creation details, just in case a tool forgot to call
release():
  File: $frame->[1]
  Line: $frame->[2]
  Tool: $frame->[3]

Here is a trace to the code that caused the context to be destroyed, this could
be an exit(), a goto, or simply the end of a scope:
$mess

Cleaning up the CONTEXT stack...
            EOT
        }
    }

    return if $self->{+_IS_SPAWN};

    # Remove the key itself to avoid a slow memory leak
    delete $CONTEXTS->{$hid};
    $self->{+_IS_CANON} = undef;

    if (my $cbk = $self->{+_ON_RELEASE}) {
        $_->($self) for reverse @$cbk;
    }
    if (my $hcbk = $hub->{_context_release}) {
        $_->($self) for reverse @$hcbk;
    }
    $_->($self) for reverse @$ON_RELEASE;
}

# release exists to implement behaviors like die-on-fail. In die-on-fail you
# want to die after a failure, but only after diagnostics have been reported.
# The ideal time for the die to happen is when the context is released.
# Unfortunately die does not work in a DESTROY block.
sub release {
    my ($self) = @_;

    ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} and return if $self->{+THROWN};

    ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} and return $self->{+_IS_SPAWN} = undef
        if $self->{+_IS_SPAWN};

    croak "release() should not be called on context that is neither canon nor a child"
        unless $self->{+_IS_CANON};

    my $hub = $self->{+HUB};
    my $hid = $hub->{hid};

    croak "context thinks it is canon, but it is not"
        unless $CONTEXTS->{$hid} && $CONTEXTS->{$hid} == $self;

    # Remove the key itself to avoid a slow memory leak
    $self->{+_IS_CANON} = undef;
    delete $CONTEXTS->{$hid};

    if (my $cbk = $self->{+_ON_RELEASE}) {
        $_->($self) for reverse @$cbk;
    }
    if (my $hcbk = $hub->{_context_release}) {
        $_->($self) for reverse @$hcbk;
    }
    $_->($self) for reverse @$ON_RELEASE;

    # Do this last so that nothing else changes them.
    # If one of the hooks dies then these do not get restored, this is
    # intentional
    ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR};

    return;
}

sub do_in_context {
    my $self = shift;
    my ($sub, @args) = @_;

    # We need to update the pid/tid and error vars.
    my $clone = $self->snapshot;
    @$clone{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} = ($!, $@, $?);
    $clone->{+TRACE} = $clone->{+TRACE}->snapshot(pid => $$, tid => get_tid());

    my $hub = $clone->{+HUB};
    my $hid = $hub->hid;

    my $old = $CONTEXTS->{$hid};

    $clone->{+_IS_CANON} = 1;
    $CONTEXTS->{$hid} = $clone;
    weaken($CONTEXTS->{$hid});
    my ($ok, $err) = &try($sub, @args);
    my ($rok, $rerr) = try { $clone->release };
    delete $clone->{+_IS_CANON};

    if ($old) {
        $CONTEXTS->{$hid} = $old;
        weaken($CONTEXTS->{$hid});
    }
    else {
        delete $CONTEXTS->{$hid};
    }

    die $err  unless $ok;
    die $rerr unless $rok;
}

sub done_testing {
    my $self = shift;
    $self->hub->finalize($self->trace, 1);
    return;
}

sub throw {
    my ($self, $msg) = @_;
    $self->{+THROWN} = 1;
    ${$self->{+_ABORTED}}++ if $self->{+_ABORTED};
    $self->release if $self->{+_IS_CANON} || $self->{+_IS_SPAWN};
    $self->trace->throw($msg);
}

sub alert {
    my ($self, $msg) = @_;
    $self->trace->alert($msg);
}

sub send_ev2_and_release {
    my $self = shift;
    my $out  = $self->send_ev2(@_);
    $self->release;
    return $out;
}

sub send_ev2 {
    my $self = shift;

    my $e;
    {
        local $Carp::CarpLevel = $Carp::CarpLevel + 1;
        $e = Test2::Event::V2->new(
            trace => $self->{+TRACE}->snapshot,
            @_,
        );
    }

    if ($self->{+_ABORTED}) {
        my $f = $e->facet_data;
        ${$self->{+_ABORTED}}++ if $f->{control}->{halt} || defined($f->{control}->{terminate}) || defined($e->terminate);
    }
    $self->{+HUB}->send($e);
}

sub build_ev2 {
    my $self = shift;

    local $Carp::CarpLevel = $Carp::CarpLevel + 1;
    Test2::Event::V2->new(
        trace => $self->{+TRACE}->snapshot,
        @_,
    );
}

sub send_event_and_release {
    my $self = shift;
    my $out = $self->send_event(@_);
    $self->release;
    return $out;
}

sub send_event {
    my $self  = shift;
    my $event = shift;
    my %args  = @_;

    my $pkg = $LOADED{$event} || $self->_parse_event($event);

    my $e;
    {
        local $Carp::CarpLevel = $Carp::CarpLevel + 1;
        $e = $pkg->new(
            trace => $self->{+TRACE}->snapshot,
            %args,
        );
    }

    if ($self->{+_ABORTED}) {
        my $f = $e->facet_data;
        ${$self->{+_ABORTED}}++ if $f->{control}->{halt} || defined($f->{control}->{terminate}) || defined($e->terminate);
    }
    $self->{+HUB}->send($e);
}

sub build_event {
    my $self  = shift;
    my $event = shift;
    my %args  = @_;

    my $pkg = $LOADED{$event} || $self->_parse_event($event);

    local $Carp::CarpLevel = $Carp::CarpLevel + 1;
    $pkg->new(
        trace => $self->{+TRACE}->snapshot,
        %args,
    );
}

sub pass {
    my $self = shift;
    my ($name) = @_;

    my $e = bless(
        {
            trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'),
            name  => $name,
        },
        "Test2::Event::Pass"
    );

    $self->{+HUB}->send($e);
    return $e;
}

sub pass_and_release {
    my $self = shift;
    my ($name) = @_;

    my $e = bless(
        {
            trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'),
            name  => $name,
        },
        "Test2::Event::Pass"
    );

    $self->{+HUB}->send($e);
    $self->release;
    return 1;
}

sub fail {
    my $self = shift;
    my ($name, @diag) = @_;

    my $e = bless(
        {
            trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'),
            name  => $name,
        },
        "Test2::Event::Fail"
    );

    for my $msg (@diag) {
        if (ref($msg) eq 'Test2::EventFacet::Info::Table') {
            $e->add_info({tag => 'DIAG', debug => 1, $msg->info_args});
        }
        else {
            $e->add_info({tag => 'DIAG', debug => 1, details => $msg});
        }
    }

    $self->{+HUB}->send($e);
    return $e;
}

sub fail_and_release {
    my $self = shift;
    my ($name, @diag) = @_;

    my $e = bless(
        {
            trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'),
            name  => $name,
        },
        "Test2::Event::Fail"
    );

    for my $msg (@diag) {
        if (ref($msg) eq 'Test2::EventFacet::Info::Table') {
            $e->add_info({tag => 'DIAG', debug => 1, $msg->info_args});
        }
        else {
            $e->add_info({tag => 'DIAG', debug => 1, details => $msg});
        }
    }

    $self->{+HUB}->send($e);
    $self->release;
    return 0;
}

sub ok {
    my $self = shift;
    my ($pass, $name, $on_fail) = @_;

    my $hub = $self->{+HUB};

    my $e = bless {
        trace => bless( {%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'),
        pass  => $pass,
        name  => $name,
    }, 'Test2::Event::Ok';
    $e->init;

    $hub->send($e);
    return $e if $pass;

    $self->failure_diag($e);

    if ($on_fail && @$on_fail) {
        $self->diag($_) for @$on_fail;
    }

    return $e;
}

sub failure_diag {
    my $self = shift;
    my ($e) = @_;

    # Figure out the debug info, this is typically the file name and line
    # number, but can also be a custom message. If no trace object is provided
    # then we have nothing useful to display.
    my $name  = $e->name;
    my $trace = $e->trace;
    my $debug = $trace ? $trace->debug : "[No trace info available]";

    # Create the initial diagnostics. If the test has a name we put the debug
    # info on a second line, this behavior is inherited from Test::Builder.
    my $msg = defined($name)
        ? qq[Failed test '$name'\n$debug.\n]
        : qq[Failed test $debug.\n];

    $self->diag($msg);
}

sub skip {
    my $self = shift;
    my ($name, $reason, @extra) = @_;
    $self->send_event(
        'Skip',
        name => $name,
        reason => $reason,
        pass => 1,
        @extra,
    );
}

sub note {
    my $self = shift;
    my ($message) = @_;
    $self->send_event('Note', message => $message);
}

sub diag {
    my $self = shift;
    my ($message) = @_;
    my $hub = $self->{+HUB};
    $self->send_event(
        'Diag',
        message => $message,
    );
}

sub plan {
    my ($self, $max, $directive, $reason) = @_;
    $self->send_event('Plan', max => $max, directive => $directive, reason => $reason);
}

sub bail {
    my ($self, $reason) = @_;
    $self->send_event('Bail', reason => $reason);
}

sub _parse_event {
    my $self = shift;
    my $event = shift;

    my $pkg;
    if ($event =~ m/^\+(.*)/) {
        $pkg = $1;
    }
    else {
        $pkg = "Test2::Event::$event";
    }

    unless ($LOADED{$pkg}) {
        my $file = pkg_to_file($pkg);
        my ($ok, $err) = try { require $file };
        $self->throw("Could not load event module '$pkg': $err")
            unless $ok;

        $LOADED{$pkg} = $pkg;
    }

    confess "'$pkg' is not a subclass of 'Test2::Event'"
        unless $pkg->isa('Test2::Event');

    $LOADED{$event} = $pkg;

    return $pkg;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::API::Context - Object to represent a testing context.

=head1 DESCRIPTION

The context object is the primary interface for authors of testing tools
written with L<Test2>. The context object represents the context in
which a test takes place (File and Line Number), and provides a quick way to
generate events from that context. The context object also takes care of
sending events to the correct L<Test2::Hub> instance.

=head1 SYNOPSIS

In general you will not be creating contexts directly. To obtain a context you
should always use C<context()> which is exported by the L<Test2::API> module.

    use Test2::API qw/context/;

    sub my_ok {
        my ($bool, $name) = @_;
        my $ctx = context();

        if ($bool) {
            $ctx->pass($name);
        }
        else {
            $ctx->fail($name);
        }

        $ctx->release; # You MUST do this!
        return $bool;
    }

Context objects make it easy to wrap other tools that also use context. Once
you grab a context, any tool you call before releasing your context will
inherit it:

    sub wrapper {
        my ($bool, $name) = @_;
        my $ctx = context();
        $ctx->diag("wrapping my_ok");

        my $out = my_ok($bool, $name);
        $ctx->release; # You MUST do this!
        return $out;
    }

=head1 CRITICAL DETAILS

=over 4

=item you MUST always use the context() sub from Test2::API

Creating your own context via C<< Test2::API::Context->new() >> will almost never
produce a desirable result. Use C<context()> which is exported by L<Test2::API>.

There are a handful of cases where a tool author may want to create a new
context by hand, which is why the C<new> method exists. Unless you really know
what you are doing you should avoid this.

=item You MUST always release the context when done with it

Releasing the context tells the system you are done with it. This gives it a
chance to run any necessary callbacks or cleanup tasks. If you forget to
release the context it will try to detect the problem and warn you about it.

=item You MUST NOT pass context objects around

When you obtain a context object it is made specifically for your tool and any
tools nested within. If you pass a context around you run the risk of polluting
other tools with incorrect context information.

If you are certain that you want a different tool to use the same context you
may pass it a snapshot. C<< $ctx->snapshot >> will give you a shallow clone of
the context that is safe to pass around or store.

=item You MUST NOT store or cache a context for later

As long as a context exists for a given hub, all tools that try to get a
context will get the existing instance. If you try to store the context you
will pollute other tools with incorrect context information.

If you are certain that you want to save the context for later, you can use a
snapshot. C<< $ctx->snapshot >> will give you a shallow clone of the context
that is safe to pass around or store.

C<context()> has some mechanisms to protect you if you do cause a context to
persist beyond the scope in which it was obtained. In practice you should not
rely on these protections, and they are fairly noisy with warnings.

=item You SHOULD obtain your context as soon as possible in a given tool

You never know what tools you call from within your own tool will need a
context. Obtaining the context early ensures that nested tools can find the
context you want them to find.

=back

=head1 METHODS

=over 4

=item $ctx->done_testing;

Note that testing is finished. If no plan has been set this will generate a
Plan event.

=item $clone = $ctx->snapshot()

This will return a shallow clone of the context. The shallow clone is safe to
store for later.

=item $ctx->release()

This will release the context. This runs cleanup tasks, and several important
hooks. It will also restore C<$!>, C<$?>, and C<$@> to what they were when the
context was created.

B<Note:> If a context is acquired more than once an internal refcount is kept.
C<release()> decrements the ref count, none of the other actions of
C<release()> will occur unless the refcount hits 0. This means only the last
call to C<release()> will reset C<$?>, C<$!>, C<$@>,and run the cleanup tasks.

=item $ctx->throw($message)

This will throw an exception reporting to the file and line number of the
context. This will also release the context for you.

=item $ctx->alert($message)

This will issue a warning from the file and line number of the context.

=item $stack = $ctx->stack()

This will return the L<Test2::API::Stack> instance the context used to find
the current hub.

=item $hub = $ctx->hub()

This will return the L<Test2::Hub> instance the context recognizes as the
current one to which all events should be sent.

=item $dbg = $ctx->trace()

This will return the L<Test2::EventFacet::Trace> instance used by the context.

=item $ctx->do_in_context(\&code, @args);

Sometimes you have a context that is not current, and you want things to use it
as the current one. In these cases you can call
C<< $ctx->do_in_context(sub { ... }) >>. The codeblock will be run, and
anything inside of it that looks for a context will find the one on which the
method was called.

This B<DOES NOT> affect context on other hubs, only the hub used by the context
will be affected.

    my $ctx = ...;
    $ctx->do_in_context(sub {
        my $ctx = context(); # returns the $ctx the sub is called on
    });

B<Note:> The context will actually be cloned, the clone will be used instead of
the original. This allows the thread id, process id, and error variables to be correct without
modifying the original context.

=item $ctx->restore_error_vars()

This will set C<$!>, C<$?>, and C<$@> to what they were when the context was
created. There is no localization or anything done here, calling this method
will actually set these vars.

=item $! = $ctx->errno()

The (numeric) value of C<$!> when the context was created.

=item $? = $ctx->child_error()

The value of C<$?> when the context was created.

=item $@ = $ctx->eval_error()

The value of C<$@> when the context was created.

=back

=head2 EVENT PRODUCTION METHODS

B<Which one do I use?>

The C<pass*> and C<fail*> are optimal if they meet your situation, using one of
them will always be the most optimal. That said they are optimal by eliminating
many features.

Method such as C<ok>, and C<note> are shortcuts for generating common 1-task
events based on the old API, however they are forward compatible, and easy to
use. If these meet your needs then go ahead and use them, but please check back
often for alternatives that may be added.

If you want to generate new style events, events that do many things at once,
then you want the C<*ev2*> methods. These let you directly specify which facets
you wish to use.

=over 4

=item $event = $ctx->pass()

=item $event = $ctx->pass($name)

This will send and return an L<Test2::Event::Pass> event. You may optionally
provide a C<$name> for the assertion.

The L<Test2::Event::Pass> is a specially crafted and optimized event, using
this will help the performance of passing tests.

=item $true = $ctx->pass_and_release()

=item $true = $ctx->pass_and_release($name)

This is a combination of C<pass()> and C<release()>. You can use this if you do
not plan to do anything with the context after sending the event. This helps
write more clear and compact code.

    sub shorthand {
        my ($bool, $name) = @_;
        my $ctx = context();
        return $ctx->pass_and_release($name) if $bool;

        ... Handle a failure ...
    }

    sub longform {
        my ($bool, $name) = @_;
        my $ctx = context();

        if ($bool) {
            $ctx->pass($name);
            $ctx->release;
            return 1;
        }

        ... Handle a failure ...
    }

=item my $event = $ctx->fail()

=item my $event = $ctx->fail($name)

=item my $event = $ctx->fail($name, @diagnostics)

This lets you send an L<Test2::Event::Fail> event. You may optionally provide a
C<$name> and C<@diagnostics> messages.

Diagnostics messages can be simple strings, data structures, or instances of
L<Test2::EventFacet::Info::Table> (which are converted inline into the
L<Test2::EventFacet::Info> structure).

=item my $false = $ctx->fail_and_release()

=item my $false = $ctx->fail_and_release($name)

=item my $false = $ctx->fail_and_release($name, @diagnostics)

This is a combination of C<fail()> and C<release()>. This can be used to write
clearer and shorter code.

    sub shorthand {
        my ($bool, $name) = @_;
        my $ctx = context();
        return $ctx->fail_and_release($name) unless $bool;

        ... Handle a success ...
    }

    sub longform {
        my ($bool, $name) = @_;
        my $ctx = context();

        unless ($bool) {
            $ctx->pass($name);
            $ctx->release;
            return 1;
        }

        ... Handle a success ...
    }


=item $event = $ctx->ok($bool, $name)

=item $event = $ctx->ok($bool, $name, \@on_fail)

B<NOTE:> Use of this method is discouraged in favor of C<pass()> and C<fail()>
which produce L<Test2::Event::Pass> and L<Test2::Event::Fail> events. These
newer event types are faster and less crufty.

This will create an L<Test2::Event::Ok> object for you. If C<$bool> is false
then an L<Test2::Event::Diag> event will be sent as well with details about the
failure. If you do not want automatic diagnostics you should use the
C<send_event()> method directly.

The third argument C<\@on_fail>) is an optional set of diagnostics to be sent in
the event of a test failure. Unlike with C<fail()> these diagnostics must be
plain strings, data structures are not supported.

=item $event = $ctx->note($message)

Send an L<Test2::Event::Note>. This event prints a message to STDOUT.

=item $event = $ctx->diag($message)

Send an L<Test2::Event::Diag>. This event prints a message to STDERR.

=item $event = $ctx->plan($max)

=item $event = $ctx->plan(0, 'SKIP', $reason)

This can be used to send an L<Test2::Event::Plan> event. This event
usually takes either a number of tests you expect to run. Optionally you can
set the expected count to 0 and give the 'SKIP' directive with a reason to
cause all tests to be skipped.

=item $event = $ctx->skip($name, $reason);

Send an L<Test2::Event::Skip> event.

=item $event = $ctx->bail($reason)

This sends an L<Test2::Event::Bail> event. This event will completely
terminate all testing.

=item $event = $ctx->send_ev2(%facets)

This lets you build and send a V2 event directly from facets. The event is
returned after it is sent.

This example sends a single assertion, a note (comment for stdout in
Test::Builder talk) and sets the plan to 1.

    my $event = $ctx->send_event(
        plan   => {count => 1},
        assert => {pass  => 1, details => "A passing assert"},
        info => [{tag => 'NOTE', details => "This is a note"}],
    );

=item $event = $ctx->build_e2(%facets)

This is the same as C<send_ev2()>, except it builds and returns the event
without sending it.

=item $event = $ctx->send_ev2_and_release($Type, %parameters)

This is a combination of C<send_ev2()> and C<release()>.

    sub shorthand {
        my $ctx = context();
        return $ctx->send_ev2_and_release(assert => {pass => 1, details => 'foo'});
    }

    sub longform {
        my $ctx = context();
        my $event = $ctx->send_ev2(assert => {pass => 1, details => 'foo'});
        $ctx->release;
        return $event;
    }

=item $event = $ctx->send_event($Type, %parameters)

B<It is better to use send_ev2() in new code.>

This lets you build and send an event of any type. The C<$Type> argument should
be the event package name with C<Test2::Event::> left off, or a fully
qualified package name prefixed with a '+'. The event is returned after it is
sent.

    my $event = $ctx->send_event('Ok', ...);

or

    my $event = $ctx->send_event('+Test2::Event::Ok', ...);

=item $event = $ctx->build_event($Type, %parameters)

B<It is better to use build_ev2() in new code.>

This is the same as C<send_event()>, except it builds and returns the event
without sending it.

=item $event = $ctx->send_event_and_release($Type, %parameters)

B<It is better to use send_ev2_and_release() in new code.>

This is a combination of C<send_event()> and C<release()>.

    sub shorthand {
        my $ctx = context();
        return $ctx->send_event_and_release(Pass => { name => 'foo' });
    }

    sub longform {
        my $ctx = context();
        my $event = $ctx->send_event(Pass => { name => 'foo' });
        $ctx->release;
        return $event;
    }

=back

=head1 HOOKS

There are 2 types of hooks, init hooks, and release hooks. As the names
suggest, these hooks are triggered when contexts are created or released.

=head2 INIT HOOKS

These are called whenever a context is initialized. That means when a new
instance is created. These hooks are B<NOT> called every time something
requests a context, just when a new one is created.

=head3 GLOBAL

This is how you add a global init callback. Global callbacks happen for every
context for any hub or stack.

    Test2::API::test2_add_callback_context_init(sub {
        my $ctx = shift;
        ...
    });

=head3 PER HUB

This is how you add an init callback for all contexts created for a given hub.
These callbacks will not run for other hubs.

    $hub->add_context_init(sub {
        my $ctx = shift;
        ...
    });

=head3 PER CONTEXT

This is how you specify an init hook that will only run if your call to
C<context()> generates a new context. The callback will be ignored if
C<context()> is returning an existing context.

    my $ctx = context(on_init => sub {
        my $ctx = shift;
        ...
    });

=head2 RELEASE HOOKS

These are called whenever a context is released. That means when the last
reference to the instance is about to be destroyed. These hooks are B<NOT>
called every time C<< $ctx->release >> is called.

=head3 GLOBAL

This is how you add a global release callback. Global callbacks happen for every
context for any hub or stack.

    Test2::API::test2_add_callback_context_release(sub {
        my $ctx = shift;
        ...
    });

=head3 PER HUB

This is how you add a release callback for all contexts created for a given
hub. These callbacks will not run for other hubs.

    $hub->add_context_release(sub {
        my $ctx = shift;
        ...
    });

=head3 PER CONTEXT

This is how you add release callbacks directly to a context. The callback will
B<ALWAYS> be added to the context that gets returned, it does not matter if a
new one is generated, or if an existing one is returned.

    my $ctx = context(on_release => sub {
        my $ctx = shift;
        ...
    });

=head1 THIRD PARTY META-DATA

This object consumes L<Test2::Util::ExternalMeta> which provides a consistent
way for you to attach meta-data to instances of this class. This is useful for
tools, plugins, and other extensions.

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=item Kent Fredric E<lt>kentnl@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! u��S�S  �S    perl5/Test2/API/Instance.pmnu ��6�$        package Test2::API::Instance;
use strict;
use warnings;

our $VERSION = '1.302183';

our @CARP_NOT = qw/Test2::API Test2::API::Instance Test2::IPC::Driver Test2::Formatter/;
use Carp qw/confess carp/;
use Scalar::Util qw/reftype/;

use Test2::Util qw/get_tid USE_THREADS CAN_FORK pkg_to_file try CAN_SIGSYS/;

use Test2::EventFacet::Trace();
use Test2::API::Stack();

use Test2::Util::HashBase qw{
    _pid _tid
    no_wait
    finalized loaded
    ipc stack formatter
    contexts

    add_uuid_via

    -preload

    ipc_disabled
    ipc_polling
    ipc_drivers
    ipc_timeout
    formatters

    exit_callbacks
    post_load_callbacks
    context_acquire_callbacks
    context_init_callbacks
    context_release_callbacks
    pre_subtest_callbacks
};

sub DEFAULT_IPC_TIMEOUT() { 30 }

sub pid { $_[0]->{+_PID} }
sub tid { $_[0]->{+_TID} }

# Wrap around the getters that should call _finalize.
BEGIN {
    for my $finalizer (IPC, FORMATTER) {
        my $orig = __PACKAGE__->can($finalizer);
        my $new  = sub {
            my $self = shift;
            $self->_finalize unless $self->{+FINALIZED};
            $self->$orig;
        };

        no strict 'refs';
        no warnings 'redefine';
        *{$finalizer} = $new;
    }
}

sub has_ipc { !!$_[0]->{+IPC} }

sub import {
    my $class = shift;
    return unless @_;
    my ($ref) = @_;
    $$ref = $class->new;
}

sub init { $_[0]->reset }

sub start_preload {
    my $self = shift;

    confess "preload cannot be started, Test2::API has already been initialized"
        if $self->{+FINALIZED} || $self->{+LOADED};

    return $self->{+PRELOAD} = 1;
}

sub stop_preload {
    my $self = shift;

    return 0 unless $self->{+PRELOAD};
    $self->{+PRELOAD} = 0;

    $self->post_preload_reset();

    return 1;
}

sub post_preload_reset {
    my $self = shift;

    delete $self->{+_PID};
    delete $self->{+_TID};

    $self->{+ADD_UUID_VIA} = undef unless exists $self->{+ADD_UUID_VIA};

    $self->{+CONTEXTS} = {};

    $self->{+FORMATTERS} = [];

    $self->{+FINALIZED} = undef;
    $self->{+IPC}       = undef;
    $self->{+IPC_DISABLED} = $ENV{T2_NO_IPC} ? 1 : 0;

    $self->{+IPC_TIMEOUT} = DEFAULT_IPC_TIMEOUT() unless defined $self->{+IPC_TIMEOUT};

    $self->{+LOADED} = 0;

    $self->{+STACK} ||= Test2::API::Stack->new;
}

sub reset {
    my $self = shift;

    delete $self->{+_PID};
    delete $self->{+_TID};

    $self->{+ADD_UUID_VIA} = undef;

    $self->{+CONTEXTS} = {};

    $self->{+IPC_DRIVERS} = [];
    $self->{+IPC_POLLING} = undef;

    $self->{+FORMATTERS} = [];
    $self->{+FORMATTER}  = undef;

    $self->{+FINALIZED}    = undef;
    $self->{+IPC}          = undef;
    $self->{+IPC_DISABLED} = $ENV{T2_NO_IPC} ? 1 : 0;

    $self->{+IPC_TIMEOUT} = DEFAULT_IPC_TIMEOUT() unless defined $self->{+IPC_TIMEOUT};

    $self->{+NO_WAIT} = 0;
    $self->{+LOADED}  = 0;

    $self->{+EXIT_CALLBACKS}            = [];
    $self->{+POST_LOAD_CALLBACKS}       = [];
    $self->{+CONTEXT_ACQUIRE_CALLBACKS} = [];
    $self->{+CONTEXT_INIT_CALLBACKS}    = [];
    $self->{+CONTEXT_RELEASE_CALLBACKS} = [];
    $self->{+PRE_SUBTEST_CALLBACKS}     = [];

    $self->{+STACK} = Test2::API::Stack->new;
}

sub _finalize {
    my $self = shift;
    my ($caller) = @_;
    $caller ||= [caller(1)];

    confess "Attempt to initialize Test2::API during preload"
        if $self->{+PRELOAD};

    $self->{+FINALIZED} = $caller;

    $self->{+_PID} = $$        unless defined $self->{+_PID};
    $self->{+_TID} = get_tid() unless defined $self->{+_TID};

    unless ($self->{+FORMATTER}) {
        my ($formatter, $source);
        if ($ENV{T2_FORMATTER}) {
            $source = "set by the 'T2_FORMATTER' environment variable";

            if ($ENV{T2_FORMATTER} =~ m/^(\+)?(.*)$/) {
                $formatter = $1 ? $2 : "Test2::Formatter::$2"
            }
            else {
                $formatter = '';
            }
        }
        elsif (@{$self->{+FORMATTERS}}) {
            ($formatter) = @{$self->{+FORMATTERS}};
            $source = "Most recently added";
        }
        else {
            $formatter = 'Test2::Formatter::TAP';
            $source    = 'default formatter';
        }

        unless (ref($formatter) || $formatter->can('write')) {
            my $file = pkg_to_file($formatter);
            my ($ok, $err) = try { require $file };
            unless ($ok) {
                my $line   = "* COULD NOT LOAD FORMATTER '$formatter' ($source) *";
                my $border = '*' x length($line);
                die "\n\n  $border\n  $line\n  $border\n\n$err";
            }
        }

        $self->{+FORMATTER} = $formatter;
    }

    # Turn on IPC if threads are on, drivers are registered, or the Test2::IPC
    # module is loaded.
    return if $self->{+IPC_DISABLED};
    return unless USE_THREADS || $INC{'Test2/IPC.pm'} || @{$self->{+IPC_DRIVERS}};

    # Turn on polling by default, people expect it.
    $self->enable_ipc_polling;

    unless (@{$self->{+IPC_DRIVERS}}) {
        my ($ok, $error) = try { require Test2::IPC::Driver::Files };
        die $error unless $ok;
        push @{$self->{+IPC_DRIVERS}} => 'Test2::IPC::Driver::Files';
    }

    for my $driver (@{$self->{+IPC_DRIVERS}}) {
        next unless $driver->can('is_viable') && $driver->is_viable;
        $self->{+IPC} = $driver->new or next;
        return;
    }

    die "IPC has been requested, but no viable drivers were found. Aborting...\n";
}

sub formatter_set { $_[0]->{+FORMATTER} ? 1 : 0 }

sub add_formatter {
    my $self = shift;
    my ($formatter) = @_;
    unshift @{$self->{+FORMATTERS}} => $formatter;

    return unless $self->{+FINALIZED};

    # Why is the @CARP_NOT entry not enough?
    local %Carp::Internal = %Carp::Internal;
    $Carp::Internal{'Test2::Formatter'} = 1;

    carp "Formatter $formatter loaded too late to be used as the global formatter";
}

sub add_context_acquire_callback {
    my $self =  shift;
    my ($code) = @_;

    my $rtype = reftype($code) || "";

    confess "Context-acquire callbacks must be coderefs"
        unless $code && $rtype eq 'CODE';

    push @{$self->{+CONTEXT_ACQUIRE_CALLBACKS}} => $code;
}

sub add_context_init_callback {
    my $self =  shift;
    my ($code) = @_;

    my $rtype = reftype($code) || "";

    confess "Context-init callbacks must be coderefs"
        unless $code && $rtype eq 'CODE';

    push @{$self->{+CONTEXT_INIT_CALLBACKS}} => $code;
}

sub add_context_release_callback {
    my $self =  shift;
    my ($code) = @_;

    my $rtype = reftype($code) || "";

    confess "Context-release callbacks must be coderefs"
        unless $code && $rtype eq 'CODE';

    push @{$self->{+CONTEXT_RELEASE_CALLBACKS}} => $code;
}

sub add_post_load_callback {
    my $self = shift;
    my ($code) = @_;

    my $rtype = reftype($code) || "";

    confess "Post-load callbacks must be coderefs"
        unless $code && $rtype eq 'CODE';

    push @{$self->{+POST_LOAD_CALLBACKS}} => $code;
    $code->() if $self->{+LOADED};
}

sub add_pre_subtest_callback {
    my $self =  shift;
    my ($code) = @_;

    my $rtype = reftype($code) || "";

    confess "Pre-subtest callbacks must be coderefs"
        unless $code && $rtype eq 'CODE';

    push @{$self->{+PRE_SUBTEST_CALLBACKS}} => $code;
}

sub load {
    my $self = shift;
    unless ($self->{+LOADED}) {
        confess "Attempt to initialize Test2::API during preload"
            if $self->{+PRELOAD};

        $self->{+_PID} = $$        unless defined $self->{+_PID};
        $self->{+_TID} = get_tid() unless defined $self->{+_TID};

        # This is for https://github.com/Test-More/test-more/issues/16
        # and https://rt.perl.org/Public/Bug/Display.html?id=127774
        # END blocks run in reverse order. This insures the END block is loaded
        # as late as possible. It will not solve all cases, but it helps.
        eval "END { Test2::API::test2_set_is_end() }; 1" or die $@;

        $self->{+LOADED} = 1;
        $_->() for @{$self->{+POST_LOAD_CALLBACKS}};
    }
    return $self->{+LOADED};
}

sub add_exit_callback {
    my $self = shift;
    my ($code) = @_;
    my $rtype = reftype($code) || "";

    confess "End callbacks must be coderefs"
        unless $code && $rtype eq 'CODE';

    push @{$self->{+EXIT_CALLBACKS}} => $code;
}

sub ipc_disable {
    my $self = shift;

    confess "Attempt to disable IPC after it has been initialized"
        if $self->{+IPC};

    $self->{+IPC_DISABLED} = 1;
}

sub add_ipc_driver {
    my $self = shift;
    my ($driver) = @_;
    unshift @{$self->{+IPC_DRIVERS}} => $driver;

    return unless $self->{+FINALIZED};

    # Why is the @CARP_NOT entry not enough?
    local %Carp::Internal = %Carp::Internal;
    $Carp::Internal{'Test2::IPC::Driver'} = 1;

    carp "IPC driver $driver loaded too late to be used as the global ipc driver";
}

sub enable_ipc_polling {
    my $self = shift;

    $self->{+_PID} = $$        unless defined $self->{+_PID};
    $self->{+_TID} = get_tid() unless defined $self->{+_TID};

    $self->add_context_init_callback(
        # This is called every time a context is created, it needs to be fast.
        # $_[0] is a context object
        sub {
            return unless $self->{+IPC_POLLING};
            return unless $self->{+IPC};
            return unless $self->{+IPC}->pending();
            return $_[0]->{hub}->cull;
        }
    ) unless defined $self->ipc_polling;

    $self->set_ipc_polling(1);
}

sub get_ipc_pending {
    my $self = shift;
    return -1 unless $self->{+IPC};
    $self->{+IPC}->pending();
}

sub _check_pid {
    my $self = shift;
    my ($pid) = @_;
    return kill(0, $pid);
}

sub set_ipc_pending {
    my $self = shift;
    return unless $self->{+IPC};
    my ($val) = @_;

    confess "value is required for set_ipc_pending"
        unless $val;

    $self->{+IPC}->set_pending($val);
}

sub disable_ipc_polling {
    my $self = shift;
    return unless defined $self->{+IPC_POLLING};
    $self->{+IPC_POLLING} = 0;
}

sub _ipc_wait {
    my ($timeout) = @_;
    my $fail = 0;

    $timeout = DEFAULT_IPC_TIMEOUT() unless defined $timeout;

    my $ok = eval {
        if (CAN_FORK) {
            local $SIG{ALRM} = sub { die "Timeout waiting on child processes" };
            alarm $timeout;

            while (1) {
                my $pid = CORE::wait();
                my $err = $?;
                last if $pid == -1;
                next unless $err;
                $fail++;

                my $sig = $err & 127;
                my $exit = $err >> 8;
                warn "Process $pid did not exit cleanly (wstat: $err, exit: $exit, sig: $sig)\n";
            }

            alarm 0;
        }

        if (USE_THREADS) {
            my $start = time;

            while (1) {
                last unless threads->list();
                die "Timeout waiting on child thread" if time - $start >= $timeout;
                sleep 1;
                for my $t (threads->list) {
                    # threads older than 1.34 do not have this :-(
                    next if $t->can('is_joinable') && !$t->is_joinable;
                    $t->join;
                    # In older threads we cannot check if a thread had an error unless
                    # we control it and its return.
                    my $err = $t->can('error') ? $t->error : undef;
                    next unless $err;
                    my $tid = $t->tid();
                    $fail++;
                    chomp($err);
                    warn "Thread $tid did not end cleanly: $err\n";
                }
            }
        }

        1;
    };
    my $error = $@;

    return 0 if $ok && !$fail;
    warn $error unless $ok;
    return 255;
}

sub set_exit {
    my $self = shift;

    return if $self->{+PRELOAD};

    my $exit     = $?;
    my $new_exit = $exit;

    if ($INC{'Test/Builder.pm'} && $Test::Builder::VERSION ne $Test2::API::VERSION) {
        print STDERR <<"        EOT";

********************************************************************************
*                                                                              *
*            Test::Builder -- Test2::API version mismatch detected             *
*                                                                              *
********************************************************************************
   Test2::API Version: $Test2::API::VERSION
Test::Builder Version: $Test::Builder::VERSION

This is not a supported configuration, you will have problems.

        EOT
    }

    for my $ctx (values %{$self->{+CONTEXTS}}) {
        next unless $ctx;

        next if $ctx->_aborted && ${$ctx->_aborted};

        # Only worry about contexts in this PID
        my $trace = $ctx->trace || next;
        next unless $trace->pid && $trace->pid == $$;

        # Do not worry about contexts that have no hub
        my $hub = $ctx->hub  || next;

        # Do not worry if the state came to a sudden end.
        next if $hub->bailed_out;
        next if defined $hub->skip_reason;

        # now we worry
        $trace->alert("context object was never released! This means a testing tool is behaving very badly");

        $exit     = 255;
        $new_exit = 255;
    }

    if (!defined($self->{+_PID}) or !defined($self->{+_TID}) or $self->{+_PID} != $$ or $self->{+_TID} != get_tid()) {
        $? = $exit;
        return;
    }

    my @hubs = $self->{+STACK} ? $self->{+STACK}->all : ();

    if (@hubs and $self->{+IPC} and !$self->{+NO_WAIT}) {
        local $?;
        my %seen;
        for my $hub (reverse @hubs) {
            my $ipc = $hub->ipc or next;
            next if $seen{$ipc}++;
            $ipc->waiting();
        }

        my $ipc_exit = _ipc_wait($self->{+IPC_TIMEOUT});
        $new_exit ||= $ipc_exit;
    }

    # None of this is necessary if we never got a root hub
    if(my $root = shift @hubs) {
        my $trace = Test2::EventFacet::Trace->new(
            frame  => [__PACKAGE__, __FILE__, 0, __PACKAGE__ . '::END'],
            detail => __PACKAGE__ . ' END Block finalization',
        );
        my $ctx = Test2::API::Context->new(
            trace => $trace,
            hub   => $root,
        );

        if (@hubs) {
            $ctx->diag("Test ended with extra hubs on the stack!");
            $new_exit  = 255;
        }

        unless ($root->no_ending) {
            local $?;
            $root->finalize($trace) unless $root->ended;
            $_->($ctx, $exit, \$new_exit) for @{$self->{+EXIT_CALLBACKS}};
            $new_exit ||= $root->failed;
            $new_exit ||= 255 unless $root->is_passing;
        }
    }

    $new_exit = 255 if $new_exit > 255;

    if ($new_exit && eval { require Test2::API::Breakage; 1 }) {
        my @warn = Test2::API::Breakage->report();

        if (@warn) {
            print STDERR "\nYou have loaded versions of test modules known to have problems with Test2.\nThis could explain some test failures.\n";
            print STDERR "$_\n" for @warn;
            print STDERR "\n";
        }
    }

    $? = $new_exit;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::API::Instance - Object used by Test2::API under the hood

=head1 DESCRIPTION

This object encapsulates the global shared state tracked by
L<Test2>. A single global instance of this package is stored (and
obscured) by the L<Test2::API> package.

There is no reason to directly use this package. This package is documented for
completeness. This package can change, or go away completely at any time.
Directly using, or monkeypatching this package is not supported in any way
shape or form.

=head1 SYNOPSIS

    use Test2::API::Instance;

    my $obj = Test2::API::Instance->new;

=over 4

=item $pid = $obj->pid

PID of this instance.

=item $obj->tid

Thread ID of this instance.

=item $obj->reset()

Reset the object to defaults.

=item $obj->load()

Set the internal state to loaded, and run and stored post-load callbacks.

=item $bool = $obj->loaded

Check if the state is set to loaded.

=item $arrayref = $obj->post_load_callbacks

Get the post-load callbacks.

=item $obj->add_post_load_callback(sub { ... })

Add a post-load callback. If C<load()> has already been called then the callback will
be immediately executed. If C<load()> has not been called then the callback will be
stored and executed later when C<load()> is called.

=item $hashref = $obj->contexts()

Get a hashref of all active contexts keyed by hub id.

=item $arrayref = $obj->context_acquire_callbacks

Get all context acquire callbacks.

=item $arrayref = $obj->context_init_callbacks

Get all context init callbacks.

=item $arrayref = $obj->context_release_callbacks

Get all context release callbacks.

=item $arrayref = $obj->pre_subtest_callbacks

Get all pre-subtest callbacks.

=item $obj->add_context_init_callback(sub { ... })

Add a context init callback. Subs are called every time a context is created. Subs
get the newly created context as their only argument.

=item $obj->add_context_release_callback(sub { ... })

Add a context release callback. Subs are called every time a context is released. Subs
get the released context as their only argument. These callbacks should not
call release on the context.

=item $obj->add_pre_subtest_callback(sub { ... })

Add a pre-subtest callback. Subs are called every time a subtest is
going to be run. Subs get the subtest name, coderef, and any
arguments.

=item $obj->set_exit()

This is intended to be called in an C<END { ... }> block. This will look at
test state and set $?. This will also call any end callbacks, and wait on child
processes/threads.

=item $obj->set_ipc_pending($val)

Tell other processes and threads there is a pending event. C<$val> should be a
unique value no other thread/process will generate.

B<Note:> This will also make the current process see a pending event.

=item $pending = $obj->get_ipc_pending()

This returns -1 if it is not possible to know.

This returns 0 if there are no pending events.

This returns 1 if there are pending events.

=item $timeout = $obj->ipc_timeout;

=item $obj->set_ipc_timeout($timeout);

How long to wait for child processes and threads before aborting.

=item $drivers = $obj->ipc_drivers

Get the list of IPC drivers.

=item $obj->add_ipc_driver($DRIVER_CLASS)

Add an IPC driver to the list. The most recently added IPC driver will become
the global one during initialization. If a driver is added after initialization
has occurred a warning will be generated:

    "IPC driver $driver loaded too late to be used as the global ipc driver"

=item $bool = $obj->ipc_polling

Check if polling is enabled.

=item $obj->enable_ipc_polling

Turn on polling. This will cull events from other processes and threads every
time a context is created.

=item $obj->disable_ipc_polling

Turn off IPC polling.

=item $bool = $obj->no_wait

=item $bool = $obj->set_no_wait($bool)

Get/Set no_wait. This option is used to turn off process/thread waiting at exit.

=item $arrayref = $obj->exit_callbacks

Get the exit callbacks.

=item $obj->add_exit_callback(sub { ... })

Add an exit callback. This callback will be called by C<set_exit()>.

=item $bool = $obj->finalized

Check if the object is finalized. Finalization happens when either C<ipc()>,
C<stack()>, or C<format()> are called on the object. Once finalization happens
these fields are considered unchangeable (not enforced here, enforced by
L<Test2>).

=item $ipc = $obj->ipc

Get the one true IPC instance.

=item $obj->ipc_disable

Turn IPC off

=item $bool = $obj->ipc_disabled

Check if IPC is disabled

=item $stack = $obj->stack

Get the one true hub stack.

=item $formatter = $obj->formatter

Get the global formatter. By default this is the C<'Test2::Formatter::TAP'>
package. This could be any package that implements the C<write()> method. This
can also be an instantiated object.

=item $bool = $obj->formatter_set()

Check if a formatter has been set.

=item $obj->add_formatter($class)

=item $obj->add_formatter($obj)

Add a formatter. The most recently added formatter will become the global one
during initialization. If a formatter is added after initialization has occurred
a warning will be generated:

    "Formatter $formatter loaded too late to be used as the global formatter"

=item $obj->set_add_uuid_via(sub { ... })

=item $sub = $obj->add_uuid_via()

This allows you to provide a UUID generator. If provided UUIDs will be attached
to all events, hubs, and contexts. This is useful for storing, tracking, and
linking these objects.

The sub you provide should always return a unique identifier. Most things will
expect a proper UUID string, however nothing in Test2::API enforces this.

The sub will receive exactly 1 argument, the type of thing being tagged
'context', 'hub', or 'event'. In the future additional things may be tagged, in
which case new strings will be passed in. These are purely informative, you can
(and usually should) ignore them.

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! BV3�  �    perl5/Test2/API/Breakage.pmnu ��6�$        package Test2::API::Breakage;
use strict;
use warnings;

our $VERSION = '1.302183';


use Test2::Util qw/pkg_to_file/;

our @EXPORT_OK = qw{
    upgrade_suggested
    upgrade_required
    known_broken
};
BEGIN { require Exporter; our @ISA = qw(Exporter) }

sub upgrade_suggested {
    return (
        'Test::Exception'    => '0.42',
        'Test::FITesque'     => '0.04',
        'Test::Module::Used' => '0.2.5',
        'Test::Moose::More'  => '0.025',
    );
}

sub upgrade_required {
    return (
        'Test::Builder::Clutch'   => '0.07',
        'Test::Dist::VersionSync' => '1.1.4',
        'Test::Modern'            => '0.012',
        'Test::SharedFork'        => '0.34',
        'Test::Alien'             => '0.04',
        'Test::UseAllModules'     => '0.14',
        'Test::More::Prefix'      => '0.005',

        'Test2::Tools::EventDumper' => 0.000007,
        'Test2::Harness'            => 0.000013,

        'Test::DBIx::Class::Schema'    => '1.0.9',
        'Test::Clustericious::Cluster' => '0.30',
    );
}

sub known_broken {
    return (
        'Net::BitTorrent'       => '0.052',
        'Test::Able'            => '0.11',
        'Test::Aggregate'       => '0.373',
        'Test::Flatten'         => '0.11',
        'Test::Group'           => '0.20',
        'Test::ParallelSubtest' => '0.05',
        'Test::Pretty'          => '0.32',
        'Test::Wrapper'         => '0.3.0',

        'Log::Dispatch::Config::TestLog' => '0.02',
    );
}

# Not reportable:
# Device::Chip => 0.07   - Tests will not pass, but not broken if already installed, also no fixed version we can upgrade to.

sub report {
    my $class = shift;
    my ($require) = @_;

    my %suggest  = __PACKAGE__->upgrade_suggested();
    my %required = __PACKAGE__->upgrade_required();
    my %broken   = __PACKAGE__->known_broken();

    my @warn;
    for my $mod (keys %suggest) {
        my $file = pkg_to_file($mod);
        next unless $INC{$file} || ($require && eval { require $file; 1 });
        my $want = $suggest{$mod};
        next if eval { $mod->VERSION($want); 1 };
        my $error = $@;
        chomp $error;
        push @warn => " * Module '$mod' is outdated, we recommed updating above $want. error was: '$error'; INC is $INC{$file}";
    }

    for my $mod (keys %required) {
        my $file = pkg_to_file($mod);
        next unless $INC{$file} || ($require && eval { require $file; 1 });
        my $want = $required{$mod};
        next if eval { $mod->VERSION($want); 1 };
        push @warn => " * Module '$mod' is outdated and known to be broken, please update to $want or higher.";
    }

    for my $mod (keys %broken) {
        my $file = pkg_to_file($mod);
        next unless $INC{$file} || ($require && eval { require $file; 1 });
        my $tested = $broken{$mod};
        push @warn => " * Module '$mod' is known to be broken in version $tested and below, newer versions have not been tested. You have: " . $mod->VERSION;
    }

    return @warn;
}

1;

__END__


=pod

=encoding UTF-8

=head1 NAME

Test2::API::Breakage - What breaks at what version

=head1 DESCRIPTION

This module provides lists of modules that are broken, or have been broken in
the past, when upgrading L<Test::Builder> to use L<Test2>.

=head1 FUNCTIONS

These can be imported, or called as methods on the class.

=over 4

=item %mod_ver = upgrade_suggested()

=item %mod_ver = Test2::API::Breakage->upgrade_suggested()

This returns key/value pairs. The key is the module name, the value is the
version number. If the installed version of the module is at or below the
specified one then an upgrade would be a good idea, but not strictly necessary.

=item %mod_ver = upgrade_required()

=item %mod_ver = Test2::API::Breakage->upgrade_required()

This returns key/value pairs. The key is the module name, the value is the
version number. If the installed version of the module is at or below the
specified one then an upgrade is required for the module to work properly.

=item %mod_ver = known_broken()

=item %mod_ver = Test2::API::Breakage->known_broken()

This returns key/value pairs. The key is the module name, the value is the
version number. If the installed version of the module is at or below the
specified one then the module will not work. A newer version may work, but is
not tested or verified.

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! �U�  �    perl5/Test2/API/Stack.pmnu ��6�$        package Test2::API::Stack;
use strict;
use warnings;

our $VERSION = '1.302183';


use Test2::Hub();

use Carp qw/confess/;

sub new {
    my $class = shift;
    return bless [], $class;
}

sub new_hub {
    my $self = shift;
    my %params = @_;

    my $class = delete $params{class} || 'Test2::Hub';

    my $hub = $class->new(%params);

    if (@$self) {
        $hub->inherit($self->[-1], %params);
    }
    else {
        require Test2::API;
        $hub->format(Test2::API::test2_formatter()->new_root)
            unless $hub->format || exists($params{formatter});

        my $ipc = Test2::API::test2_ipc();
        if ($ipc && !$hub->ipc && !exists($params{ipc})) {
            $hub->set_ipc($ipc);
            $ipc->add_hub($hub->hid);
        }
    }

    push @$self => $hub;

    $hub;
}

sub top {
    my $self = shift;
    return $self->new_hub unless @$self;
    return $self->[-1];
}

sub peek {
    my $self = shift;
    return @$self ? $self->[-1] : undef;
}

sub cull {
    my $self = shift;
    $_->cull for reverse @$self;
}

sub all {
    my $self = shift;
    return @$self;
}

sub root {
    my $self = shift;
    return unless @$self;
    return $self->[0];
}

sub clear {
    my $self = shift;
    @$self = ();
}

# Do these last without keywords in order to prevent them from getting used
# when we want the real push/pop.

{
    no warnings 'once';

    *push = sub {
        my $self = shift;
        my ($hub) = @_;
        $hub->inherit($self->[-1]) if @$self;
        push @$self => $hub;
    };

    *pop = sub {
        my $self = shift;
        my ($hub) = @_;
        confess "No hubs on the stack"
            unless @$self;
        confess "You cannot pop the root hub"
            if 1 == @$self;
        confess "Hub stack mismatch, attempted to pop incorrect hub"
            unless $self->[-1] == $hub;
        pop @$self;
    };
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::API::Stack - Object to manage a stack of L<Test2::Hub>
instances.

=head1 ***INTERNALS NOTE***

B<The internals of this package are subject to change at any time!> The public
methods provided will not change in backwards incompatible ways, but the
underlying implementation details might. B<Do not break encapsulation here!>

=head1 DESCRIPTION

This module is used to represent and manage a stack of L<Test2::Hub>
objects. Hubs are usually in a stack so that you can push a new hub into place
that can intercept and handle events differently than the primary hub.

=head1 SYNOPSIS

    my $stack = Test2::API::Stack->new;
    my $hub = $stack->top;

=head1 METHODS

=over 4

=item $stack = Test2::API::Stack->new()

This will create a new empty stack instance. All arguments are ignored.

=item $hub = $stack->new_hub()

=item $hub = $stack->new_hub(%params)

=item $hub = $stack->new_hub(%params, class => $class)

This will generate a new hub and push it to the top of the stack. Optionally
you can provide arguments that will be passed into the constructor for the
L<Test2::Hub> object.

If you specify the C<< 'class' => $class >> argument, the new hub will be an
instance of the specified class.

Unless your parameters specify C<'formatter'> or C<'ipc'> arguments, the
formatter and IPC instance will be inherited from the current top hub. You can
set the parameters to C<undef> to avoid having a formatter or IPC instance.

If there is no top hub, and you do not ask to leave IPC and formatter undef,
then a new formatter will be created, and the IPC instance from
L<Test2::API> will be used.

=item $hub = $stack->top()

This will return the top hub from the stack. If there is no top hub yet this
will create it.

=item $hub = $stack->peek()

This will return the top hub from the stack. If there is no top hub yet this
will return undef.

=item $stack->cull

This will call C<< $hub->cull >> on all hubs in the stack.

=item @hubs = $stack->all

This will return all the hubs in the stack as a list.

=item $stack->clear

This will completely remove all hubs from the stack. Normally you do not want
to do this, but there are a few valid reasons for it.

=item $stack->push($hub)

This will push the new hub onto the stack.

=item $stack->pop($hub)

This will pop a hub from the stack, if the hub at the top of the stack does not
match the hub you expect (passed in as an argument) it will throw an exception.

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! u�ge�F  �F  "  perl5/Test2/API/InterceptResult.pmnu ��6�$        package Test2::API::InterceptResult;
use strict;
use warnings;

our $VERSION = '1.302183';

use Scalar::Util qw/blessed/;
use Test2::Util  qw/pkg_to_file/;
use Storable     qw/dclone/;
use Carp         qw/croak/;

use Test2::API::InterceptResult::Squasher;
use Test2::API::InterceptResult::Event;
use Test2::API::InterceptResult::Hub;

sub new {
    croak "Called a method that creates a new instance in void context" unless defined wantarray;
    my $class = shift;
    bless([@_], $class);
}

sub new_from_ref {
    croak "Called a method that creates a new instance in void context" unless defined wantarray;
    bless($_[1], $_[0]);
}

sub clone { blessed($_[0])->new(@{dclone($_[0])}) }

sub event_list { @{$_[0]} }

sub _upgrade {
    my $self = shift;
    my ($event, %params) = @_;

    my $blessed = blessed($event);

    my $upgrade_class = $params{upgrade_class} ||= 'Test2::API::InterceptResult::Event';

    return $event if $blessed && $event->isa($upgrade_class) && !$params{_upgrade_clone};

    my $fd = dclone($blessed ? $event->facet_data : $event);

    my $class = $params{result_class} ||= blessed($self);

    if (my $parent = $fd->{parent}) {
        $parent->{children} = $class->new_from_ref($parent->{children} || [])->upgrade(%params);
    }

    my $uc_file = pkg_to_file($upgrade_class);
    require($uc_file) unless $INC{$uc_file};
    return $upgrade_class->new(facet_data => $fd, result_class => $class);
}

sub hub {
    my $self = shift;

    my $hub = Test2::API::InterceptResult::Hub->new();
    $hub->process($_) for @$self;
    $hub->set_ended(1);

    return $hub;
}

sub state {
    my $self = shift;
    my %params = @_;

    my $hub = $self->hub;

    my $out = {
        map {($_ => scalar $hub->$_)} qw/count failed is_passing plan bailed_out skip_reason/
    };

    $out->{bailed_out} = $self->_upgrade($out->{bailed_out}, %params)->bailout_reason || 1
        if $out->{bailed_out};

    $out->{follows_plan} = $hub->check_plan;

    return $out;
}

sub upgrade {
    my $self = shift;
    my %params = @_;

    my @out = map { $self->_upgrade($_, %params, _upgrade_clone => 1) } @$self;

    return blessed($self)->new_from_ref(\@out)
        unless $params{in_place};

    @$self = @out;
    return $self;
}

sub squash_info {
    my $self = shift;
    my %params = @_;

    my @out;

    {
        my $squasher = Test2::API::InterceptResult::Squasher->new(events => \@out);
        # Clone to make sure we do not indirectly modify an existing one if it
        # is already upgraded
        $squasher->process($self->_upgrade($_, %params)->clone) for @$self;
        $squasher->flush_down();
    }

    return blessed($self)->new_from_ref(\@out)
        unless $params{in_place};

    @$self = @out;
    return $self;
}

sub asserts        { shift->grep(has_assert     => @_) }
sub subtests       { shift->grep(has_subtest    => @_) }
sub diags          { shift->grep(has_diags      => @_) }
sub notes          { shift->grep(has_notes      => @_) }
sub errors         { shift->grep(has_errors     => @_) }
sub plans          { shift->grep(has_plan       => @_) }
sub causes_fail    { shift->grep(causes_fail    => @_) }
sub causes_failure { shift->grep(causes_failure => @_) }

sub flatten         { shift->map(flatten        => @_) }
sub briefs          { shift->map(brief          => @_) }
sub summaries       { shift->map(summary        => @_) }
sub subtest_results { shift->map(subtest_result => @_) }
sub diag_messages   { shift->map(diag_messages  => @_) }
sub note_messages   { shift->map(note_messages  => @_) }
sub error_messages  { shift->map(error_messages => @_) }

no warnings 'once';

*map = sub {
    my $self = shift;
    my ($call, %params) = @_;

    my $args = $params{args} ||= [];

    return [map { local $_ = $self->_upgrade($_, %params); $_->$call(@$args) } @$self];
};

*grep = sub {
    my $self = shift;
    my ($call, %params) = @_;

    my $args = $params{args} ||= [];

    my @out = grep { local $_ = $self->_upgrade($_, %params); $_->$call(@$args) } @$self;

    return blessed($self)->new_from_ref(\@out)
        unless $params{in_place};

    @$self = @out;
    return $self;
};

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::API::InterceptResult - Representation of a list of events.

=head1 DESCRIPTION

This class represents a list of events, normally obtained using C<intercept()>
from L<Test2::API>.

This class is intended for people who with to verify the results of test tools
they write.

This class provides methods to normalize, summarize, or map the list of events.
The output of these operations makes verifying your testing tools and the
events they generate significantly easier. In most cases this spares you from
needing a deep understanding of the event/facet model.

=head1 SYNOPSIS

Usually you get an instance of this class when you use C<intercept()> from
L<Test2::API>.

    use Test2::V0;
    use Test2::API qw/intercept/;

    my $events = intercept {
        ok(1, "pass");
        ok(0, "fail");
        todo "broken" => sub { ok(0, "fixme") };
        plan 3;
    };

    # This is typically the most useful construct
    # squash_info() merges assertions and diagnostics that are associated
    #   (and returns a new instance with the modifications)
    # flatten() condenses the facet data into the key details for each event
    #   (and returns those structures in an arrayref)
    is(
        $events->squash_info->flatten(),
        [
            {
                causes_failure => 0,

                name => 'pass',
                pass => 1,

                trace_file => 'xxx.t',
                trace_line => 5,
            },
            {
                causes_failure => 1,

                name => 'fail',
                pass => 0,

                trace_file => 'xxx.t',
                trace_line => 6,

                # There can be more than one diagnostics message so this is
                # always an array when present.
                diag => ["Failed test 'fail'\nat xxx.t line 6."],
            },
            {
                causes_failure => 0,

                name => 'fixme',
                pass => 0,

                trace_file => 'xxx.t',
                trace_line => 7,

                # There can be more than one diagnostics message or todo
                # reason, so these are always an array when present.
                todo => ['broken'],

                # Diag message was turned into a note since the assertion was
                # TODO
                note => ["Failed test 'fixme'\nat xxx.t line 7."],
            },
            {
                causes_failure => 0,

                plan => 3,

                trace_file => 'xxx.t',
                trace_line => 8,
            },
        ],
        "Flattened events look like we expect"
    );

See L<Test2::API::InterceptResult::Event> for a full description of what
C<flatten()> provides for each event.

=head1 METHODS

Please note that no methods modify the original instance unless asked to do so.

=head2 CONSTRUCTION

=over 4

=item $events = Test2::API::InterceptResult->new(@EVENTS)

=item $events = Test2::API::InterceptResult->new_from_ref(\@EVENTS)

These create a new instance of Test2::API::InterceptResult from the given
events.

In the first form a new blessed arrayref is returned. In the 'new_from_ref'
form the reference you pass in is directly blessed.

Both of these will throw an exception if called in void context. This is mainly
important for the 'filtering' methods listed below which normally return a new
instance, they throw an exception in such cases as it probably means someone
meant to filter the original in place.

=item $clone = $events->clone()

Make a clone of the original events. Note that this is a deep copy, the entire
structure is duplicated. This uses C<dclone> from L<Storable> to achieve the
deep clone.

=back

=head2 NORMALIZATION

=over 4

=item @events = $events->event_list

This returns all the events in list-form.

=item $hub = $events->hub

This returns a new L<Test2::Hub> instance that has processed all the events
contained in the instance. This gives you a simple way to inspect the state
changes your events cause.

=item $state = $events->state

This returns a summary of the state of a hub after processing all the events.

    {
        count        => 2,      # Number of assertions made
        failed       => 1,      # Number of test failures seen
        is_passing   => 0,      # Boolean, true if the test would be passing
                                # after the events are processed.

        plan         => 2,      # Plan, either a number, undef, 'SKIP', or 'NO PLAN'
        follows_plan => 1,      # True if there is a plan and it was followed.
                                # False if the plan and assertions did not
                                # match, undef if no plan was present in the
                                # event list.

        bailed_out   => undef,  # undef unless there was a bail-out in the
                                # events in which case this will be a string
                                # explaining why there was a bailout, if no
                                # reason was given this will simply be set to
                                # true (1).

        skip_reason  => undef,  # If there was a skip_all this will give the
                                # reason.
    }


=item $new = $events->upgrade

=item $events->upgrade(in_place => $BOOL)

B<Note:> This normally returns a new instance, leaving the original unchanged.
If you call it in void context it will throw an exception. If you want to
modify the original you must pass in the C<< in_place => 1 >> option. You may
call this in void context when you ask to modify it in place. The in-place form
returns the instance that was modified so you can chain methods.

This will create a clone of the list where all events have been converted into
L<Test2::API::InterceptResult::Event> instances. This is extremely helpful as
L<Test2::API::InterceptResult::Event> provide a much better interface for
working with events. This allows you to avoid thinking about legacy event
types.

This also means your tests against the list are not fragile if the tool
you are testing randomly changes what type of events it generates (IE Changing
from L<Test2::Event::Ok> to L<Test2::Event::Pass>, both make assertions and
both will normalize to identical (or close enough)
L<Test2::API::InterceptResult::Event> instances.

Really you almost always want this, the only reason it is not done
automatically is to make sure the C<intercept()> tool is backwards compatible.

=item $new = $events->squash_info

=item $events->squash_info(in_place => $BOOL)

B<Note:> This normally returns a new instance, leaving the original unchanged.
If you call it in void context it will throw an exception. If you want to
modify the original you must pass in the C<< in_place => 1 >> option. You may
call this in void context when you ask to modify it in place. The in-place form
returns the instance that was modified so you can chain methods.

B<Note:> All events in the new or modified instance will be converted to
L<Test2::API::InterceptResult::Event> instances. There is no way to avoid this,
the squash operation requires the upgraded event class.

L<Test::More> and many other legacy tools would send notes, diags, and
assertions as seperate events. A subtest in L<Test::More> would send a note
with the subtest name, the subtest assertion, and finally a diagnostics event
if the subtest failed. This method will normalize things by squashing the note
and diag into the same event as the subtest (This is different from putting
them into the subtest, which is not what happens).

=back

=head2 FILTERING

B<Note:> These normally return new instances, leaving the originals unchanged.
If you call them in void context they will throw exceptions. If you want to
modify the originals you must pass in the C<< in_place => 1 >> option. You may
call these in void context when you ask to modify them in place. The in-place
forms return the instance that was modified so you can chain methods.

=head3 %PARAMS

These all accept the same 2 optional parameters:

=over 4

=item in_place => $BOOL

When true the method will modify the instance in place instead of returning a
new instance.

=item args => \@ARGS

If you wish to pass parameters into the event method being used for filtering,
you may do so here.

=back

=head3 METHODS

=over 4

=item $events->grep($CALL, %PARAMS)

This is essentially:

    Test2::API::InterceptResult->new(
        grep { $_->$CALL( @{$PARAMS{args}} ) } $self->event_list,
    );

B<Note:> that $CALL is called on an upgraded version of the event, though
the events returned will be the original ones, not the upgraded ones.

$CALL may be either the name of a method on
L<Test2::API::InterceptResult::Event>, or a coderef.

=item $events->asserts(%PARAMS)

This is essentially:

    $events->grep(has_assert => @{$PARAMS{args}})

It returns a new instance containing only the events that made assertions.

=item $events->subtests(%PARAMS)

This is essentially:

    $events->grep(has_subtest => @{$PARAMS{args}})

It returns a new instance containing only the events that have subtests.

=item $events->diags(%PARAMS)

This is essentially:

    $events->grep(has_diags => @{$PARAMS{args}})

It returns a new instance containing only the events that have diags.

=item $events->notes(%PARAMS)

This is essentially:

    $events->grep(has_notes => @{$PARAMS{args}})

It returns a new instance containing only the events that have notes.

=item $events->errors(%PARAMS)

B<Note:> Errors are NOT failing assertions. Failing assertions are a different
thing.

This is essentially:

    $events->grep(has_errors => @{$PARAMS{args}})

It returns a new instance containing only the events that have errors.

=item $events->plans(%PARAMS)

This is essentially:

    $events->grep(has_plan => @{$PARAMS{args}})

It returns a new instance containing only the events that set the plan.

=item $events->causes_fail(%PARAMS)

=item $events->causes_failure(%PARAMS)

These are essentially:

    $events->grep(causes_fail    => @{$PARAMS{args}})
    $events->grep(causes_failure => @{$PARAMS{args}})

B<Note:> C<causes_fail()> and C<causes_failure()> are both aliases for
eachother in events, so these methods are effectively aliases here as well.

It returns a new instance containing only the events that cause failure.

=back

=head2 MAPPING

These methods B<ALWAYS> return an arrayref.

B<Note:> No methods on L<Test2::API::InterceptResult::Event> alter the event in
any way.

B<Important Notes about Events>:

L<Test2::API::InterceptResult::Event> was tailor-made to be used in
event-lists. Most methods that are not applicable to a given event will return
an empty list, so you normally do not need to worry about unwanted C<undef>
values or exceptions being thrown. Mapping over event methods is an entended
use, so it works well to produce lists.

B<Exceptions to the rule:>

Some methods such as C<causes_fail> always return a boolean true or false for
all events. Any method prefixed with C<the_> conveys the intent that the event
should have exactly 1 of something, so those will throw an exception when that
condition is not true.

=over 4

=item $arrayref = $events->map($CALL, %PARAMS)

This is essentially:

    [ map { $_->$CALL(@{ $PARAMS{args} }) } $events->upgrade->event_list ];

$CALL may be either the name of a method on
L<Test2::API::InterceptResult::Event>, or a coderef.

=item $arrayref = $events->flatten(%PARAMS)

This is essentially:

    [ map { $_->flatten(@{ $PARAMS{args} }) } $events->upgrade->event_list ];

It returns a new list of flattened structures.

See L<Test2::API::InterceptResult::Event> for details on what C<flatten()>
returns.

=item $arrayref = $events->briefs(%PARAMS)

This is essentially:

    [ map { $_->briefs(@{ $PARAMS{args} }) } $events->upgrade->event_list ];

It returns a new list of event briefs.

See L<Test2::API::InterceptResult::Event> for details on what C<brief()>
returns.

=item $arrayref = $events->summaries(%PARAMS)

This is essentially:

    [ map { $_->summaries(@{ $PARAMS{args} }) } $events->upgrade->event_list ];

It returns a new list of event summaries.

See L<Test2::API::InterceptResult::Event> for details on what C<summary()>
returns.

=item $arrayref = $events->subtest_results(%PARAMS)

This is essentially:

    [ map { $_->subtest_result(@{ $PARAMS{args} }) } $events->upgrade->event_list ];

It returns a new list of event summaries.

See L<Test2::API::InterceptResult::Event> for details on what
C<subtest_result()> returns.

=item $arrayref = $events->diag_messages(%PARAMS)

This is essentially:

    [ map { $_->diag_messages(@{ $PARAMS{args} }) } $events->upgrade->event_list ];

It returns a new list of diagnostic messages (strings).

See L<Test2::API::InterceptResult::Event> for details on what
C<diag_messages()> returns.

=item $arrayref = $events->note_messages(%PARAMS)

This is essentially:

    [ map { $_->note_messages(@{ $PARAMS{args} }) } $events->upgrade->event_list ];

It returns a new list of notification messages (strings).

See L<Test2::API::InterceptResult::Event> for details on what
C<note_messages()> returns.

=item $arrayref = $events->error_messages(%PARAMS)

This is essentially:

    [ map { $_->error_messages(@{ $PARAMS{args} }) } $events->upgrade->event_list ];

It returns a new list of error messages (strings).

See L<Test2::API::InterceptResult::Event> for details on what
C<error_messages()> returns.

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! ��:`Z  Z  +  perl5/Test2/API/InterceptResult/Squasher.pmnu ��6�$        package Test2::API::InterceptResult::Squasher;
use strict;
use warnings;

our $VERSION = '1.302183';

use Carp qw/croak/;
use List::Util qw/first/;

use Test2::Util::HashBase qw{
    <events

    +down_sig +down_buffer

    +up_into +up_sig +up_clear
};

sub init {
    my $self = shift;

    croak "'events' is a required attribute"  unless $self->{+EVENTS};
}

sub can_squash {
    my $self = shift;
    my ($event) = @_;

    # No info, no squash
    return unless $event->has_info;

    # Do not merge up if one of these is true
    return if first { $event->$_ } 'causes_fail', 'has_assert', 'has_bailout', 'has_errors', 'has_plan', 'has_subtest';

    # Signature if we can squash
    return $event->trace_signature;
}

sub process {
    my $self = shift;
    my ($event) = @_;

    return if $self->squash_up($event);
    return if $self->squash_down($event);

    $self->flush_down($event);

    push @{$self->{+EVENTS}} => $event;

    return;
}

sub squash_down {
    my $self = shift;
    my ($event) = @_;

    my $sig = $self->can_squash($event)
        or return;

    $self->flush_down()
        if $self->{+DOWN_SIG} && $self->{+DOWN_SIG} ne $sig;

    $self->{+DOWN_SIG} ||= $sig;
    push @{$self->{+DOWN_BUFFER}} => $event;

    return 1;
}

sub flush_down {
    my $self = shift;
    my ($into) = @_;

    my $sig    = delete $self->{+DOWN_SIG};
    my $buffer = delete $self->{+DOWN_BUFFER};

    return unless $buffer && @$buffer;

    my $fsig = $into ? $into->trace_signature : undef;

    if ($fsig && $fsig eq $sig) {
        $self->squash($into, @$buffer);
    }
    else {
        push @{$self->{+EVENTS}} => @$buffer if $buffer;
    }
}

sub clear_up {
    my $self = shift;

    return unless $self->{+UP_CLEAR};

    delete $self->{+UP_INTO};
    delete $self->{+UP_SIG};
    delete $self->{+UP_CLEAR};
}

sub squash_up {
    my $self = shift;
    my ($event) = @_;
    no warnings 'uninitialized';

    $self->clear_up;

    if ($event->has_assert) {
        if(my $sig = $event->trace_signature) {
            $self->{+UP_INTO}  = $event;
            $self->{+UP_SIG}   = $sig;
            $self->{+UP_CLEAR} = 0;
        }
        else {
            $self->{+UP_CLEAR} = 1;
            $self->clear_up;
        }

        return;
    }

    my $into = $self->{+UP_INTO} or return;

    # Next iteration should clear unless something below changes that
    $self->{+UP_CLEAR} = 1;

    # Only merge into matching trace signatres
    my $sig = $self->can_squash($event);
    return unless $sig eq $self->{+UP_SIG};

    # OK Merge! Do not clear merge in case the return event is also a matching sig diag-only
    $self->{+UP_CLEAR} = 0;

    $self->squash($into, $event);

    return 1;
}

sub squash {
    my $self = shift;
    my ($into, @from) = @_;
    push @{$into->facet_data->{info}} => $_->info for @from;
}

sub DESTROY {
    my $self = shift;

    return unless $self->{+EVENTS};
    $self->flush_down();
    return;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::API::InterceptResult::Squasher - Encapsulation of the algorithm that
squashes diags into assertions.

=head1 DESCRIPTION

Internal use only, please ignore.

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! �����  �  &  perl5/Test2/API/InterceptResult/Hub.pmnu ��6�$        package Test2::API::InterceptResult::Hub;
use strict;
use warnings;

our $VERSION = '1.302183';

BEGIN { require Test2::Hub; our @ISA = qw(Test2::Hub) }
use Test2::Util::HashBase;

sub init {
    my $self = shift;
    $self->SUPER::init();
    $self->{+NESTED} = 0;
}

sub inherit {
    my $self = shift;

    $self->{+NESTED} = 0;
}

sub terminate { }

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::API::InterceptResult::Hub - Hub used by InterceptResult.

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! ��o��o  �o  (  perl5/Test2/API/InterceptResult/Event.pmnu ��6�$        package Test2::API::InterceptResult::Event;
use strict;
use warnings;

our $VERSION = '1.302183';

use List::Util   qw/first/;
use Test2::Util  qw/pkg_to_file/;
use Scalar::Util qw/reftype blessed/;

use Storable qw/dclone/;
use Carp     qw/confess croak/;

use Test2::API::InterceptResult::Facet;
use Test2::API::InterceptResult::Hub;

use Test2::Util::HashBase qw{
    +causes_failure
    <facet_data
    <result_class
};

my %FACETS;
BEGIN {
    local $@;
    local *plugins;
    if (eval { require Module::Pluggable; 1 }) {
        Module::Pluggable->import(
            # We will replace the sub later
            require          => 1,
            on_require_error => sub { 1 },
            search_path      => ['Test2::EventFacet'],
            max_depth        => 3,
            min_depth        => 3,
        );

        for my $facet_type (__PACKAGE__->plugins) {
            my ($key, $list);
            eval {
                $key  = $facet_type->facet_key;
                $list = $facet_type->is_list;
            };
            next unless $key && defined($list);

            $FACETS{$key} = {list => $list, class => $facet_type, loaded => 1};
        }
    }

    $FACETS{__GENERIC__} = {class => 'Test2::API::InterceptResult::Facet', loaded => 1};
}

sub facet_map { \%FACETS }

sub facet_info {
    my $facet = pop;

    return $FACETS{$facet} if exists $FACETS{$facet};

    my $mname = ucfirst(lc($facet));
    $mname =~ s/s$//;

    for my $name ($mname, "${mname}s") {
        my $file  = "Test2/EventFacet/$name.pm";
        my $class = "Test2::EventFacet::$name";

        local $@;
        my $ok = eval {
            require $file;

            my $key = $class->facet_key;
            my $list = $class->is_list;

            $FACETS{$key} = {list => $list, class => $class, loaded => 1};
            $FACETS{$facet} = $FACETS{$key} if $facet ne $key;

            1;
        };

        return $FACETS{$facet} if $ok && $FACETS{$facet};
    }

    return $FACETS{$facet} = $FACETS{__GENERIC__};
}

sub init {
    my $self = shift;

    my $rc = $self->{+RESULT_CLASS} ||= 'Test2::API::InterceptResult';
    my $rc_file = pkg_to_file($rc);
    require($rc_file) unless $INC{$rc_file};

    my $fd = $self->{+FACET_DATA} ||= {};

    for my $facet (keys %$fd) {
        my $finfo = $self->facet_info($facet);
        my $is_list = $finfo->{list};
        next unless defined $is_list;

        my $type = reftype($fd->{$facet});

        if ($is_list) {
            confess "Facet '$facet' is a list facet, but got '$type' instead of an arrayref"
                unless $type eq 'ARRAY';

            for my $item (@{$fd->{$facet}}) {
                my $itype = reftype($item);
                next if $itype eq 'HASH';

                confess "Got item type '$itype' in list-facet '$facet', all items must be hashrefs";
            }
        }
        else {
            confess "Facet '$facet' is an only-one facet, but got '$type' instead of a hashref"
                unless $type eq 'HASH';
        }
    }
}

sub clone {
    my $self = shift;
    my $class = blessed($self);

    my %data = %$self;

    $data{+FACET_DATA} = dclone($data{+FACET_DATA});

    return bless(\%data, $class);
}

sub _facet_class {
    my $self = shift;
    my ($name) = @_;

    my $spec  = $self->facet_info($name);
    my $class = $spec->{class};
    unless ($spec->{loaded}) {
        my $file = pkg_to_file($class);
        require $file unless $INC{$file};
        $spec->{loaded} = 1;
    }

    return $class;
}

sub the_facet {
    my $self = shift;
    my ($name) = @_;

    return undef unless defined $self->{+FACET_DATA}->{$name};

    my $data = $self->{+FACET_DATA}->{$name};

    my $type = reftype($data) or confess "Facet '$name' has a value that is not a reference, this should not happen";

    return $self->_facet_class($name)->new(%{dclone($data)})
        if $type eq 'HASH';

    if ($type eq 'ARRAY') {
        return undef unless @$data;
        croak "'the_facet' called for facet '$name', but '$name' has '" . @$data . "' items" if @$data != 1;
        return $self->_facet_class($name)->new(%{dclone($data->[0])});
    }

    die "Invalid facet data type: $type";
}

sub facet {
    my $self = shift;
    my ($name) = @_;

    return () unless exists $self->{+FACET_DATA}->{$name};

    my $data = $self->{+FACET_DATA}->{$name};

    my $type = reftype($data) or confess "Facet '$name' has a value that is not a reference, this should not happen";

    my @out;
    @out = ($data)  if $type eq 'HASH';
    @out = (@$data) if $type eq 'ARRAY';

    my $class = $self->_facet_class($name);

    return map { $class->new(%{dclone($_)}) } @out;
}

sub causes_failure {
    my $self = shift;

    return $self->{+CAUSES_FAILURE}
        if exists $self->{+CAUSES_FAILURE};

    my $hub = Test2::API::InterceptResult::Hub->new();
    $hub->process($self);

    return $self->{+CAUSES_FAILURE} = ($hub->is_passing ? 0 : 1);
}

sub causes_fail { shift->causes_failure }

sub trace         { $_[0]->facet('trace') }
sub the_trace     { $_[0]->the_facet('trace') }
sub frame         { my $t = $_[0]->the_trace or return undef; $t->{frame} || undef }
sub trace_details { my $t = $_[0]->the_trace or return undef; $t->{details} || undef }
sub trace_package { my $f = $_[0]->frame or return undef; $f->[0] || undef }
sub trace_file    { my $f = $_[0]->frame or return undef; $f->[1] || undef }
sub trace_line    { my $f = $_[0]->frame or return undef; $f->[2] || undef }
sub trace_subname { my $f = $_[0]->frame or return undef; $f->[3] || undef }
sub trace_tool    { my $f = $_[0]->frame or return undef; $f->[3] || undef }

sub trace_signature { my $t = $_[0]->the_trace or return undef; Test2::EventFacet::Trace::signature($t) || undef }

sub brief {
    my $self = shift;

    my @try = qw{
        bailout_brief
        error_brief
        assert_brief
        plan_brief
    };

    for my $meth (@try) {
        my $got = $self->$meth or next;
        return $got;
    }

    return;
}

sub flatten {
    my $self = shift;
    my %params = @_;

    my $todo = {%{$self->{+FACET_DATA}}};
    delete $todo->{hubs};
    delete $todo->{meta};
    delete $todo->{trace};

    my $out = $self->summary;
    delete $out->{brief};
    delete $out->{facets};
    delete $out->{trace_tool};
    delete $out->{trace_details} unless defined($out->{trace_details});

    for my $tagged (grep { my $finfo = $self->facet_info($_); $finfo->{list} && $finfo->{class}->can('tag') } keys %FACETS, keys %$todo) {
        my $set = delete $todo->{$tagged} or next;

        my $fd = $self->{+FACET_DATA};
        my $has_assert = $self->has_assert;
        my $has_parent = $self->has_subtest;
        my $has_fatal_error = $self->has_errors && grep { $_->{fail} } $self->errors;

        next if $tagged eq 'amnesty' && !($has_assert || $has_parent || $has_fatal_error);

        for my $item (@$set) {
            push @{$out->{lc($item->{tag})}} => $item->{fail} ? "FATAL: $item->{details}" : $item->{details};
        }
    }

    if (my $assert = delete $todo->{assert}) {
        $out->{pass} = $assert->{pass};
        $out->{name} = $assert->{details};
    }

    if (my $parent = delete $todo->{parent}) {
        delete $out->{subtest}->{bailed_out}  unless defined $out->{subtest}->{bailed_out};
        delete $out->{subtest}->{skip_reason} unless defined $out->{subtest}->{skip_reason};

        if (my $res = $self->subtest_result) {
            my $state = $res->state;
            delete $state->{$_} for grep { !defined($state->{$_}) } keys %$state;
            $out->{subtest} = $state;
            $out->{subevents} = $res->flatten(%params)
                if $params{include_subevents};
        }
    }

    if (my $control = delete $todo->{control}) {
        if ($control->{halt}) {
            $out->{bailed_out} = $control->{details} || 1;
        }
        elsif(defined $control->{details}) {
            $out->{control} = $control->{details};
        }
    }

    if (my $plan = delete $todo->{plan}) {
        $out->{plan} = $self->plan_brief;
        $out->{plan} =~ s/^PLAN\s*//;
    }

    for my $other (keys %$todo) {
        my $data = $todo->{$other} or next;

        if (reftype($data) eq 'ARRAY') {
            if (!$out->{$other} || reftype($out->{$other}) eq 'ARRAY') {
                for my $item (@$data) {
                    push @{$out->{$other}} => $item->{details} if defined $item->{details};
                }
            }
        }
        else {
            $out->{$other} = $data->{details} if defined($data->{details}) && !defined($out->{$other});
        }
    }

    if (my $fields = $params{fields}) {
        $out = { map {exists($out->{$_}) ? ($_ => $out->{$_}) : ()} @$fields };
    }

    if (my $remove = $params{remove}) {
        delete $out->{$_} for @$remove;
    }

    return $out;
}

sub summary {
    my $self = shift;
    my %params = @_;

    my $out = {
        brief => $self->brief || '',

        causes_failure => $self->causes_failure,

        trace_line    => $self->trace_line,
        trace_file    => $self->trace_file,
        trace_tool    => $self->trace_subname,
        trace_details => $self->trace_details,

        facets => [ sort keys(%{$self->{+FACET_DATA}}) ],
    };

    if (my $fields = $params{fields}) {
        $out = { map {exists($out->{$_}) ? ($_ => $out->{$_}) : ()} @$fields };
    }

    if (my $remove = $params{remove}) {
        delete $out->{$_} for @$remove;
    }

    return $out;
}

sub has_assert { $_[0]->{+FACET_DATA}->{assert} ? 1 : 0 }
sub the_assert { $_[0]->the_facet('assert') }
sub assert     { $_[0]->facet('assert') }

sub assert_brief {
    my $self = shift;

    my $fd = $self->{+FACET_DATA};
    my $as = $fd->{assert} or return;
    my $am = $fd->{amnesty};

    my $out = $as->{pass} ? "PASS" : "FAIL";
    $out .= " with amnesty" if $am;
    return $out;
}

sub has_subtest { $_[0]->{+FACET_DATA}->{parent} ? 1 : 0 }
sub the_subtest { $_[0]->the_facet('parent') }
sub subtest     { $_[0]->facet('parent') }

sub subtest_result {
    my $self = shift;

    my $parent = $self->{+FACET_DATA}->{parent} or return;
    my $children = $parent->{children} || [];

    $children = $self->{+RESULT_CLASS}->new(@$children)->upgrade
        unless blessed($children) && $children->isa($self->{+RESULT_CLASS});

    return $children;
}

sub has_bailout { $_[0]->bailout ? 1 : 0 }
sub the_bailout { my ($b) = $_[0]->bailout; $b }

sub bailout {
    my $self = shift;
    my $control = $self->{+FACET_DATA}->{control} or return;
    return $control if $control->{halt};
    return;
}

sub bailout_brief {
    my $self = shift;
    my $bo = $self->bailout or return;

    my $reason = $bo->{details} or return "BAILED OUT";
    return "BAILED OUT: $reason";
}

sub bailout_reason {
    my $self = shift;
    my $bo = $self->bailout or return;
    return $bo->{details} || '';
}

sub has_plan { $_[0]->{+FACET_DATA}->{plan} ? 1 : 0 }
sub the_plan { $_[0]->the_facet('plan') }
sub plan     { $_[0]->facet('plan') }

sub plan_brief {
    my $self = shift;

    my $plan = $self->{+FACET_DATA}->{plan} or return;

    my $base = $self->_plan_brief($plan);

    my $reason = $plan->{details} or return $base;
    return "$base: $reason";
}

sub _plan_brief {
    my $self = shift;
    my ($plan) = @_;

    return 'NO PLAN' if $plan->{none};
    return "SKIP ALL" if $plan->{skip} || !$plan->{count};
    return "PLAN $plan->{count}";
}

sub has_amnesty     { $_[0]->{+FACET_DATA}->{amnesty} ? 1 : 0 }
sub the_amnesty     { $_[0]->the_facet('amnesty') }
sub amnesty         { $_[0]->facet('amnesty') }
sub amnesty_reasons { map { $_->{details} } $_[0]->amnesty }

sub has_todos    { &first(sub { uc($_->{tag}) eq 'TODO' }, $_[0]->amnesty) ? 1 : 0 }
sub todos        {       grep { uc($_->{tag}) eq 'TODO' }  $_[0]->amnesty          }
sub todo_reasons {       map  { $_->{details} || 'TODO' }  $_[0]->todos            }

sub has_skips    { &first(sub { uc($_->{tag}) eq 'SKIP' }, $_[0]->amnesty) ? 1 : 0 }
sub skips        {       grep { uc($_->{tag}) eq 'SKIP' }  $_[0]->amnesty          }
sub skip_reasons {       map  { $_->{details} || 'SKIP' }  $_[0]->skips            }

my %TODO_OR_SKIP = (SKIP => 1, TODO => 1);
sub has_other_amnesty     { &first( sub { !$TODO_OR_SKIP{uc($_->{tag})}            }, $_[0]->amnesty) ? 1 : 0 }
sub other_amnesty         {        grep { !$TODO_OR_SKIP{uc($_->{tag})}            }  $_[0]->amnesty          }
sub other_amnesty_reasons {        map  { $_->{details} ||  $_->{tag} || 'AMNESTY' }  $_[0]->other_amnesty    }

sub has_errors     { $_[0]->{+FACET_DATA}->{errors} ? 1 : 0 }
sub the_errors     { $_[0]->the_facet('errors') }
sub errors         { $_[0]->facet('errors') }
sub error_messages { map { $_->{details} || $_->{tag} || 'ERROR' } $_[0]->errors }

sub error_brief {
    my $self = shift;

    my $errors = $self->{+FACET_DATA}->{errors} or return;

    my $base = @$errors > 1 ? "ERRORS" : "ERROR";

    return $base unless @$errors;

    my ($msg, @extra) = split /[\n\r]+/, $errors->[0]->{details};

    my $out = "$base: $msg";

    $out .= " [...]" if @extra || @$errors > 1;

    return $out;
}

sub has_info      { $_[0]->{+FACET_DATA}->{info} ? 1 : 0 }
sub the_info      { $_[0]->the_facet('info') }
sub info          { $_[0]->facet('info') }
sub info_messages { map { $_->{details} } $_[0]->info }

sub has_diags { &first(sub { uc($_->{tag}) eq 'DIAG' }, $_[0]->info) ? 1 : 0 }
sub diags         {   grep { uc($_->{tag}) eq 'DIAG' }  $_[0]->info          }
sub diag_messages {   map  { $_->{details} || 'DIAG' }  $_[0]->diags         }

sub has_notes { &first(sub { uc($_->{tag}) eq 'NOTE' }, $_[0]->info) ? 1 : 0 }
sub notes         {   grep { uc($_->{tag}) eq 'NOTE' }  $_[0]->info          }
sub note_messages {   map  { $_->{details} || 'NOTE' }  $_[0]->notes         }

my %NOTE_OR_DIAG = (NOTE => 1, DIAG => 1);
sub has_other_info { &first(sub { !$NOTE_OR_DIAG{uc($_->{tag})}         }, $_[0]->info) ? 1 : 0 }
sub other_info          {  grep { !$NOTE_OR_DIAG{uc($_->{tag})}         }  $_[0]->info          }
sub other_info_messages {  map  { $_->{details} ||  $_->{tag} || 'INFO' }  $_[0]->other_info    }

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::API::InterceptResult::Event - Representation of an event for use in
testing other test tools.

=head1 DESCRIPTION

C<intercept { ... }> from L<Test2::API> returns an instance of
L<Test2::API::InterceptResult> which is a blessed arrayref of
L<Test2::API::InterceptResult::Event> objects.

This POD documents the methods of these events, which are mainly provided for
you to use when testing your test tools.

=head1 SYNOPSIS

    use Test2::V0;
    use Test2::API qw/intercept/;

    my $events = intercept {
        ok(1, "A passing assertion");
        plan(1);
    };

    # This will convert all events into instances of
    # Test2::API::InterceptResult::Event. Until we do this they are the
    # original Test::Event::* instances
    $events->upgrade(in_place => 1);

    # Now we can get individual events in this form
    my $assert = $events->[0];
    my $plan   = $events->[1];

    # Or we can operate on all events at once:
    my $flattened = $events->flatten;
    is(
        $flattened,
        [
          {
            causes_failure => 0,

            name => 'A passing assertion',
            pass => 1,

            trace_file => 'xxx.t',
            trace_line => 5,
          },
          {
            causes_failure => 0,

            plan => 1,

            trace_file => 'xxx.t',
            trace_line => 6,
          },
        ],
        "Flattened both events and returned an arrayref of the results
    );

=head1 METHODS

=head2 !!! IMPORTANT NOTES ON DESIGN !!!

Please pay attention to what these return, many return a scalar when
applicable or an empty list when not (as opposed to undef). Many also always
return a list of 0 or more items. Some always return a scalar. Note that none
of the methods care about context, their behavior is consistent regardless of
scalar, list, or void context.

This was done because this class was specifically designed to be used in a list
and generate more lists in bulk operations. Sometimes in a map you want nothing
to show up for the event, and you do not want an undef in its place. In general
single event instances are not going to be used alone, though that is allowed.

As a general rule any method prefixed with C<the_> implies the event should
have exactly 1 of the specified item, and and exception will be thrown if there
are 0, or more than 1 of the item.

=head2 ATTRIBUTES

=over 4

=item $hashref = $event->facet_data

This will return the facet data hashref, which is all Test2 cares about for any
given event.

=item $class = $event->result_class

This is normally L<Test2::API::InterceptResult>. This is set at construction so
that subtest results can be turned into instances of it on demand.

=back

=head2 DUPLICATION

=over 4

=item $copy = $event->clone

Create a deep copy of the event. Modifying either event will not effect the
other.

=back

=head2 CONDENSED MULTI-FACET DATA

=over 4

=item $bool = $event->causes_failure

=item $bool = $event->causes_fail

These are both aliases of the same functionality.

This will always return either a true value, or a false value. This never
returns a list.

This method may be relatively slow (still super fast) because it determines
pass or fail by creating an instance of L<Test2::Hub> and asking it to process
the event, and then asks the hub for its pass/fail state. This is slower than
bulding in logic to do the check, but it is more reliable as it will always
tell you what the hub thinks, so the logic will never be out of date relative
to the Test2 logic that actually cares.

=item STRING_OR_EMPTY_LIST = $event->brief

Not all events have a brief, some events are not rendered by the formatter,
others have no "brief" data worth seeing. When this is the case an empty list
is returned. This is done intentionally so it can be used in a map operation
without having C<undef> being included in the result.

When a brief can be generated it is always a single 1-line string, and is
returned as-is, not in a list.

Possible briefs:

    # From control facets
    "BAILED OUT"
    "BAILED OUT: $why"

    # From error facets
    "ERROR"
    "ERROR: $message"
    "ERROR: $partial_message [...]"
    "ERRORS: $first_error_message [...]"

    # From assert facets
    "PASS"
    "FAIL"
    "PASS with amnesty"
    "FAIL with amnesty"

    # From plan facets
    "PLAN $count"
    "NO PLAN"
    "SKIP ALL"
    "SKIP ALL: $why"

Note that only the first applicable brief is returned. This is essnetially a
poor-mans TAP that only includes facets that could (but not necessarily do)
cause a failure.

=item $hashref = $event->flatten

=item $hashref = $event->flatten(include_subevents => 1)

This ALWAYS returns a hashref. This puts all the most useful data for the most
interesting facets into a single hashref for easy validation.

If there are no meaningful facets this will return an empty hashref.

If given the 'include_subevents' parameter it will also include subtest data:

Here is a list of EVERY possible field. If a field is not applicable it will
not be present.

=over 4

=item always present

        causes_failure => 1,    # Always present

=item Present if the event has a trace facet

        trace_line    => 42,
        trace_file    => 'Foo/Bar.pm',
        trace_details => 'Extra trace details',    # usually not present

=item If an assertion is present

        pass => 0,
        name => "1 + 1 = 2, so math works",

=item If a plan is present:

        plan => $count_or_SKIP_ALL_or_NO_PLAN,

=item If amnesty facets are present

You get an array for each type that is present.

        todo => [    # Yes you could be under multiple todos, this will list them all.
            "I will fix this later",
            "I promise to fix these",
        ],

        skip => ["This will format the main drive, do not run"],

        ... => ["Other amnesty"]

=item If Info (note/diag) facets are present

You get an arrayref for any that are present, the key is not defined if they are not present.

        diag => [
            "Test failed at Foo/Bar.pm line 42",
            "You forgot to tie your boots",
        ],

        note => ["Your boots are red"],

        ...  => ["Other info"],

=item If error facets are present

Always an arrayref

        error => [
            "non fatal error (does not cause test failure, just an FYI",
            "FATAL: This is a fatal error (causes failure)",
        ],

        # Errors can have alternative tags, but in practice are always 'error',
        # listing this for completeness.
        ... => [ ... ]

=item Present if the event is a subtest

        subtest => {
            count      => 2,    # Number of assertions made
            failed     => 1,    # Number of test failures seen
            is_passing => 0,    # Boolean, true if the test would be passing
                                # after the events are processed.

            plan         => 2,  # Plan, either a number, undef, 'SKIP', or 'NO PLAN'
            follows_plan => 1,  # True if there is a plan and it was followed.
                                # False if the plan and assertions did not
                                # match, undef if no plan was present in the
                                # event list.

            bailed_out => "foo",    # if there was a bail-out in the
                                    # events in this will be a string explaining
                                    # why there was a bailout, if no reason was
                                    # given this will simply be set to true (1).

            skip_reason => "foo",   # If there was a skip_all this will give the
                                    # reason.
        },

if C<< (include_subtest => 1) >> was provided as a parameter then the following
will be included. This is the result of turning all subtest child events into
an L<Test2::API::InterceptResult> instance and calling the C<flatten> method on
it.

        subevents => Test2::API::InterceptResult->new(@child_events)->flatten(...),

=item If a bail-out is being requested

If no reason was given this will be set to 1.

        bailed_out => "reason",

=back

=item $hashref = $event->summary()

This returns a limited summary. See C<flatten()>, which is usually a better
option.

    {
        brief => $event->brief || '',

        causes_failure => $event->causes_failure,

        trace_line    => $event->trace_line,
        trace_file    => $event->trace_file,
        trace_tool    => $event->trace_subname,
        trace_details => $event->trace_details,

        facets => [ sort keys(%{$event->{+FACET_DATA}}) ],
    }

=back

=head2 DIRECT ARBITRARY FACET ACCESS

=over 4

=item @list_of_facets = $event->facet($name)

This always returns a list of 0 or more items. This fetches the facet instances
from the event. For facets like 'assert' this will always return 0 or 1
item. For events like 'info' (diags, notes) this will return 0 or more
instances, once for each instance of the facet.

These will be blessed into the proper L<Test2::EventFacet> subclass. If no
subclass can be found it will be blessed as an
L<Test2::API::InterceptResult::Facet> generic facet class.

=item $undef_or_facet = $event->the_facet($name)

If you know you will have exactly 1 instance of a facet you can call this.

If you are correct and there is exactly one instance of the facet it will
always return the hashref.

If there are 0 instances of the facet this will reutrn undef, not an empty
list.

If there are more than 1 instance this will throw an exception because your
assumption was incorrect.

=back

=head2 TRACE FACET

=over 4

=item @list_of_facets = $event->trace

TODO

=item $undef_or_hashref = $event->the_trace

This returns the trace hashref, or undef if it is not present.

=item $undef_or_arrayref = $event->frame

If a trace is present, and has a caller frame, this will be an arrayref:

    [$package, $file, $line, $subname]

If the trace is not present, or has no caller frame this will return undef.

=item $undef_or_string = $event->trace_details

This is usually undef, but occasionally has a string that overrides the
file/line number debugging a trace usually provides on test failure.

=item $undef_or_string = $event->trace_package

Same as C<(caller())[0]>, the first element of the trace frame.

Will be undef if not present.

=item $undef_or_string = $event->trace_file

Same as C<(caller())[1]>, the second element of the trace frame.

Will be undef if not present.

=item $undef_or_integer = $event->trace_line

Same as C<(caller())[2]>, the third element of the trace frame.

Will be undef if not present.

=item $undef_or_string = $event->trace_subname

=item $undef_or_string = $event->trace_tool

Aliases for the same thing

Same as C<(caller($level))[4]>, the fourth element of the trace frame.

Will be undef if not present.

=item $undef_or_string = $event->trace_signature

A string that is a unique signature for the trace. If a single context
generates multiple events they will all have the same signature. This can be
used to tie assertions and diagnostics sent as seperate events together after
the fact.

=back

=head2 ASSERT FACET

=over 4

=item $bool = $event->has_assert

Returns true if the event has an assert facet, false if it does not.

=item $undef_or_hashref = $event->the_assert

Returns the assert facet if present, undef if it is not.

=item @list_of_facets = $event->assert

TODO

=item EMPTY_LIST_OR_STRING = $event->assert_brief

Returns a string giving a brief of the assertion if an assertion is present.
Returns an empty list if no assertion is present.

=back

=head2 SUBTESTS (PARENT FACET)

=over 4

=item $bool = $event->has_subtest

True if a subetest is present in this event.

=item $undef_or_hashref = $event->the_subtest

Get the one subtest if present, otherwise undef.

=item @list_of_facets = $event->subtest

TODO

=item EMPTY_LIST_OR_OBJECT = $event->subtest_result

Returns an empty list if there is no subtest.

Get an instance of L<Test2::API::InterceptResult> representing the subtest.

=back

=head2 CONTROL FACET (BAILOUT, ENCODING)

=over 4

=item $bool = $event->has_bailout

True if there was a bailout

=item $undef_hashref = $event->the_bailout

Return the control facet if it requested a bailout.

=item EMPTY_LIST_OR_HASHREF = $event->bailout

Get a list of 0 or 1 hashrefs. The hashref will be the control facet if a
bail-out was requested.

=item EMPTY_LIST_OR_STRING = $event->bailout_brief

Get the brief of the balout if present.

=item EMPTY_LIST_OR_STRING = $event->bailout_reason

Get the reason for the bailout, an empty string if no reason was provided, or
an empty list if there was no bailout.

=back

=head2 PLAN FACET

TODO

=over 4

=item $bool = $event->has_plan

=item $undef_or_hashref = $event->the_plan

=item @list_if_hashrefs = $event->plan

=item EMPTY_LIST_OR_STRING $event->plan_brief

=back

=head2 AMNESTY FACET (TODO AND SKIP)

TODO

=over 4

=item $event->has_amnesty

=item $event->the_amnesty

=item $event->amnesty

=item $event->amnesty_reasons

=item $event->has_todos

=item $event->todos

=item $event->todo_reasons

=item $event->has_skips

=item $event->skips

=item $event->skip_reasons

=item $event->has_other_amnesty

=item $event->other_amnesty

=item $event->other_amnesty_reasons

=back

=head2 ERROR FACET (CAPTURED EXCEPTIONS)

TODO

=over 4

=item $event->has_errors

=item $event->the_errors

=item $event->errors

=item $event->error_messages

=item $event->error_brief

=back

=head2 INFO FACET (DIAG, NOTE)

TODO

=over 4

=item $event->has_info

=item $event->the_info

=item $event->info

=item $event->info_messages

=item $event->has_diags

=item $event->diags

=item $event->diag_messages

=item $event->has_notes

=item $event->notes

=item $event->note_messages

=item $event->has_other_info

=item $event->other_info

=item $event->other_info_messages

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! &RI|  |  (  perl5/Test2/API/InterceptResult/Facet.pmnu ��6�$        package Test2::API::InterceptResult::Facet;
use strict;
use warnings;

our $VERSION = '1.302183';

BEGIN {
    require Test2::EventFacet;
    our @ISA = ('Test2::EventFacet');
}

our $AUTOLOAD;
sub AUTOLOAD {
    my $self = shift;

    my $name = $AUTOLOAD;
    $name =~ s/^.*:://g;

    return undef unless exists $self->{$name};
    return $self->{$name};
}

sub DESTROY {}

1;
PK       ! �r�f  f    perl5/Test2/IPC.pmnu ��6�$        package Test2::IPC;
use strict;
use warnings;

our $VERSION = '1.302183';


use Test2::API::Instance;
use Test2::Util qw/get_tid/;
use Test2::API qw{
    test2_in_preload
    test2_init_done
    test2_ipc
    test2_has_ipc
    test2_ipc_enable_polling
    test2_pid
    test2_stack
    test2_tid
    context
};

# Make sure stuff is finalized before anyone tried to fork or start a new thread.
{
    # Avoid warnings if things are loaded at run-time
    no warnings 'void';
    INIT {
        use warnings 'void';
        context()->release() unless test2_in_preload();
    }
}

use Carp qw/confess/;

our @EXPORT_OK = qw/cull/;
BEGIN { require Exporter; our @ISA = qw(Exporter) }

sub unimport { Test2::API::test2_ipc_disable() }

sub import {
    goto &Exporter::import if test2_has_ipc || !test2_init_done();

    confess "IPC is disabled" if Test2::API::test2_ipc_disabled();
    confess "Cannot add IPC in a child process (" . test2_pid() . " vs $$)" if test2_pid() != $$;
    confess "Cannot add IPC in a child thread (" . test2_tid() . " vs " . get_tid() . ")"  if test2_tid() != get_tid();

    Test2::API::_set_ipc(_make_ipc());
    apply_ipc(test2_stack());

    goto &Exporter::import;
}

sub _make_ipc {
    # Find a driver
    my ($driver) = Test2::API::test2_ipc_drivers();
    unless ($driver) {
        require Test2::IPC::Driver::Files;
        $driver = 'Test2::IPC::Driver::Files';
    }

    return $driver->new();
}

sub apply_ipc {
    my $stack = shift;

    my ($root) = @$stack;

    return unless $root;

    confess "Cannot add IPC in a child process" if $root->pid != $$;
    confess "Cannot add IPC in a child thread"  if $root->tid != get_tid();

    my $ipc = $root->ipc || test2_ipc() || _make_ipc();

    # Add the IPC to all hubs
    for my $hub (@$stack) {
        my $has = $hub->ipc;
        confess "IPC Mismatch!" if $has && $has != $ipc;
        next if $has;
        $hub->set_ipc($ipc);
        $ipc->add_hub($hub->hid);
    }

    test2_ipc_enable_polling();

    return $ipc;
}

sub cull {
    my $ctx = context();
    $ctx->hub->cull;
    $ctx->release;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::IPC - Turn on IPC for threading or forking support.

=head1 SYNOPSIS

You should C<use Test2::IPC;> as early as possible in your test file. If you
import this module after API initialization it will attempt to retrofit IPC
onto the existing hubs.

=head2 DISABLING IT

You can use C<no Test2::IPC;> to disable IPC for good. You can also use the
T2_NO_IPC env var.

=head1 EXPORTS

All exports are optional.

=over 4

=item cull()

Cull allows you to collect results from other processes or threads on demand.

=back

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.

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

See F<http://dev.perl.org/licenses/>

=cut
PK       ! ��!G�s  �s    perl5/Capture/Tiny.pmnu ��6�$        use 5.006;
use strict;
use warnings;
package Capture::Tiny;
# ABSTRACT: Capture STDOUT and STDERR from Perl, XS or external programs
our $VERSION = '0.48';
use Carp ();
use Exporter ();
use IO::Handle ();
use File::Spec ();
use File::Temp qw/tempfile tmpnam/;
use Scalar::Util qw/reftype blessed/;
# Get PerlIO or fake it
BEGIN {
  local $@;
  eval { require PerlIO; PerlIO->can('get_layers') }
    or *PerlIO::get_layers = sub { return () };
}

#--------------------------------------------------------------------------#
# create API subroutines and export them
# [do STDOUT flag, do STDERR flag, do merge flag, do tee flag]
#--------------------------------------------------------------------------#

my %api = (
  capture         => [1,1,0,0],
  capture_stdout  => [1,0,0,0],
  capture_stderr  => [0,1,0,0],
  capture_merged  => [1,1,1,0],
  tee             => [1,1,0,1],
  tee_stdout      => [1,0,0,1],
  tee_stderr      => [0,1,0,1],
  tee_merged      => [1,1,1,1],
);

for my $sub ( keys %api ) {
  my $args = join q{, }, @{$api{$sub}};
  eval "sub $sub(&;@) {unshift \@_, $args; goto \\&_capture_tee;}"; ## no critic
}

our @ISA = qw/Exporter/;
our @EXPORT_OK = keys %api;
our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK );

#--------------------------------------------------------------------------#
# constants and fixtures
#--------------------------------------------------------------------------#

my $IS_WIN32 = $^O eq 'MSWin32';

##our $DEBUG = $ENV{PERL_CAPTURE_TINY_DEBUG};
##
##my $DEBUGFH;
##open $DEBUGFH, "> DEBUG" if $DEBUG;
##
##*_debug = $DEBUG ? sub(@) { print {$DEBUGFH} @_ } : sub(){0};

our $TIMEOUT = 30;

#--------------------------------------------------------------------------#
# command to tee output -- the argument is a filename that must
# be opened to signal that the process is ready to receive input.
# This is annoying, but seems to be the best that can be done
# as a simple, portable IPC technique
#--------------------------------------------------------------------------#
my @cmd = ($^X, '-C0', '-e', <<'HERE');
use Fcntl;
$SIG{HUP}=sub{exit};
if ( my $fn=shift ) {
    sysopen(my $fh, qq{$fn}, O_WRONLY|O_CREAT|O_EXCL) or die $!;
    print {$fh} $$;
    close $fh;
}
my $buf; while (sysread(STDIN, $buf, 2048)) {
    syswrite(STDOUT, $buf); syswrite(STDERR, $buf);
}
HERE

#--------------------------------------------------------------------------#
# filehandle manipulation
#--------------------------------------------------------------------------#

sub _relayer {
  my ($fh, $apply_layers) = @_;
  # _debug("# requested layers (@{$layers}) for @{[fileno $fh]}\n");

  # eliminate pseudo-layers
  binmode( $fh, ":raw" );
  # strip off real layers until only :unix is left
  while ( 1 < ( my $layers =()= PerlIO::get_layers( $fh, output => 1 ) ) ) {
      binmode( $fh, ":pop" );
  }
  # apply other layers
  my @to_apply = @$apply_layers;
  shift @to_apply; # eliminate initial :unix
  # _debug("# applying layers  (unix @to_apply) to @{[fileno $fh]}\n");
  binmode($fh, ":" . join(":",@to_apply));
}

sub _name {
  my $glob = shift;
  no strict 'refs'; ## no critic
  return *{$glob}{NAME};
}

sub _open {
  open $_[0], $_[1] or Carp::confess "Error from open(" . join(q{, }, @_) . "): $!";
  # _debug( "# open " . join( ", " , map { defined $_ ? _name($_) : 'undef' } @_ ) . " as " . fileno( $_[0] ) . "\n" );
}

sub _close {
  # _debug( "# closing " . ( defined $_[0] ? _name($_[0]) : 'undef' )  . " on " . fileno( $_[0] ) . "\n" );
  close $_[0] or Carp::confess "Error from close(" . join(q{, }, @_) . "): $!";
}

my %dup; # cache this so STDIN stays fd0
my %proxy_count;
sub _proxy_std {
  my %proxies;
  if ( ! defined fileno STDIN ) {
    $proxy_count{stdin}++;
    if (defined $dup{stdin}) {
      _open \*STDIN, "<&=" . fileno($dup{stdin});
      # _debug( "# restored proxy STDIN as " . (defined fileno STDIN ? fileno STDIN : 'undef' ) . "\n" );
    }
    else {
      _open \*STDIN, "<" . File::Spec->devnull;
      # _debug( "# proxied STDIN as " . (defined fileno STDIN ? fileno STDIN : 'undef' ) . "\n" );
      _open $dup{stdin} = IO::Handle->new, "<&=STDIN";
    }
    $proxies{stdin} = \*STDIN;
    binmode(STDIN, ':utf8') if $] >= 5.008; ## no critic
  }
  if ( ! defined fileno STDOUT ) {
    $proxy_count{stdout}++;
    if (defined $dup{stdout}) {
      _open \*STDOUT, ">&=" . fileno($dup{stdout});
      # _debug( "# restored proxy STDOUT as " . (defined fileno STDOUT ? fileno STDOUT : 'undef' ) . "\n" );
    }
    else {
      _open \*STDOUT, ">" . File::Spec->devnull;
       # _debug( "# proxied STDOUT as " . (defined fileno STDOUT ? fileno STDOUT : 'undef' ) . "\n" );
      _open $dup{stdout} = IO::Handle->new, ">&=STDOUT";
    }
    $proxies{stdout} = \*STDOUT;
    binmode(STDOUT, ':utf8') if $] >= 5.008; ## no critic
  }
  if ( ! defined fileno STDERR ) {
    $proxy_count{stderr}++;
    if (defined $dup{stderr}) {
      _open \*STDERR, ">&=" . fileno($dup{stderr});
       # _debug( "# restored proxy STDERR as " . (defined fileno STDERR ? fileno STDERR : 'undef' ) . "\n" );
    }
    else {
      _open \*STDERR, ">" . File::Spec->devnull;
       # _debug( "# proxied STDERR as " . (defined fileno STDERR ? fileno STDERR : 'undef' ) . "\n" );
      _open $dup{stderr} = IO::Handle->new, ">&=STDERR";
    }
    $proxies{stderr} = \*STDERR;
    binmode(STDERR, ':utf8') if $] >= 5.008; ## no critic
  }
  return %proxies;
}

sub _unproxy {
  my (%proxies) = @_;
  # _debug( "# unproxying: " . join(" ", keys %proxies) . "\n" );
  for my $p ( keys %proxies ) {
    $proxy_count{$p}--;
    # _debug( "# unproxied " . uc($p) . " ($proxy_count{$p} left)\n" );
    if ( ! $proxy_count{$p} ) {
      _close $proxies{$p};
      _close $dup{$p} unless $] < 5.008; # 5.6 will have already closed this as dup
      delete $dup{$p};
    }
  }
}

sub _copy_std {
  my %handles;
  for my $h ( qw/stdout stderr stdin/ ) {
    next if $h eq 'stdin' && ! $IS_WIN32; # WIN32 hangs on tee without STDIN copied
    my $redir = $h eq 'stdin' ? "<&" : ">&";
    _open $handles{$h} = IO::Handle->new(), $redir . uc($h); # ">&STDOUT" or "<&STDIN"
  }
  return \%handles;
}

# In some cases we open all (prior to forking) and in others we only open
# the output handles (setting up redirection)
sub _open_std {
  my ($handles) = @_;
  _open \*STDIN, "<&" . fileno $handles->{stdin} if defined $handles->{stdin};
  _open \*STDOUT, ">&" . fileno $handles->{stdout} if defined $handles->{stdout};
  _open \*STDERR, ">&" . fileno $handles->{stderr} if defined $handles->{stderr};
}

#--------------------------------------------------------------------------#
# private subs
#--------------------------------------------------------------------------#

sub _start_tee {
  my ($which, $stash) = @_; # $which is "stdout" or "stderr"
  # setup pipes
  $stash->{$_}{$which} = IO::Handle->new for qw/tee reader/;
  pipe $stash->{reader}{$which}, $stash->{tee}{$which};
  # _debug( "# pipe for $which\: " .  _name($stash->{tee}{$which}) . " " . fileno( $stash->{tee}{$which} ) . " => " . _name($stash->{reader}{$which}) . " " . fileno( $stash->{reader}{$which}) . "\n" );
  select((select($stash->{tee}{$which}), $|=1)[0]); # autoflush
  # setup desired redirection for parent and child
  $stash->{new}{$which} = $stash->{tee}{$which};
  $stash->{child}{$which} = {
    stdin   => $stash->{reader}{$which},
    stdout  => $stash->{old}{$which},
    stderr  => $stash->{capture}{$which},
  };
  # flag file is used to signal the child is ready
  $stash->{flag_files}{$which} = scalar( tmpnam() ) . $$;
  # execute @cmd as a separate process
  if ( $IS_WIN32 ) {
    my $old_eval_err=$@;
    undef $@;

    eval "use Win32API::File qw/GetOsFHandle SetHandleInformation fileLastError HANDLE_FLAG_INHERIT INVALID_HANDLE_VALUE/ ";
    # _debug( "# Win32API::File loaded\n") unless $@;
    my $os_fhandle = GetOsFHandle( $stash->{tee}{$which} );
    # _debug( "# Couldn't get OS handle: " . fileLastError() . "\n") if ! defined $os_fhandle || $os_fhandle == INVALID_HANDLE_VALUE();
    my $result = SetHandleInformation( $os_fhandle, HANDLE_FLAG_INHERIT(), 0);
    # _debug( $result ? "# set no-inherit flag on $which tee\n" : ("# can't disable tee handle flag inherit: " . fileLastError() . "\n"));
    _open_std( $stash->{child}{$which} );
    $stash->{pid}{$which} = system(1, @cmd, $stash->{flag_files}{$which});
    # not restoring std here as it all gets redirected again shortly anyway
    $@=$old_eval_err;
  }
  else { # use fork
    _fork_exec( $which, $stash );
  }
}

sub _fork_exec {
  my ($which, $stash) = @_; # $which is "stdout" or "stderr"
  my $pid = fork;
  if ( not defined $pid ) {
    Carp::confess "Couldn't fork(): $!";
  }
  elsif ($pid == 0) { # child
    # _debug( "# in child process ...\n" );
    untie *STDIN; untie *STDOUT; untie *STDERR;
    _close $stash->{tee}{$which};
    # _debug( "# redirecting handles in child ...\n" );
    _open_std( $stash->{child}{$which} );
    # _debug( "# calling exec on command ...\n" );
    exec @cmd, $stash->{flag_files}{$which};
  }
  $stash->{pid}{$which} = $pid
}

my $have_usleep = eval "use Time::HiRes 'usleep'; 1";
sub _files_exist {
  return 1 if @_ == grep { -f } @_;
  Time::HiRes::usleep(1000) if $have_usleep;
  return 0;
}

sub _wait_for_tees {
  my ($stash) = @_;
  my $start = time;
  my @files = values %{$stash->{flag_files}};
  my $timeout = defined $ENV{PERL_CAPTURE_TINY_TIMEOUT}
              ? $ENV{PERL_CAPTURE_TINY_TIMEOUT} : $TIMEOUT;
  1 until _files_exist(@files) || ($timeout && (time - $start > $timeout));
  Carp::confess "Timed out waiting for subprocesses to start" if ! _files_exist(@files);
  unlink $_ for @files;
}

sub _kill_tees {
  my ($stash) = @_;
  if ( $IS_WIN32 ) {
    # _debug( "# closing handles\n");
    close($_) for values %{ $stash->{tee} };
    # _debug( "# waiting for subprocesses to finish\n");
    my $start = time;
    1 until wait == -1 || (time - $start > 30);
  }
  else {
    _close $_ for values %{ $stash->{tee} };
    waitpid $_, 0 for values %{ $stash->{pid} };
  }
}

sub _slurp {
  my ($name, $stash) = @_;
  my ($fh, $pos) = map { $stash->{$_}{$name} } qw/capture pos/;
  # _debug( "# slurping captured $name from " . fileno($fh) . " at pos $pos with layers: @{[PerlIO::get_layers($fh)]}\n");
  seek( $fh, $pos, 0 ) or die "Couldn't seek on capture handle for $name\n";
  my $text = do { local $/; scalar readline $fh };
  return defined($text) ? $text : "";
}

#--------------------------------------------------------------------------#
# _capture_tee() -- generic main sub for capturing or teeing
#--------------------------------------------------------------------------#

sub _capture_tee {
  # _debug( "# starting _capture_tee with (@_)...\n" );
  my ($do_stdout, $do_stderr, $do_merge, $do_tee, $code, @opts) = @_;
  my %do = ($do_stdout ? (stdout => 1) : (),  $do_stderr ? (stderr => 1) : ());
  Carp::confess("Custom capture options must be given as key/value pairs\n")
    unless @opts % 2 == 0;
  my $stash = { capture => { @opts } };
  for ( keys %{$stash->{capture}} ) {
    my $fh = $stash->{capture}{$_};
    Carp::confess "Custom handle for $_ must be seekable\n"
      unless ref($fh) eq 'GLOB' || (blessed($fh) && $fh->isa("IO::Seekable"));
  }
  # save existing filehandles and setup captures
  local *CT_ORIG_STDIN  = *STDIN ;
  local *CT_ORIG_STDOUT = *STDOUT;
  local *CT_ORIG_STDERR = *STDERR;
  # find initial layers
  my %layers = (
    stdin   => [PerlIO::get_layers(\*STDIN) ],
    stdout  => [PerlIO::get_layers(\*STDOUT, output => 1)],
    stderr  => [PerlIO::get_layers(\*STDERR, output => 1)],
  );
  # _debug( "# existing layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/;
  # get layers from underlying glob of tied filehandles if we can
  # (this only works for things that work like Tie::StdHandle)
  $layers{stdout} = [PerlIO::get_layers(tied *STDOUT)]
    if tied(*STDOUT) && (reftype tied *STDOUT eq 'GLOB');
  $layers{stderr} = [PerlIO::get_layers(tied *STDERR)]
    if tied(*STDERR) && (reftype tied *STDERR eq 'GLOB');
  # _debug( "# tied object corrected layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/;
  # bypass scalar filehandles and tied handles
  # localize scalar STDIN to get a proxy to pick up FD0, then restore later to CT_ORIG_STDIN
  my %localize;
  $localize{stdin}++,  local(*STDIN)
    if grep { $_ eq 'scalar' } @{$layers{stdin}};
  $localize{stdout}++, local(*STDOUT)
    if $do_stdout && grep { $_ eq 'scalar' } @{$layers{stdout}};
  $localize{stderr}++, local(*STDERR)
    if ($do_stderr || $do_merge) && grep { $_ eq 'scalar' } @{$layers{stderr}};
  $localize{stdin}++, local(*STDIN), _open( \*STDIN, "<&=0")
    if tied *STDIN && $] >= 5.008;
  $localize{stdout}++, local(*STDOUT), _open( \*STDOUT, ">&=1")
    if $do_stdout && tied *STDOUT && $] >= 5.008;
  $localize{stderr}++, local(*STDERR), _open( \*STDERR, ">&=2")
    if ($do_stderr || $do_merge) && tied *STDERR && $] >= 5.008;
  # _debug( "# localized $_\n" ) for keys %localize;
  # proxy any closed/localized handles so we don't use fds 0, 1 or 2
  my %proxy_std = _proxy_std();
  # _debug( "# proxy std: @{ [%proxy_std] }\n" );
  # update layers after any proxying
  $layers{stdout} = [PerlIO::get_layers(\*STDOUT, output => 1)] if $proxy_std{stdout};
  $layers{stderr} = [PerlIO::get_layers(\*STDERR, output => 1)] if $proxy_std{stderr};
  # _debug( "# post-proxy layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/;
  # store old handles and setup handles for capture
  $stash->{old} = _copy_std();
  $stash->{new} = { %{$stash->{old}} }; # default to originals
  for ( keys %do ) {
    $stash->{new}{$_} = ($stash->{capture}{$_} ||= File::Temp->new);
    seek( $stash->{capture}{$_}, 0, 2 ) or die "Could not seek on capture handle for $_\n";
    $stash->{pos}{$_} = tell $stash->{capture}{$_};
    # _debug("# will capture $_ on " . fileno($stash->{capture}{$_})."\n" );
    _start_tee( $_ => $stash ) if $do_tee; # tees may change $stash->{new}
  }
  _wait_for_tees( $stash ) if $do_tee;
  # finalize redirection
  $stash->{new}{stderr} = $stash->{new}{stdout} if $do_merge;
  # _debug( "# redirecting in parent ...\n" );
  _open_std( $stash->{new} );
  # execute user provided code
  my ($exit_code, $inner_error, $outer_error, $orig_pid, @result);
  {
    $orig_pid = $$;
    local *STDIN = *CT_ORIG_STDIN if $localize{stdin}; # get original, not proxy STDIN
    # _debug( "# finalizing layers ...\n" );
    _relayer(\*STDOUT, $layers{stdout}) if $do_stdout;
    _relayer(\*STDERR, $layers{stderr}) if $do_stderr;
    # _debug( "# running code $code ...\n" );
    my $old_eval_err=$@;
    undef $@;
    eval { @result = $code->(); $inner_error = $@ };
    $exit_code = $?; # save this for later
    $outer_error = $@; # save this for later
    STDOUT->flush if $do_stdout;
    STDERR->flush if $do_stderr;
    $@ = $old_eval_err;
  }
  # restore prior filehandles and shut down tees
  # _debug( "# restoring filehandles ...\n" );
  _open_std( $stash->{old} );
  _close( $_ ) for values %{$stash->{old}}; # don't leak fds
  # shouldn't need relayering originals, but see rt.perl.org #114404
  _relayer(\*STDOUT, $layers{stdout}) if $do_stdout;
  _relayer(\*STDERR, $layers{stderr}) if $do_stderr;
  _unproxy( %proxy_std );
  # _debug( "# killing tee subprocesses ...\n" ) if $do_tee;
  _kill_tees( $stash ) if $do_tee;
  # return captured output, but shortcut in void context
  # unless we have to echo output to tied/scalar handles;
  my %got;
  if ( $orig_pid == $$ and ( defined wantarray or ($do_tee && keys %localize) ) ) {
    for ( keys %do ) {
      _relayer($stash->{capture}{$_}, $layers{$_});
      $got{$_} = _slurp($_, $stash);
      # _debug("# slurped " . length($got{$_}) . " bytes from $_\n");
    }
    print CT_ORIG_STDOUT $got{stdout}
      if $do_stdout && $do_tee && $localize{stdout};
    print CT_ORIG_STDERR $got{stderr}
      if $do_stderr && $do_tee && $localize{stderr};
  }
  $? = $exit_code;
  $@ = $inner_error if $inner_error;
  die $outer_error if $outer_error;
  # _debug( "# ending _capture_tee with (@_)...\n" );
  return unless defined wantarray;
  my @return;
  push @return, $got{stdout} if $do_stdout;
  push @return, $got{stderr} if $do_stderr && ! $do_merge;
  push @return, @result;
  return wantarray ? @return : $return[0];
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Capture::Tiny - Capture STDOUT and STDERR from Perl, XS or external programs

=head1 VERSION

version 0.48

=head1 SYNOPSIS

  use Capture::Tiny ':all';

  # capture from external command

  ($stdout, $stderr, $exit) = capture {
    system( $cmd, @args );
  };

  # capture from arbitrary code (Perl or external)

  ($stdout, $stderr, @result) = capture {
    # your code here
  };

  # capture partial or merged output

  $stdout = capture_stdout { ... };
  $stderr = capture_stderr { ... };
  $merged = capture_merged { ... };

  # tee output

  ($stdout, $stderr) = tee {
    # your code here
  };

  $stdout = tee_stdout { ... };
  $stderr = tee_stderr { ... };
  $merged = tee_merged { ... };

=head1 DESCRIPTION

Capture::Tiny provides a simple, portable way to capture almost anything sent
to STDOUT or STDERR, regardless of whether it comes from Perl, from XS code or
from an external program.  Optionally, output can be teed so that it is
captured while being passed through to the original filehandles.  Yes, it even
works on Windows (usually).  Stop guessing which of a dozen capturing modules
to use in any particular situation and just use this one.

=head1 USAGE

The following functions are available.  None are exported by default.

=head2 capture

  ($stdout, $stderr, @result) = capture \&code;
  $stdout = capture \&code;

The C<capture> function takes a code reference and returns what is sent to
STDOUT and STDERR as well as any return values from the code reference.  In
scalar context, it returns only STDOUT.  If no output was received for a
filehandle, it returns an empty string for that filehandle.  Regardless of calling
context, all output is captured -- nothing is passed to the existing filehandles.

It is prototyped to take a subroutine reference as an argument. Thus, it
can be called in block form:

  ($stdout, $stderr) = capture {
    # your code here ...
  };

Note that the coderef is evaluated in list context.  If you wish to force
scalar context on the return value, you must use the C<scalar> keyword.

  ($stdout, $stderr, $count) = capture {
    my @list = qw/one two three/;
    return scalar @list; # $count will be 3
  };

Also note that within the coderef, the C<@_> variable will be empty.  So don't
use arguments from a surrounding subroutine without copying them to an array
first:

  sub wont_work {
    my ($stdout, $stderr) = capture { do_stuff( @_ ) };    # WRONG
    ...
  }

  sub will_work {
    my @args = @_;
    my ($stdout, $stderr) = capture { do_stuff( @args ) }; # RIGHT
    ...
  }

Captures are normally done to an anonymous temporary filehandle.  To
capture via a named file (e.g. to externally monitor a long-running capture),
provide custom filehandles as a trailing list of option pairs:

  my $out_fh = IO::File->new("out.txt", "w+");
  my $err_fh = IO::File->new("out.txt", "w+");
  capture { ... } stdout => $out_fh, stderr => $err_fh;

The filehandles must be read/write and seekable.  Modifying the files or
filehandles during a capture operation will give unpredictable results.
Existing IO layers on them may be changed by the capture.

When called in void context, C<capture> saves memory and time by
not reading back from the capture handles.

=head2 capture_stdout

  ($stdout, @result) = capture_stdout \&code;
  $stdout = capture_stdout \&code;

The C<capture_stdout> function works just like C<capture> except only
STDOUT is captured.  STDERR is not captured.

=head2 capture_stderr

  ($stderr, @result) = capture_stderr \&code;
  $stderr = capture_stderr \&code;

The C<capture_stderr> function works just like C<capture> except only
STDERR is captured.  STDOUT is not captured.

=head2 capture_merged

  ($merged, @result) = capture_merged \&code;
  $merged = capture_merged \&code;

The C<capture_merged> function works just like C<capture> except STDOUT and
STDERR are merged. (Technically, STDERR is redirected to the same capturing
handle as STDOUT before executing the function.)

Caution: STDOUT and STDERR output in the merged result are not guaranteed to be
properly ordered due to buffering.

=head2 tee

  ($stdout, $stderr, @result) = tee \&code;
  $stdout = tee \&code;

The C<tee> function works just like C<capture>, except that output is captured
as well as passed on to the original STDOUT and STDERR.

When called in void context, C<tee> saves memory and time by
not reading back from the capture handles, except when the
original STDOUT OR STDERR were tied or opened to a scalar
handle.

=head2 tee_stdout

  ($stdout, @result) = tee_stdout \&code;
  $stdout = tee_stdout \&code;

The C<tee_stdout> function works just like C<tee> except only
STDOUT is teed.  STDERR is not teed (output goes to STDERR as usual).

=head2 tee_stderr

  ($stderr, @result) = tee_stderr \&code;
  $stderr = tee_stderr \&code;

The C<tee_stderr> function works just like C<tee> except only
STDERR is teed.  STDOUT is not teed (output goes to STDOUT as usual).

=head2 tee_merged

  ($merged, @result) = tee_merged \&code;
  $merged = tee_merged \&code;

The C<tee_merged> function works just like C<capture_merged> except that output
is captured as well as passed on to STDOUT.

Caution: STDOUT and STDERR output in the merged result are not guaranteed to be
properly ordered due to buffering.

=head1 LIMITATIONS

=head2 Portability

Portability is a goal, not a guarantee.  C<tee> requires fork, except on
Windows where C<system(1, @cmd)> is used instead.  Not tested on any
particularly esoteric platforms yet.  See the
L<CPAN Testers Matrix|http://matrix.cpantesters.org/?dist=Capture-Tiny>
for test result by platform.

=head2 PerlIO layers

Capture::Tiny does its best to preserve PerlIO layers such as ':utf8' or
':crlf' when capturing (only for Perl 5.8.1+) .  Layers should be applied to
STDOUT or STDERR I<before> the call to C<capture> or C<tee>.  This may not work
for tied filehandles (see below).

=head2 Modifying filehandles before capturing

Generally speaking, you should do little or no manipulation of the standard IO
filehandles prior to using Capture::Tiny.  In particular, closing, reopening,
localizing or tying standard filehandles prior to capture may cause a variety of
unexpected, undesirable and/or unreliable behaviors, as described below.
Capture::Tiny does its best to compensate for these situations, but the
results may not be what you desire.

=head3 Closed filehandles

Capture::Tiny will work even if STDIN, STDOUT or STDERR have been previously
closed.  However, since they will be reopened to capture or tee output, any
code within the captured block that depends on finding them closed will, of
course, not find them to be closed.  If they started closed, Capture::Tiny will
close them again when the capture block finishes.

Note that this reopening will happen even for STDIN or a filehandle not being
captured to ensure that the filehandle used for capture is not opened to file
descriptor 0, as this causes problems on various platforms.

Prior to Perl 5.12, closed STDIN combined with PERL_UNICODE=D leaks filehandles
and also breaks tee() for undiagnosed reasons.  So don't do that.

=head3 Localized filehandles

If code localizes any of Perl's standard filehandles before capturing, the capture
will affect the localized filehandles and not the original ones.  External system
calls are not affected by localizing a filehandle in Perl and will continue
to send output to the original filehandles (which will thus not be captured).

=head3 Scalar filehandles

If STDOUT or STDERR are reopened to scalar filehandles prior to the call to
C<capture> or C<tee>, then Capture::Tiny will override the output filehandle for
the duration of the C<capture> or C<tee> call and then, for C<tee>, send captured
output to the output filehandle after the capture is complete.  (Requires Perl
5.8)

Capture::Tiny attempts to preserve the semantics of STDIN opened to a scalar
reference, but note that external processes will not be able to read from such
a handle.  Capture::Tiny tries to ensure that external processes will read from
the null device instead, but this is not guaranteed.

=head3 Tied output filehandles

If STDOUT or STDERR are tied prior to the call to C<capture> or C<tee>, then
Capture::Tiny will attempt to override the tie for the duration of the
C<capture> or C<tee> call and then send captured output to the tied filehandle after
the capture is complete.  (Requires Perl 5.8)

Capture::Tiny may not succeed resending UTF-8 encoded data to a tied
STDOUT or STDERR filehandle.  Characters may appear as bytes.  If the tied filehandle
is based on L<Tie::StdHandle>, then Capture::Tiny will attempt to determine
appropriate layers like C<:utf8> from the underlying filehandle and do the right
thing.

=head3 Tied input filehandle

Capture::Tiny attempts to preserve the semantics of tied STDIN, but this
requires Perl 5.8 and is not entirely predictable.  External processes
will not be able to read from such a handle.

Unless having STDIN tied is crucial, it may be safest to localize STDIN when
capturing:

  my ($out, $err) = do { local *STDIN; capture { ... } };

=head2 Modifying filehandles during a capture

Attempting to modify STDIN, STDOUT or STDERR I<during> C<capture> or C<tee> is
almost certainly going to cause problems.  Don't do that.

=head3 Forking inside a capture

Forks aren't portable.  The behavior of filehandles during a fork is even
less so.  If Capture::Tiny detects that a fork has occurred within a
capture, it will shortcut in the child process and return empty strings for
captures.  Other problems may occur in the child or parent, as well.
Forking in a capture block is not recommended.

=head3 Using threads

Filehandles are global.  Mixing up I/O and captures in different threads
without coordination is going to cause problems.  Besides, threads are
officially discouraged.

=head3 Dropping privileges during a capture

If you drop privileges during a capture, temporary files created to
facilitate the capture may not be cleaned up afterwards.

=head2 No support for Perl 5.8.0

It's just too buggy when it comes to layers and UTF-8.  Perl 5.8.1 or later
is recommended.

=head2 Limited support for Perl 5.6

Perl 5.6 predates PerlIO.  UTF-8 data may not be captured correctly.

=head1 ENVIRONMENT

=head2 PERL_CAPTURE_TINY_TIMEOUT

Capture::Tiny uses subprocesses internally for C<tee>.  By default,
Capture::Tiny will timeout with an error if such subprocesses are not ready to
receive data within 30 seconds (or whatever is the value of
C<$Capture::Tiny::TIMEOUT>).  An alternate timeout may be specified by setting
the C<PERL_CAPTURE_TINY_TIMEOUT> environment variable.  Setting it to zero will
disable timeouts.  B<NOTE>, this does not timeout the code reference being
captured -- this only prevents Capture::Tiny itself from hanging your process
waiting for its child processes to be ready to proceed.

=head1 SEE ALSO

This module was inspired by L<IO::CaptureOutput>, which provides
similar functionality without the ability to tee output and with more
complicated code and API.  L<IO::CaptureOutput> does not handle layers
or most of the unusual cases described in the L</Limitations> section and
I no longer recommend it.

There are many other CPAN modules that provide some sort of output capture,
albeit with various limitations that make them appropriate only in particular
circumstances.  I'm probably missing some.  The long list is provided to show
why I felt Capture::Tiny was necessary.

=over 4

=item *

L<IO::Capture>

=item *

L<IO::Capture::Extended>

=item *

L<IO::CaptureOutput>

=item *

L<IPC::Capture>

=item *

L<IPC::Cmd>

=item *

L<IPC::Open2>

=item *

L<IPC::Open3>

=item *

L<IPC::Open3::Simple>

=item *

L<IPC::Open3::Utils>

=item *

L<IPC::Run>

=item *

L<IPC::Run::SafeHandles>

=item *

L<IPC::Run::Simple>

=item *

L<IPC::Run3>

=item *

L<IPC::System::Simple>

=item *

L<Tee>

=item *

L<IO::Tee>

=item *

L<File::Tee>

=item *

L<Filter::Handle>

=item *

L<Tie::STDERR>

=item *

L<Tie::STDOUT>

=item *

L<Test::Output>

=back

=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan

=head1 SUPPORT

=head2 Bugs / Feature Requests

Please report any bugs or feature requests through the issue tracker
at L<https://github.com/dagolden/Capture-Tiny/issues>.
You will be notified automatically of any progress on your issue.

=head2 Source Code

This is open source software.  The code repository is available for
public review and contribution under the terms of the license.

L<https://github.com/dagolden/Capture-Tiny>

  git clone https://github.com/dagolden/Capture-Tiny.git

=head1 AUTHOR

David Golden <dagolden@cpan.org>

=head1 CONTRIBUTORS

=for stopwords Dagfinn Ilmari Mannsåker David E. Wheeler fecundf Graham Knop Peter Rabbitson

=over 4

=item *

Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>

=item *

David E. Wheeler <david@justatheory.com>

=item *

fecundf <not.com+github@gmail.com>

=item *

Graham Knop <haarg@haarg.org>

=item *

Peter Rabbitson <ribasushi@cpan.org>

=back

=head1 COPYRIGHT AND LICENSE

This software is Copyright (c) 2009 by David Golden.

This is free software, licensed under:

  The Apache License, Version 2.0, January 2004

=cut
PK       ! uP`y7  y7    perl5/HDB.pmnu ��6�$        #############################################################################
## Name:        HDB.pm
## Purpose:     HDB - Hybrid database
## Author:      Graciliano M. P.
## Modified by:
## Created:     06/01/2003
## RCS-ID:      
## Copyright:   (c) 2003 Graciliano M. P.
## Licence:     This program is free software; you can redistribute it and/or
##              modify it under the same terms as Perl itself
#############################################################################

package HDB ;
use 5.006 ;

use strict qw(vars) ;

use vars qw(@ISA $AUTOLOAD) ;
no warnings ;

our ($VERSION) ;
$VERSION = '1.05' ;

my $REQUIRED ;

###########
# REQUIRE #
###########

sub REQUIRE {
  return if $REQUIRED ;
  require HDB::CORE ;
  require HDB::CMDS ;
  require HDB::Encode ;
  require HDB::MOD ;
  require HDB::Object ;
  $REQUIRED = 1 ;
}

##########
# SCOPES #
##########

  use vars qw($HPL_Run_MAIN $HPL_Run_NOW) ;

  *HPL_Run_MAIN = \$HPL::Run::MAIN ;
  *HPL_Run_NOW = \$HPL::Run::NOW ;

############
# HPL_MAIN #
############

sub HPL_MAIN {
  return $HPL_Run_MAIN if UNIVERSAL::isa($HPL_Run_MAIN,'UNIVERSAL') ;
  return $main::HPL if UNIVERSAL::isa($main::HPL,'UNIVERSAL') ;
  return ${"main::HPL"} ;
}

########
# VARS #
########

  my %args_types = (
  file     =>  [qw(file dbfile databasefile db database)] ,
  db       =>  [qw(db database)] ,
  host     => [[qw(host hostname)],localhost] ,
  user     =>  [qw(user username)] ,
  pass     =>  [qw(pass password)] ,
  type     => [[qw(type dbtype databasetype dbd)],auto] ,
  cache    => [[qw(cache)],1] ,
  id       =>  [qw(id ident)] ,
  warning  => [[qw(warning warnings error errors alert alerts carp)],1] ,
  dynamic  => [[qw(dynamic dyn)],1] ,
  conf_hpl =>  [qw(confhpl hplconf)] ,
  );
  
  my (%PASS , %DB , $WITH_HPL , %MOD_LOADED , $RESET_X) ;
  
##########
# IMPORT #
##########

sub import {
  my $class = shift ;
  if ($_[0] =~ /HPL/i) {
    $WITH_HPL = 1 ;
    &REQUIRE() ;
  }
}

############
# AUTOLOAD #
############

sub AUTOLOAD {

  if ( $#_ == 0 && ref($_[0]) && UNIVERSAL::isa($_[0],'HDB') ) {
    if ( ref($_[0]) eq 'HDB' ) {
      my $this = shift ;
      my $type = $this->{MOD}{type} ;
      bless($this , "HDB::MOD::$type") ;
      $this->connect ;
      my ($method) = ( $AUTOLOAD =~ /(\w+)$/s );
      $this->$method(@_) ;
    }
  
    my ($table) = ( $AUTOLOAD =~ /(\w+)$/s ) ;
    my $TABLE_OBJ = HDB::TABLE->new($_[0] , $table) ;
    return $TABLE_OBJ ;
  }

  if (ref($_[0])) {
    my @caller = caller ;
    &HDB::Error(undef,qq`Can't find $AUTOLOAD at $caller[1] line $caller[2]!`) ;
    return undef ;
  }
  
  my ($id0) = ( $AUTOLOAD =~ /(\w+)$/ ) ;
  my $id = lc($id0) ;
  
  if ( $WITH_HPL && $id ne '' ) {
    my $hpl = &HPL_MAIN() ;
    
    if ( $hpl ) {
      my $hpl_root = $hpl->pack_root ;
      
      if ( $id eq 'hploo' && !${"$hpl_root\::MYHDB::DB"}{$id} ) {
        $id = (sort keys %{"$hpl_root\::MYHDB::DB"})[0] ;
        if ( $id ) {
          $hpl->warn(qq`HDB id HPLOO not defined, using 1st defined DB for HDB::Object persistence.` , 1) ;
          ${"$hpl_root\::MYHDB::DB"}{hploo} = ${"$hpl_root\::MYHDB::DB"}{$id} ;
        }
      }
      
      my $obj = ${"$hpl_root\::MYHDB::DB"}{$id} ;
      if (!$obj) { $hpl->warn(qq`Can't find HDB id "$id" for dynamic access $_[0]\->$id0 !`) ;}
      return $obj ;
    }
  }
  else {
    if (! $DB{$id}) { &HDB::Error(undef,qq`Can't find HDB id "$id" for dynamic access $_[0]\->$id0 !`) ;}
    return $DB{$id} ;
  }
  
  return undef ;
}

###########
# ALIASES #
###########

sub WITH_HPL { $WITH_HPL ;}

sub open {
  if ( ref $_[0] && UNIVERSAL::isa($_[0],'HDB') ) {
    $_[0]->connect ;
    return $_[0] ;
  }
  else { return &new(@_) ;}
}

sub close { $_[0]->disconnect ;}

#######
# NEW #
#######

sub new {
  &REQUIRE() ;
  
  my $class = shift ;
  my $this = {} ;
  
  &HDB::CORE::parse_args($this , \%args_types , @_) ;
  $this->{file} = &HDB::CORE::path($this->{file}) if defined $this->{file} ;
  
  $this->{id} =~ s/\W//s ;
  $this->{id} = lc( $this->{id} ) ;
  
  if ( $this->{type} eq 'auto' ) {
    if ( defined $this->{file} ) { $this->{type} = 'sqlite' ;}
    else { $this->{type} = 'mysql' ;}
  }
  else {
    my $type = $this->{type} ;
    $this->{type} =~ s/\W//gs ;
    $this->{type} = lc( $this->{type} ) ;
  }

  return Error($this,"Invalid type!") if $this->{type} eq '' ;
  
  my $type = $this->{type} ;
  
  if ( !&_require_module($type) ) { return Error($this,"Can't find HDB module for $type (HDB::MOD::$type)!") ;}

  &{"HDB::MOD::$type\::new"}($this) ;
  
  return $this->Error("Error on loanding HDB module $type (HDB::MOD::$type)!") if !$this ;

  if ( ($this->{conf_hpl} || $WITH_HPL ) && $this->{file} ) {
    my $hpl = &HPL_MAIN() ;
    if ( defined $hpl->env->{DOCUMENT_ROOT} ) {
      $this->{file} =~ s/^[\/\\][\/\\]/$hpl->env->{DOCUMENT_ROOT}/se ;
    }
  }

  ## "HIDDE" PASS:
  $PASS{$this} = $this->{pass} ;
  delete $this->{pass} ;

  eval { $this->connect };
  
  if ( !$this || !$this->connected || !$this->dbh ) { $this->Error("Can't connect to DB. Load error!") ; return ;}
  
  if ($this->{dynamic} && $this->{id} ne '') {
    if ( $WITH_HPL ) {
      $this->{WITH_HPL} = 1 ;
      my $hpl = &HPL_MAIN() ;
      if ( $hpl ) {
        my $hpl_root = $hpl->pack_root ;
        ${"$hpl_root\::MYHDB::DB"}{ $this->{id} } = $this ;
      }
    }
    else { $DB{ $this->{id} } = $this ;}
  }

  
  if ( $WITH_HPL ) {
    $this->dbh->{HandleError} = \&HPL_show_error ;
  }

  return $this ;
}

##################
# HPL_SHOW_ERROR #
##################

sub HPL_show_error {
  my $hpl = &HPL_MAIN() ;
  $hpl->warn($_[0]) if $hpl ;
  return $_[2] ;
}

###########
# CONNECT #
###########

sub connect {
  if ( $_[0]->{dbh} ) { return $_[0]->{dbh} ;}
  $_[0]->MOD_connect( $PASS{$_[0]} ) ;
  return $_[0]->{dbh} ;
}

#############
# RECONNECT #
#############

sub reconnect {
  $_[0]->disconnect ;
  $_[0]->connect ;
}

#########
# ERROR #
#########

sub Error {

  if ( $_[0]->{sth} ) {
    $_[0]->{sth}->finish ;
    $_[0]->{sth} = undef ;
  }

  if ($_[0] && !$_[0]->{warning}) { return ;}
  if ($_[0] && ref $_[0]->{warning} eq 'CODE') { &{$_[0]->{warning}}($_[1]) }
  else {
    if ($WITH_HPL) {
      my $hpl = &HPL_MAIN() ;
      $hpl->warn($_[1] , $_[2]) if $hpl ;
    }
    else {
      eval {
        require Carp ;
        Carp::carp($_[1]) ;    
      };
    }
  }
  
  return ;
}

###################
# _REQUIRE_MODULE #
###################

sub _require_module {
  my ( $module ) = @_ ;
  return 1 if $MOD_LOADED{$module} ;
  eval("require HDB::MOD::$module ;") ;
  return undef if $@ ;
  return $MOD_LOADED{$module} = 1 ;
}

###########
# DESTROY #
###########

sub DESTROY {
  delete $PASS{$_[0]} ;
  $_[0]->disconnect ;
}

#########
# RESET #
#########

sub RESET {
  ++$RESET_X ;
  
  HDB::Object::RESET() if defined &HDB::Object::RESET && (!$WITH_HPL || $RESET_X > 10) ;

  if ( $WITH_HPL ) {
    my $hpl = &HPL_MAIN() ;
    if ( $hpl ) {
      my $HDB_LINKED = \%{ $hpl->pack_root ."::MYHDB::DB"} ;
      %$HDB_LINKED = () ;
      undef %$HDB_LINKED ;
      eval {
        foreach my $Key ( keys %$HDB_LINKED ) { $$HDB_LINKED{$Key}->UNLINK ;}
      };
    }
  }

  %DB = () ;
  
  HDB::Parser::RESET() if defined &HDB::Parser::RESET && (!$WITH_HPL || $RESET_X > 10) ;
  
  $RESET_X = 0 if $RESET_X > 10 ;
  
  return 1 ;
}

sub END { &RESET }

#########
# TABLE #
#########

sub TABLE { HDB::TABLE->new(@_) ;}

##############
# HDB::TABLE #
##############

package HDB::TABLE ;

use vars qw($AUTOLOAD) ;

#######
# NEW #
#######

sub new {
  bless({
  hdb => $_[1] ,
  table => $_[2] ,
  },$_[0]) ;
}

sub DESTROY {
  ##print main::STDOUT "DESTROY>> @_\n" ;
}

sub AUTOLOAD {
  my $obj = shift ;
  my ($method) = ( $AUTOLOAD =~ /(\w+)$/s ) ;
  my $class = ref $obj->{hdb} ;
  return ($obj->{hdb})->$method($obj->{table} , @_) ;
}

#############
# HDB::CMDS #
#############

package HDB::CMDS ;

sub default_types { require HDB::CMDS ; &default_types ;}
sub predefined_columns { require HDB::CMDS ; &predefined_columns ;}
sub default_mod { require HDB::CMDS ; &default_mod ;}

#######
# END #
#######

1;

__END__

=head1 NAME

HDB - Hybrid Database - Handles multiple databases with the same interface.

=head1 DESCRIPTION

B<HDB is an easy, fast and powerfull way to access any type of database>. With it you B<don't need to know SQL, DBI, or the type of the database> that you are using.
HDB will make all the work around between the differences of any database. From HDB you still can use DBI and SQL commands if needed, but this won't be portable between database types.
If you use only HDB querys (not DBI) B<you can change the database that you are using, Server and OS without change your code!> For example, you can test/develope your code in your desktop (let's say Win32) with SQLite, and send your code to the Server (Linux), where you use MySQL.

HDB borns like a module to access in a easy way MySQL databases from HPL Documents.
From HPL6, when it was fully rewrited, the module MYSQL was rewrited too and called HDB, where the resources were expanded for other DB types, like SQLite.
Also HDB was turned into a Perl module, that can run independent of HPL when not called from it.

=head1 USAGE

  use HDB ;
  
  my $HDB = HDB->new(
  type => 'sqlite' ,
  file => 'test.db' ,
  ) ;
  
  ... or ...
  
  my $HDB = HDB->new(
  type => 'mysql' ,
  host => 'some.domain.com' ,
  user => 'foo' ,
  pass => 'bar' ,
  ) ;
  
  $HDB->create('users',[
  'user' => 100 ,
  'name' => 100 ,
  'age' => 'int(200)' ,
  'more' => 1024*4 ,
  ]);
  
  $HDB->insert( 'users' , {
  user => 'joe' ,
  name => 'joe tribianny' ,
  age  => '30' ,
  } ) ;
  
  ... or ...
  
  $HDB->users->insert( {
  user => 'joe' ,
  name => 'joe tribianny' ,
  age  => '30' ,
  } ) ;

  
  ...
  
  my @sel = $HDB->select('users' , 'name =~ joe' , '@%' ) ;
  
  foreach my $sel_i ( @sel ) {
    my %cols = %$sel_i ;
    ...
  }
  
  ...
  
  my $hdbhandle = $HDB->select('users' , '<%>');
  
  while( my %cols = <$hdbhandle> ) {
    foreach my $Key ( keys %cols ) { print "$Key = $cols{$Key}\n" ;}
    ...
  }
  
  ...
  
  $HDB->update('users' , 'user eq joe' , { user => 'JoeT' } )
  
  ...
  
  $HDB->disconnect ;


=head1 METHODS

=head2 new

Create the HDB object connected to the DB.

B<Arguments:>

=over 10

=item FILE

File for flat databases, like SQLite.

=item DB

The database name.

=item HOST

The host of the database server. If omited and needed will use "localhost".

=item USER

The user for connection.

=item PASS

The password for connection.

=item TYPE

The database type. See modules inside HDB/MOD for installed names.

=item CACHE (boolean)

Turn on/off the cache of sth and col names.

=item ID

Set a global ID for dynamic access.

=item DYNAMIC (boolean)

Enable/disable the dynamic acess. 

=item WARNING (boolean)

Turn on/off errors/warnings.

=back

=head2 open

Alias for new.

=head2 connect

Connect to the database. Note, no arguments are needed, they will be get from the object.

** Password will be hidden inside the class, not int the object.

=head2 disconnect

Disconnect the database and free any sth or cache.

=head2 reconnect

Disconnect, if needed, and reconnect the database.

=head2 dbh

Use to access in the DBI way:

  $HDB->dbh->do("select * from users") ;
  
  ...
  
  my $sth = $HDB->dbh->prepare("INSERT INTO users VALUES (?, ?, ?)") ;
  $sth->execute("joe", "Joe Tribiany", "joe\friends.com") ;

You can use I<dbi> too:

  $HDB->dbi->do("select * from users") ;

B<** Try to avoid this way to keep your code portable between database types and OS>.

=head1 COMMANDS METHODS

** See L<HDB::CMDS> for usage.

B<Commands:> select, insert, update, delete, create, drop, cmd, names, tables, table_columns...

=head1 DYNAMIC ACCESS

You can access the database connection without have the object variable. With this you have a global access to any connection with the ID set.

The Dynamic Access allow the use of a table as a method too:

  $HDB->users->select('name == joe');

Since the table is always the first argument, HDB will paste the fake method (table name) to the CMD (select) as the fisrt argument.

** Note that the name of the table can't be a HDB method.

=head2 USAGE

  my $HDB = HDB->new(
  type => 'mysql' ,
  db   => 'test' ,
  user => 'joe' ,
  pass => '12345' ,
  id   => 'TEST' ;
  ) ;
  
  ...
  
  HDB->TEST->select(users , 'user == joe');
  
  ...

  my $HDB = HDB->TEST ;

  $HDB->users->update('name == joe',{name => 'Jeff'}) ;
  
  ... or ...
  
  my $table_users = $HDB->TABLE(users) ;
  $table_users->update('name == joe',{name => 'Jeff'}) ;
  
  ... or ...
  
  HDB->TEST->users->update('name == joe',{name => 'Jeff'}) ;
  
  ...

B<** Dynamic access is used for global connections in HPL (connections set in the config file: .conf.hpl).>

=head1 HDB::Object - Persistent Objects

An automatic persistence framework was built over HDB, where is possible to
create persistent classes in a easy and fast way. HDB was designed to handle any
type of DB behind it, what extends the persistence framework to any DB that DBI
can handle with standart SQL.

Take a look at L<HDB::Object>.

=head1 SEE ALSO

L<HDB::CMDS>, L<HDB::Encode>, L<HDB::sqlite>, L<HDB::mysql>.

L<HDB::Object>, L<HPL>.

=head1 AUTHOR

Graciliano M. P. <gm@virtuasites.com.br>

I will appreciate any type of feedback (include your opinions and/or suggestions). ;-P

=head1 COPYRIGHT

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

PK       ! ���O�  O�    perl5/local/lib.pmnu ��6�$        package local::lib;
use 5.006;
BEGIN {
  if ($ENV{RELEASE_TESTING}) {
    require strict;
    strict->import;
    require warnings;
    warnings->import;
  }
}
use Config ();

our $VERSION = '2.000029';
$VERSION =~ tr/_//d;

BEGIN {
  *_WIN32 = ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'symbian')
    ? sub(){1} : sub(){0};
  # punt on these systems
  *_USE_FSPEC = ($^O eq 'MacOS' || $^O eq 'VMS' || $INC{'File/Spec.pm'})
    ? sub(){1} : sub(){0};
}
my $_archname = $Config::Config{archname};
my $_version = $Config::Config{version};
my @_inc_version_list = reverse split / /, $Config::Config{inc_version_list};
my $_path_sep = $Config::Config{path_sep};

our $_DIR_JOIN = _WIN32 ? '\\' : '/';
our $_DIR_SPLIT = (_WIN32 || $^O eq 'cygwin') ? qr{[\\/]}
                                              : qr{/};
our $_ROOT = _WIN32 ? do {
  my $UNC = qr{[\\/]{2}[^\\/]+[\\/][^\\/]+};
  qr{^(?:$UNC|[A-Za-z]:|)$_DIR_SPLIT};
} : qr{^/};
our $_PERL;

sub _perl {
  if (!$_PERL) {
    # untaint and validate
    ($_PERL, my $exe) = $^X =~ /((?:.*$_DIR_SPLIT)?(.+))/;
    $_PERL = 'perl'
      if $exe !~ /perl/;
    if (_is_abs($_PERL)) {
    }
    elsif (-x $Config::Config{perlpath}) {
      $_PERL = $Config::Config{perlpath};
    }
    elsif ($_PERL =~ $_DIR_SPLIT && -x $_PERL) {
      $_PERL = _rel2abs($_PERL);
    }
    else {
      ($_PERL) =
        map { /(.*)/ }
        grep { -x $_ }
        map { ($_, _WIN32 ? ("$_.exe") : ()) }
        map { join($_DIR_JOIN, $_, $_PERL) }
        split /\Q$_path_sep\E/, $ENV{PATH};
    }
  }
  $_PERL;
}

sub _cwd {
  if (my $cwd
    = defined &Cwd::sys_cwd ? \&Cwd::sys_cwd
    : defined &Cwd::cwd     ? \&Cwd::cwd
    : undef
  ) {
    no warnings 'redefine';
    *_cwd = $cwd;
    goto &$cwd;
  }
  my $drive = shift;
  return Win32::GetCwd()
    if _WIN32 && defined &Win32::GetCwd && !$drive;
  local @ENV{qw(PATH IFS CDPATH ENV BASH_ENV)};
  delete @ENV{qw(PATH IFS CDPATH ENV BASH_ENV)};
  my $cmd = $drive ? "eval { Cwd::getdcwd(q($drive)) }"
                   : 'getcwd';
  my $perl = _perl;
  my $cwd = `"$perl" -MCwd -le "print $cmd"`;
  chomp $cwd;
  if (!length $cwd && $drive) {
    $cwd = $drive;
  }
  $cwd =~ s/$_DIR_SPLIT?$/$_DIR_JOIN/;
  $cwd;
}

sub _catdir {
  if (_USE_FSPEC) {
    require File::Spec;
    File::Spec->catdir(@_);
  }
  else {
    my $dir = join($_DIR_JOIN, @_);
    $dir =~ s{($_DIR_SPLIT)(?:\.?$_DIR_SPLIT)+}{$1}g;
    $dir;
  }
}

sub _is_abs {
  if (_USE_FSPEC) {
    require File::Spec;
    File::Spec->file_name_is_absolute($_[0]);
  }
  else {
    $_[0] =~ $_ROOT;
  }
}

sub _rel2abs {
  my ($dir, $base) = @_;
  return $dir
    if _is_abs($dir);

  $base = _WIN32 && $dir =~ s/^([A-Za-z]:)// ? _cwd("$1")
        : $base                              ? _rel2abs($base)
                                             : _cwd;
  return _catdir($base, $dir);
}

our $_DEVNULL;
sub _devnull {
  return $_DEVNULL ||=
    _USE_FSPEC      ? (require File::Spec, File::Spec->devnull)
    : _WIN32        ? 'nul'
    : $^O eq 'os2'  ? '/dev/nul'
    : '/dev/null';
}

sub import {
  my ($class, @args) = @_;
  if ($0 eq '-') {
    push @args, @ARGV;
    require Cwd;
  }

  my @steps;
  my %opts;
  my %attr;
  my $shelltype;

  while (@args) {
    my $arg = shift @args;
    # check for lethal dash first to stop processing before causing problems
    # the fancy dash is U+2212 or \xE2\x88\x92
    if ($arg =~ /\xE2\x88\x92/) {
      die <<'DEATH';
WHOA THERE! It looks like you've got some fancy dashes in your commandline!
These are *not* the traditional -- dashes that software recognizes. You
probably got these by copy-pasting from the perldoc for this module as
rendered by a UTF8-capable formatter. This most typically happens on an OS X
terminal, but can happen elsewhere too. Please try again after replacing the
dashes with normal minus signs.
DEATH
    }
    elsif ($arg eq '--self-contained') {
      die <<'DEATH';
FATAL: The local::lib --self-contained flag has never worked reliably and the
original author, Mark Stosberg, was unable or unwilling to maintain it. As
such, this flag has been removed from the local::lib codebase in order to
prevent misunderstandings and potentially broken builds. The local::lib authors
recommend that you look at the lib::core::only module shipped with this
distribution in order to create a more robust environment that is equivalent to
what --self-contained provided (although quite possibly not what you originally
thought it provided due to the poor quality of the documentation, for which we
apologise).
DEATH
    }
    elsif( $arg =~ /^--deactivate(?:=(.*))?$/ ) {
      my $path = defined $1 ? $1 : shift @args;
      push @steps, ['deactivate', $path];
    }
    elsif ( $arg eq '--deactivate-all' ) {
      push @steps, ['deactivate_all'];
    }
    elsif ( $arg =~ /^--shelltype(?:=(.*))?$/ ) {
      $shelltype = defined $1 ? $1 : shift @args;
    }
    elsif ( $arg eq '--no-create' ) {
      $opts{no_create} = 1;
    }
    elsif ( $arg eq '--quiet' ) {
      $attr{quiet} = 1;
    }
    elsif ( $arg eq '--always' ) {
      $attr{always} = 1;
    }
    elsif ( $arg =~ /^--/ ) {
      die "Unknown import argument: $arg";
    }
    else {
      push @steps, ['activate', $arg, \%opts];
    }
  }
  if (!@steps) {
    push @steps, ['activate', undef, \%opts];
  }

  my $self = $class->new(%attr);

  for (@steps) {
    my ($method, @args) = @$_;
    $self = $self->$method(@args);
  }

  if ($0 eq '-') {
    print $self->environment_vars_string($shelltype);
    exit 0;
  }
  else {
    $self->setup_local_lib;
  }
}

sub new {
  my $class = shift;
  bless {@_}, $class;
}

sub clone {
  my $self = shift;
  bless {%$self, @_}, ref $self;
}

sub inc { $_[0]->{inc}     ||= \@INC }
sub libs { $_[0]->{libs}   ||= [ \'PERL5LIB' ] }
sub bins { $_[0]->{bins}   ||= [ \'PATH' ] }
sub roots { $_[0]->{roots} ||= [ \'PERL_LOCAL_LIB_ROOT' ] }
sub extra { $_[0]->{extra} ||= {} }
sub quiet { $_[0]->{quiet} }

sub _as_list {
  my $list = shift;
  grep length, map {
    !(ref $_ && ref $_ eq 'SCALAR') ? $_ : (
      defined $ENV{$$_} ? split(/\Q$_path_sep/, $ENV{$$_})
                        : ()
    )
  } ref $list ? @$list : $list;
}
sub _remove_from {
  my ($list, @remove) = @_;
  return @$list
    if !@remove;
  my %remove = map { $_ => 1 } @remove;
  grep !$remove{$_}, _as_list($list);
}

my @_lib_subdirs = (
  [$_version, $_archname],
  [$_version],
  [$_archname],
  (map [$_], @_inc_version_list),
  [],
);

sub install_base_bin_path {
  my ($class, $path) = @_;
  return _catdir($path, 'bin');
}
sub install_base_perl_path {
  my ($class, $path) = @_;
  return _catdir($path, 'lib', 'perl5');
}
sub install_base_arch_path {
  my ($class, $path) = @_;
  _catdir($class->install_base_perl_path($path), $_archname);
}

sub lib_paths_for {
  my ($class, $path) = @_;
  my $base = $class->install_base_perl_path($path);
  return map { _catdir($base, @$_) } @_lib_subdirs;
}

sub _mm_escape_path {
  my $path = shift;
  $path =~ s/\\/\\\\/g;
  if ($path =~ s/ /\\ /g) {
    $path = qq{"$path"};
  }
  return $path;
}

sub _mb_escape_path {
  my $path = shift;
  $path =~ s/\\/\\\\/g;
  return qq{"$path"};
}

sub installer_options_for {
  my ($class, $path) = @_;
  return (
    PERL_MM_OPT =>
      defined $path ? "INSTALL_BASE="._mm_escape_path($path) : undef,
    PERL_MB_OPT =>
      defined $path ? "--install_base "._mb_escape_path($path) : undef,
  );
}

sub active_paths {
  my ($self) = @_;
  $self = ref $self ? $self : $self->new;

  return grep {
    # screen out entries that aren't actually reflected in @INC
    my $active_ll = $self->install_base_perl_path($_);
    grep { $_ eq $active_ll } @{$self->inc};
  } _as_list($self->roots);
}


sub deactivate {
  my ($self, $path) = @_;
  $self = $self->new unless ref $self;
  $path = $self->resolve_path($path);
  $path = $self->normalize_path($path);

  my @active_lls = $self->active_paths;

  if (!grep { $_ eq $path } @active_lls) {
    warn "Tried to deactivate inactive local::lib '$path'\n";
    return $self;
  }

  my %args = (
    bins  => [ _remove_from($self->bins,
      $self->install_base_bin_path($path)) ],
    libs  => [ _remove_from($self->libs,
      $self->install_base_perl_path($path)) ],
    inc   => [ _remove_from($self->inc,
      $self->lib_paths_for($path)) ],
    roots => [ _remove_from($self->roots, $path) ],
  );

  $args{extra} = { $self->installer_options_for($args{roots}[0]) };

  $self->clone(%args);
}

sub deactivate_all {
  my ($self) = @_;
  $self = $self->new unless ref $self;

  my @active_lls = $self->active_paths;

  my %args;
  if (@active_lls) {
    %args = (
      bins => [ _remove_from($self->bins,
        map $self->install_base_bin_path($_), @active_lls) ],
      libs => [ _remove_from($self->libs,
        map $self->install_base_perl_path($_), @active_lls) ],
      inc => [ _remove_from($self->inc,
        map $self->lib_paths_for($_), @active_lls) ],
      roots => [ _remove_from($self->roots, @active_lls) ],
    );
  }

  $args{extra} = { $self->installer_options_for(undef) };

  $self->clone(%args);
}

sub activate {
  my ($self, $path, $opts) = @_;
  $opts ||= {};
  $self = $self->new unless ref $self;
  $path = $self->resolve_path($path);
  $self->ensure_dir_structure_for($path, { quiet => $self->quiet })
    unless $opts->{no_create};

  $path = $self->normalize_path($path);

  my @active_lls = $self->active_paths;

  if (grep { $_ eq $path } @active_lls[1 .. $#active_lls]) {
    $self = $self->deactivate($path);
  }

  my %args;
  if ($opts->{always} || !@active_lls || $active_lls[0] ne $path) {
    %args = (
      bins  => [ $self->install_base_bin_path($path), @{$self->bins} ],
      libs  => [ $self->install_base_perl_path($path), @{$self->libs} ],
      inc   => [ $self->lib_paths_for($path), @{$self->inc} ],
      roots => [ $path, @{$self->roots} ],
    );
  }

  $args{extra} = { $self->installer_options_for($path) };

  $self->clone(%args);
}

sub normalize_path {
  my ($self, $path) = @_;
  $path = ( Win32::GetShortPathName($path) || $path )
    if $^O eq 'MSWin32';
  return $path;
}

sub build_environment_vars_for {
  my $self = $_[0]->new->activate($_[1], { always => 1 });
  $self->build_environment_vars;
}
sub build_activate_environment_vars_for {
  my $self = $_[0]->new->activate($_[1], { always => 1 });
  $self->build_environment_vars;
}
sub build_deactivate_environment_vars_for {
  my $self = $_[0]->new->deactivate($_[1]);
  $self->build_environment_vars;
}
sub build_deact_all_environment_vars_for {
  my $self = $_[0]->new->deactivate_all;
  $self->build_environment_vars;
}
sub build_environment_vars {
  my $self = shift;
  (
    PATH                => join($_path_sep, _as_list($self->bins)),
    PERL5LIB            => join($_path_sep, _as_list($self->libs)),
    PERL_LOCAL_LIB_ROOT => join($_path_sep, _as_list($self->roots)),
    %{$self->extra},
  );
}

sub setup_local_lib_for {
  my $self = $_[0]->new->activate($_[1]);
  $self->setup_local_lib;
}

sub setup_local_lib {
  my $self = shift;

  # if Carp is already loaded, ensure Carp::Heavy is also loaded, to avoid
  # $VERSION mismatch errors (Carp::Heavy loads Carp, so we do not need to
  # check in the other direction)
  require Carp::Heavy if $INC{'Carp.pm'};

  $self->setup_env_hash;
  @INC = @{$self->inc};
}

sub setup_env_hash_for {
  my $self = $_[0]->new->activate($_[1]);
  $self->setup_env_hash;
}
sub setup_env_hash {
  my $self = shift;
  my %env = $self->build_environment_vars;
  for my $key (keys %env) {
    if (defined $env{$key}) {
      $ENV{$key} = $env{$key};
    }
    else {
      delete $ENV{$key};
    }
  }
}

sub print_environment_vars_for {
  print $_[0]->environment_vars_string_for(@_[1..$#_]);
}

sub environment_vars_string_for {
  my $self = $_[0]->new->activate($_[1], { always => 1});
  $self->environment_vars_string;
}
sub environment_vars_string {
  my ($self, $shelltype) = @_;

  $shelltype ||= $self->guess_shelltype;

  my $extra = $self->extra;
  my @envs = (
    PATH                => $self->bins,
    PERL5LIB            => $self->libs,
    PERL_LOCAL_LIB_ROOT => $self->roots,
    map { $_ => $extra->{$_} } sort keys %$extra,
  );
  $self->_build_env_string($shelltype, \@envs);
}

sub _build_env_string {
  my ($self, $shelltype, $envs) = @_;
  my @envs = @$envs;

  my $build_method = "build_${shelltype}_env_declaration";

  my $out = '';
  while (@envs) {
    my ($name, $value) = (shift(@envs), shift(@envs));
    if (
        ref $value
        && @$value == 1
        && ref $value->[0]
        && ref $value->[0] eq 'SCALAR'
        && ${$value->[0]} eq $name) {
      next;
    }
    $out .= $self->$build_method($name, $value);
  }
  my $wrap_method = "wrap_${shelltype}_output";
  if ($self->can($wrap_method)) {
    return $self->$wrap_method($out);
  }
  return $out;
}

sub build_bourne_env_declaration {
  my ($class, $name, $args) = @_;
  my $value = $class->_interpolate($args, '${%s:-}', qr/["\\\$!`]/, '\\%s');

  if (!defined $value) {
    return qq{unset $name;\n};
  }

  $value =~ s/(^|\G|$_path_sep)\$\{$name:-\}$_path_sep/$1\${$name}\${$name:+$_path_sep}/g;
  $value =~ s/$_path_sep\$\{$name:-\}$/\${$name:+$_path_sep\${$name}}/;

  qq{${name}="$value"; export ${name};\n}
}

sub build_csh_env_declaration {
  my ($class, $name, $args) = @_;
  my ($value, @vars) = $class->_interpolate($args, '${%s}', qr/["\$]/, '"\\%s"');
  if (!defined $value) {
    return qq{unsetenv $name;\n};
  }

  my $out = '';
  for my $var (@vars) {
    $out .= qq{if ! \$?$name setenv $name '';\n};
  }

  my $value_without = $value;
  if ($value_without =~ s/(?:^|$_path_sep)\$\{$name\}(?:$_path_sep|$)//g) {
    $out .= qq{if "\${$name}" != '' setenv $name "$value";\n};
    $out .= qq{if "\${$name}" == '' };
  }
  $out .= qq{setenv $name "$value_without";\n};
  return $out;
}

sub build_cmd_env_declaration {
  my ($class, $name, $args) = @_;
  my $value = $class->_interpolate($args, '%%%s%%', qr(%), '%s');
  if (!$value) {
    return qq{\@set $name=\n};
  }

  my $out = '';
  my $value_without = $value;
  if ($value_without =~ s/(?:^|$_path_sep)%$name%(?:$_path_sep|$)//g) {
    $out .= qq{\@if not "%$name%"=="" set "$name=$value"\n};
    $out .= qq{\@if "%$name%"=="" };
  }
  $out .= qq{\@set "$name=$value_without"\n};
  return $out;
}

sub build_powershell_env_declaration {
  my ($class, $name, $args) = @_;
  my $value = $class->_interpolate($args, '$env:%s', qr/["\$]/, '`%s');

  if (!$value) {
    return qq{Remove-Item -ErrorAction 0 Env:\\$name;\n};
  }

  my $maybe_path_sep = qq{\$(if("\$env:$name"-eq""){""}else{"$_path_sep"})};
  $value =~ s/(^|\G|$_path_sep)\$env:$name$_path_sep/$1\$env:$name"+$maybe_path_sep+"/g;
  $value =~ s/$_path_sep\$env:$name$/"+$maybe_path_sep+\$env:$name+"/;

  qq{\$env:$name = \$("$value");\n};
}
sub wrap_powershell_output {
  my ($class, $out) = @_;
  return $out || " \n";
}

sub build_fish_env_declaration {
  my ($class, $name, $args) = @_;
  my $value = $class->_interpolate($args, '$%s', qr/[\\"'$ ]/, '\\%s');
  if (!defined $value) {
    return qq{set -e $name;\n};
  }

  # fish has special handling for PATH, CDPATH, and MANPATH.  They are always
  # treated as arrays, and joined with ; when storing the environment.  Other
  # env vars can be arrays, but will be joined without a separator.  We only
  # really care about PATH, but might as well make this routine more general.
  if ($name =~ /^(?:CD|MAN)?PATH$/) {
    $value =~ s/$_path_sep/ /g;
    my $silent = $name =~ /^(?:CD)?PATH$/ ? " 2>"._devnull : '';
    return qq{set -x $name $value$silent;\n};
  }

  my $out = '';
  my $value_without = $value;
  if ($value_without =~ s/(?:^|$_path_sep)\$$name(?:$_path_sep|$)//g) {
    $out .= qq{set -q $name; and set -x $name $value;\n};
    $out .= qq{set -q $name; or };
  }
  $out .= qq{set -x $name $value_without;\n};
  $out;
}

sub _interpolate {
  my ($class, $args, $var_pat, $escape, $escape_pat) = @_;
  return
    unless defined $args;
  my @args = ref $args ? @$args : $args;
  return
    unless @args;
  my @vars = map { $$_ } grep { ref $_ eq 'SCALAR' } @args;
  my $string = join $_path_sep, map {
    ref $_ eq 'SCALAR' ? sprintf($var_pat, $$_) : do {
      s/($escape)/sprintf($escape_pat, $1)/ge; $_;
    };
  } @args;
  return wantarray ? ($string, \@vars) : $string;
}

sub pipeline;

sub pipeline {
  my @methods = @_;
  my $last = pop(@methods);
  if (@methods) {
    \sub {
      my ($obj, @args) = @_;
      $obj->${pipeline @methods}(
        $obj->$last(@args)
      );
    };
  } else {
    \sub {
      shift->$last(@_);
    };
  }
}

sub resolve_path {
  my ($class, $path) = @_;

  $path = $class->${pipeline qw(
    resolve_relative_path
    resolve_home_path
    resolve_empty_path
  )}($path);

  $path;
}

sub resolve_empty_path {
  my ($class, $path) = @_;
  if (defined $path) {
    $path;
  } else {
    '~/perl5';
  }
}

sub resolve_home_path {
  my ($class, $path) = @_;
  $path =~ /^~([^\/]*)/ or return $path;
  my $user = $1;
  my $homedir = do {
    if (! length($user) && defined $ENV{HOME}) {
      $ENV{HOME};
    }
    else {
      require File::Glob;
      File::Glob::bsd_glob("~$user", File::Glob::GLOB_TILDE());
    }
  };
  unless (defined $homedir) {
    require Carp; require Carp::Heavy;
    Carp::croak(
      "Couldn't resolve homedir for "
      .(defined $user ? $user : 'current user')
    );
  }
  $path =~ s/^~[^\/]*/$homedir/;
  $path;
}

sub resolve_relative_path {
  my ($class, $path) = @_;
  _rel2abs($path);
}

sub ensure_dir_structure_for {
  my ($class, $path, $opts) = @_;
  $opts ||= {};
  my @dirs;
  foreach my $dir (
    $class->lib_paths_for($path),
    $class->install_base_bin_path($path),
  ) {
    my $d = $dir;
    while (!-d $d) {
      push @dirs, $d;
      require File::Basename;
      $d = File::Basename::dirname($d);
    }
  }

  warn "Attempting to create directory ${path}\n"
    if !$opts->{quiet} && @dirs;

  my %seen;
  foreach my $dir (reverse @dirs) {
    next
      if $seen{$dir}++;

    mkdir $dir
      or -d $dir
      or die "Unable to create $dir: $!"
  }
  return;
}

sub guess_shelltype {
  my $shellbin
    = defined $ENV{SHELL} && length $ENV{SHELL}
      ? ($ENV{SHELL} =~ /([\w.]+)$/)[-1]
    : ( $^O eq 'MSWin32' && exists $ENV{'!EXITCODE'} )
      ? 'bash'
    : ( $^O eq 'MSWin32' && $ENV{PROMPT} && $ENV{COMSPEC} )
      ? ($ENV{COMSPEC} =~ /([\w.]+)$/)[-1]
    : ( $^O eq 'MSWin32' && !$ENV{PROMPT} )
      ? 'powershell.exe'
    : 'sh';

  for ($shellbin) {
    return
        /csh$/                   ? 'csh'
      : /fish$/                  ? 'fish'
      : /command(?:\.com)?$/i    ? 'cmd'
      : /cmd(?:\.exe)?$/i        ? 'cmd'
      : /4nt(?:\.exe)?$/i        ? 'cmd'
      : /powershell(?:\.exe)?$/i ? 'powershell'
                                 : 'bourne';
  }
}

1;
__END__

=encoding utf8

=head1 NAME

local::lib - create and use a local lib/ for perl modules with PERL5LIB

=head1 SYNOPSIS

In code -

  use local::lib; # sets up a local lib at ~/perl5

  use local::lib '~/foo'; # same, but ~/foo

  # Or...
  use FindBin;
  use local::lib "$FindBin::Bin/../support";  # app-local support library

From the shell -

  # Install LWP and its missing dependencies to the '~/perl5' directory
  perl -MCPAN -Mlocal::lib -e 'CPAN::install(LWP)'

  # Just print out useful shell commands
  $ perl -Mlocal::lib
  PERL_MB_OPT='--install_base /home/username/perl5'; export PERL_MB_OPT;
  PERL_MM_OPT='INSTALL_BASE=/home/username/perl5'; export PERL_MM_OPT;
  PERL5LIB="/home/username/perl5/lib/perl5"; export PERL5LIB;
  PATH="/home/username/perl5/bin:$PATH"; export PATH;
  PERL_LOCAL_LIB_ROOT="/home/usename/perl5:$PERL_LOCAL_LIB_ROOT"; export PERL_LOCAL_LIB_ROOT;

From a F<.bash_profile> or F<.bashrc> file -

  eval "$(perl -I$HOME/perl5/lib/perl5 -Mlocal::lib)"

=head2 The bootstrapping technique

A typical way to install local::lib is using what is known as the
"bootstrapping" technique.  You would do this if your system administrator
hasn't already installed local::lib.  In this case, you'll need to install
local::lib in your home directory.

Even if you do have administrative privileges, you will still want to set up your
environment variables, as discussed in step 4. Without this, you would still
install the modules into the system CPAN installation and also your Perl scripts
will not use the lib/ path you bootstrapped with local::lib.

By default local::lib installs itself and the CPAN modules into ~/perl5.

Windows users must also see L</Differences when using this module under Win32>.

=over 4

=item 1.

Download and unpack the local::lib tarball from CPAN (search for "Download"
on the CPAN page about local::lib).  Do this as an ordinary user, not as root
or administrator.  Unpack the file in your home directory or in any other
convenient location.

=item 2.

Run this:

  perl Makefile.PL --bootstrap

If the system asks you whether it should automatically configure as much
as possible, you would typically answer yes.

=item 3.

Run this: (local::lib assumes you have make installed on your system)

  make test && make install

=item 4.

Now we need to setup the appropriate environment variables, so that Perl
starts using our newly generated lib/ directory. If you are using bash or
any other Bourne shells, you can add this to your shell startup script this
way:

  echo 'eval "$(perl -I$HOME/perl5/lib/perl5 -Mlocal::lib)"' >>~/.bashrc

If you are using C shell, you can do this as follows:

  % echo $SHELL
  /bin/csh
  $ echo 'eval `perl -I$HOME/perl5/lib/perl5 -Mlocal::lib`' >> ~/.cshrc

After writing your shell configuration file, be sure to re-read it to get the
changed settings into your current shell's environment. Bourne shells use
C<. ~/.bashrc> for this, whereas C shells use C<source ~/.cshrc>.

=back

=head3 Bootstrapping into an alternate directory

In order to install local::lib into a directory other than the default, you need
to specify the name of the directory when you call bootstrap.  Then, when
setting up the environment variables, both perl and local::lib must be told the
location of the bootstrap directory.  The setup process would look as follows:

  perl Makefile.PL --bootstrap=~/foo
  make test && make install
  echo 'eval "$(perl -I$HOME/foo/lib/perl5 -Mlocal::lib=$HOME/foo)"' >>~/.bashrc
  . ~/.bashrc

=head3 Other bootstrapping options

If you're on a slower machine, or are operating under draconian disk space
limitations, you can disable the automatic generation of manpages from POD when
installing modules by using the C<--no-manpages> argument when bootstrapping:

  perl Makefile.PL --bootstrap --no-manpages

To avoid doing several bootstrap for several Perl module environments on the
same account, for example if you use it for several different deployed
applications independently, you can use one bootstrapped local::lib
installation to install modules in different directories directly this way:

  cd ~/mydir1
  perl -Mlocal::lib=./
  eval $(perl -Mlocal::lib=./)  ### To set the environment for this shell alone
  printenv                      ### You will see that ~/mydir1 is in the PERL5LIB
  perl -MCPAN -e install ...    ### whatever modules you want
  cd ../mydir2
  ... REPEAT ...

If you use F<.bashrc> to activate a local::lib automatically, the local::lib
will be re-enabled in any sub-shells used, overriding adjustments you may have
made in the parent shell.  To avoid this, you can initialize the local::lib in
F<.bash_profile> rather than F<.bashrc>, or protect the local::lib invocation
with a C<$SHLVL> check:

  [ $SHLVL -eq 1 ] && eval "$(perl -I$HOME/perl5/lib/perl5 -Mlocal::lib)"

If you are working with several C<local::lib> environments, you may want to
remove some of them from the current environment without disturbing the others.
You can deactivate one environment like this (using bourne sh):

  eval $(perl -Mlocal::lib=--deactivate,~/path)

which will generate and run the commands needed to remove C<~/path> from your
various search paths. Whichever environment was B<activated most recently> will
remain the target for module installations. That is, if you activate
C<~/path_A> and then you activate C<~/path_B>, new modules you install will go
in C<~/path_B>. If you deactivate C<~/path_B> then modules will be installed
into C<~/pathA> -- but if you deactivate C<~/path_A> then they will still be
installed in C<~/pathB> because pathB was activated later.

You can also ask C<local::lib> to clean itself completely out of the current
shell's environment with the C<--deactivate-all> option.
For multiple environments for multiple apps you may need to include a modified
version of the C<< use FindBin >> instructions in the "In code" sample above.
If you did something like the above, you have a set of Perl modules at C<<
~/mydir1/lib >>. If you have a script at C<< ~/mydir1/scripts/myscript.pl >>,
you need to tell it where to find the modules you installed for it at C<<
~/mydir1/lib >>.

In C<< ~/mydir1/scripts/myscript.pl >>:

  use strict;
  use warnings;
  use local::lib "$FindBin::Bin/..";  ### points to ~/mydir1 and local::lib finds lib
  use lib "$FindBin::Bin/../lib";     ### points to ~/mydir1/lib

Put this before any BEGIN { ... } blocks that require the modules you installed.

=head2 Differences when using this module under Win32

To set up the proper environment variables for your current session of
C<CMD.exe>, you can use this:

  C:\>perl -Mlocal::lib
  set PERL_MB_OPT=--install_base C:\DOCUME~1\ADMINI~1\perl5
  set PERL_MM_OPT=INSTALL_BASE=C:\DOCUME~1\ADMINI~1\perl5
  set PERL5LIB=C:\DOCUME~1\ADMINI~1\perl5\lib\perl5
  set PATH=C:\DOCUME~1\ADMINI~1\perl5\bin;%PATH%

  ### To set the environment for this shell alone
  C:\>perl -Mlocal::lib > %TEMP%\tmp.bat && %TEMP%\tmp.bat && del %TEMP%\tmp.bat
  ### instead of $(perl -Mlocal::lib=./)

If you want the environment entries to persist, you'll need to add them to the
Control Panel's System applet yourself or use L<App::local::lib::Win32Helper>.

The "~" is translated to the user's profile directory (the directory named for
the user under "Documents and Settings" (Windows XP or earlier) or "Users"
(Windows Vista or later)) unless $ENV{HOME} exists. After that, the home
directory is translated to a short name (which means the directory must exist)
and the subdirectories are created.

=head3 PowerShell

local::lib also supports PowerShell, and can be used with the
C<Invoke-Expression> cmdlet.

  Invoke-Expression "$(perl -Mlocal::lib)"

=head1 RATIONALE

The version of a Perl package on your machine is not always the version you
need.  Obviously, the best thing to do would be to update to the version you
need.  However, you might be in a situation where you're prevented from doing
this.  Perhaps you don't have system administrator privileges; or perhaps you
are using a package management system such as Debian, and nobody has yet gotten
around to packaging up the version you need.

local::lib solves this problem by allowing you to create your own directory of
Perl packages downloaded from CPAN (in a multi-user system, this would typically
be within your own home directory).  The existing system Perl installation is
not affected; you simply invoke Perl with special options so that Perl uses the
packages in your own local package directory rather than the system packages.
local::lib arranges things so that your locally installed version of the Perl
packages takes precedence over the system installation.

If you are using a package management system (such as Debian), you don't need to
worry about Debian and CPAN stepping on each other's toes.  Your local version
of the packages will be written to an entirely separate directory from those
installed by Debian.

=head1 DESCRIPTION

This module provides a quick, convenient way of bootstrapping a user-local Perl
module library located within the user's home directory. It also constructs and
prints out for the user the list of environment variables using the syntax
appropriate for the user's current shell (as specified by the C<SHELL>
environment variable), suitable for directly adding to one's shell
configuration file.

More generally, local::lib allows for the bootstrapping and usage of a
directory containing Perl modules outside of Perl's C<@INC>. This makes it
easier to ship an application with an app-specific copy of a Perl module, or
collection of modules. Useful in cases like when an upstream maintainer hasn't
applied a patch to a module of theirs that you need for your application.

On import, local::lib sets the following environment variables to appropriate
values:

=over 4

=item PERL_MB_OPT

=item PERL_MM_OPT

=item PERL5LIB

=item PATH

=item PERL_LOCAL_LIB_ROOT

=back

When possible, these will be appended to instead of overwritten entirely.

These values are then available for reference by any code after import.

=head1 CREATING A SELF-CONTAINED SET OF MODULES

See L<lib::core::only> for one way to do this - but note that
there are a number of caveats, and the best approach is always to perform a
build against a clean perl (i.e. site and vendor as close to empty as possible).

=head1 IMPORT OPTIONS

Options are values that can be passed to the C<local::lib> import besides the
directory to use. They are specified as C<use local::lib '--option'[, path];>
or C<perl -Mlocal::lib=--option[,path]>.

=head2 --deactivate

Remove the chosen path (or the default path) from the module search paths if it
was added by C<local::lib>, instead of adding it.

=head2 --deactivate-all

Remove all directories that were added to search paths by C<local::lib> from the
search paths.

=head2 --quiet

Don't output any messages about directories being created.

=head2 --always

Always add directories to environment variables, ignoring if they are already
included.

=head2 --shelltype

Specify the shell type to use for output.  By default, the shell will be
detected based on the environment.  Should be one of: C<bourne>, C<csh>,
C<cmd>, or C<powershell>.

=head2 --no-create

Prevents C<local::lib> from creating directories when activating dirs.  This is
likely to cause issues on Win32 systems.

=head1 CLASS METHODS

=head2 ensure_dir_structure_for

=over 4

=item Arguments: $path

=item Return value: None

=back

Attempts to create a local::lib directory, including subdirectories and all
required parent directories. Throws an exception on failure.

=head2 print_environment_vars_for

=over 4

=item Arguments: $path

=item Return value: None

=back

Prints to standard output the variables listed above, properly set to use the
given path as the base directory.

=head2 build_environment_vars_for

=over 4

=item Arguments: $path

=item Return value: %environment_vars

=back

Returns a hash with the variables listed above, properly set to use the
given path as the base directory.

=head2 setup_env_hash_for

=over 4

=item Arguments: $path

=item Return value: None

=back

Constructs the C<%ENV> keys for the given path, by calling
L</build_environment_vars_for>.

=head2 active_paths

=over 4

=item Arguments: None

=item Return value: @paths

=back

Returns a list of active C<local::lib> paths, according to the
C<PERL_LOCAL_LIB_ROOT> environment variable and verified against
what is really in C<@INC>.

=head2 install_base_perl_path

=over 4

=item Arguments: $path

=item Return value: $install_base_perl_path

=back

Returns a path describing where to install the Perl modules for this local
library installation. Appends the directories C<lib> and C<perl5> to the given
path.

=head2 lib_paths_for

=over 4

=item Arguments: $path

=item Return value: @lib_paths

=back

Returns the list of paths perl will search for libraries, given a base path.
This includes the base path itself, the architecture specific subdirectory, and
perl version specific subdirectories.  These paths may not all exist.

=head2 install_base_bin_path

=over 4

=item Arguments: $path

=item Return value: $install_base_bin_path

=back

Returns a path describing where to install the executable programs for this
local library installation. Appends the directory C<bin> to the given path.

=head2 installer_options_for

=over 4

=item Arguments: $path

=item Return value: %installer_env_vars

=back

Returns a hash of environment variables that should be set to cause
installation into the given path.

=head2 resolve_empty_path

=over 4

=item Arguments: $path

=item Return value: $base_path

=back

Builds and returns the base path into which to set up the local module
installation. Defaults to C<~/perl5>.

=head2 resolve_home_path

=over 4

=item Arguments: $path

=item Return value: $home_path

=back

Attempts to find the user's home directory.
If no definite answer is available, throws an exception.

=head2 resolve_relative_path

=over 4

=item Arguments: $path

=item Return value: $absolute_path

=back

Translates the given path into an absolute path.

=head2 resolve_path

=over 4

=item Arguments: $path

=item Return value: $absolute_path

=back

Calls the following in a pipeline, passing the result from the previous to the
next, in an attempt to find where to configure the environment for a local
library installation: L</resolve_empty_path>, L</resolve_home_path>,
L</resolve_relative_path>. Passes the given path argument to
L</resolve_empty_path> which then returns a result that is passed to
L</resolve_home_path>, which then has its result passed to
L</resolve_relative_path>. The result of this final call is returned from
L</resolve_path>.

=head1 OBJECT INTERFACE

=head2 new

=over 4

=item Arguments: %attributes

=item Return value: $local_lib

=back

Constructs a new C<local::lib> object, representing the current state of
C<@INC> and the relevant environment variables.

=head1 ATTRIBUTES

=head2 roots

An arrayref representing active C<local::lib> directories.

=head2 inc

An arrayref representing C<@INC>.

=head2 libs

An arrayref representing the PERL5LIB environment variable.

=head2 bins

An arrayref representing the PATH environment variable.

=head2 extra

A hashref of extra environment variables (e.g. C<PERL_MM_OPT> and
C<PERL_MB_OPT>)

=head2 no_create

If set, C<local::lib> will not try to create directories when activating them.

=head1 OBJECT METHODS

=head2 clone

=over 4

=item Arguments: %attributes

=item Return value: $local_lib

=back

Constructs a new C<local::lib> object based on the existing one, overriding the
specified attributes.

=head2 activate

=over 4

=item Arguments: $path

=item Return value: $new_local_lib

=back

Constructs a new instance with the specified path active.

=head2 deactivate

=over 4

=item Arguments: $path

=item Return value: $new_local_lib

=back

Constructs a new instance with the specified path deactivated.

=head2 deactivate_all

=over 4

=item Arguments: None

=item Return value: $new_local_lib

=back

Constructs a new instance with all C<local::lib> directories deactivated.

=head2 environment_vars_string

=over 4

=item Arguments: [ $shelltype ]

=item Return value: $shell_env_string

=back

Returns a string to set up the C<local::lib>, meant to be run by a shell.

=head2 build_environment_vars

=over 4

=item Arguments: None

=item Return value: %environment_vars

=back

Returns a hash with the variables listed above, properly set to use the
given path as the base directory.

=head2 setup_env_hash

=over 4

=item Arguments: None

=item Return value: None

=back

Constructs the C<%ENV> keys for the given path, by calling
L</build_environment_vars>.

=head2 setup_local_lib

Constructs the C<%ENV> hash using L</setup_env_hash>, and set up C<@INC>.

=head1 A WARNING ABOUT UNINST=1

Be careful about using local::lib in combination with "make install UNINST=1".
The idea of this feature is that will uninstall an old version of a module
before installing a new one. However it lacks a safety check that the old
version and the new version will go in the same directory. Used in combination
with local::lib, you can potentially delete a globally accessible version of a
module while installing the new version in a local place. Only combine "make
install UNINST=1" and local::lib if you understand these possible consequences.

=head1 LIMITATIONS

=over 4

=item * Directory names with spaces in them are not well supported by the perl
toolchain and the programs it uses.  Pure-perl distributions should support
spaces, but problems are more likely with dists that require compilation. A
workaround you can do is moving your local::lib to a directory with spaces
B<after> you installed all modules inside your local::lib bootstrap. But be
aware that you can't update or install CPAN modules after the move.

=item * Rather basic shell detection. Right now anything with csh in its name is
assumed to be a C shell or something compatible, and everything else is assumed
to be Bourne, except on Win32 systems. If the C<SHELL> environment variable is
not set, a Bourne-compatible shell is assumed.

=item * Kills any existing PERL_MM_OPT or PERL_MB_OPT.

=item * Should probably auto-fixup CPAN config if not already done.

=item * On VMS and MacOS Classic (pre-OS X), local::lib loads L<File::Spec>.
This means any L<File::Spec> version installed in the local::lib will be
ignored by scripts using local::lib.  A workaround for this is using
C<use lib "$local_lib/lib/perl5";> instead of using C<local::lib> directly.

=item * Conflicts with L<ExtUtils::MakeMaker>'s C<PREFIX> option.
C<local::lib> uses the C<INSTALL_BASE> option, as it has more predictable and
sane behavior.  If something attempts to use the C<PREFIX> option when running
a F<Makefile.PL>, L<ExtUtils::MakeMaker> will refuse to run, as the two
options conflict.  This can be worked around by temporarily unsetting the
C<PERL_MM_OPT> environment variable.

=item * Conflicts with L<Module::Build>'s C<--prefix> option.  Similar to the
previous limitation, but any C<--prefix> option specified will be ignored.
This can be worked around by temporarily unsetting the C<PERL_MB_OPT>
environment variable.

=back

Patches very much welcome for any of the above.

=over 4

=item * On Win32 systems, does not have a way to write the created environment
variables to the registry, so that they can persist through a reboot.

=back

=head1 TROUBLESHOOTING

If you've configured local::lib to install CPAN modules somewhere in to your
home directory, and at some point later you try to install a module with C<cpan
-i Foo::Bar>, but it fails with an error like: C<Warning: You do not have
permissions to install into /usr/lib64/perl5/site_perl/5.8.8/x86_64-linux at
/usr/lib64/perl5/5.8.8/Foo/Bar.pm> and buried within the install log is an
error saying C<'INSTALL_BASE' is not a known MakeMaker parameter name>, then
you've somehow lost your updated ExtUtils::MakeMaker module.

To remedy this situation, rerun the bootstrapping procedure documented above.

Then, run C<rm -r ~/.cpan/build/Foo-Bar*>

Finally, re-run C<cpan -i Foo::Bar> and it should install without problems.

=head1 ENVIRONMENT

=over 4

=item SHELL

=item COMSPEC

local::lib looks at the user's C<SHELL> environment variable when printing out
commands to add to the shell configuration file.

On Win32 systems, C<COMSPEC> is also examined.

=back

=head1 SEE ALSO

=over 4

=item * L<Perl Advent article, 2011|http://perladvent.org/2011/2011-12-01.html>

=back

=head1 SUPPORT

IRC:

    Join #toolchain on irc.perl.org.

=head1 AUTHOR

Matt S Trout <mst@shadowcat.co.uk> http://www.shadowcat.co.uk/

auto_install fixes kindly sponsored by http://www.takkle.com/

=head1 CONTRIBUTORS

Patches to correctly output commands for csh style shells, as well as some
documentation additions, contributed by Christopher Nehren <apeiron@cpan.org>.

Doc patches for a custom local::lib directory, more cleanups in the english
documentation and a L<german documentation|POD2::DE::local::lib> contributed by
Torsten Raudssus <torsten@raudssus.de>.

Hans Dieter Pearcey <hdp@cpan.org> sent in some additional tests for ensuring
things will install properly, submitted a fix for the bug causing problems with
writing Makefiles during bootstrapping, contributed an example program, and
submitted yet another fix to ensure that local::lib can install and bootstrap
properly. Many, many thanks!

pattern of Freenode IRC contributed the beginnings of the Troubleshooting
section. Many thanks!

Patch to add Win32 support contributed by Curtis Jewell <csjewell@cpan.org>.

Warnings for missing PATH/PERL5LIB (as when not running interactively) silenced
by a patch from Marco Emilio Poleggi.

Mark Stosberg <mark@summersault.com> provided the code for the now deleted
'--self-contained' option.

Documentation patches to make win32 usage clearer by
David Mertens <dcmertens.perl@gmail.com> (run4flat).

Brazilian L<portuguese translation|POD2::PT_BR::local::lib> and minor doc
patches contributed by Breno G. de Oliveira <garu@cpan.org>.

Improvements to stacking multiple local::lib dirs and removing them from the
environment later on contributed by Andrew Rodland <arodland@cpan.org>.

Patch for Carp version mismatch contributed by Hakim Cassimally
<osfameron@cpan.org>.

Rewrite of internals and numerous bug fixes and added features contributed by
Graham Knop <haarg@haarg.org>.

=head1 COPYRIGHT

Copyright (c) 2007 - 2013 the local::lib L</AUTHOR> and L</CONTRIBUTORS> as
listed above.

=head1 LICENSE

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

=cut
PK       ! ��E�1$  1$    perl5/libwww/lwpcook.podnu ��6�$        =head1 NAME

lwpcook - The libwww-perl cookbook

=head1 DESCRIPTION

This document contain some examples that show typical usage of the
libwww-perl library.  You should consult the documentation for the
individual modules for more detail.

All examples should be runnable programs. You can, in most cases, test
the code sections by piping the program text directly to perl.


=head1 GET

It is very easy to use this library to just fetch documents from the
net.  The LWP::Simple module provides the get() function that return
the document specified by its URL argument:

  use LWP::Simple;
  $doc = get 'http://search.cpan.org/dist/libwww-perl/';

or, as a perl one-liner using the getprint() function:

  perl -MLWP::Simple -e 'getprint "http://search.cpan.org/dist/libwww-perl/"'

or, how about fetching the latest perl by running this command:

  perl -MLWP::Simple -e '
    getstore "ftp://ftp.sunet.se/pub/lang/perl/CPAN/src/latest.tar.gz",
             "perl.tar.gz"'

You will probably first want to find a CPAN site closer to you by
running something like the following command:

  perl -MLWP::Simple -e 'getprint "http://www.cpan.org/SITES.html"'

Enough of this simple stuff!  The LWP object oriented interface gives
you more control over the request sent to the server.  Using this
interface you have full control over headers sent and how you want to
handle the response returned.

  use LWP::UserAgent;
  $ua = LWP::UserAgent->new;
  $ua->agent("$0/0.1 " . $ua->agent);
  # $ua->agent("Mozilla/8.0") # pretend we are very capable browser

  $req = HTTP::Request->new(
     GET => 'http://search.cpan.org/dist/libwww-perl/');
  $req->header('Accept' => 'text/html');

  # send request
  $res = $ua->request($req);

  # check the outcome
  if ($res->is_success) {
     print $res->decoded_content;
  }
  else {
     print "Error: " . $res->status_line . "\n";
  }

The lwp-request program (alias GET) that is distributed with the
library can also be used to fetch documents from WWW servers.


=head1 HEAD

If you just want to check if a document is present (i.e. the URL is
valid) try to run code that looks like this:

  use LWP::Simple;

  if (head($url)) {
     # ok document exists
  }

The head() function really returns a list of meta-information about
the document.  The first three values of the list returned are the
document type, the size of the document, and the age of the document.

More control over the request or access to all header values returned
require that you use the object oriented interface described for GET
above.  Just s/GET/HEAD/g.


=head1 POST

There is no simple procedural interface for posting data to a WWW server.  You
must use the object oriented interface for this. The most common POST
operation is to access a WWW form application:

  use LWP::UserAgent;
  $ua = LWP::UserAgent->new;

  my $req = HTTP::Request->new(
      POST => 'https://rt.cpan.org/Public/Dist/Display.html');
  $req->content_type('application/x-www-form-urlencoded');
  $req->content('Status=Active&Name=libwww-perl');

  my $res = $ua->request($req);
  print $res->as_string;

Lazy people use the HTTP::Request::Common module to set up a suitable
POST request message (it handles all the escaping issues) and has a
suitable default for the content_type:

  use HTTP::Request::Common qw(POST);
  use LWP::UserAgent;
  $ua = LWP::UserAgent->new;

  my $req = POST 'https://rt.cpan.org/Public/Dist/Display.html',
                [ Status => 'Active', Name => 'libwww-perl' ];

  print $ua->request($req)->as_string;

The lwp-request program (alias POST) that is distributed with the
library can also be used for posting data.


=head1 PROXIES

Some sites use proxies to go through fire wall machines, or just as
cache in order to improve performance.  Proxies can also be used for
accessing resources through protocols not supported directly (or
supported badly :-) by the libwww-perl library.

You should initialize your proxy setting before you start sending
requests:

  use LWP::UserAgent;
  $ua = LWP::UserAgent->new;
  $ua->env_proxy; # initialize from environment variables
  # or
  $ua->proxy(ftp  => 'http://proxy.myorg.com');
  $ua->proxy(wais => 'http://proxy.myorg.com');
  $ua->no_proxy(qw(no se fi));

  my $req = HTTP::Request->new(GET => 'wais://xxx.com/');
  print $ua->request($req)->as_string;

The LWP::Simple interface will call env_proxy() for you automatically.
Applications that use the $ua->env_proxy() method will normally not
use the $ua->proxy() and $ua->no_proxy() methods.

Some proxies also require that you send it a username/password in
order to let requests through.  You should be able to add the
required header, with something like this:

 use LWP::UserAgent;

 $ua = LWP::UserAgent->new;
 $ua->proxy(['http', 'ftp'] => 'http://username:password@proxy.myorg.com');

 $req = HTTP::Request->new('GET',"http://www.perl.com");

 $res = $ua->request($req);
 print $res->decoded_content if $res->is_success;

Replace C<proxy.myorg.com>, C<username> and
C<password> with something suitable for your site.


=head1 ACCESS TO PROTECTED DOCUMENTS

Documents protected by basic authorization can easily be accessed
like this:

  use LWP::UserAgent;
  $ua = LWP::UserAgent->new;
  $req = HTTP::Request->new(GET => 'http://www.linpro.no/secret/');
  $req->authorization_basic('aas', 'mypassword');
  print $ua->request($req)->as_string;

The other alternative is to provide a subclass of I<LWP::UserAgent> that
overrides the get_basic_credentials() method. Study the I<lwp-request>
program for an example of this.


=head1 COOKIES

Some sites like to play games with cookies.  By default LWP ignores
cookies provided by the servers it visits.  LWP will collect cookies
and respond to cookie requests if you set up a cookie jar. LWP doesn't
provide a cookie jar itself, but if you install L<HTTP::CookieJar::LWP>,
it can be used like this:

  use LWP::UserAgent;
  use HTTP::CookieJar::LWP;

  $ua = LWP::UserAgent->new(
      cookie_jar => HTTP::CookieJar::LWP->new,
  );

  # and then send requests just as you used to do
  $res = $ua->request(HTTP::Request->new(GET => "http://no.yahoo.com/"));
  print $res->status_line, "\n";

=head1 HTTPS

URLs with https scheme are accessed in exactly the same way as with
http scheme, provided that an SSL interface module for LWP has been
properly installed (see the F<README.SSL> file found in the
libwww-perl distribution for more details).  If no SSL interface is
installed for LWP to use, then you will get "501 Protocol scheme
'https' is not supported" errors when accessing such URLs.

Here's an example of fetching and printing a WWW page using SSL:

  use LWP::UserAgent;

  my $ua = LWP::UserAgent->new;
  my $req = HTTP::Request->new(GET => 'https://www.helsinki.fi/');
  my $res = $ua->request($req);
  if ($res->is_success) {
      print $res->as_string;
  }
  else {
      print "Failed: ", $res->status_line, "\n";
  }

=head1 MIRRORING

If you want to mirror documents from a WWW server, then try to run
code similar to this at regular intervals:

  use LWP::Simple;

  %mirrors = (
     'http://www.sn.no/'                       => 'sn.html',
     'http://www.perl.com/'                    => 'perl.html',
     'http://search.cpan.org/distlibwww-perl/' => 'lwp.html',
     'gopher://gopher.sn.no/'                  => 'gopher.html',
  );

  while (($url, $localfile) = each(%mirrors)) {
     mirror($url, $localfile);
  }

Or, as a perl one-liner:

  perl -MLWP::Simple -e 'mirror("http://www.perl.com/", "perl.html")';

The document will not be transferred unless it has been updated.


=head1 LARGE DOCUMENTS

If the document you want to fetch is too large to be kept in memory,
then you have two alternatives.  You can instruct the library to write
the document content to a file (second $ua->request() argument is a file
name):

  use LWP::UserAgent;
  $ua = LWP::UserAgent->new;

  my $req = HTTP::Request->new(GET =>
      'http://www.cpan.org/CPAN/authors/id/O/OA/OALDERS/libwww-perl-6.26.tar.gz');
  $res = $ua->request($req, "libwww-perl.tar.gz");
  if ($res->is_success) {
     print "ok\n";
  }
  else {
     print $res->status_line, "\n";
  }


Or you can process the document as it arrives (second $ua->request()
argument is a code reference):

  use LWP::UserAgent;
  $ua = LWP::UserAgent->new;
  $URL = 'ftp://ftp.isc.org/pub/rfc/rfc-index.txt';

  my $expected_length;
  my $bytes_received = 0;
  my $res =
     $ua->request(HTTP::Request->new(GET => $URL),
               sub {
                   my($chunk, $res) = @_;
                   $bytes_received += length($chunk);
	           unless (defined $expected_length) {
	              $expected_length = $res->content_length || 0;
                   }
		   if ($expected_length) {
		        printf STDERR "%d%% - ",
	                          100 * $bytes_received / $expected_length;
                   }
	           print STDERR "$bytes_received bytes received\n";

                   # XXX Should really do something with the chunk itself
	           # print $chunk;
               });
   print $res->status_line, "\n";


=head1 COPYRIGHT

Copyright 1996-2001, Gisle Aas

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


PK       ! ���va  va    perl5/libwww/lwptut.podnu ��6�$        =head1 NAME

lwptut -- An LWP Tutorial

=head1 DESCRIPTION

LWP (short for "Library for WWW in Perl") is a very popular group of
Perl modules for accessing data on the Web. Like most Perl
module-distributions, each of LWP's component modules comes with
documentation that is a complete reference to its interface. However,
there are so many modules in LWP that it's hard to know where to start
looking for information on how to do even the simplest most common
things.

Really introducing you to using LWP would require a whole book -- a book
that just happens to exist, called I<Perl & LWP>. But this article
should give you a taste of how you can go about some common tasks with
LWP.


=head2 Getting documents with LWP::Simple

If you just want to get what's at a particular URL, the simplest way
to do it is LWP::Simple's functions.

In a Perl program, you can call its C<get($url)> function.  It will try
getting that URL's content.  If it works, then it'll return the
content; but if there's some error, it'll return undef.

  my $url = 'http://www.npr.org/programs/fa/?todayDate=current';
    # Just an example: the URL for the most recent /Fresh Air/ show

  use LWP::Simple;
  my $content = get $url;
  die "Couldn't get $url" unless defined $content;

  # Then go do things with $content, like this:

  if($content =~ m/jazz/i) {
    print "They're talking about jazz today on Fresh Air!\n";
  }
  else {
    print "Fresh Air is apparently jazzless today.\n";
  }

The handiest variant on C<get> is C<getprint>, which is useful in Perl
one-liners.  If it can get the page whose URL you provide, it sends it
to STDOUT; otherwise it complains to STDERR.

  % perl -MLWP::Simple -e "getprint 'http://www.cpan.org/RECENT'"

That is the URL of a plain text file that lists new files in CPAN in
the past two weeks.  You can easily make it part of a tidy little
shell command, like this one that mails you the list of new
C<Acme::> modules:

  % perl -MLWP::Simple -e "getprint 'http://www.cpan.org/RECENT'"  \
     | grep "/by-module/Acme" | mail -s "New Acme modules! Joy!" $USER

There are other useful functions in LWP::Simple, including one function
for running a HEAD request on a URL (useful for checking links, or
getting the last-revised time of a URL), and two functions for
saving/mirroring a URL to a local file. See L<the LWP::Simple
documentation|LWP::Simple> for the full details, or chapter 2 of I<Perl
& LWP> for more examples.


=for comment
 ##########################################################################


=head2 The Basics of the LWP Class Model

LWP::Simple's functions are handy for simple cases, but its functions
don't support cookies or authorization, don't support setting header
lines in the HTTP request, generally don't support reading header lines
in the HTTP response (notably the full HTTP error message, in case of an
error). To get at all those features, you'll have to use the full LWP
class model.

While LWP consists of dozens of classes, the main two that you have to
understand are L<LWP::UserAgent> and L<HTTP::Response>. LWP::UserAgent
is a class for "virtual browsers" which you use for performing requests,
and L<HTTP::Response> is a class for the responses (or error messages)
that you get back from those requests.

The basic idiom is C<< $response = $browser->get($url) >>, or more fully
illustrated:

  # Early in your program:
  
  use LWP 5.64; # Loads all important LWP classes, and makes
                #  sure your version is reasonably recent.

  my $browser = LWP::UserAgent->new;
  
  ...
  
  # Then later, whenever you need to make a get request:
  my $url = 'http://www.npr.org/programs/fa/?todayDate=current';
  
  my $response = $browser->get( $url );
  die "Can't get $url -- ", $response->status_line
   unless $response->is_success;

  die "Hey, I was expecting HTML, not ", $response->content_type
   unless $response->content_type eq 'text/html';
     # or whatever content-type you're equipped to deal with

  # Otherwise, process the content somehow:
  
  if($response->decoded_content =~ m/jazz/i) {
    print "They're talking about jazz today on Fresh Air!\n";
  }
  else {
    print "Fresh Air is apparently jazzless today.\n";
  }

There are two objects involved: C<$browser>, which holds an object of
class LWP::UserAgent, and then the C<$response> object, which is of
class HTTP::Response. You really need only one browser object per
program; but every time you make a request, you get back a new
HTTP::Response object, which will have some interesting attributes:

=over

=item *

A status code indicating
success or failure
(which you can test with C<< $response->is_success >>).

=item *

An HTTP status
line that is hopefully informative if there's failure (which you can
see with C<< $response->status_line >>,
returning something like "404 Not Found").

=item *

A MIME content-type like "text/html", "image/gif",
"application/xml", etc., which you can see with 
C<< $response->content_type >>

=item *

The actual content of the response, in C<< $response->decoded_content >>.
If the response is HTML, that's where the HTML source will be; if
it's a GIF, then C<< $response->decoded_content >> will be the binary
GIF data.

=item *

And dozens of other convenient and more specific methods that are
documented in the docs for L<HTTP::Response>, and its superclasses
L<HTTP::Message> and L<HTTP::Headers>.

=back


=for comment
 ##########################################################################


=head2 Adding Other HTTP Request Headers

The most commonly used syntax for requests is C<< $response =
$browser->get($url) >>, but in truth, you can add extra HTTP header
lines to the request by adding a list of key-value pairs after the URL,
like so:

  $response = $browser->get( $url, $key1, $value1, $key2, $value2, ... );

For example, here's how to send some commonly used headers, in case
you're dealing with a site that would otherwise reject your request:


  my @ns_headers = (
   'User-Agent' => 'Mozilla/4.76 [en] (Win98; U)',
   'Accept' => 'image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, image/png, */*',
   'Accept-Charset' => 'iso-8859-1,*,utf-8',
   'Accept-Language' => 'en-US',
  );

  ...
  
  $response = $browser->get($url, @ns_headers);

If you weren't reusing that array, you could just go ahead and do this: 

  $response = $browser->get($url,
   'User-Agent' => 'Mozilla/4.76 [en] (Win98; U)',
   'Accept' => 'image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, image/png, */*',
   'Accept-Charset' => 'iso-8859-1,*,utf-8',
   'Accept-Language' => 'en-US',
  );

If you were only ever changing the 'User-Agent' line, you could just change
the C<$browser> object's default line from "libwww-perl/5.65" (or the like)
to whatever you like, using the LWP::UserAgent C<agent> method:

   $browser->agent('Mozilla/4.76 [en] (Win98; U)');


=for comment
 ##########################################################################


=head2 Enabling Cookies

A default LWP::UserAgent object acts like a browser with its cookies
support turned off. There are various ways of turning it on, by setting
its C<cookie_jar> attribute. A "cookie jar" is an object representing
a little database of all
the HTTP cookies that a browser knows about. It can correspond to a
file on disk or 
an in-memory object that starts out empty, and whose collection of
cookies will disappear once the program is finished running.

To give a browser an in-memory empty cookie jar, you set its C<cookie_jar>
attribute like so:

  use HTTP::CookieJar::LWP;
  $browser->cookie_jar( HTTP::CookieJar::LWP->new );

To save a cookie jar to disk, see L<< HTTP::CookieJar/dump_cookies >>.
To load cookies from disk into a jar, see L<<
HTTP::CookieJar/load_cookies >>.

=for comment
 ##########################################################################


=head2 Posting Form Data

Many HTML forms send data to their server using an HTTP POST request, which
you can send with this syntax:

 $response = $browser->post( $url,
   [
     formkey1 => value1, 
     formkey2 => value2, 
     ...
   ],
 );

Or if you need to send HTTP headers:

 $response = $browser->post( $url,
   [
     formkey1 => value1, 
     formkey2 => value2, 
     ...
   ],
   headerkey1 => value1, 
   headerkey2 => value2, 
 );

For example, the following program makes a search request to AltaVista
(by sending some form data via an HTTP POST request), and extracts from
the HTML the report of the number of matches:

  use strict;
  use warnings;
  use LWP 5.64;
  my $browser = LWP::UserAgent->new;

  my $word = 'tarragon';

  my $url = 'http://search.yahoo.com/yhs/search';
  my $response = $browser->post( $url,
    [ 'q' => $word,  # the Altavista query string
      'fr' => 'altavista', 'pg' => 'q', 'avkw' => 'tgz', 'kl' => 'XX',
    ]
  );
  die "$url error: ", $response->status_line
   unless $response->is_success;
  die "Weird content type at $url -- ", $response->content_type
   unless $response->content_is_html;

  if( $response->decoded_content =~ m{([0-9,]+)(?:<.*?>)? results for} ) {
    # The substring will be like "996,000</strong> results for"
    print "$word: $1\n";
  }
  else {
    print "Couldn't find the match-string in the response\n";
  }


=for comment
 ##########################################################################


=head2 Sending GET Form Data

Some HTML forms convey their form data not by sending the data
in an HTTP POST request, but by making a normal GET request with
the data stuck on the end of the URL.  For example, if you went to
C<www.imdb.com> and ran a search on "Blade Runner", the URL you'd see
in your browser window would be:

  http://www.imdb.com/find?s=all&q=Blade+Runner

To run the same search with LWP, you'd use this idiom, which involves
the URI class:

  use URI;
  my $url = URI->new( 'http://www.imdb.com/find' );
    # makes an object representing the URL

  $url->query_form(  # And here the form data pairs:
    'q' => 'Blade Runner',
    's' => 'all',
  );

  my $response = $browser->get($url);

See chapter 5 of I<Perl & LWP> for a longer discussion of HTML forms
and of form data, and chapters 6 through 9 for a longer discussion of
extracting data from HTML.


=head2 Absolutizing URLs

The URI class that we just mentioned above provides all sorts of methods
for accessing and modifying parts of URLs (such as asking sort of URL it
is with C<< $url->scheme >>, and asking what host it refers to with C<<
$url->host >>, and so on, as described in L<the docs for the URI
class|URI>.  However, the methods of most immediate interest
are the C<query_form> method seen above, and now the C<new_abs> method
for taking a probably-relative URL string (like "../foo.html") and getting
back an absolute URL (like "http://www.perl.com/stuff/foo.html"), as
shown here:

  use URI;
  $abs = URI->new_abs($maybe_relative, $base);

For example, consider this program that matches URLs in the HTML
list of new modules in CPAN:

  use strict;
  use warnings;
  use LWP;
  my $browser = LWP::UserAgent->new;
  
  my $url = 'http://www.cpan.org/RECENT.html';
  my $response = $browser->get($url);
  die "Can't get $url -- ", $response->status_line
   unless $response->is_success;
  
  my $html = $response->decoded_content;
  while( $html =~ m/<A HREF=\"(.*?)\"/g ) {
    print "$1\n";
  }

When run, it emits output that starts out something like this:

  MIRRORING.FROM
  RECENT
  RECENT.html
  authors/00whois.html
  authors/01mailrc.txt.gz
  authors/id/A/AA/AASSAD/CHECKSUMS
  ...

However, if you actually want to have those be absolute URLs, you
can use the URI module's C<new_abs> method, by changing the C<while>
loop to this:

  while( $html =~ m/<A HREF=\"(.*?)\"/g ) {
    print URI->new_abs( $1, $response->base ) ,"\n";
  }

(The C<< $response->base >> method from L<HTTP::Message|HTTP::Message>
is for returning what URL
should be used for resolving relative URLs -- it's usually just
the same as the URL that you requested.)

That program then emits nicely absolute URLs:

  http://www.cpan.org/MIRRORING.FROM
  http://www.cpan.org/RECENT
  http://www.cpan.org/RECENT.html
  http://www.cpan.org/authors/00whois.html
  http://www.cpan.org/authors/01mailrc.txt.gz
  http://www.cpan.org/authors/id/A/AA/AASSAD/CHECKSUMS
  ...

See chapter 4 of I<Perl & LWP> for a longer discussion of URI objects.

Of course, using a regexp to match hrefs is a bit simplistic, and for
more robust programs, you'll probably want to use an HTML-parsing module
like L<HTML::LinkExtor> or L<HTML::TokeParser> or even maybe
L<HTML::TreeBuilder>.


=for comment
 ##########################################################################

=head2 Other Browser Attributes

LWP::UserAgent objects have many attributes for controlling how they
work.  Here are a few notable ones:

=over

=item *

C<< $browser->timeout(15); >>

This sets this browser object to give up on requests that don't answer
within 15 seconds.


=item *

C<< $browser->protocols_allowed( [ 'http', 'gopher'] ); >>

This sets this browser object to not speak any protocols other than HTTP
and gopher. If it tries accessing any other kind of URL (like an "ftp:"
or "mailto:" or "news:" URL), then it won't actually try connecting, but
instead will immediately return an error code 500, with a message like
"Access to 'ftp' URIs has been disabled".


=item *

C<< use LWP::ConnCache; $browser->conn_cache(LWP::ConnCache->new()); >>

This tells the browser object to try using the HTTP/1.1 "Keep-Alive"
feature, which speeds up requests by reusing the same socket connection
for multiple requests to the same server.


=item *

C<< $browser->agent( 'SomeName/1.23 (more info here maybe)' ) >>

This changes how the browser object will identify itself in
the default "User-Agent" line is its HTTP requests.  By default,
it'll send "libwww-perl/I<versionnumber>", like
"libwww-perl/5.65".  You can change that to something more descriptive
like this:

  $browser->agent( 'SomeName/3.14 (contact@robotplexus.int)' );

Or if need be, you can go in disguise, like this:

  $browser->agent( 'Mozilla/4.0 (compatible; MSIE 5.12; Mac_PowerPC)' );


=item *

C<< push @{ $ua->requests_redirectable }, 'POST'; >>

This tells this browser to obey redirection responses to POST requests
(like most modern interactive browsers), even though the HTTP RFC says
that should not normally be done.


=back


For more options and information, see L<the full documentation for
LWP::UserAgent|LWP::UserAgent>.


=for comment
 ##########################################################################


=head2 Writing Polite Robots

If you want to make sure that your LWP-based program respects F<robots.txt>
files and doesn't make too many requests too fast, you can use the LWP::RobotUA
class instead of the LWP::UserAgent class.

LWP::RobotUA class is just like LWP::UserAgent, and you can use it like so:

  use LWP::RobotUA;
  my $browser = LWP::RobotUA->new('YourSuperBot/1.34', 'you@yoursite.com');
    # Your bot's name and your email address

  my $response = $browser->get($url);

But HTTP::RobotUA adds these features:


=over

=item *

If the F<robots.txt> on C<$url>'s server forbids you from accessing
C<$url>, then the C<$browser> object (assuming it's of class LWP::RobotUA)
won't actually request it, but instead will give you back (in C<$response>) a 403 error
with a message "Forbidden by robots.txt".  That is, if you have this line:

  die "$url -- ", $response->status_line, "\nAborted"
   unless $response->is_success;

then the program would die with an error message like this:

  http://whatever.site.int/pith/x.html -- 403 Forbidden by robots.txt
  Aborted at whateverprogram.pl line 1234

=item *

If this C<$browser> object sees that the last time it talked to
C<$url>'s server was too recently, then it will pause (via C<sleep>) to
avoid making too many requests too often. How long it will pause for, is
by default one minute -- but you can control it with the C<<
$browser->delay( I<minutes> ) >> attribute.

For example, this code:

  $browser->delay( 7/60 );

...means that this browser will pause when it needs to avoid talking to
any given server more than once every 7 seconds.

=back

For more options and information, see L<the full documentation for
LWP::RobotUA|LWP::RobotUA>.


=for comment
 ##########################################################################

=head2 Using Proxies

In some cases, you will want to (or will have to) use proxies for
accessing certain sites and/or using certain protocols. This is most
commonly the case when your LWP program is running (or could be running)
on a machine that is behind a firewall.

To make a browser object use proxies that are defined in the usual
environment variables (C<HTTP_PROXY>, etc.), just call the C<env_proxy>
on a user-agent object before you go making any requests on it.
Specifically:

  use LWP::UserAgent;
  my $browser = LWP::UserAgent->new;
  
  # And before you go making any requests:
  $browser->env_proxy;

For more information on proxy parameters, see L<the LWP::UserAgent
documentation|LWP::UserAgent>, specifically the C<proxy>, C<env_proxy>,
and C<no_proxy> methods.


=for comment
 ##########################################################################

=head2 HTTP Authentication

Many web sites restrict access to documents by using "HTTP
Authentication". This isn't just any form of "enter your password"
restriction, but is a specific mechanism where the HTTP server sends the
browser an HTTP code that says "That document is part of a protected
'realm', and you can access it only if you re-request it and add some
special authorization headers to your request".

For example, the Unicode.org admins stop email-harvesting bots from
harvesting the contents of their mailing list archives, by protecting
them with HTTP Authentication, and then publicly stating the username
and password (at C<http://www.unicode.org/mail-arch/>) -- namely
username "unicode-ml" and password "unicode".  

For example, consider this URL, which is part of the protected
area of the web site:

  http://www.unicode.org/mail-arch/unicode-ml/y2002-m08/0067.html

If you access that with a browser, you'll get a prompt
like 
"Enter username and password for 'Unicode-MailList-Archives' at server
'www.unicode.org'".

In LWP, if you just request that URL, like this:

  use LWP;
  my $browser = LWP::UserAgent->new;

  my $url =
   'http://www.unicode.org/mail-arch/unicode-ml/y2002-m08/0067.html';
  my $response = $browser->get($url);

  die "Error: ", $response->header('WWW-Authenticate') || 'Error accessing',
    #  ('WWW-Authenticate' is the realm-name)
    "\n ", $response->status_line, "\n at $url\n Aborting"
   unless $response->is_success;

Then you'll get this error:

  Error: Basic realm="Unicode-MailList-Archives"
   401 Authorization Required
   at http://www.unicode.org/mail-arch/unicode-ml/y2002-m08/0067.html
   Aborting at auth1.pl line 9.  [or wherever]

...because the C<$browser> doesn't know any the username and password
for that realm ("Unicode-MailList-Archives") at that host
("www.unicode.org").  The simplest way to let the browser know about this
is to use the C<credentials> method to let it know about a username and
password that it can try using for that realm at that host.  The syntax is:

  $browser->credentials(
    'servername:portnumber',
    'realm-name',
   'username' => 'password'
  );

In most cases, the port number is 80, the default TCP/IP port for HTTP; and
you usually call the C<credentials> method before you make any requests.
For example:

  $browser->credentials(
    'reports.mybazouki.com:80',
    'web_server_usage_reports',
    'plinky' => 'banjo123'
  );

So if we add the following to the program above, right after the C<<
$browser = LWP::UserAgent->new; >> line...

  $browser->credentials(  # add this to our $browser 's "key ring"
    'www.unicode.org:80',
    'Unicode-MailList-Archives',
    'unicode-ml' => 'unicode'
  );

...then when we run it, the request succeeds, instead of causing the
C<die> to be called.


=for comment
 ##########################################################################

=head2 Accessing HTTPS URLs

When you access an HTTPS URL, it'll work for you just like an HTTP URL
would -- if your LWP installation has HTTPS support (via an appropriate
Secure Sockets Layer library).  For example:

  use LWP;
  my $url = 'https://www.paypal.com/';   # Yes, HTTPS!
  my $browser = LWP::UserAgent->new;
  my $response = $browser->get($url);
  die "Error at $url\n ", $response->status_line, "\n Aborting"
   unless $response->is_success;
  print "Whee, it worked!  I got that ",
   $response->content_type, " document!\n";

If your LWP installation doesn't have HTTPS support set up, then the
response will be unsuccessful, and you'll get this error message:

  Error at https://www.paypal.com/
   501 Protocol scheme 'https' is not supported
   Aborting at paypal.pl line 7.   [or whatever program and line]

If your LWP installation I<does> have HTTPS support installed, then the
response should be successful, and you should be able to consult
C<$response> just like with any normal HTTP response.

For information about installing HTTPS support for your LWP
installation, see the helpful F<README.SSL> file that comes in the
libwww-perl distribution.


=for comment
 ##########################################################################


=head2 Getting Large Documents

When you're requesting a large (or at least potentially large) document,
a problem with the normal way of using the request methods (like C<<
$response = $browser->get($url) >>) is that the response object in
memory will have to hold the whole document -- I<in memory>. If the
response is a thirty megabyte file, this is likely to be quite an
imposition on this process's memory usage.

A notable alternative is to have LWP save the content to a file on disk,
instead of saving it up in memory.  This is the syntax to use:

  $response = $ua->get($url,
                         ':content_file' => $filespec,
                      );

For example,

  $response = $ua->get('http://search.cpan.org/',
                         ':content_file' => '/tmp/sco.html'
                      );

When you use this C<:content_file> option, the C<$response> will have
all the normal header lines, but C<< $response->content >> will be
empty.  Errors writing to the content file (for example due to
permission denied or the filesystem being full) will be reported via
the C<Client-Aborted> or C<X-Died> response headers, and not the
C<is_success> method:

  if ($response->header('Client-Aborted') eq 'die') {
    # handle error ...

Note that this ":content_file" option isn't supported under older
versions of LWP, so you should consider adding C<use LWP 5.66;> to check
the LWP version, if you think your program might run on systems with
older versions.

If you need to be compatible with older LWP versions, then use
this syntax, which does the same thing:

  use HTTP::Request::Common;
  $response = $ua->request( GET($url), $filespec );


=for comment
 ##########################################################################


=head1 SEE ALSO

Remember, this article is just the most rudimentary introduction to
LWP -- to learn more about LWP and LWP-related tasks, you really
must read from the following:

=over

=item *

L<LWP::Simple> -- simple functions for getting/heading/mirroring URLs

=item *

L<LWP> -- overview of the libwww-perl modules

=item *

L<LWP::UserAgent> -- the class for objects that represent "virtual browsers"

=item *

L<HTTP::Response> -- the class for objects that represent the response to
a LWP response, as in C<< $response = $browser->get(...) >>

=item *

L<HTTP::Message> and L<HTTP::Headers> -- classes that provide more methods
to HTTP::Response.

=item *

L<URI> -- class for objects that represent absolute or relative URLs

=item *

L<URI::Escape> -- functions for URL-escaping and URL-unescaping strings
(like turning "this & that" to and from "this%20%26%20that").

=item *

L<HTML::Entities> -- functions for HTML-escaping and HTML-unescaping strings
(like turning "C. & E. BrontE<euml>" to and from "C. &amp; E. Bront&euml;")

=item *

L<HTML::TokeParser> and L<HTML::TreeBuilder> -- classes for parsing HTML

=item *

L<HTML::LinkExtor> -- class for finding links in HTML documents

=item *

The book I<Perl & LWP> by Sean M. Burke.  O'Reilly & Associates, 
2002.  ISBN: 0-596-00178-9, L<http://oreilly.com/catalog/perllwp/>.  The
whole book is also available free online:
L<http://lwp.interglacial.com>.

=back


=head1 COPYRIGHT

Copyright 2002, Sean M. Burke.  You can redistribute this document and/or
modify it, but only under the same terms as Perl itself.

=head1 AUTHOR

Sean M. Burke C<sburke@cpan.org>

=for comment
 ##########################################################################

=cut

# End of Pod
PK       ! !	M}�A  �A    perl5/alienfile.pmnu ��6�$        package alienfile;

use strict;
use warnings;
use 5.008004;
use Alien::Build;
use Exporter ();
use Path::Tiny ();
use Carp ();

sub _path { Path::Tiny::path(@_) }

# ABSTRACT: Specification for defining an external dependency for CPAN
our $VERSION = '2.83'; # VERSION


our @EXPORT = qw( requires on plugin probe configure share sys download fetch decode prefer extract patch patch_ffi build build_ffi gather gather_ffi meta_prop ffi log test start_url before after digest );


sub requires
{
  my($module, $version) = @_;
  $version ||= 0;
  my $caller = caller;
  my $meta = $caller->meta;
  $meta->add_requires($meta->{phase}, $module, $version);
  ();
}


sub plugin
{
  my($name, @args) = @_;

  my $caller = caller;
  $caller->meta->apply_plugin($name, @args);
  return;
}


sub probe
{
  my($instr) = @_;
  my $caller = caller;
  if(my $phase = $caller->meta->{phase})
  {
    Carp::croak "probe must not be in a $phase block" if $phase ne 'any';
  }
  $caller->meta->register_hook(probe => $instr);
  return;
}


sub _phase
{
  my($code, $phase) = @_;
  my $caller = caller(1);
  my $meta = $caller->meta;
  local $meta->{phase} = $phase;
  $code->();
  return;
}

sub configure (&)
{
  _phase($_[0], 'configure');
}


sub sys (&)
{
  _phase($_[0], 'system');
}


sub share (&)
{
  _phase($_[0], 'share');
}


sub _in_phase
{
  my($phase) = @_;
  my $caller = caller(1);
  my(undef, undef, undef, $sub) = caller(1);
  my $meta = $caller->meta;
  $sub =~ s/^.*:://;
  Carp::croak "$sub must be in a $phase block"
    unless $meta->{phase} eq $phase;
}

sub start_url
{
  my($url) = @_;
  _in_phase 'share';
  my $caller = caller;
  my $meta = $caller->meta;
  $meta->prop->{start_url} = $url;
  $meta->add_requires('configure' => 'Alien::Build' => '1.19');
  return;
}


sub digest
{
  my($algo, $digest) = @_;

  my $caller = caller;
  $caller->meta->apply_plugin('Digest', [$algo, $digest]);
  return;
}


sub download
{
  my($instr) = @_;
  _in_phase 'share';
  my $caller = caller;
  $caller->meta->register_hook(download => $instr);
  return;
}


sub fetch
{
  my($instr) = @_;
  _in_phase 'share';
  my $caller = caller;
  $caller->meta->register_hook(fetch => $instr);
  return;
}


sub decode
{
  my($instr) = @_;
  _in_phase 'share';
  my $caller = caller;
  $caller->meta->register_hook(decode => $instr);
  return;
}


sub prefer
{
  my($instr) = @_;
  _in_phase 'share';
  my $caller = caller;
  $caller->meta->register_hook(prefer => $instr);
  return;
}


sub extract
{
  my($instr) = @_;
  _in_phase 'share';
  my $caller = caller;
  $caller->meta->register_hook(extract => $instr);
  return;
}


sub patch
{
  my($instr) = @_;
  _in_phase 'share';
  my $caller = caller;
  my $suffix = $caller->meta->{build_suffix};
  $caller->meta->register_hook("patch$suffix" => $instr);
  return;
}


sub patch_ffi
{
  my($instr) = @_;
  Carp::carp("patch_ffi is deprecated, use ffi { patch ... } } instead");
  _in_phase 'share';
  my $caller = caller;
  $caller->meta->register_hook(patch_ffi => $instr);
  return;
}


sub build
{
  my($instr) = @_;
  _in_phase 'share';
  my $caller = caller;
  my $suffix = $caller->meta->{build_suffix};
  $caller->meta->register_hook("build$suffix" => $instr);
  return;
}


sub build_ffi
{
  my($instr) = @_;
  Carp::carp("build_ffi is deprecated, use ffi { build ... } } instead");
  _in_phase 'share';
  my $caller = caller;
  $caller->meta->register_hook(build_ffi => $instr);
  return;
}


sub gather
{
  my($instr) = @_;
  my $caller = caller;
  my $meta = $caller->meta;
  my $phase = $meta->{phase};
  Carp::croak "gather is not allowed in configure block"
    if $phase eq 'configure';
  my $suffix = $caller->meta->{build_suffix};
  if($suffix eq '_ffi')
  {
    $meta->register_hook(gather_ffi => $instr)
  }
  else
  {
    $meta->register_hook(gather_system => $instr) if $phase =~ /^(any|system)$/;
    $meta->register_hook(gather_share => $instr)  if $phase =~ /^(any|share)$/;
  }
  return;
}


sub gather_ffi
{
  my($instr) = @_;
  Carp::carp("gather_ffi is deprecated, use ffi { gather ... } } instead");
  _in_phase 'share';
  my $caller = caller;
  $caller->meta->register_hook(gather_ffi => $instr);
  return;
}


sub ffi (&)
{
  my($code) = @_;
  _in_phase 'share';
  my $caller = caller;
  local $caller->meta->{build_suffix} = '_ffi';
  $code->();
  return;
}


sub meta_prop
{
  my $caller = caller;
  my $meta = $caller->meta;
  $meta->prop;
}


sub log
{
  unshift @_, 'Alien::Build';
  goto &Alien::Build::log;
}


sub test
{
  my($instr) = @_;
  my $caller = caller;
  my $meta = $caller->meta;
  my $phase = $meta->{phase};
  Carp::croak "test is not allowed in $phase block"
    if $phase eq 'any' || $phase eq 'configure';

  $meta->add_requires('configure' => 'Alien::Build' => '1.14');

  if($phase eq 'share')
  {
    my $suffix = $caller->meta->{build_suffix} || '_share';
    $meta->register_hook(
      "test$suffix" => $instr,
    );
  }
  elsif($phase eq 'system')
  {
    $meta->register_hook(
      "test_system" => $instr,
    );
  }
  else
  {
    die "unknown phase: $phase";
  }
}


my %modifiers = (
  probe    => { any   => 'probe'    },
  download => { share => 'download' },
  fetch    => { share => 'fetch'    },
  decode   => { share => 'fetch'    },
  prefer   => { share => 'prefer'   },
  extract  => { share => 'extract'  },
  patch    => { share => 'patch$'   },
  build    => { share => 'build$'   },
  test     => { share => 'test$'    },
  # Note: below special case gather_ffi for the ffi block :P
  gather   => { share => 'gather_share', system => 'gather_system', any => 'gather_share,gather_system' },
);

sub _add_modifier
{
  my($type, $stage, $sub) = @_;

  my $method = "${type}_hook";

  Carp::croak "No such stage $stage" unless defined $modifiers{$stage};
  Carp::croak "$type $stage argument must be a code reference" unless defined $sub && ref($sub) eq 'CODE';

  my $caller = caller;
  my $meta = $caller->meta;
  Carp::croak "$type $stage is not allowed in sys block" unless defined $modifiers{$stage}->{$meta->{phase}};

  $meta->add_requires('configure' => 'Alien::Build' => '1.40');

  my $suffix = $meta->{build_suffix};
  if($suffix eq '_ffi' && $stage eq 'gather')
  {
    $meta->$method('gather_ffi' => $sub);
  }

  foreach my $hook (
    map { split /,/, $_ }                        # split on , for when multiple hooks must be attached (gather in any)
    map { my $x = $_ ; $x =~ s/\$/$suffix/; $x } # substitute $ at the end for a suffix (_ffi) if any
    $modifiers{$stage}->{$meta->{phase}})        # get the list of modifiers
  {
    $meta->$method($hook => $sub);
  }

  return;
}

sub before
{
  my($stage, $sub) = @_;
  @_ = ('before', @_);
  goto &alienfile::_add_modifier;
}


sub after
{
  my($stage, $sub) = @_;
  @_ = ('after', @_);
  goto &alienfile::_add_modifier;
}

sub import
{
  strict->import;
  warnings->import;
  goto &Exporter::import;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

alienfile - Specification for defining an external dependency for CPAN

=head1 VERSION

version 2.83

=head1 SYNOPSIS

Do-it-yourself approach:

 use alienfile;
 
 probe [ 'pkg-config --exists libarchive' ];
 
 share {
 
   start_url 'http://libarchive.org/downloads/libarchive-3.2.2.tar.gz';
 
   # the first one which succeeds will be used
   download [ 'wget %{.meta.start_url}' ];
   download [ 'curl -o %{.meta.start_url}' ];
 
   extract [ 'tar xf %{.install.download}' ];
 
   build [
     # Note: will not work on Windows, better to use Build::Autoconf plugin
     # if you need windows support
     './configure --prefix=%{.install.prefix} --disable-shared',
     '%{make}',
     '%{make} install',
   ];
 }
 
 gather [
   [ 'pkg-config', '--modversion', 'libarchive', \'%{.runtime.version}' ],
   [ 'pkg-config', '--cflags',     'libarchive', \'%{.runtime.cflags}'  ],
   [ 'pkg-config', '--libs',       'libarchive', \'%{.runtime.libs}'    ],
 ];

With plugins (better):

 use alienfile;
 
 plugin 'PkgConfig' => 'libarchive';
 
 share {
   start_url 'http://libarchive.org/downloads/';
   plugin Download => (
     filter => qr/^libarchive-.*\.tar\.gz$/,
     version => qr/([0-9\.]+)/,
   );
   plugin Extract => 'tar.gz';
   plugin 'Build::Autoconf';
   plugin 'Gather::IsolateDynamic';
   build [
     '%{configure}',
     '%{make}',
     '%{make} install',
   ];
 };

=head1 DESCRIPTION

An alienfile is a recipe used by L<Alien::Build> to, probe for system libraries or download from the internet, and build source
for those libraries.  This document acts as reference for the alienfile system, but if you are starting out writing your own Alien
you should read L<Alien::Build::Manual::AlienAuthor>, which will teach you how to write your own complete Alien using alienfile +
L<Alien::Build> + L<ExtUtils::MakeMaker>.  Special attention should be taken to the section "a note about dynamic vs. static
libraries".

=head1 DIRECTIVES

=head2 requires

"any" requirement (either share or system):

 requires $module;
 requires $module => $version;

configure time requirement:

 configure {
   requires $module;
   requires $module => $version;
 };

system requirement:

 sys {
   requires $module;
   requires $module => $version;
 };

share requirement:

 share {
   requires $module;
   requires $module => $version;
 };

specifies a requirement.  L<Alien::Build> takes advantage of dynamic requirements, so only
modules that are needed for the specific type of install need to be loaded.  Here are the
different types of requirements:

=over

=item configure

Configure requirements should already be installed before the alienfile is loaded.

=item any

"Any" requirements are those that are needed either for the probe stage, or in either the
system or share installs.

=item share

Share requirements are those modules needed when downloading and building from source.

=item system

System requirements are those modules needed when the system provides the library or tool.

=back

=head2 plugin

 plugin $name => (%args);
 plugin $name => $arg;

Load the given plugin.  If you prefix the plugin name with an C<=> sign,
then it will be assumed to be a fully qualified path name.  Otherwise the
plugin will be assumed to live in the C<Alien::Build::Plugin> namespace.
If there is an appropriate negotiate plugin, that one will be loaded.
Examples:

 # Loads Alien::Build::Plugin::Fetch::Negotiate
 # which will pick the best Alien::Build::Plugin::Fetch
 # plugin based on the URL, and system configuration
 plugin 'Fetch' => 'http://ftp.gnu.org/gnu/gcc';
 
 # loads the plugin with the badly named class!
 plugin '=Badly::Named::Plugin::Not::In::Alien::Build::Namespace';
 
 # explicitly loads Alien::Build::Plugin::Prefer::SortVersions
 plugin 'Prefer::SortVersions' => (
   filter => qr/^gcc-.*\.tar\.gz$/,
   version => qr/([0-9\.]+)/,
 );

=head2 probe

 probe \&code;
 probe \@commandlist;

Instructions for the probe stage.  May be either a code reference, or a command list.
Multiple probes and probe plugins can be given.  These will be used in sequence,
stopping at the first that detects a system installation.  L<Alien::Build> will use
a share install if no system installation is detected by the probes.

=head2 configure

 configure {
   ...
 };

Configure block.  The only directive allowed in a configure block is
requires.

=head2 sys

 sys {
   ...
 };

System block.  Allowed directives are: requires and gather.

=head2 share

 share {
   ...
 };

System block.  Allowed directives are: download, fetch, decode, prefer, extract, build, gather.

=head2 start_url

 share {
   start_url $url;
 };

Set the start URL for download.  This should be the URL to an index page, or the actual tarball of the source.

=head2 digest

[experimental]

 share {
   digest $algorithm, $digest;
 };

Check fetched and downloaded files against the given algorithm and
digest.  Typically you will want to use SHA256 as the algorithm.

=head2 download

 share {
   download \&code;
   download \@commandlist;
 };

Instructions for the download stage.  May be either a
code reference, or a command list.

=head2 fetch

 share {
   fetch \&code;
   fetch \@commandlist;
 };

Instructions for the fetch stage.  May be either a
code reference, or a command list.

=head2 decode

 share {
   decode \&code;
   decode \@commandlist;
 };

Instructions for the decode stage.  May be either a
code reference, or a command list.

=head2 prefer

 share {
   prefer \&code;
   prefer \@commandlist;
 };

Instructions for the prefer stage.  May be either a
code reference, or a command list.

=head2 extract

 share {
   extract \&code;
   extract \@commandlist;
 };

Instructions for the extract stage.  May be either a
code reference, or a command list.

=head2 patch

 share {
   patch \&code;
   patch \@commandlist;
 };

Instructions for the patch stage.  May be either a
code reference, or a command list.

=head2 patch_ffi

 share {
   patch_ffi \&code;
   patch_ffi \@commandlist;
 };

[DEPRECATED]

Instructions for the patch_ffi stage.  May be either a
code reference, or a command list.

=head2 build

 share {
   build \&code;
   build \@commandlist;
 };

Instructions for the build stage.  May be either a
code reference, or a command list.

=head2 build_ffi

 share {
   build \&code;
   build \@commandlist;
 };

[DEPRECATED]

Instructions for the build FFI stage.  Builds shared libraries instead of static.
This is optional, and is only necessary if a fresh and separate build needs to be
done for FFI.

=head2 gather

 gather \&code;
 gather \@commandlist;
 
 share {
   gather \&code;
   gather \@commandlist;
 };
 
 sys {
   gather \&code;
   gather \@commandlist;
 };

Instructions for the gather stage.  May be either a code reference, or a command list.
In the root block of the alienfile it will trigger in both share and system build.
In the share or sys block it will only trigger in the corresponding build.

=head2 gather_ffi

 share {
   gather_ffi \&code;
   gather_ffi \@commandlist;
 }

[DEPRECATED]

Gather specific to C<build_ffi>.  Not usually necessary.

=head2 ffi

 share {
   ffi {
     patch \&code;
     patch \@commandlist;
     build \&code;
     build \@commandlist;
     gather \&code;
     gather \@commandlist;
   }
 }

Specify patch, build or gather stages related to FFI.

=head2 meta_prop

 my $hash = meta_prop;

Get the meta_prop hash reference.

=head2 meta

 my $meta = meta;

Returns the meta object for your L<alienfile>.  For methods that can be used on the
meta object, see L<Alien::Build/"META METHODS">.

=head2 log

 log($message);

Prints the given log to stdout.

=head2 test

 share {
   test \&code;
   test \@commandlist;
 };
 sys {
   test \&code;
   test \@commandlist;
 };

Run the tests

=head2 before

 before $stage => \&code;

Execute the given code before the given stage.  Stage should be one of
C<probe>, C<download>, C<fetch>, C<decode>, C<prefer>, C<extract>,
C<patch>, C<build>, C<test>, and C<gather>.

The before directive is only legal in the same blocks as the stage would
normally be legal in.  For example, you can't do this:

 use alienfile;
 
 sys {
   before 'build' => sub {
     ...
   };
 };

Because a C<build> wouldn't be legal inside a C<sys> block.

=head2 after

 after $stage => \&code;

Execute the given code after the given stage.  Stage should be one of
C<probe>, C<download>, C<fetch>, C<decode>, C<prefer>, C<extract>,
C<patch>, C<build>, C<test>, and C<gather>.

The after directive is only legal in the same blocks as the stage would
normally be legal in.  For example, you can't do this:

 use alienfile;
 
 sys {
   after 'build' => sub {
     ...
   };
 };

Because a C<build> wouldn't be legal inside a C<sys> block.

=head1 SEE ALSO

=over 4

=item L<Alien>

=item L<Alien::Build>

=item L<Alien::Build::MM>

=item L<Alien::Base>

=back

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! ���|1  1    perl5/cPanelUserConfig.pmnu �[���        # cpanel - cPanelUserConfig.pm                  Copyright(c) 2021 cPanel, L.L.C.
#                                                           All Rights Reserved.
# copyright@cpanel.net                                         http://cpanel.net
# This code is subject to the cPanel license. Unauthorized copying is prohibited

BEGIN {
    if ( $> != 0 ) {
        my $b__dir = ( getpwuid($>) )[7] . '/perl';
        unshift @INC, $b__dir . '5/lib/perl5', $b__dir . '5/lib/perl5/x86_64-linux-thread-multi', map { $b__dir . $_ } grep { $_ ne '.' } @INC;
    }
}
1;
PK       ! X6q��R  �R    perl5/Try/Tiny.pmnu ��6�$        package Try::Tiny; # git description: v0.30-11-g1b81d0a
use 5.006;
# ABSTRACT: Minimal try/catch with proper preservation of $@

our $VERSION = '0.31';

use strict;
use warnings;

use Exporter 5.57 'import';
our @EXPORT = our @EXPORT_OK = qw(try catch finally);

use Carp;
$Carp::Internal{+__PACKAGE__}++;

BEGIN {
  my $su = $INC{'Sub/Util.pm'} && defined &Sub::Util::set_subname;
  my $sn = $INC{'Sub/Name.pm'} && eval { Sub::Name->VERSION(0.08) };
  unless ($su || $sn) {
    $su = eval { require Sub::Util; } && defined &Sub::Util::set_subname;
    unless ($su) {
      $sn = eval { require Sub::Name; Sub::Name->VERSION(0.08) };
    }
  }

  *_subname = $su ? \&Sub::Util::set_subname
            : $sn ? \&Sub::Name::subname
            : sub { $_[1] };
  *_HAS_SUBNAME = ($su || $sn) ? sub(){1} : sub(){0};
}

my %_finally_guards;

# Need to prototype as @ not $$ because of the way Perl evaluates the prototype.
# Keeping it at $$ means you only ever get 1 sub because we need to eval in a list
# context & not a scalar one

sub try (&;@) {
  my ( $try, @code_refs ) = @_;

  # we need to save this here, the eval block will be in scalar context due
  # to $failed
  my $wantarray = wantarray;

  # work around perl bug by explicitly initializing these, due to the likelyhood
  # this will be used in global destruction (perl rt#119311)
  my ( $catch, @finally ) = ();

  # find labeled blocks in the argument list.
  # catch and finally tag the blocks by blessing a scalar reference to them.
  foreach my $code_ref (@code_refs) {

    if ( ref($code_ref) eq 'Try::Tiny::Catch' ) {
      croak 'A try() may not be followed by multiple catch() blocks'
        if $catch;
      $catch = ${$code_ref};
    } elsif ( ref($code_ref) eq 'Try::Tiny::Finally' ) {
      push @finally, ${$code_ref};
    } else {
      croak(
        'try() encountered an unexpected argument ('
      . ( defined $code_ref ? $code_ref : 'undef' )
      . ') - perhaps a missing semi-colon before or'
      );
    }
  }

  # FIXME consider using local $SIG{__DIE__} to accumulate all errors. It's
  # not perfect, but we could provide a list of additional errors for
  # $catch->();

  # name the blocks if we have Sub::Name installed
  _subname(caller().'::try {...} ' => $try)
    if _HAS_SUBNAME;

  # set up scope guards to invoke the finally blocks at the end.
  # this should really be a function scope lexical variable instead of
  # file scope + local but that causes issues with perls < 5.20 due to
  # perl rt#119311
  local $_finally_guards{guards} = [
    map Try::Tiny::ScopeGuard->_new($_),
    @finally
  ];

  # save the value of $@ so we can set $@ back to it in the beginning of the eval
  # and restore $@ after the eval finishes
  my $prev_error = $@;

  my ( @ret, $error );

  # failed will be true if the eval dies, because 1 will not be returned
  # from the eval body
  my $failed = not eval {
    $@ = $prev_error;

    # evaluate the try block in the correct context
    if ( $wantarray ) {
      @ret = $try->();
    } elsif ( defined $wantarray ) {
      $ret[0] = $try->();
    } else {
      $try->();
    };

    return 1; # properly set $failed to false
  };

  # preserve the current error and reset the original value of $@
  $error = $@;
  $@ = $prev_error;

  # at this point $failed contains a true value if the eval died, even if some
  # destructor overwrote $@ as the eval was unwinding.
  if ( $failed ) {
    # pass $error to the finally blocks
    push @$_, $error for @{$_finally_guards{guards}};

    # if we got an error, invoke the catch block.
    if ( $catch ) {
      # This works like given($error), but is backwards compatible and
      # sets $_ in the dynamic scope for the body of C<$catch>
      for ($error) {
        return $catch->($error);
      }

      # in case when() was used without an explicit return, the C<for>
      # loop will be aborted and there's no useful return value
    }

    return;
  } else {
    # no failure, $@ is back to what it was, everything is fine
    return $wantarray ? @ret : $ret[0];
  }
}

sub catch (&;@) {
  my ( $block, @rest ) = @_;

  croak 'Useless bare catch()' unless wantarray;

  _subname(caller().'::catch {...} ' => $block)
    if _HAS_SUBNAME;
  return (
    bless(\$block, 'Try::Tiny::Catch'),
    @rest,
  );
}

sub finally (&;@) {
  my ( $block, @rest ) = @_;

  croak 'Useless bare finally()' unless wantarray;

  _subname(caller().'::finally {...} ' => $block)
    if _HAS_SUBNAME;
  return (
    bless(\$block, 'Try::Tiny::Finally'),
    @rest,
  );
}

{
  package # hide from PAUSE
    Try::Tiny::ScopeGuard;

  use constant UNSTABLE_DOLLARAT => ("$]" < '5.013002') ? 1 : 0;

  sub _new {
    shift;
    bless [ @_ ];
  }

  sub DESTROY {
    my ($code, @args) = @{ $_[0] };

    local $@ if UNSTABLE_DOLLARAT;
    eval {
      $code->(@args);
      1;
    } or do {
      warn
        "Execution of finally() block $code resulted in an exception, which "
      . '*CAN NOT BE PROPAGATED* due to fundamental limitations of Perl. '
      . 'Your program will continue as if this event never took place. '
      . "Original exception text follows:\n\n"
      . (defined $@ ? $@ : '$@ left undefined...')
      . "\n"
      ;
    }
  }
}

__PACKAGE__

__END__

=pod

=encoding UTF-8

=head1 NAME

Try::Tiny - Minimal try/catch with proper preservation of $@

=head1 VERSION

version 0.31

=head1 SYNOPSIS

You can use Try::Tiny's C<try> and C<catch> to expect and handle exceptional
conditions, avoiding quirks in Perl and common mistakes:

  # handle errors with a catch handler
  try {
    die "foo";
  } catch {
    warn "caught error: $_"; # not $@
  };

You can also use it like a standalone C<eval> to catch and ignore any error
conditions.  Obviously, this is an extreme measure not to be undertaken
lightly:

  # just silence errors
  try {
    die "foo";
  };

=head1 DESCRIPTION

This module provides bare bones C<try>/C<catch>/C<finally> statements that are designed to
minimize common mistakes with eval blocks, and NOTHING else.

This is unlike L<TryCatch> which provides a nice syntax and avoids adding
another call stack layer, and supports calling C<return> from the C<try> block to
return from the parent subroutine. These extra features come at a cost of a few
dependencies, namely L<Devel::Declare> and L<Scope::Upper> which are
occasionally problematic, and the additional catch filtering uses L<Moose>
type constraints which may not be desirable either.

The main focus of this module is to provide simple and reliable error handling
for those having a hard time installing L<TryCatch>, but who still want to
write correct C<eval> blocks without 5 lines of boilerplate each time.

It's designed to work as correctly as possible in light of the various
pathological edge cases (see L</BACKGROUND>) and to be compatible with any style
of error values (simple strings, references, objects, overloaded objects, etc).

If the C<try> block dies, it returns the value of the last statement executed in
the C<catch> block, if there is one. Otherwise, it returns C<undef> in scalar
context or the empty list in list context. The following examples all
assign C<"bar"> to C<$x>:

  my $x = try { die "foo" } catch { "bar" };
  my $x = try { die "foo" } || "bar";
  my $x = (try { die "foo" }) // "bar";

  my $x = eval { die "foo" } || "bar";

You can add C<finally> blocks, yielding the following:

  my $x;
  try { die 'foo' } finally { $x = 'bar' };
  try { die 'foo' } catch { warn "Got a die: $_" } finally { $x = 'bar' };

C<finally> blocks are always executed making them suitable for cleanup code
which cannot be handled using local.  You can add as many C<finally> blocks to a
given C<try> block as you like.

Note that adding a C<finally> block without a preceding C<catch> block
suppresses any errors. This behaviour is consistent with using a standalone
C<eval>, but it is not consistent with C<try>/C<finally> patterns found in
other programming languages, such as Java, Python, Javascript or C#. If you
learned the C<try>/C<finally> pattern from one of these languages, watch out for
this.

=head1 EXPORTS

All functions are exported by default using L<Exporter>.

If you need to rename the C<try>, C<catch> or C<finally> keyword consider using
L<Sub::Import> to get L<Sub::Exporter>'s flexibility.

=over 4

=item try (&;@)

Takes one mandatory C<try> subroutine, an optional C<catch> subroutine and C<finally>
subroutine.

The mandatory subroutine is evaluated in the context of an C<eval> block.

If no error occurred the value from the first block is returned, preserving
list/scalar context.

If there was an error and the second subroutine was given it will be invoked
with the error in C<$_> (localized) and as that block's first and only
argument.

C<$@> does B<not> contain the error. Inside the C<catch> block it has the same
value it had before the C<try> block was executed.

Note that the error may be false, but if that happens the C<catch> block will
still be invoked.

Once all execution is finished then the C<finally> block, if given, will execute.

=item catch (&;@)

Intended to be used in the second argument position of C<try>.

Returns a reference to the subroutine it was given but blessed as
C<Try::Tiny::Catch> which allows try to decode correctly what to do
with this code reference.

  catch { ... }

Inside the C<catch> block the caught error is stored in C<$_>, while previous
value of C<$@> is still available for use.  This value may or may not be
meaningful depending on what happened before the C<try>, but it might be a good
idea to preserve it in an error stack.

For code that captures C<$@> when throwing new errors (i.e.
L<Class::Throwable>), you'll need to do:

  local $@ = $_;

=item finally (&;@)

  try     { ... }
  catch   { ... }
  finally { ... };

Or

  try     { ... }
  finally { ... };

Or even

  try     { ... }
  finally { ... }
  catch   { ... };

Intended to be the second or third element of C<try>. C<finally> blocks are always
executed in the event of a successful C<try> or if C<catch> is run. This allows
you to locate cleanup code which cannot be done via C<local()> e.g. closing a file
handle.

When invoked, the C<finally> block is passed the error that was caught.  If no
error was caught, it is passed nothing.  (Note that the C<finally> block does not
localize C<$_> with the error, since unlike in a C<catch> block, there is no way
to know if C<$_ == undef> implies that there were no errors.) In other words,
the following code does just what you would expect:

  try {
    die_sometimes();
  } catch {
    # ...code run in case of error
  } finally {
    if (@_) {
      print "The try block died with: @_\n";
    } else {
      print "The try block ran without error.\n";
    }
  };

B<You must always do your own error handling in the C<finally> block>. C<Try::Tiny> will
not do anything about handling possible errors coming from code located in these
blocks.

Furthermore B<exceptions in C<finally> blocks are not trappable and are unable
to influence the execution of your program>. This is due to limitation of
C<DESTROY>-based scope guards, which C<finally> is implemented on top of. This
may change in a future version of Try::Tiny.

In the same way C<catch()> blesses the code reference this subroutine does the same
except it bless them as C<Try::Tiny::Finally>.

=back

=head1 BACKGROUND

There are a number of issues with C<eval>.

=head2 Clobbering $@

When you run an C<eval> block and it succeeds, C<$@> will be cleared, potentially
clobbering an error that is currently being caught.

This causes action at a distance, clearing previous errors your caller may have
not yet handled.

C<$@> must be properly localized before invoking C<eval> in order to avoid this
issue.

More specifically,
L<before Perl version 5.14.0|perl5140delta/"Exception Handling">
C<$@> was clobbered at the beginning of the C<eval>, which
also made it impossible to capture the previous error before you die (for
instance when making exception objects with error stacks).

For this reason C<try> will actually set C<$@> to its previous value (the one
available before entering the C<try> block) in the beginning of the C<eval>
block.

=head2 Localizing $@ silently masks errors

Inside an C<eval> block, C<die> behaves sort of like:

  sub die {
    $@ = $_[0];
    return_undef_from_eval();
  }

This means that if you were polite and localized C<$@> you can't die in that
scope, or your error will be discarded (printing "Something's wrong" instead).

The workaround is very ugly:

  my $error = do {
    local $@;
    eval { ... };
    $@;
  };

  ...
  die $error;

=head2 $@ might not be a true value

This code is wrong:

  if ( $@ ) {
    ...
  }

because due to the previous caveats it may have been unset.

C<$@> could also be an overloaded error object that evaluates to false, but
that's asking for trouble anyway.

The classic failure mode (fixed in L<Perl 5.14.0|perl5140delta/"Exception Handling">) is:

  sub Object::DESTROY {
    eval { ... }
  }

  eval {
    my $obj = Object->new;

    die "foo";
  };

  if ( $@ ) {

  }

In this case since C<Object::DESTROY> is not localizing C<$@> but still uses
C<eval>, it will set C<$@> to C<"">.

The destructor is called when the stack is unwound, after C<die> sets C<$@> to
C<"foo at Foo.pm line 42\n">, so by the time C<if ( $@ )> is evaluated it has
been cleared by C<eval> in the destructor.

The workaround for this is even uglier than the previous ones. Even though we
can't save the value of C<$@> from code that doesn't localize, we can at least
be sure the C<eval> was aborted due to an error:

  my $failed = not eval {
    ...

    return 1;
  };

This is because an C<eval> that caught a C<die> will always return a false
value.

=head1 ALTERNATE SYNTAX

Using Perl 5.10 you can use L<perlsyn/"Switch statements"> (but please don't,
because that syntax has since been deprecated because there was too much
unexpected magical behaviour).

=for stopwords topicalizer

The C<catch> block is invoked in a topicalizer context (like a C<given> block),
but note that you can't return a useful value from C<catch> using the C<when>
blocks without an explicit C<return>.

This is somewhat similar to Perl 6's C<CATCH> blocks. You can use it to
concisely match errors:

  try {
    require Foo;
  } catch {
    when (/^Can't locate .*?\.pm in \@INC/) { } # ignore
    default { die $_ }
  };

=head1 CAVEATS

=over 4

=item *

C<@_> is not available within the C<try> block, so you need to copy your
argument list. In case you want to work with argument values directly via C<@_>
aliasing (i.e. allow C<$_[1] = "foo">), you need to pass C<@_> by reference:

  sub foo {
    my ( $self, @args ) = @_;
    try { $self->bar(@args) }
  }

or

  sub bar_in_place {
    my $self = shift;
    my $args = \@_;
    try { $_ = $self->bar($_) for @$args }
  }

=item *

C<return> returns from the C<try> block, not from the parent sub (note that
this is also how C<eval> works, but not how L<TryCatch> works):

  sub parent_sub {
    try {
      die;
    }
    catch {
      return;
    };

    say "this text WILL be displayed, even though an exception is thrown";
  }

Instead, you should capture the return value:

  sub parent_sub {
    my $success = try {
      die;
      1;
    };
    return unless $success;

    say "This text WILL NEVER appear!";
  }
  # OR
  sub parent_sub_with_catch {
    my $success = try {
      die;
      1;
    }
    catch {
      # do something with $_
      return undef; #see note
    };
    return unless $success;

    say "This text WILL NEVER appear!";
  }

Note that if you have a C<catch> block, it must return C<undef> for this to work,
since if a C<catch> block exists, its return value is returned in place of C<undef>
when an exception is thrown.

=item *

C<try> introduces another caller stack frame. L<Sub::Uplevel> is not used. L<Carp>
will not report this when using full stack traces, though, because
C<%Carp::Internal> is used. This lack of magic is considered a feature.

=for stopwords unhygienically

=item *

The value of C<$_> in the C<catch> block is not guaranteed to be the value of
the exception thrown (C<$@>) in the C<try> block.  There is no safe way to
ensure this, since C<eval> may be used unhygienically in destructors.  The only
guarantee is that the C<catch> will be called if an exception is thrown.

=item *

The return value of the C<catch> block is not ignored, so if testing the result
of the expression for truth on success, be sure to return a false value from
the C<catch> block:

  my $obj = try {
    MightFail->new;
  } catch {
    ...

    return; # avoid returning a true value;
  };

  return unless $obj;

=item *

C<$SIG{__DIE__}> is still in effect.

Though it can be argued that C<$SIG{__DIE__}> should be disabled inside of
C<eval> blocks, since it isn't people have grown to rely on it. Therefore in
the interests of compatibility, C<try> does not disable C<$SIG{__DIE__}> for
the scope of the error throwing code.

=item *

Lexical C<$_> may override the one set by C<catch>.

For example Perl 5.10's C<given> form uses a lexical C<$_>, creating some
confusing behavior:

  given ($foo) {
    when (...) {
      try {
        ...
      } catch {
        warn $_; # will print $foo, not the error
        warn $_[0]; # instead, get the error like this
      }
    }
  }

Note that this behavior was changed once again in
L<Perl5 version 18|https://metacpan.org/module/perldelta#given-now-aliases-the-global-_>.
However, since the entirety of lexical C<$_> is now L<considered experimental
|https://metacpan.org/module/perldelta#Lexical-_-is-now-experimental>, it
is unclear whether the new version 18 behavior is final.

=back

=head1 SEE ALSO

=over 4

=item L<Syntax::Keyword::Try>

Only available on perls >= 5.14, with a slightly different syntax (e.g. no trailing C<;> because
it's actually a keyword, not a sub, but this means you can C<return> and C<next> within it). Use
L<Feature::Compat::Try> to automatically switch to the native C<try> syntax in newer perls (when
available). See also L<Try Catch Exception Handling|perlsyn/Try-Catch-Exception-Handling>.

=item L<TryCatch>

Much more feature complete, more convenient semantics, but at the cost of
implementation complexity.

=item L<autodie>

Automatic error throwing for builtin functions and more. Also designed to
work well with C<given>/C<when>.

=item L<Throwable>

A lightweight role for rolling your own exception classes.

=item L<Error>

Exception object implementation with a C<try> statement. Does not localize
C<$@>.

=item L<Exception::Class::TryCatch>

Provides a C<catch> statement, but properly calling C<eval> is your
responsibility.

The C<try> keyword pushes C<$@> onto an error stack, avoiding some of the
issues with C<$@>, but you still need to localize to prevent clobbering.

=back

=head1 LIGHTNING TALK

I gave a lightning talk about this module, you can see the slides (Firefox
only):

L<http://web.archive.org/web/20100628040134/http://nothingmuch.woobling.org/talks/takahashi.xul>

Or read the source:

L<http://web.archive.org/web/20100305133605/http://nothingmuch.woobling.org/talks/yapc_asia_2009/try_tiny.yml>

=head1 SUPPORT

Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=Try-Tiny>
(or L<bug-Try-Tiny@rt.cpan.org|mailto:bug-Try-Tiny@rt.cpan.org>).

=head1 AUTHORS

=over 4

=item *

יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>

=item *

Jesse Luehrs <doy@tozt.net>

=back

=head1 CONTRIBUTORS

=for stopwords Karen Etheridge Peter Rabbitson Ricardo Signes Mark Fowler Graham Knop Aristotle Pagaltzis Dagfinn Ilmari Mannsåker Lukas Mai Alex anaxagoras Andrew Yates awalker chromatic cm-perl David Lowe Glenn Hans Dieter Pearcey Jens Berthold Jonathan Yu Marc Mims Stosberg Pali Paul Howarth Rudolf Leermakers

=over 4

=item *

Karen Etheridge <ether@cpan.org>

=item *

Peter Rabbitson <ribasushi@cpan.org>

=item *

Ricardo Signes <rjbs@cpan.org>

=item *

Mark Fowler <mark@twoshortplanks.com>

=item *

Graham Knop <haarg@haarg.org>

=item *

Aristotle Pagaltzis <pagaltzis@gmx.de>

=item *

Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>

=item *

Lukas Mai <l.mai@web.de>

=item *

Alex <alex@koban.(none)>

=item *

anaxagoras <walkeraj@gmail.com>

=item *

Andrew Yates <ayates@haddock.local>

=item *

awalker <awalker@sourcefire.com>

=item *

chromatic <chromatic@wgz.org>

=item *

cm-perl <cm-perl@users.noreply.github.com>

=item *

David Lowe <davidl@lokku.com>

=item *

Glenn Fowler <cebjyre@cpan.org>

=item *

Hans Dieter Pearcey <hdp@weftsoar.net>

=item *

Jens Berthold <jens@jebecs.de>

=item *

Jonathan Yu <JAWNSY@cpan.org>

=item *

Marc Mims <marc@questright.com>

=item *

Mark Stosberg <mark@stosberg.com>

=item *

Pali <pali@cpan.org>

=item *

Paul Howarth <paul@city-fan.org>

=item *

Rudolf Leermakers <rudolf@hatsuseno.org>

=back

=head1 COPYRIGHT AND LICENCE

This software is Copyright (c) 2009 by יובל קוג'מן (Yuval Kogman).

This is free software, licensed under:

  The MIT (X11) License

=cut
PK       ! ��-}  }  @  perl5/x86_64-linux-thread-multi/.meta/Net-HTTP-6.19/install.jsonnu ��6�$        {"provides":{"Net::HTTP":{"version":6.19,"file":"lib/Net/HTTP.pm"},"Net::HTTPS":{"version":6.19,"file":"lib/Net/HTTPS.pm"},"Net::HTTP::NB":{"version":6.19,"file":"lib/Net/HTTP/NB.pm"},"Net::HTTP::Methods":{"version":6.19,"file":"lib/Net/HTTP/Methods.pm"}},"target":"Net::HTTP","version":6.19,"name":"Net::HTTP","dist":"Net-HTTP-6.19","pathname":"O/OA/OALDERS/Net-HTTP-6.19.tar.gz"}PK       ! �+tH8k  8k  ?  perl5/x86_64-linux-thread-multi/.meta/Net-HTTP-6.19/MYMETA.jsonnu ��6�$        {
   "abstract" : "Low-level HTTP connection (client)",
   "author" : [
      "Gisle Aas <gisle@activestate.com>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "Dist::Zilla version 6.012, CPAN::Meta::Converter version 2.150010",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : 2
   },
   "name" : "Net-HTTP",
   "no_index" : {
      "directory" : [
         "examples",
         "t",
         "xt"
      ]
   },
   "prereqs" : {
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         },
         "suggests" : {
            "JSON::PP" : "2.27300"
         }
      },
      "develop" : {
         "requires" : {
            "Test::More" : "0",
            "Test::Pod" : "1.41"
         }
      },
      "runtime" : {
         "requires" : {
            "Carp" : "0",
            "Compress::Raw::Zlib" : "0",
            "IO::Socket::INET" : "0",
            "IO::Uncompress::Gunzip" : "0",
            "URI" : "0",
            "base" : "0",
            "perl" : "5.006002",
            "strict" : "0",
            "vars" : "0",
            "warnings" : "0"
         },
         "suggests" : {
            "IO::Socket" : "0",
            "IO::Socket::INET6" : "0",
            "IO::Socket::IP" : "0",
            "IO::Socket::SSL" : "2.012",
            "Symbol" : "0"
         }
      },
      "test" : {
         "recommends" : {
            "CPAN::Meta" : "2.120900"
         },
         "requires" : {
            "Data::Dumper" : "0",
            "ExtUtils::MakeMaker" : "0",
            "File::Spec" : "0",
            "IO::Select" : "0",
            "Socket" : "0",
            "Test::More" : "0"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "web" : "https://github.com/libwww-perl/Net-HTTP/issues"
      },
      "homepage" : "https://github.com/libwww-perl/Net-HTTP",
      "repository" : {
         "type" : "git",
         "url" : "https://github.com/libwww-perl/Net-HTTP.git",
         "web" : "https://github.com/libwww-perl/Net-HTTP"
      },
      "x_IRC" : "irc://irc.perl.org/#lwp",
      "x_MailingList" : "mailto:libwww@perl.org"
   },
   "version" : "6.19",
   "x_Dist_Zilla" : {
      "perl" : {
         "version" : "5.026001"
      },
      "plugins" : [
         {
            "class" : "Dist::Zilla::Plugin::MetaResources",
            "name" : "MetaResources",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::Prereqs",
            "config" : {
               "Dist::Zilla::Plugin::Prereqs" : {
                  "phase" : "runtime",
                  "type" : "requires"
               }
            },
            "name" : "Prereqs",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::PromptIfStale",
            "config" : {
               "Dist::Zilla::Plugin::PromptIfStale" : {
                  "check_all_plugins" : 0,
                  "check_all_prereqs" : 0,
                  "modules" : [
                     "Dist::Zilla::PluginBundle::Author::OALDERS"
                  ],
                  "phase" : "build",
                  "run_under_travis" : 0,
                  "skip" : []
               }
            },
            "name" : "@Author::OALDERS/stale modules, build",
            "version" : "0.055"
         },
         {
            "class" : "Dist::Zilla::Plugin::PromptIfStale",
            "config" : {
               "Dist::Zilla::Plugin::PromptIfStale" : {
                  "check_all_plugins" : 1,
                  "check_all_prereqs" : 1,
                  "modules" : [],
                  "phase" : "release",
                  "run_under_travis" : 0,
                  "skip" : []
               }
            },
            "name" : "@Author::OALDERS/stale modules, release",
            "version" : "0.055"
         },
         {
            "class" : "Dist::Zilla::Plugin::MAXMIND::TidyAll",
            "name" : "@Author::OALDERS/MAXMIND::TidyAll",
            "version" : "0.83"
         },
         {
            "class" : "Dist::Zilla::Plugin::MakeMaker",
            "config" : {
               "Dist::Zilla::Role::TestRunner" : {
                  "default_jobs" : 1
               }
            },
            "name" : "@Author::OALDERS/MakeMaker",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::CPANFile",
            "name" : "@Author::OALDERS/CPANFile",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::ContributorsFile",
            "name" : "@Author::OALDERS/ContributorsFile",
            "version" : "0.3.0"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaJSON",
            "name" : "@Author::OALDERS/MetaJSON",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaYAML",
            "name" : "@Author::OALDERS/MetaYAML",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::Manifest",
            "name" : "@Author::OALDERS/Manifest",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaNoIndex",
            "name" : "@Author::OALDERS/MetaNoIndex",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaConfig",
            "name" : "@Author::OALDERS/MetaConfig",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaResources",
            "name" : "@Author::OALDERS/MetaResources",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::License",
            "name" : "@Author::OALDERS/License",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::InstallGuide",
            "config" : {
               "Dist::Zilla::Role::ModuleMetadata" : {
                  "Module::Metadata" : "1.000033",
                  "version" : "0.004"
               }
            },
            "name" : "@Author::OALDERS/InstallGuide",
            "version" : "1.200013"
         },
         {
            "class" : "Dist::Zilla::Plugin::ExecDir",
            "name" : "@Author::OALDERS/ExecDir",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::PodSyntaxTests",
            "name" : "@Author::OALDERS/PodSyntaxTests",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::TestRelease",
            "name" : "@Author::OALDERS/TestRelease",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::ReportPrereqs",
            "name" : "@Author::OALDERS/Test::ReportPrereqs",
            "version" : "0.027"
         },
         {
            "class" : "Dist::Zilla::Plugin::RunExtraTests",
            "config" : {
               "Dist::Zilla::Role::TestRunner" : {
                  "default_jobs" : 1
               }
            },
            "name" : "@Author::OALDERS/RunExtraTests",
            "version" : "0.029"
         },
         {
            "class" : "Dist::Zilla::Plugin::PodWeaver",
            "config" : {
               "Dist::Zilla::Plugin::PodWeaver" : {
                  "finder" : [
                     ":InstallModules",
                     ":ExecFiles"
                  ],
                  "plugins" : [
                     {
                        "class" : "Pod::Weaver::Plugin::EnsurePod5",
                        "name" : "@CorePrep/EnsurePod5",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Plugin::H1Nester",
                        "name" : "@CorePrep/H1Nester",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Plugin::SingleEncoding",
                        "name" : "@Default/SingleEncoding",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Name",
                        "name" : "@Default/Name",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Version",
                        "name" : "@Default/Version",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Region",
                        "name" : "@Default/prelude",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Generic",
                        "name" : "SYNOPSIS",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Generic",
                        "name" : "DESCRIPTION",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Generic",
                        "name" : "OVERVIEW",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Collect",
                        "name" : "ATTRIBUTES",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Collect",
                        "name" : "METHODS",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Collect",
                        "name" : "FUNCTIONS",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Leftovers",
                        "name" : "@Default/Leftovers",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Region",
                        "name" : "@Default/postlude",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Authors",
                        "name" : "@Default/Authors",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Legal",
                        "name" : "@Default/Legal",
                        "version" : "4.015"
                     }
                  ]
               }
            },
            "name" : "@Author::OALDERS/PodWeaver",
            "version" : "4.008"
         },
         {
            "class" : "Dist::Zilla::Plugin::PruneCruft",
            "name" : "@Author::OALDERS/PruneCruft",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::CopyFilesFromBuild",
            "name" : "@Author::OALDERS/CopyFilesFromBuild",
            "version" : "0.170880"
         },
         {
            "class" : "Dist::Zilla::Plugin::GithubMeta",
            "name" : "@Author::OALDERS/GithubMeta",
            "version" : "0.58"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::GatherDir",
            "config" : {
               "Dist::Zilla::Plugin::GatherDir" : {
                  "exclude_filename" : [
                     "Install",
                     "LICENSE",
                     "META.json",
                     "Makefile.PL",
                     "README.md",
                     "cpanfile"
                  ],
                  "exclude_match" : [],
                  "follow_symlinks" : 0,
                  "include_dotfiles" : 0,
                  "prefix" : "",
                  "prune_directory" : [],
                  "root" : "."
               },
               "Dist::Zilla::Plugin::Git::GatherDir" : {
                  "include_untracked" : 0
               }
            },
            "name" : "@Author::OALDERS/Git::GatherDir",
            "version" : "2.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::CopyFilesFromRelease",
            "config" : {
               "Dist::Zilla::Plugin::CopyFilesFromRelease" : {
                  "filename" : [
                     "Install"
                  ],
                  "match" : []
               }
            },
            "name" : "@Author::OALDERS/CopyFilesFromRelease",
            "version" : "0.006"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Check",
            "config" : {
               "Dist::Zilla::Plugin::Git::Check" : {
                  "untracked_files" : "die"
               },
               "Dist::Zilla::Role::Git::DirtyFiles" : {
                  "allow_dirty" : [
                     "Changes",
                     "Install",
                     "LICENSE",
                     "META.json",
                     "Makefile.PL",
                     "README.md",
                     "cpanfile",
                     "dist.ini"
                  ],
                  "allow_dirty_match" : [],
                  "changelog" : "Changes"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.21.0",
                  "repo_root" : "."
               }
            },
            "name" : "@Author::OALDERS/Git::Check",
            "version" : "2.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Contributors",
            "config" : {
               "Dist::Zilla::Plugin::Git::Contributors" : {
                  "git_version" : "2.21.0",
                  "include_authors" : 0,
                  "include_releaser" : 1,
                  "order_by" : "name",
                  "paths" : []
               }
            },
            "name" : "@Author::OALDERS/Git::Contributors",
            "version" : "0.035"
         },
         {
            "class" : "Dist::Zilla::Plugin::ReadmeAnyFromPod",
            "config" : {
               "Dist::Zilla::Role::FileWatcher" : {
                  "version" : "0.006"
               }
            },
            "name" : "@Author::OALDERS/ReadmeMdInBuild",
            "version" : "0.163250"
         },
         {
            "class" : "Dist::Zilla::Plugin::ShareDir",
            "name" : "@Author::OALDERS/ShareDir",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::TravisCI::StatusBadge",
            "name" : "@Author::OALDERS/TravisCI::StatusBadge",
            "version" : "0.007"
         },
         {
            "class" : "Dist::Zilla::Plugin::CheckIssues",
            "name" : "@Author::OALDERS/CheckIssues",
            "version" : "0.010"
         },
         {
            "class" : "Dist::Zilla::Plugin::ConfirmRelease",
            "name" : "@Author::OALDERS/ConfirmRelease",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::UploadToCPAN",
            "name" : "@Author::OALDERS/UploadToCPAN",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::RewriteVersion::Transitional",
            "config" : {
               "Dist::Zilla::Plugin::RewriteVersion" : {
                  "add_tarball_name" : 0,
                  "finders" : [
                     ":ExecFiles",
                     ":InstallModules"
                  ],
                  "global" : 0,
                  "skip_version_provider" : 0
               },
               "Dist::Zilla::Plugin::RewriteVersion::Transitional" : {}
            },
            "name" : "@Author::OALDERS/@Git::VersionManager/RewriteVersion::Transitional",
            "version" : "0.009"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaProvides::Update",
            "name" : "@Author::OALDERS/@Git::VersionManager/MetaProvides::Update",
            "version" : "0.007"
         },
         {
            "class" : "Dist::Zilla::Plugin::CopyFilesFromRelease",
            "config" : {
               "Dist::Zilla::Plugin::CopyFilesFromRelease" : {
                  "filename" : [
                     "Changes"
                  ],
                  "match" : []
               }
            },
            "name" : "@Author::OALDERS/@Git::VersionManager/CopyFilesFromRelease",
            "version" : "0.006"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Commit",
            "config" : {
               "Dist::Zilla::Plugin::Git::Commit" : {
                  "add_files_in" : [],
                  "commit_msg" : "v%V%n%n%c"
               },
               "Dist::Zilla::Role::Git::DirtyFiles" : {
                  "allow_dirty" : [
                     "Changes",
                     "Install",
                     "LICENSE",
                     "META.json",
                     "Makefile.PL",
                     "README.md",
                     "cpanfile",
                     "dist.ini"
                  ],
                  "allow_dirty_match" : [],
                  "changelog" : "Changes"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.21.0",
                  "repo_root" : "."
               },
               "Dist::Zilla::Role::Git::StringFormatter" : {
                  "time_zone" : "local"
               }
            },
            "name" : "@Author::OALDERS/@Git::VersionManager/release snapshot",
            "version" : "2.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Tag",
            "config" : {
               "Dist::Zilla::Plugin::Git::Tag" : {
                  "branch" : null,
                  "changelog" : "Changes",
                  "signed" : 0,
                  "tag" : "v6.19",
                  "tag_format" : "v%V",
                  "tag_message" : "v%V"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.21.0",
                  "repo_root" : "."
               },
               "Dist::Zilla::Role::Git::StringFormatter" : {
                  "time_zone" : "local"
               }
            },
            "name" : "@Author::OALDERS/@Git::VersionManager/Git::Tag",
            "version" : "2.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::BumpVersionAfterRelease::Transitional",
            "config" : {
               "Dist::Zilla::Plugin::BumpVersionAfterRelease" : {
                  "finders" : [
                     ":ExecFiles",
                     ":InstallModules"
                  ],
                  "global" : 0,
                  "munge_makefile_pl" : 1
               },
               "Dist::Zilla::Plugin::BumpVersionAfterRelease::Transitional" : {}
            },
            "name" : "@Author::OALDERS/@Git::VersionManager/BumpVersionAfterRelease::Transitional",
            "version" : "0.009"
         },
         {
            "class" : "Dist::Zilla::Plugin::NextRelease",
            "name" : "@Author::OALDERS/@Git::VersionManager/NextRelease",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Commit",
            "config" : {
               "Dist::Zilla::Plugin::Git::Commit" : {
                  "add_files_in" : [],
                  "commit_msg" : "increment $VERSION after %v release"
               },
               "Dist::Zilla::Role::Git::DirtyFiles" : {
                  "allow_dirty" : [
                     "Build.PL",
                     "Changes",
                     "Makefile.PL"
                  ],
                  "allow_dirty_match" : [
                     "(?^:^lib/.*\\.pm$)"
                  ],
                  "changelog" : "Changes"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.21.0",
                  "repo_root" : "."
               },
               "Dist::Zilla::Role::Git::StringFormatter" : {
                  "time_zone" : "local"
               }
            },
            "name" : "@Author::OALDERS/@Git::VersionManager/post-release commit",
            "version" : "2.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Push",
            "config" : {
               "Dist::Zilla::Plugin::Git::Push" : {
                  "push_to" : [
                     "origin"
                  ],
                  "remotes_must_exist" : 1
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.21.0",
                  "repo_root" : "."
               }
            },
            "name" : "@Author::OALDERS/Git::Push",
            "version" : "2.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::AutoPrereqs",
            "name" : "AutoPrereqs",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::Prereqs",
            "config" : {
               "Dist::Zilla::Plugin::Prereqs" : {
                  "phase" : "runtime",
                  "type" : "suggests"
               }
            },
            "name" : "RuntimeSuggests",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::Prereqs::Soften",
            "config" : {
               "Dist::Zilla::Plugin::Prereqs::Soften" : {
                  "copy_to" : [],
                  "modules" : [
                     "IO::Socket",
                     "IO::Socket::INET6",
                     "IO::Socket::IP",
                     "IO::Socket::SSL",
                     "Symbol"
                  ],
                  "modules_from_features" : null,
                  "to_relationship" : "suggests"
               }
            },
            "name" : "Prereqs::Soften",
            "version" : "0.006003"
         },
         {
            "class" : "Dist::Zilla::Plugin::StaticInstall",
            "config" : {
               "Dist::Zilla::Plugin::StaticInstall" : {
                  "dry_run" : 0,
                  "mode" : "on"
               }
            },
            "name" : "StaticInstall",
            "version" : "0.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":InstallModules",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":IncModules",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":TestFiles",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":ExtraTestFiles",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":ExecFiles",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":PerlExecFiles",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":ShareFiles",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":MainModule",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":AllFiles",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":NoFiles",
            "version" : "6.012"
         }
      ],
      "zilla" : {
         "class" : "Dist::Zilla::Dist::Builder",
         "config" : {
            "is_trial" : 0
         },
         "version" : "6.012"
      }
   },
   "x_contributors" : [
      "Adam Kennedy <adamk@cpan.org>",
      "Adam Sjogren <asjo@koldfront.dk>",
      "Alexey Tourbin <at@altlinux.ru>",
      "Alex Kapranoff <ka@nadoby.ru>",
      "amire80 <amir.aharoni@gmail.com>",
      "Andreas J. Koenig <andreas.koenig@anima.de>",
      "Andy Grundman <andyg@activestate.com>",
      "Bill Mann <wfmann@alum.mit.edu>",
      "Bron Gondwana <brong@fastmail.fm>",
      "Chase Whitener <cwhitener@gmail.com>",
      "Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>",
      "Daniel Hedlund <Daniel.Hedlund@eprize.com>",
      "Dave Rolsky <autarch@urth.org>",
      "David E. Wheeler <david@justatheory.com>",
      "DAVIDRW <davidrw@cpan.org>",
      "David Steinbrunner <dsteinbrunner@pobox.com>",
      "Eric Wong <normalperson@yhbt.net>",
      "Father Chrysostomos <sprout@cpan.org>",
      "FWILES <FWILES@cpan.org>",
      "Gavin Peters <gpeters@deepsky.com>",
      "Gisle Aas <aas@oslonett.no>",
      "Gisle Aas <gisle.aas@it.uib.no>",
      "Gisle Aas <gisle@aas.no>",
      "Gisle Aas <gisle@baux-2.lan>",
      "Graeme Thompson <Graeme.Thompson@mobilecohesion.com>",
      "Hans-H. Froehlich <hfroehlich@co-de-co.de>",
      "Ian Kilgore <iank@cpan.org>",
      "Jacob J <waif@chaos2.org>",
      "Jason A Fesler <jfesler@badamount-lm.corp.yahoo.com>",
      "Jay Hannah <jay.hannah@iinteractive.com>",
      "Jean-Louis Martineau <martineau@zmanda.com>",
      "jefflee <shaohua@gmail.com>",
      "Jesse Luehrs <doy@tozt.net>",
      "john9art <john9art@yahoo.com>",
      "Karen Etheridge <ether@cpan.org>",
      "Kent Fredric <kentfredric@gmail.com>",
      "Lasse Makholm <lasse@unity3d.com>",
      "Marinos Yannikos <mjy@geizhals.at>",
      "Mark Overmeer <MARKOV@cpan.org>",
      "Mark Stosberg <mark@stosberg.com>",
      "Mark Stosberg <MARKSTOS@cpan.org>",
      "Mark Stosberg <mark@summersault.com>",
      "Mike Schilli <github@perlmeister.com>",
      "Mike Schilli <mschilli@yahoo-inc.com>",
      "Mohammad S Anwar <mohammad.anwar@yahoo.com>",
      "murphy <murphy@genome.chop.edu>",
      "Olaf Alders <olaf@wundersolutions.com>",
      "Ondrej Hanak <ondrej.hanak@ubs.com>",
      "Peter Rabbitson <ribasushi@cpan.org>",
      "phrstbrn <phrstbrn@gmail.com>",
      "Robert Stone <talby@trap.mtview.ca.us>",
      "Rolf Grossmann <rg@progtech.net>",
      "ruff <ruff@ukrpost.net>",
      "sasao <sasao@yugen.org>",
      "Sean M. Burke <sburke@cpan.org>",
      "Shoichi Kaji <skaji@cpan.org>",
      "Slaven Rezic <slaven@rezic.de>",
      "Slaven Rezic <srezic@iconmobile.com>",
      "Spiros Denaxas <s.denaxas@gmail.com>",
      "Steffen Ullrich <Steffen_Ullrich@genua.de>",
      "Steve Hay <SteveHay@planit.com>",
      "Todd Lipcon <todd@amiestreet.com>",
      "Tom Hukins <tom@eborcom.com>",
      "Tony Finch <dot@dotat.at>",
      "Toru Yamaguchi <zigorou@cpan.org>",
      "uid39246 <uid39246>",
      "Ville Skytta <ville.skytta@iki.fi>",
      "Yuri Karaban <tech@askold.net>",
      "Zefram <zefram@fysh.org>"
   ],
   "x_generated_by_perl" : "v5.26.1",
   "x_serialization_backend" : "JSON::PP version 2.97001",
   "x_static_install" : 1
}
PK       ! |����  �  A  perl5/x86_64-linux-thread-multi/.meta/HTML-Form-6.07/install.jsonnu ��6�$        {"provides":{"HTML::Form":{"version":"6.07","file":"lib/HTML/Form.pm"},"HTML::Form::ListInput":{"version":"6.07","file":"lib/HTML/Form.pm"},"HTML::Form::TextInput":{"version":"6.07","file":"lib/HTML/Form.pm"},"HTML::Form::ImageInput":{"version":"6.07","file":"lib/HTML/Form.pm"},"HTML::Form::FileInput":{"version":"6.07","file":"lib/HTML/Form.pm"},"HTML::Form::IgnoreInput":{"version":"6.07","file":"lib/HTML/Form.pm"},"HTML::Form::KeygenInput":{"version":"6.07","file":"lib/HTML/Form.pm"},"HTML::Form::Input":{"version":"6.07","file":"lib/HTML/Form.pm"},"HTML::Form::SubmitInput":{"version":"6.07","file":"lib/HTML/Form.pm"}},"target":"HTML::Form","version":"6.07","name":"HTML::Form","dist":"HTML-Form-6.07","pathname":"O/OA/OALDERS/HTML-Form-6.07.tar.gz"}PK       ! Q�e��s  �s  @  perl5/x86_64-linux-thread-multi/.meta/HTML-Form-6.07/MYMETA.jsonnu ��6�$        {
   "abstract" : "Class that represents an HTML form element",
   "author" : [
      "Gisle Aas <gisle@activestate.com>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "Dist::Zilla version 6.012, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "HTML-Form",
   "no_index" : {
      "directory" : [
         "t",
         "xt"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "develop" : {
         "recommends" : {
            "Dist::Zilla::PluginBundle::Git::VersionManager" : "0.007"
         },
         "requires" : {
            "File::Spec" : "0",
            "IO::Handle" : "0",
            "IPC::Open3" : "0",
            "Pod::Coverage::TrustPod" : "0",
            "Pod::Wordlist" : "0",
            "Test::EOL" : "0",
            "Test::MinimumVersion" : "0",
            "Test::Mojibake" : "0",
            "Test::More" : "0.94",
            "Test::Pod" : "1.41",
            "Test::Pod::Coverage" : "1.08",
            "Test::Portability::Files" : "0",
            "Test::Spelling" : "0.12",
            "Test::Version" : "1",
            "perl" : "5.006",
            "warnings" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "Carp" : "0",
            "Encode" : "2",
            "HTML::TokeParser" : "0",
            "HTTP::Request" : "6",
            "HTTP::Request::Common" : "6.03",
            "URI" : "1.10",
            "perl" : "5.008001",
            "strict" : "0",
            "vars" : "0"
         }
      },
      "test" : {
         "recommends" : {
            "CPAN::Meta" : "2.120900"
         },
         "requires" : {
            "ExtUtils::MakeMaker" : "0",
            "File::Spec" : "0",
            "HTTP::Response" : "0",
            "Test" : "0",
            "Test::More" : "0",
            "lib" : "0",
            "warnings" : "0"
         }
      }
   },
   "provides" : {
      "HTML::Form" : {
         "file" : "lib/HTML/Form.pm",
         "version" : "6.07"
      },
      "HTML::Form::FileInput" : {
         "file" : "lib/HTML/Form.pm",
         "version" : "6.07"
      },
      "HTML::Form::IgnoreInput" : {
         "file" : "lib/HTML/Form.pm",
         "version" : "6.07"
      },
      "HTML::Form::ImageInput" : {
         "file" : "lib/HTML/Form.pm",
         "version" : "6.07"
      },
      "HTML::Form::Input" : {
         "file" : "lib/HTML/Form.pm",
         "version" : "6.07"
      },
      "HTML::Form::KeygenInput" : {
         "file" : "lib/HTML/Form.pm",
         "version" : "6.07"
      },
      "HTML::Form::ListInput" : {
         "file" : "lib/HTML/Form.pm",
         "version" : "6.07"
      },
      "HTML::Form::SubmitInput" : {
         "file" : "lib/HTML/Form.pm",
         "version" : "6.07"
      },
      "HTML::Form::TextInput" : {
         "file" : "lib/HTML/Form.pm",
         "version" : "6.07"
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "web" : "https://github.com/libwww-perl/HTML-Form/issues"
      },
      "homepage" : "https://github.com/libwww-perl/HTML-Form",
      "repository" : {
         "type" : "git",
         "url" : "https://github.com/libwww-perl/HTML-Form.git",
         "web" : "https://github.com/libwww-perl/HTML-Form"
      },
      "x_IRC" : "irc://irc.perl.org/#lwp",
      "x_MailingList" : "mailto:libwww@perl.org"
   },
   "version" : "6.07",
   "x_Dist_Zilla" : {
      "perl" : {
         "version" : "5.026001"
      },
      "plugins" : [
         {
            "class" : "Dist::Zilla::Plugin::Git::GatherDir",
            "config" : {
               "Dist::Zilla::Plugin::GatherDir" : {
                  "exclude_filename" : [
                     "LICENSE",
                     "META.json",
                     "Makefile.PL",
                     "README.md",
                     "cpanfile"
                  ],
                  "exclude_match" : [],
                  "follow_symlinks" : 0,
                  "include_dotfiles" : 0,
                  "prefix" : "",
                  "prune_directory" : [],
                  "root" : "."
               },
               "Dist::Zilla::Plugin::Git::GatherDir" : {
                  "include_untracked" : 0
               }
            },
            "name" : "Git::GatherDir",
            "version" : "2.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaConfig",
            "name" : "MetaConfig",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaProvides::Package",
            "config" : {
               "Dist::Zilla::Plugin::MetaProvides::Package" : {
                  "finder_objects" : [
                     {
                        "class" : "Dist::Zilla::Plugin::FinderCode",
                        "name" : "MetaProvides::Package/AUTOVIV/:InstallModulesPM",
                        "version" : "6.012"
                     }
                  ],
                  "include_underscores" : 0
               },
               "Dist::Zilla::Role::MetaProvider::Provider" : {
                  "$Dist::Zilla::Role::MetaProvider::Provider::VERSION" : "2.002004",
                  "inherit_missing" : 1,
                  "inherit_version" : 1,
                  "meta_noindex" : 1
               },
               "Dist::Zilla::Role::ModuleMetadata" : {
                  "Module::Metadata" : "1.000036",
                  "version" : "0.006"
               }
            },
            "name" : "MetaProvides::Package",
            "version" : "2.004003"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaNoIndex",
            "name" : "MetaNoIndex",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaYAML",
            "name" : "MetaYAML",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaJSON",
            "name" : "MetaJSON",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaResources",
            "name" : "MetaResources",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Contributors",
            "config" : {
               "Dist::Zilla::Plugin::Git::Contributors" : {
                  "git_version" : "2.25.0",
                  "include_authors" : 0,
                  "include_releaser" : 1,
                  "order_by" : "name",
                  "paths" : []
               }
            },
            "name" : "Git::Contributors",
            "version" : "0.035"
         },
         {
            "class" : "Dist::Zilla::Plugin::GithubMeta",
            "name" : "GithubMeta",
            "version" : "0.58"
         },
         {
            "class" : "Dist::Zilla::Plugin::Authority",
            "name" : "Authority",
            "version" : "1.009"
         },
         {
            "class" : "Dist::Zilla::Plugin::Manifest",
            "name" : "Manifest",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::License",
            "name" : "License",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::InstallGuide",
            "config" : {
               "Dist::Zilla::Role::ModuleMetadata" : {
                  "Module::Metadata" : "1.000036",
                  "version" : "0.006"
               }
            },
            "name" : "InstallGuide",
            "version" : "1.200013"
         },
         {
            "class" : "Dist::Zilla::Plugin::ExecDir",
            "name" : "ExecDir",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::Prereqs",
            "config" : {
               "Dist::Zilla::Plugin::Prereqs" : {
                  "phase" : "runtime",
                  "type" : "requires"
               }
            },
            "name" : "Prereqs",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::AutoPrereqs",
            "name" : "AutoPrereqs",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::CPANFile",
            "name" : "CPANFile",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::MakeMaker",
            "config" : {
               "Dist::Zilla::Role::TestRunner" : {
                  "default_jobs" : 1
               }
            },
            "name" : "MakeMaker",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::MojibakeTests",
            "name" : "MojibakeTests",
            "version" : "0.8"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::Version",
            "name" : "Test::Version",
            "version" : "1.09"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::ReportPrereqs",
            "name" : "Test::ReportPrereqs",
            "version" : "0.027"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::Compile",
            "config" : {
               "Dist::Zilla::Plugin::Test::Compile" : {
                  "bail_out_on_fail" : "1",
                  "fail_on_warning" : "author",
                  "fake_home" : 0,
                  "filename" : "xt/author/00-compile.t",
                  "module_finder" : [
                     ":InstallModules"
                  ],
                  "needs_display" : 0,
                  "phase" : "develop",
                  "script_finder" : [
                     ":PerlExecFiles"
                  ],
                  "skips" : [],
                  "switch" : []
               }
            },
            "name" : "Test::Compile",
            "version" : "2.058"
         },
         {
            "class" : "Dist::Zilla::Plugin::Substitute",
            "name" : "00-compile.t",
            "version" : "0.006"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::Portability",
            "config" : {
               "Dist::Zilla::Plugin::Test::Portability" : {
                  "options" : ""
               }
            },
            "name" : "Test::Portability",
            "version" : "2.001000"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::EOL",
            "config" : {
               "Dist::Zilla::Plugin::Test::EOL" : {
                  "filename" : "xt/author/eol.t",
                  "finder" : [
                     ":ExecFiles",
                     ":InstallModules",
                     ":TestFiles"
                  ],
                  "trailing_whitespace" : 1
               }
            },
            "name" : "Test::EOL",
            "version" : "0.19"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::ChangesHasContent",
            "name" : "Test::ChangesHasContent",
            "version" : "0.011"
         },
         {
            "class" : "Dist::Zilla::Plugin::Substitute",
            "name" : "changes_has_content.t",
            "version" : "0.006"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::MinimumVersion",
            "config" : {
               "Dist::Zilla::Plugin::Test::MinimumVersion" : {
                  "max_target_perl" : null
               }
            },
            "name" : "Test::MinimumVersion",
            "version" : "2.000010"
         },
         {
            "class" : "Dist::Zilla::Plugin::PodSyntaxTests",
            "name" : "PodSyntaxTests",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::Pod::Coverage::Configurable",
            "name" : "Test::Pod::Coverage::Configurable",
            "version" : "0.07"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::PodSpelling",
            "config" : {
               "Dist::Zilla::Plugin::Test::PodSpelling" : {
                  "directories" : [
                     "bin",
                     "lib"
                  ],
                  "spell_cmd" : "aspell list",
                  "stopwords" : [
                     "CGI",
                     "autocomplete",
                     "checkbox",
                     "readonly",
                     "unsetting",
                     "unvisited"
                  ],
                  "wordlist" : "Pod::Wordlist"
               }
            },
            "name" : "Test::PodSpelling",
            "version" : "2.007005"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Check",
            "config" : {
               "Dist::Zilla::Plugin::Git::Check" : {
                  "untracked_files" : "die"
               },
               "Dist::Zilla::Role::Git::DirtyFiles" : {
                  "allow_dirty" : [],
                  "allow_dirty_match" : [],
                  "changelog" : "Changes"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.25.0",
                  "repo_root" : "."
               }
            },
            "name" : "Git::Check",
            "version" : "2.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::CheckStrictVersion",
            "name" : "CheckStrictVersion",
            "version" : "0.001"
         },
         {
            "class" : "Dist::Zilla::Plugin::RunExtraTests",
            "config" : {
               "Dist::Zilla::Role::TestRunner" : {
                  "default_jobs" : 1
               }
            },
            "name" : "RunExtraTests",
            "version" : "0.029"
         },
         {
            "class" : "Dist::Zilla::Plugin::PodWeaver",
            "config" : {
               "Dist::Zilla::Plugin::PodWeaver" : {
                  "finder" : [
                     ":InstallModules",
                     ":ExecFiles"
                  ],
                  "plugins" : [
                     {
                        "class" : "Pod::Weaver::Plugin::EnsurePod5",
                        "name" : "@CorePrep/EnsurePod5",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Plugin::H1Nester",
                        "name" : "@CorePrep/H1Nester",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Plugin::SingleEncoding",
                        "name" : "@Default/SingleEncoding",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Name",
                        "name" : "@Default/Name",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Version",
                        "name" : "@Default/Version",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Region",
                        "name" : "@Default/prelude",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Generic",
                        "name" : "SYNOPSIS",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Generic",
                        "name" : "DESCRIPTION",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Generic",
                        "name" : "OVERVIEW",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Collect",
                        "name" : "ATTRIBUTES",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Collect",
                        "name" : "METHODS",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Collect",
                        "name" : "FUNCTIONS",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Leftovers",
                        "name" : "@Default/Leftovers",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Region",
                        "name" : "@Default/postlude",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Authors",
                        "name" : "@Default/Authors",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Legal",
                        "name" : "@Default/Legal",
                        "version" : "4.015"
                     }
                  ]
               }
            },
            "name" : "PodWeaver",
            "version" : "4.008"
         },
         {
            "class" : "Dist::Zilla::Plugin::CheckChangeLog",
            "name" : "CheckChangeLog",
            "version" : "0.05"
         },
         {
            "class" : "Dist::Zilla::Plugin::CheckChangesHasContent",
            "name" : "CheckChangesHasContent",
            "version" : "0.011"
         },
         {
            "class" : "Dist::Zilla::Plugin::TestRelease",
            "name" : "TestRelease",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::UploadToCPAN",
            "name" : "UploadToCPAN",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::ReadmeAnyFromPod",
            "config" : {
               "Dist::Zilla::Role::FileWatcher" : {
                  "version" : "0.006"
               }
            },
            "name" : "Markdown_Readme",
            "version" : "0.163250"
         },
         {
            "class" : "Dist::Zilla::Plugin::CopyFilesFromRelease",
            "config" : {
               "Dist::Zilla::Plugin::CopyFilesFromRelease" : {
                  "filename" : [
                     "LICENSE",
                     "META.json",
                     "Makefile.PL",
                     "cpanfile"
                  ],
                  "match" : []
               }
            },
            "name" : "CopyFilesFromRelease",
            "version" : "0.006"
         },
         {
            "class" : "Dist::Zilla::Plugin::Prereqs",
            "config" : {
               "Dist::Zilla::Plugin::Prereqs" : {
                  "phase" : "develop",
                  "type" : "recommends"
               }
            },
            "name" : "@Git::VersionManager/pluginbundle version",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::RewriteVersion::Transitional",
            "config" : {
               "Dist::Zilla::Plugin::RewriteVersion" : {
                  "add_tarball_name" : 0,
                  "finders" : [
                     ":ExecFiles",
                     ":InstallModules"
                  ],
                  "global" : 0,
                  "skip_version_provider" : 0
               },
               "Dist::Zilla::Plugin::RewriteVersion::Transitional" : {}
            },
            "name" : "@Git::VersionManager/RewriteVersion::Transitional",
            "version" : "0.009"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaProvides::Update",
            "name" : "@Git::VersionManager/MetaProvides::Update",
            "version" : "0.007"
         },
         {
            "class" : "Dist::Zilla::Plugin::CopyFilesFromRelease",
            "config" : {
               "Dist::Zilla::Plugin::CopyFilesFromRelease" : {
                  "filename" : [
                     "Changes"
                  ],
                  "match" : []
               }
            },
            "name" : "@Git::VersionManager/CopyFilesFromRelease",
            "version" : "0.006"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Commit",
            "config" : {
               "Dist::Zilla::Plugin::Git::Commit" : {
                  "add_files_in" : [],
                  "commit_msg" : "v%V%n%n%c"
               },
               "Dist::Zilla::Role::Git::DirtyFiles" : {
                  "allow_dirty" : [
                     "Changes",
                     "LICENSE",
                     "META.json",
                     "README.md",
                     "cpanfile"
                  ],
                  "allow_dirty_match" : [],
                  "changelog" : "Changes"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.25.0",
                  "repo_root" : "."
               },
               "Dist::Zilla::Role::Git::StringFormatter" : {
                  "time_zone" : "local"
               }
            },
            "name" : "@Git::VersionManager/release snapshot",
            "version" : "2.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Tag",
            "config" : {
               "Dist::Zilla::Plugin::Git::Tag" : {
                  "branch" : null,
                  "changelog" : "Changes",
                  "signed" : 0,
                  "tag" : "v6.07",
                  "tag_format" : "v%V",
                  "tag_message" : "v%V"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.25.0",
                  "repo_root" : "."
               },
               "Dist::Zilla::Role::Git::StringFormatter" : {
                  "time_zone" : "local"
               }
            },
            "name" : "@Git::VersionManager/Git::Tag",
            "version" : "2.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::BumpVersionAfterRelease::Transitional",
            "config" : {
               "Dist::Zilla::Plugin::BumpVersionAfterRelease" : {
                  "finders" : [
                     ":ExecFiles",
                     ":InstallModules"
                  ],
                  "global" : 0,
                  "munge_makefile_pl" : 1
               },
               "Dist::Zilla::Plugin::BumpVersionAfterRelease::Transitional" : {}
            },
            "name" : "@Git::VersionManager/BumpVersionAfterRelease::Transitional",
            "version" : "0.009"
         },
         {
            "class" : "Dist::Zilla::Plugin::NextRelease",
            "name" : "@Git::VersionManager/NextRelease",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Commit",
            "config" : {
               "Dist::Zilla::Plugin::Git::Commit" : {
                  "add_files_in" : [],
                  "commit_msg" : "increment $VERSION after %v release"
               },
               "Dist::Zilla::Role::Git::DirtyFiles" : {
                  "allow_dirty" : [
                     "Build.PL",
                     "Changes",
                     "Makefile.PL"
                  ],
                  "allow_dirty_match" : [
                     "(?^:^lib/.*\\.pm$)"
                  ],
                  "changelog" : "Changes"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.25.0",
                  "repo_root" : "."
               },
               "Dist::Zilla::Role::Git::StringFormatter" : {
                  "time_zone" : "local"
               }
            },
            "name" : "@Git::VersionManager/post-release commit",
            "version" : "2.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Push",
            "config" : {
               "Dist::Zilla::Plugin::Git::Push" : {
                  "push_to" : [
                     "origin"
                  ],
                  "remotes_must_exist" : 1
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.25.0",
                  "repo_root" : "."
               }
            },
            "name" : "Git::Push",
            "version" : "2.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::ConfirmRelease",
            "name" : "ConfirmRelease",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":InstallModules",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":IncModules",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":TestFiles",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":ExtraTestFiles",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":ExecFiles",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":PerlExecFiles",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":ShareFiles",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":MainModule",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":AllFiles",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":NoFiles",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : "MetaProvides::Package/AUTOVIV/:InstallModulesPM",
            "version" : "6.012"
         }
      ],
      "zilla" : {
         "class" : "Dist::Zilla::Dist::Builder",
         "config" : {
            "is_trial" : 0
         },
         "version" : "6.012"
      }
   },
   "x_authority" : "cpan:LWWWP",
   "x_contributors" : [
      "Adam Kennedy <adamk@cpan.org>",
      "Adam Sjogren <asjo@koldfront.dk>",
      "Alessandro Ghedini <al3xbio@gmail.com>",
      "Alexandr Ciornii <alexchorny@gmail.com>",
      "Alexey Tourbin <at@altlinux.ru>",
      "Alex Kapranoff <ka@nadoby.ru>",
      "amire80 <amir.aharoni@gmail.com>",
      "Andreas J. Koenig <andreas.koenig@anima.de>",
      "Bill Mann <wfmann@alum.mit.edu>",
      "Bron Gondwana <brong@fastmail.fm>",
      "Daniel Hedlund <Daniel.Hedlund@eprize.com>",
      "David E. Wheeler <david@justatheory.com>",
      "DAVIDRW <davidrw@cpan.org>",
      "David Steinbrunner <dsteinbrunner@pobox.com>",
      "E. Choroba <choroba@matfyz.cz>",
      "Father Chrysostomos <sprout@cpan.org>",
      "FWILES <FWILES@cpan.org>",
      "Gavin Peters <gpeters@deepsky.com>",
      "Gisle Aas <aas@oslonett.no>",
      "Gisle Aas <gisle.aas@it.uib.no>",
      "Gisle Aas <gisle@aas.no>",
      "Gisle Aas <gisle@baux-2.lan>",
      "Graeme Thompson <Graeme.Thompson@mobilecohesion.com>",
      "Hans-H. Froehlich <hfroehlich@co-de-co.de>",
      "Ian Kilgore <iank@cpan.org>",
      "Jacob J <waif@chaos2.org>",
      "jefflee <shaohua@gmail.com>",
      "john9art <john9art@yahoo.com>",
      "Julien Fiegehenn <simbabque@cpan.org>",
      "Lance Wicks <lw@judocoach.com>",
      "Lukas Mai <l.mai@web.de>",
      "Mark Stosberg <mark@stosberg.com>",
      "Mark Stosberg <MARKSTOS@cpan.org>",
      "Mark Stosberg <mark@summersault.com>",
      "Mike Schilli <mschilli@yahoo-inc.com>",
      "mschilli <github@perlmeister.com>",
      "murphy <murphy@genome.chop.edu>",
      "Olaf Alders <olaf@wundersolutions.com>",
      "Ondrej Hanak <ondrej.hanak@ubs.com>",
      "Peter Rabbitson <ribasushi@cpan.org>",
      "phrstbrn <phrstbrn@gmail.com>",
      "Robert Stone <talby@trap.mtview.ca.us>",
      "Rolf Grossmann <rg@progtech.net>",
      "ruff <ruff@ukrpost.net>",
      "sasao <sasao@yugen.org>",
      "Sean M. Burke <sburke@cpan.org>",
      "Slaven Rezic <slaven@rezic.de>",
      "Slaven Rezic <srezic@iconmobile.com>",
      "Spiros Denaxas <s.denaxas@gmail.com>",
      "Steve Hay <SteveHay@planit.com>",
      "Todd Lipcon <todd@amiestreet.com>",
      "Tom Hukins <tom@eborcom.com>",
      "Tony Finch <dot@dotat.at>",
      "Toru Yamaguchi <zigorou@cpan.org>",
      "uid39246 <uid39246>",
      "Ville Skytta <ville.skytta@iki.fi>",
      "Yuri Karaban <tech@askold.net>",
      "Zefram <zefram@fysh.org>"
   ],
   "x_generated_by_perl" : "v5.26.1",
   "x_serialization_backend" : "Cpanel::JSON::XS version 4.10"
}
PK       ! 	Ɖ8U  U  I  perl5/x86_64-linux-thread-multi/.meta/Template-Toolkit-3.102/install.jsonnu ��6�$        {"provides":{"Template::Directive":{"version":"3.100","file":"lib/Template/Directive.pm"},"Template::Document":{"file":"lib/Template/Document.pm","version":"3.100"},"Template::Plugin":{"version":"3.100","file":"lib/Template/Plugin.pm"},"Template::Plugin::Iterator":{"version":"3.100","file":"lib/Template/Plugin/Iterator.pm"},"Template::Toolkit":{"file":"lib/Template/Toolkit.pm","version":"3.100"},"Template::Plugin::Pod":{"version":"3.100","file":"lib/Template/Plugin/Pod.pm"},"Template::Plugin::Date":{"file":"lib/Template/Plugin/Date.pm","version":"3.100"},"Template::Parser":{"version":"3.100","file":"lib/Template/Parser.pm"},"Template::Plugin::Image":{"file":"lib/Template/Plugin/Image.pm","version":"3.100"},"Template::Monad::Assert":{"version":"3.100","file":"lib/Template/Plugin/Assert.pm"},"Template::Constants":{"version":"3.100","file":"lib/Template/Constants.pm"},"Template::TieString":{"file":"lib/Template/Config.pm","version":"3.100"},"Template::Perl":{"version":"3.100","file":"lib/Template/Filters.pm"},"Template::Stash::XS":{"file":"lib/Template/Stash/XS.pm"},"Template::Plugin::Procedural":{"version":"3.100","file":"lib/Template/Plugin/Procedural.pm"},"Template::Plugin::Table":{"file":"lib/Template/Plugin/Table.pm","version":"3.100"},"Template::Service":{"file":"lib/Template/Service.pm","version":"3.100"},"Template::Provider":{"version":"3.100","file":"lib/Template/Provider.pm"},"Template::Plugin::Scalar":{"version":"3.100","file":"lib/Template/Plugin/Scalar.pm"},"Template::Plugin::View":{"version":"3.100","file":"lib/Template/Plugin/View.pm"},"Template::Plugin::HTML":{"file":"lib/Template/Plugin/HTML.pm","version":"3.100"},"Template::Config":{"version":"3.100","file":"lib/Template/Config.pm"},"Template::Plugin::Datafile":{"file":"lib/Template/Plugin/Datafile.pm","version":"3.100"},"Template::Plugin::Date::Manip":{"file":"lib/Template/Plugin/Date.pm","version":"3.100"},"Template::Context":{"file":"lib/Template/Context.pm","version":"3.100"},"Template::Iterator":{"version":"3.100","file":"lib/Template/Iterator.pm"},"Template::VMethods":{"file":"lib/Template/VMethods.pm","version":"3.100"},"Template::Base":{"version":"3.100","file":"lib/Template/Base.pm"},"Template":{"file":"lib/Template.pm","version":3.102},"Template::Monad::Scalar":{"file":"lib/Template/Plugin/Scalar.pm","version":"3.100"},"Template::Plugin::Directory":{"version":"3.100","file":"lib/Template/Plugin/Directory.pm"},"Template::Test":{"file":"lib/Template/Test.pm","version":"3.100"},"Template::Plugin::Wrap":{"file":"lib/Template/Plugin/Wrap.pm","version":"3.100"},"Template::Plugin::Format":{"version":"3.100","file":"lib/Template/Plugin/Format.pm"},"Template::Exception":{"version":"3.100","file":"lib/Template/Exception.pm"},"Template::App::ttree":{"file":"lib/Template/App/ttree.pm","version":2.91},"Template::Stash":{"version":"3.100","file":"lib/Template/Stash.pm"},"Template::View":{"version":"3.100","file":"lib/Template/View.pm"},"Template::Plugin::Dumper":{"file":"lib/Template/Plugin/Dumper.pm","version":"3.100"},"Template::Plugin::String":{"file":"lib/Template/Plugin/String.pm","version":"3.100"},"Template::Namespace::Constants":{"version":"3.100","file":"lib/Template/Namespace/Constants.pm"},"Template::Plugin::Math":{"version":"3.100","file":"lib/Template/Plugin/Math.pm"},"Template::Plugins":{"file":"lib/Template/Plugins.pm","version":"3.100"},"Template::Plugin::Date::Calc":{"version":"3.100","file":"lib/Template/Plugin/Date.pm"},"Template::Plugin::URL":{"version":"3.100","file":"lib/Template/Plugin/URL.pm"},"Template::Stash::Context":{"version":"3.100","file":"lib/Template/Stash/Context.pm"},"Template::Plugin::File":{"version":"3.100","file":"lib/Template/Plugin/File.pm"},"Template::Grammar":{"file":"lib/Template/Grammar.pm","version":"3.100"},"Template::Plugin::Assert":{"file":"lib/Template/Plugin/Assert.pm","version":"3.100"},"Template::Filters":{"version":"3.100","file":"lib/Template/Filters.pm"},"Template::Plugin::Filter":{"version":"3.100","file":"lib/Template/Plugin/Filter.pm"}},"pathname":"T/TO/TODDR/Template-Toolkit-3.102.tar.gz","dist":"Template-Toolkit-3.102","version":3.102,"target":"Template::Constants","name":"Template"}PK       ! ��D�  �  H  perl5/x86_64-linux-thread-multi/.meta/Template-Toolkit-3.102/MYMETA.jsonnu ��6�$        {
   "abstract" : "comprehensive template processing system",
   "author" : [
      "Andy Wardley <abw@wardley.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.64, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "Template-Toolkit",
   "no_index" : {
      "directory" : [
         "t",
         "inc"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "AppConfig" : "1.56",
            "File::Spec" : "0.8",
            "File::Temp" : "0.12",
            "Scalar::Util" : "0"
         }
      },
      "test" : {
         "requires" : {
            "Test::LeakTrace" : "0"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "web" : "https://github.com/abw/Template2/issues"
      },
      "homepage" : "http://www.template-toolkit.org",
      "repository" : {
         "type" : "git",
         "url" : "https://github.com/abw/Template2.git",
         "web" : "https://github.com/abw/Template2"
      }
   },
   "version" : "3.102",
   "x_serialization_backend" : "JSON::PP version 4.07"
}
PK       ! �~�'�   �   E  perl5/x86_64-linux-thread-multi/.meta/File-Slurp-9999.32/install.jsonnu ��6�$        {"provides":{"File::Slurp":{"version":9999.32,"file":"lib/File/Slurp.pm"}},"target":"File::Slurp","version":9999.32,"name":"File::Slurp","dist":"File-Slurp-9999.32","pathname":"C/CA/CAPOEIRAB/File-Slurp-9999.32.tar.gz"}PK       ! ��F7	  	  D  perl5/x86_64-linux-thread-multi/.meta/File-Slurp-9999.32/MYMETA.jsonnu ��6�$        {
   "abstract" : "Simple and Efficient Reading/Writing/Modifying of Complete Files",
   "author" : [
      "Uri Guttman <uri@stemsystems.com>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.44, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "File-Slurp",
   "no_index" : {
      "directory" : [
         "t",
         "inc",
         "xt"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "B" : "0",
            "Carp" : "0",
            "Errno" : "0",
            "Exporter" : "5.57",
            "Fcntl" : "0",
            "File::Basename" : "0",
            "File::Spec" : "3.01",
            "File::Temp" : "0",
            "IO::Handle" : "0",
            "POSIX" : "0",
            "strict" : "0",
            "warnings" : "0"
         }
      },
      "test" : {
         "requires" : {
            "Carp" : "0",
            "Exporter" : "5.57",
            "Fcntl" : "0",
            "File::Basename" : "0",
            "File::Spec" : "3.01",
            "File::Temp" : "0",
            "IO::Handle" : "0",
            "POSIX" : "0",
            "Scalar::Util" : "1.00",
            "Socket" : "0",
            "Symbol" : "0",
            "Test::More" : "0",
            "overload" : "0",
            "strict" : "0",
            "warnings" : "0"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "repository" : {
         "type" : "git",
         "url" : "https://github.com/perhunter/slurp.git",
         "web" : "https://github.com/perhunter/slurp"
      }
   },
   "version" : "9999.32",
   "x_contributors" : [
      "Aristotle Pagaltzis <ARISTOTLE@cpan.org>",
      "Chase Whitener <capoeirab@cpan.org>",
      "Dan Book <grinnz@gmail.com>",
      "Graham Knop <haarg@haarg.org>",
      "James E Keenan <jkeenan@cpan.org>"
   ],
   "x_serialization_backend" : "JSON::PP version 4.04"
}
PK       ! ��:��   �   >  perl5/x86_64-linux-thread-multi/.meta/Expect-1.35/install.jsonnu ��6�$        {"provides":{"Expect":{"version":1.35,"file":"lib/Expect.pm"}},"target":"Expect","version":1.35,"name":"Expect","dist":"Expect-1.35","pathname":"J/JA/JACOBY/Expect-1.35.tar.gz"}PK       ! c LM`  `  =  perl5/x86_64-linux-thread-multi/.meta/Expect-1.35/MYMETA.jsonnu ��6�$        {
   "abstract" : "automate interactions with command line programs that expose a text terminal interface.",
   "author" : [
      "Austin Schutz <ASchutz@users.sourceforge.net>",
      "Roland Giersig <RGiersig@cpan.org>",
      "Dave Jacoby <jacoby@cpan.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "Expect",
   "no_index" : {
      "directory" : [
         "t",
         "inc"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {}
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "6.64"
         }
      },
      "runtime" : {
         "requires" : {
            "Carp" : "0",
            "Errno" : "0",
            "Exporter" : "0",
            "Fcntl" : "0",
            "IO::Handle" : "0",
            "IO::Pty" : "1.11",
            "IO::Tty" : "1.11",
            "POSIX" : "0",
            "perl" : "5.006000"
         }
      },
      "test" : {
         "requires" : {
            "File::Temp" : "0",
            "Test::More" : "1.00"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "repository" : {
         "type" : "git",
         "url" : "http://github.com/jacoby/expect.pm.git",
         "web" : "http://github.com/jacoby/expect.pm"
      }
   },
   "version" : "1.35",
   "x_serialization_backend" : "JSON::PP version 2.27400"
}
PK       ! ���m  m  A  perl5/x86_64-linux-thread-multi/.meta/YAML-Syck-1.34/install.jsonnu ��6�$        {"target":"YAML::Syck","dist":"YAML-Syck-1.34","version":1.34,"provides":{"YAML::Dumper::Syck":{"file":"lib/YAML/Dumper/Syck.pm"},"YAML::Syck":{"file":"lib/YAML/Syck.pm","version":1.34},"JSON::Syck":{"version":1.34,"file":"lib/JSON/Syck.pm"},"YAML::Loader::Syck":{"file":"lib/YAML/Loader/Syck.pm"}},"name":"YAML::Syck","pathname":"T/TO/TODDR/YAML-Syck-1.34.tar.gz"}PK       ! {��+    @  perl5/x86_64-linux-thread-multi/.meta/YAML-Syck-1.34/MYMETA.jsonnu ��6�$        {
   "abstract" : "Fast, lightweight YAML loader and dumper",
   "author" : [
      "Todd Rinaldo <toddr@cpan.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.44, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "mit"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "YAML-Syck",
   "no_index" : {
      "directory" : [
         "t",
         "inc"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "Test::More" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "perl" : "5.006"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "web" : "https://github.com/toddr/YAML-Syck/issues"
      },
      "homepage" : "http://github.com/toddr/YAML-Syck",
      "license" : [
         "http://dev.perl.org/licenses/"
      ],
      "repository" : {
         "url" : "http://github.com/toddr/YAML-Syck"
      }
   },
   "version" : "1.34",
   "x_serialization_backend" : "JSON::PP version 4.04"
}
PK       ! �"�y�  �  C  perl5/x86_64-linux-thread-multi/.meta/libwww-perl-6.49/install.jsonnu ��6�$        {"provides":{"LWP::Protocol::ftp":{"version":"6.49","file":"lib/LWP/Protocol/ftp.pm"},"LWP::Protocol::cpan":{"version":"6.49","file":"lib/LWP/Protocol/cpan.pm"},"LWP::Protocol::data":{"version":"6.49","file":"lib/LWP/Protocol/data.pm"},"LWP::Protocol::nogo":{"version":"6.49","file":"lib/LWP/Protocol/nogo.pm"},"LWP::Protocol::nntp":{"version":"6.49","file":"lib/LWP/Protocol/nntp.pm"},"LWP::Simple":{"version":"6.49","file":"lib/LWP/Simple.pm"},"LWP::Protocol::mailto":{"version":"6.49","file":"lib/LWP/Protocol/mailto.pm"},"LWP::Debug::TraceHTTP":{"version":"6.49","file":"lib/LWP/Debug/TraceHTTP.pm"},"LWP::DebugFile":{"version":"6.49","file":"lib/LWP/DebugFile.pm"},"LWP::RobotUA":{"version":"6.49","file":"lib/LWP/RobotUA.pm"},"LWP::ConnCache":{"version":"6.49","file":"lib/LWP/ConnCache.pm"},"LWP::Protocol::gopher":{"version":"6.49","file":"lib/LWP/Protocol/gopher.pm"},"LWP::Protocol::file":{"version":"6.49","file":"lib/LWP/Protocol/file.pm"},"LWP::Authen::Digest":{"version":"6.49","file":"lib/LWP/Authen/Digest.pm"},"LWP::Protocol::http":{"version":"6.49","file":"lib/LWP/Protocol/http.pm"},"LWP::MemberMixin":{"version":"6.49","file":"lib/LWP/MemberMixin.pm"},"LWP::UserAgent":{"version":"6.49","file":"lib/LWP/UserAgent.pm"},"LWP::Protocol::loopback":{"version":"6.49","file":"lib/LWP/Protocol/loopback.pm"},"LWP::Debug":{"x_deprecated":1,"version":"6.49","file":"lib/LWP/Debug.pm"},"LWP::Authen::Ntlm":{"version":"6.49","file":"lib/LWP/Authen/Ntlm.pm"},"LWP::Authen::Basic":{"version":"6.49","file":"lib/LWP/Authen/Basic.pm"},"LWP::Protocol":{"version":"6.49","file":"lib/LWP/Protocol.pm"},"LWP":{"version":"6.49","file":"lib/LWP.pm"}},"target":"LWP::UserAgent","version":"6.49","name":"libwww::perl","dist":"libwww-perl-6.49","pathname":"O/OA/OALDERS/libwww-perl-6.49.tar.gz"}PK       ! ���^�  ^�  B  perl5/x86_64-linux-thread-multi/.meta/libwww-perl-6.49/MYMETA.jsonnu ��6�$        {
   "abstract" : "The World-Wide Web library for Perl",
   "author" : [
      "Gisle Aas <gisle@activestate.com>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "Dist::Zilla version 6.015, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "libwww-perl",
   "no_index" : {
      "directory" : [
         "t",
         "xt"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "CPAN::Meta::Requirements" : "2.120620",
            "ExtUtils::MakeMaker" : "0",
            "File::Copy" : "0",
            "Getopt::Long" : "0",
            "Module::Metadata" : "0"
         }
      },
      "develop" : {
         "recommends" : {
            "Dist::Zilla::PluginBundle::Git::VersionManager" : "0.007"
         },
         "requires" : {
            "Authen::NTLM" : "1.02",
            "File::Spec" : "0",
            "IO::Handle" : "0",
            "IPC::Open3" : "0",
            "Pod::Coverage::TrustPod" : "0",
            "Test::EOL" : "0",
            "Test::LeakTrace" : "0.16",
            "Test::MinimumVersion" : "0",
            "Test::Mojibake" : "0",
            "Test::More" : "0.94",
            "Test::Pod" : "1.41",
            "Test::Pod::Coverage" : "1.08",
            "Test::Portability::Files" : "0",
            "Test::Spelling" : "0.12",
            "Test::Version" : "1"
         }
      },
      "runtime" : {
         "requires" : {
            "Digest::MD5" : "0",
            "Encode" : "2.12",
            "Encode::Locale" : "0",
            "File::Listing" : "6",
            "HTML::Entities" : "0",
            "HTML::HeadParser" : "0",
            "HTTP::Cookies" : "6",
            "HTTP::Daemon" : "6",
            "HTTP::Date" : "6",
            "HTTP::Negotiate" : "6",
            "HTTP::Request" : "6",
            "HTTP::Request::Common" : "6",
            "HTTP::Response" : "6",
            "HTTP::Status" : "6.07",
            "IO::Select" : "0",
            "IO::Socket" : "0",
            "LWP::MediaTypes" : "6",
            "MIME::Base64" : "2.1",
            "Net::FTP" : "2.58",
            "Net::HTTP" : "6.18",
            "Scalar::Util" : "0",
            "Try::Tiny" : "0",
            "URI" : "1.10",
            "URI::Escape" : "0",
            "WWW::RobotRules" : "6",
            "base" : "0",
            "perl" : "5.008001",
            "strict" : "0",
            "warnings" : "0"
         },
         "suggests" : {
            "Authen::NTLM" : "1.02",
            "Data::Dump" : "1.13",
            "IO::Socket::INET" : "0",
            "LWP::Protocol::https" : "6.02"
         }
      },
      "test" : {
         "recommends" : {
            "CPAN::Meta" : "2.120900",
            "Test::LeakTrace" : "0"
         },
         "requires" : {
            "ExtUtils::MakeMaker" : "0",
            "File::Spec" : "0",
            "FindBin" : "0",
            "Test::Fatal" : "0",
            "Test::More" : "0",
            "Test::Needs" : "0",
            "Test::RequiresInternet" : "0"
         }
      }
   },
   "provides" : {
      "LWP" : {
         "file" : "lib/LWP.pm",
         "version" : "6.49"
      },
      "LWP::Authen::Basic" : {
         "file" : "lib/LWP/Authen/Basic.pm",
         "version" : "6.49"
      },
      "LWP::Authen::Digest" : {
         "file" : "lib/LWP/Authen/Digest.pm",
         "version" : "6.49"
      },
      "LWP::Authen::Ntlm" : {
         "file" : "lib/LWP/Authen/Ntlm.pm",
         "version" : "6.49"
      },
      "LWP::ConnCache" : {
         "file" : "lib/LWP/ConnCache.pm",
         "version" : "6.49"
      },
      "LWP::Debug" : {
         "file" : "lib/LWP/Debug.pm",
         "version" : "6.49",
         "x_deprecated" : 1
      },
      "LWP::Debug::TraceHTTP" : {
         "file" : "lib/LWP/Debug/TraceHTTP.pm",
         "version" : "6.49"
      },
      "LWP::DebugFile" : {
         "file" : "lib/LWP/DebugFile.pm",
         "version" : "6.49"
      },
      "LWP::MemberMixin" : {
         "file" : "lib/LWP/MemberMixin.pm",
         "version" : "6.49"
      },
      "LWP::Protocol" : {
         "file" : "lib/LWP/Protocol.pm",
         "version" : "6.49"
      },
      "LWP::Protocol::cpan" : {
         "file" : "lib/LWP/Protocol/cpan.pm",
         "version" : "6.49"
      },
      "LWP::Protocol::data" : {
         "file" : "lib/LWP/Protocol/data.pm",
         "version" : "6.49"
      },
      "LWP::Protocol::file" : {
         "file" : "lib/LWP/Protocol/file.pm",
         "version" : "6.49"
      },
      "LWP::Protocol::ftp" : {
         "file" : "lib/LWP/Protocol/ftp.pm",
         "version" : "6.49"
      },
      "LWP::Protocol::gopher" : {
         "file" : "lib/LWP/Protocol/gopher.pm",
         "version" : "6.49"
      },
      "LWP::Protocol::http" : {
         "file" : "lib/LWP/Protocol/http.pm",
         "version" : "6.49"
      },
      "LWP::Protocol::loopback" : {
         "file" : "lib/LWP/Protocol/loopback.pm",
         "version" : "6.49"
      },
      "LWP::Protocol::mailto" : {
         "file" : "lib/LWP/Protocol/mailto.pm",
         "version" : "6.49"
      },
      "LWP::Protocol::nntp" : {
         "file" : "lib/LWP/Protocol/nntp.pm",
         "version" : "6.49"
      },
      "LWP::Protocol::nogo" : {
         "file" : "lib/LWP/Protocol/nogo.pm",
         "version" : "6.49"
      },
      "LWP::RobotUA" : {
         "file" : "lib/LWP/RobotUA.pm",
         "version" : "6.49"
      },
      "LWP::Simple" : {
         "file" : "lib/LWP/Simple.pm",
         "version" : "6.49"
      },
      "LWP::UserAgent" : {
         "file" : "lib/LWP/UserAgent.pm",
         "version" : "6.49"
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "web" : "https://github.com/libwww-perl/libwww-perl/issues"
      },
      "homepage" : "https://github.com/libwww-perl/libwww-perl",
      "repository" : {
         "type" : "git",
         "url" : "https://github.com/libwww-perl/libwww-perl.git",
         "web" : "https://github.com/libwww-perl/libwww-perl"
      },
      "x_IRC" : "irc://irc.perl.org/#lwp",
      "x_MailingList" : "mailto:libwww@perl.org"
   },
   "version" : "6.49",
   "x_Dist_Zilla" : {
      "perl" : {
         "version" : "5.026001"
      },
      "plugins" : [
         {
            "class" : "Dist::Zilla::Plugin::Git::GatherDir",
            "config" : {
               "Dist::Zilla::Plugin::GatherDir" : {
                  "exclude_filename" : [
                     "LICENSE",
                     "META.json",
                     "README.md"
                  ],
                  "exclude_match" : [],
                  "follow_symlinks" : 0,
                  "include_dotfiles" : 0,
                  "prefix" : "",
                  "prune_directory" : [],
                  "root" : "."
               },
               "Dist::Zilla::Plugin::Git::GatherDir" : {
                  "include_untracked" : 0
               }
            },
            "name" : "Git::GatherDir",
            "version" : "2.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaConfig",
            "name" : "MetaConfig",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaProvides::Package",
            "config" : {
               "Dist::Zilla::Plugin::MetaProvides::Package" : {
                  "finder_objects" : [
                     {
                        "class" : "Dist::Zilla::Plugin::FinderCode",
                        "name" : "MetaProvides::Package/AUTOVIV/:InstallModulesPM",
                        "version" : "6.015"
                     }
                  ],
                  "include_underscores" : 0
               },
               "Dist::Zilla::Role::MetaProvider::Provider" : {
                  "$Dist::Zilla::Role::MetaProvider::Provider::VERSION" : "2.002004",
                  "inherit_missing" : 1,
                  "inherit_version" : 1,
                  "meta_noindex" : 1
               },
               "Dist::Zilla::Role::ModuleMetadata" : {
                  "Module::Metadata" : "1.000037",
                  "version" : "0.004"
               }
            },
            "name" : "MetaProvides::Package",
            "version" : "2.004003"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaNoIndex",
            "name" : "MetaNoIndex",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaYAML",
            "name" : "MetaYAML",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaJSON",
            "name" : "MetaJSON",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaResources",
            "name" : "MetaResources",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::Deprecated",
            "config" : {
               "Dist::Zilla::Plugin::Deprecated" : {
                  "all" : 0,
                  "modules" : [
                     "LWP::Debug"
                  ]
               }
            },
            "name" : "Deprecated",
            "version" : "0.007"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Contributors",
            "config" : {
               "Dist::Zilla::Plugin::Git::Contributors" : {
                  "git_version" : "2.28.0",
                  "include_authors" : 0,
                  "include_releaser" : 1,
                  "order_by" : "name",
                  "paths" : []
               }
            },
            "name" : "Git::Contributors",
            "version" : "0.035"
         },
         {
            "class" : "Dist::Zilla::Plugin::GithubMeta",
            "name" : "GithubMeta",
            "version" : "0.58"
         },
         {
            "class" : "Dist::Zilla::Plugin::Authority",
            "name" : "Authority",
            "version" : "1.009"
         },
         {
            "class" : "Dist::Zilla::Plugin::Manifest",
            "name" : "Manifest",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::License",
            "name" : "License",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::InstallGuide",
            "config" : {
               "Dist::Zilla::Role::ModuleMetadata" : {
                  "Module::Metadata" : "1.000037",
                  "version" : "0.004"
               }
            },
            "name" : "InstallGuide",
            "version" : "1.200013"
         },
         {
            "class" : "Dist::Zilla::Plugin::ExecDir",
            "name" : "ExecDir",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::Prereqs::FromCPANfile",
            "name" : "Prereqs::FromCPANfile",
            "version" : "0.08"
         },
         {
            "class" : "Dist::Zilla::Plugin::DynamicPrereqs",
            "config" : {
               "Dist::Zilla::Role::ModuleMetadata" : {
                  "Module::Metadata" : "1.000037",
                  "version" : "0.004"
               }
            },
            "name" : "DynamicPrereqs",
            "version" : "0.037"
         },
         {
            "class" : "Dist::Zilla::Plugin::MakeMaker::Awesome",
            "config" : {
               "Dist::Zilla::Plugin::MakeMaker" : {
                  "make_path" : "make",
                  "version" : "6.015"
               },
               "Dist::Zilla::Role::TestRunner" : {
                  "default_jobs" : "4",
                  "version" : "6.015"
               }
            },
            "name" : "MakeMaker::Awesome",
            "version" : "0.48"
         },
         {
            "class" : "Dist::Zilla::Plugin::MojibakeTests",
            "name" : "MojibakeTests",
            "version" : "0.8"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::Version",
            "name" : "Test::Version",
            "version" : "1.09"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::ReportPrereqs",
            "name" : "Test::ReportPrereqs",
            "version" : "0.027"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::Compile",
            "config" : {
               "Dist::Zilla::Plugin::Test::Compile" : {
                  "bail_out_on_fail" : "1",
                  "fail_on_warning" : "author",
                  "fake_home" : 0,
                  "filename" : "xt/author/00-compile.t",
                  "module_finder" : [
                     ":InstallModules"
                  ],
                  "needs_display" : 0,
                  "phase" : "develop",
                  "script_finder" : [
                     ":PerlExecFiles"
                  ],
                  "skips" : [],
                  "switch" : []
               }
            },
            "name" : "Test::Compile",
            "version" : "2.058"
         },
         {
            "class" : "Dist::Zilla::Plugin::Substitute",
            "name" : "00-compile.t",
            "version" : "0.006"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::Portability",
            "config" : {
               "Dist::Zilla::Plugin::Test::Portability" : {
                  "options" : ""
               }
            },
            "name" : "Test::Portability",
            "version" : "2.001000"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::EOL",
            "config" : {
               "Dist::Zilla::Plugin::Test::EOL" : {
                  "filename" : "xt/author/eol.t",
                  "finder" : [
                     ":ExecFiles",
                     ":InstallModules",
                     ":TestFiles"
                  ],
                  "trailing_whitespace" : 1
               }
            },
            "name" : "Test::EOL",
            "version" : "0.19"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::ChangesHasContent",
            "name" : "Test::ChangesHasContent",
            "version" : "0.011"
         },
         {
            "class" : "Dist::Zilla::Plugin::Substitute",
            "name" : "changes_has_content.t",
            "version" : "0.006"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::MinimumVersion",
            "config" : {
               "Dist::Zilla::Plugin::Test::MinimumVersion" : {
                  "max_target_perl" : null
               }
            },
            "name" : "Test::MinimumVersion",
            "version" : "2.000010"
         },
         {
            "class" : "Dist::Zilla::Plugin::PodSyntaxTests",
            "name" : "PodSyntaxTests",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::Pod::Coverage::Configurable",
            "name" : "Test::Pod::Coverage::Configurable",
            "version" : "0.07"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::PodSpelling",
            "config" : {
               "Dist::Zilla::Plugin::Test::PodSpelling" : {
                  "directories" : [
                     "bin",
                     "lib"
                  ],
                  "spell_cmd" : "aspell list",
                  "stopwords" : [
                     "Accomazzi",
                     "Alexandre",
                     "Andreas",
                     "Asplund",
                     "Betts",
                     "Bochner",
                     "BooK",
                     "Buenzli",
                     "CGI",
                     "CPAN",
                     "Chamas",
                     "Coppit",
                     "Dalgleish",
                     "Dubois",
                     "Dunkin",
                     "Duret",
                     "Dvornik",
                     "Eldridge",
                     "Gertjan",
                     "Graaff",
                     "Greab",
                     "Guenther",
                     "Gurusamy",
                     "Gustafsson",
                     "Hakanson",
                     "Harald",
                     "Hedlund",
                     "Hoblitt",
                     "Hwa",
                     "INOUE",
                     "Joao",
                     "Joerg",
                     "KONISHI",
                     "Kaminsky",
                     "Kartik",
                     "Katsuhiro",
                     "Kebsch",
                     "Keiichiro",
                     "Kilzer",
                     "Klar",
                     "Koster",
                     "Kronengold",
                     "Krüger",
                     "Kubb",
                     "König",
                     "Laker",
                     "Langfeldt",
                     "Langheinrich",
                     "Liam",
                     "Lindley",
                     "Lotterer",
                     "Lutz",
                     "MacEachern",
                     "Macdonald",
                     "Mailto",
                     "Marko",
                     "Markus",
                     "Martijn",
                     "McCauley",
                     "Melchner",
                     "Moshe",
                     "Murrell",
                     "NNTP",
                     "NTLM",
                     "Nagano",
                     "Newby",
                     "Nicolai",
                     "Nierstrasz",
                     "Olly",
                     "Oosten",
                     "Panchenko",
                     "Pimlott",
                     "Pon",
                     "Quaranta",
                     "Radoslaw",
                     "Radu",
                     "Rai",
                     "Rezic",
                     "RobotUA",
                     "Sarathy",
                     "Schilli",
                     "Schinder",
                     "Shirazi",
                     "Skyttä",
                     "Slaven",
                     "Spafford",
                     "Stosberg",
                     "Subbarao",
                     "TCP",
                     "Takanori",
                     "Thoennes",
                     "Thurn",
                     "Tilly",
                     "UA",
                     "Ugai",
                     "Unger",
                     "UserAgent",
                     "VanHeyningen",
                     "Vandewege",
                     "Ville",
                     "WireShark",
                     "Yee",
                     "Yitzchak",
                     "Yoshinari",
                     "Zajac",
                     "Zakharevich",
                     "Zielinski",
                     "Zoest",
                     "afPuUsSedvhx",
                     "de",
                     "erik",
                     "getprint",
                     "getstore",
                     "peterm",
                     "shildreth"
                  ],
                  "wordlist" : "Pod::Wordlist"
               }
            },
            "name" : "Test::PodSpelling",
            "version" : "2.007005"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Check",
            "config" : {
               "Dist::Zilla::Plugin::Git::Check" : {
                  "untracked_files" : "die"
               },
               "Dist::Zilla::Role::Git::DirtyFiles" : {
                  "allow_dirty" : [],
                  "allow_dirty_match" : [],
                  "changelog" : "Changes"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.28.0",
                  "repo_root" : "."
               }
            },
            "name" : "Git::Check",
            "version" : "2.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::CheckStrictVersion",
            "name" : "CheckStrictVersion",
            "version" : "0.001"
         },
         {
            "class" : "Dist::Zilla::Plugin::RunExtraTests",
            "config" : {
               "Dist::Zilla::Role::TestRunner" : {
                  "default_jobs" : "4"
               }
            },
            "name" : "RunExtraTests",
            "version" : "0.029"
         },
         {
            "class" : "Dist::Zilla::Plugin::CheckChangeLog",
            "name" : "CheckChangeLog",
            "version" : "0.05"
         },
         {
            "class" : "Dist::Zilla::Plugin::CheckChangesHasContent",
            "name" : "CheckChangesHasContent",
            "version" : "0.011"
         },
         {
            "class" : "Dist::Zilla::Plugin::TestRelease",
            "name" : "TestRelease",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::UploadToCPAN",
            "name" : "UploadToCPAN",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::ReadmeAnyFromPod",
            "config" : {
               "Dist::Zilla::Role::FileWatcher" : {
                  "version" : "0.006"
               }
            },
            "name" : "Markdown_Readme",
            "version" : "0.163250"
         },
         {
            "class" : "Dist::Zilla::Plugin::CopyFilesFromRelease",
            "config" : {
               "Dist::Zilla::Plugin::CopyFilesFromRelease" : {
                  "filename" : [
                     "LICENSE",
                     "META.json"
                  ],
                  "match" : []
               }
            },
            "name" : "CopyFilesFromRelease",
            "version" : "0.006"
         },
         {
            "class" : "Dist::Zilla::Plugin::Prereqs",
            "config" : {
               "Dist::Zilla::Plugin::Prereqs" : {
                  "phase" : "develop",
                  "type" : "recommends"
               }
            },
            "name" : "@Git::VersionManager/pluginbundle version",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::RewriteVersion::Transitional",
            "config" : {
               "Dist::Zilla::Plugin::RewriteVersion" : {
                  "add_tarball_name" : 0,
                  "finders" : [
                     ":ExecFiles",
                     ":InstallModules"
                  ],
                  "global" : 0,
                  "skip_version_provider" : 0
               },
               "Dist::Zilla::Plugin::RewriteVersion::Transitional" : {}
            },
            "name" : "@Git::VersionManager/RewriteVersion::Transitional",
            "version" : "0.009"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaProvides::Update",
            "name" : "@Git::VersionManager/MetaProvides::Update",
            "version" : "0.007"
         },
         {
            "class" : "Dist::Zilla::Plugin::CopyFilesFromRelease",
            "config" : {
               "Dist::Zilla::Plugin::CopyFilesFromRelease" : {
                  "filename" : [
                     "Changes"
                  ],
                  "match" : []
               }
            },
            "name" : "@Git::VersionManager/CopyFilesFromRelease",
            "version" : "0.006"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Commit",
            "config" : {
               "Dist::Zilla::Plugin::Git::Commit" : {
                  "add_files_in" : [],
                  "commit_msg" : "v%V%n%n%c"
               },
               "Dist::Zilla::Role::Git::DirtyFiles" : {
                  "allow_dirty" : [
                     "Changes",
                     "LICENSE",
                     "META.json",
                     "README.md"
                  ],
                  "allow_dirty_match" : [],
                  "changelog" : "Changes"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.28.0",
                  "repo_root" : "."
               },
               "Dist::Zilla::Role::Git::StringFormatter" : {
                  "time_zone" : "local"
               }
            },
            "name" : "@Git::VersionManager/release snapshot",
            "version" : "2.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Tag",
            "config" : {
               "Dist::Zilla::Plugin::Git::Tag" : {
                  "branch" : null,
                  "changelog" : "Changes",
                  "signed" : 0,
                  "tag" : "v6.49",
                  "tag_format" : "v%V",
                  "tag_message" : "v%V"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.28.0",
                  "repo_root" : "."
               },
               "Dist::Zilla::Role::Git::StringFormatter" : {
                  "time_zone" : "local"
               }
            },
            "name" : "@Git::VersionManager/Git::Tag",
            "version" : "2.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::BumpVersionAfterRelease::Transitional",
            "config" : {
               "Dist::Zilla::Plugin::BumpVersionAfterRelease" : {
                  "finders" : [
                     ":ExecFiles",
                     ":InstallModules"
                  ],
                  "global" : 0,
                  "munge_makefile_pl" : 1
               },
               "Dist::Zilla::Plugin::BumpVersionAfterRelease::Transitional" : {}
            },
            "name" : "@Git::VersionManager/BumpVersionAfterRelease::Transitional",
            "version" : "0.009"
         },
         {
            "class" : "Dist::Zilla::Plugin::NextRelease",
            "name" : "@Git::VersionManager/NextRelease",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Commit",
            "config" : {
               "Dist::Zilla::Plugin::Git::Commit" : {
                  "add_files_in" : [],
                  "commit_msg" : "increment $VERSION after %v release"
               },
               "Dist::Zilla::Role::Git::DirtyFiles" : {
                  "allow_dirty" : [
                     "Build.PL",
                     "Changes",
                     "Makefile.PL"
                  ],
                  "allow_dirty_match" : [
                     "(?^:^lib/.*\\.pm$)"
                  ],
                  "changelog" : "Changes"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.28.0",
                  "repo_root" : "."
               },
               "Dist::Zilla::Role::Git::StringFormatter" : {
                  "time_zone" : "local"
               }
            },
            "name" : "@Git::VersionManager/post-release commit",
            "version" : "2.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Push",
            "config" : {
               "Dist::Zilla::Plugin::Git::Push" : {
                  "push_to" : [
                     "origin"
                  ],
                  "remotes_must_exist" : 1
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.28.0",
                  "repo_root" : "."
               }
            },
            "name" : "Git::Push",
            "version" : "2.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::ConfirmRelease",
            "name" : "ConfirmRelease",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":InstallModules",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":IncModules",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":TestFiles",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":ExtraTestFiles",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":ExecFiles",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":PerlExecFiles",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":ShareFiles",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":MainModule",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":AllFiles",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":NoFiles",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : "MetaProvides::Package/AUTOVIV/:InstallModulesPM",
            "version" : "6.015"
         }
      ],
      "zilla" : {
         "class" : "Dist::Zilla::Dist::Builder",
         "config" : {
            "is_trial" : 0
         },
         "version" : "6.015"
      }
   },
   "x_authority" : "cpan:LWWWP",
   "x_contributors" : [
      "Adam Kennedy <adamk@cpan.org>",
      "Adam Sjogren <asjo@koldfront.dk>",
      "Alexey Tourbin <at@altlinux.ru>",
      "Alex Kapranoff <ka@nadoby.ru>",
      "amire80 <amir.aharoni@gmail.com>",
      "Andreas J. Koenig <andreas.koenig@anima.de>",
      "Andrew Grangaard <granny-github@ofb.net>",
      "Anirvan Chatterjee <anirvan@users.noreply.github.com>",
      "BGMNT <freeerider@mailinator.com>",
      "Bill Mann <wfmann@alum.mit.edu>",
      "Bron Gondwana <brong@fastmail.fm>",
      "Bryan Cardillo <bryan.cardillo@gmail.com>",
      "Chase Whitener <capoeirab@cpan.org>",
      "Christopher J. Madsen <cjm@cpan.org>",
      "Colin Newell <colin.newell@gmail.com>",
      "Daina Pettit <dpettit@bluehost.com>",
      "Daniel Hedlund <Daniel.Hedlund@eprize.com>",
      "David E. Wheeler <david@justatheory.com>",
      "DAVIDRW <davidrw@cpan.org>",
      "David Standish <dnstandish@gmail.com>",
      "David Steinbrunner <dsteinbrunner@MountainBook-Pro.local>",
      "Desmond Daignault <nawglan@cpan.org>",
      "Doug Bell <doug@preaction.me>",
      "Fabian Zeindler <faz@open.ch>",
      "Father Chrysostomos <sprout@cpan.org>",
      "Frank Maas <maas.frank@gmail.com>",
      "FWILES <FWILES@cpan.org>",
      "Galen Huntington <galen@alumni.reed.edu>",
      "Gavin Peters <gpeters@deepsky.com>",
      "Gerhard Poul <gerhard.poul@gmail.com>",
      "Gianni Ceccarelli <gianni.ceccarelli@broadbean.com>",
      "Gisle Aas <gisle@aas.no>",
      "Graeme Thompson <Graeme.Thompson@mobilecohesion.com>",
      "Graham Knop <haarg@haarg.org>",
      "Gregory Oschwald <oschwald@gmail.com>",
      "Hans-H. Froehlich <hfroehlich@co-de-co.de>",
      "Ian Kilgore <iank@cpan.org>",
      "Jacob J <waif@chaos2.org>",
      "Jakub Wilk <jwilk@jwilk.net>",
      "James Raspass <jraspass@gmail.com>",
      "Jason A Fesler <jfesler@gigo.com>",
      "jefflee <shaohua@gmail.com>",
      "Jeremy Mates <jmates@cpan.org>",
      "Joe Atzberger <ohiocore@gmail.com>",
      "john9art <john9art@yahoo.com>",
      "John Wittkoski <jwittkoski@gmail.com>",
      "Jonathan Dahan <jonathan@augwa.com>",
      "Julien Fiegehenn <simbabque@cpan.org>",
      "Karen Etheridge <ether@cpan.org>",
      "Katarina Durechova <katarina.durechova@nic.cz>",
      "leedo <leedo@users.noreply.github.com>",
      "Mark Fowler <mark@twoshortplanks.com>",
      "Mark Stosberg <mark@stosberg.com>",
      "Martin H. Sluka <martin@sluka.de>",
      "Matthew Horsfall <wolfsage@gmail.com>",
      "michael gong <michealgong@126.com>",
      "Michael G. Schwern <schwern@pobox.com>",
      "Michiel Beijen <michiel.beijen@otrs.com>",
      "Mike Schilli <github@perlmeister.com>",
      "Moritz Onken <onken@netcubed.de>",
      "murphy <murphy@genome.chop.edu>",
      "Naveed Massjouni <naveedm9@gmail.com>",
      "Nigel Gregoire <nigelgregoire@gmail.com>",
      "Nik LaBelle <nalabelle@gmail.com>",
      "Niko Tyni <ntyni@debian.org>",
      "Olaf Alders <olaf@wundersolutions.com>",
      "Ondrej Hanak <ondrej.hanak@ubs.com>",
      "Patrik Lundin <patrik.lundin@su.se>",
      "Peter Rabbitson <ribasushi@cpan.org>",
      "phrstbrn <phrstbrn@gmail.com>",
      "Piotr Roszatycki <piotr.roszatycki@gmail.com>",
      "Robert Stone <talby@trap.mtview.ca.us>",
      "Rolf Grossmann <rg@progtech.net>",
      "Roman Galeev <roman.galeev@gooddata.com>",
      "ruff <ruff@ukrpost.net>",
      "sasao <sasao@yugen.org>",
      "Sean M. Burke <sburke@cpan.org>",
      "Sebastian Paaske Tørholm <Eckankar@gmail.com>",
      "Sergey Romanov <sromanov-dev@yandex.ru>",
      "Shoichi Kaji <skaji@cpan.org>",
      "Slaven Rezic <slaven@rezic.de>",
      "Spiros Denaxas <s.denaxas@gmail.com>",
      "Steffen Ullrich <Steffen_Ullrich@genua.de>",
      "Steve Hay <SteveHay@planit.com>",
      "Takumi Akiyama <t.akiym@gmail.com>",
      "Theodore Robert Campbell Jr <trcjr@stupidfoot.com>",
      "Theo van Hoesel <Th.J.v.Hoesel+GitHub@gmail.com>",
      "Tim Couzins <tim.couzins@sophos.com>",
      "Todd Lipcon <todd@amiestreet.com>",
      "Tomasz Konojacki <me@xenu.pl>",
      "Tom Hukins <tom@eborcom.com>",
      "Tony Finch <dot@dotat.at>",
      "Toru Yamaguchi <zigorou@cpan.org>",
      "turugina <turugina@floralcompany.jp>",
      "uid39246 <uid39246>",
      "Ville Skyttä <ville.skytta@iki.fi>",
      "Vyacheslav Matyukhin <mmcleric@yandex-team.ru>",
      "Yuri Karaban <tech@askold.net>",
      "Yury Zavarin <yury.zavarin@gmail.com>",
      "Zefram <zefram@fysh.org>"
   ],
   "x_generated_by_perl" : "v5.26.1",
   "x_serialization_backend" : "Cpanel::JSON::XS version 4.04",
   "x_spdx_expression" : "Artistic-1.0-Perl OR GPL-1.0-or-later"
}
PK       ! Bg�   �   >  perl5/x86_64-linux-thread-multi/.meta/Expect-1.38/install.jsonnu ��6�$        {"provides":{"Expect":{"version":1.38,"file":"lib/Expect.pm"}},"pathname":"J/JA/JACOBY/Expect-1.38.tar.gz","name":"Expect","version":1.38,"dist":"Expect-1.38","target":"Expect"}PK       ! ve�0]  ]  =  perl5/x86_64-linux-thread-multi/.meta/Expect-1.38/MYMETA.jsonnu ��6�$        {
   "abstract" : "automate interactions with command line programs that expose a text terminal interface.",
   "author" : [
      "Austin Schutz <ASchutz@users.sourceforge.net>",
      "Roland Giersig <RGiersig@cpan.org>",
      "Dave Jacoby <jacoby@cpan.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.62, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "Expect",
   "no_index" : {
      "directory" : [
         "t",
         "inc"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {}
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "6.64"
         }
      },
      "runtime" : {
         "requires" : {
            "Carp" : "0",
            "Errno" : "0",
            "Exporter" : "0",
            "Fcntl" : "0",
            "IO::Handle" : "0",
            "IO::Pty" : "1.11",
            "IO::Tty" : "1.11",
            "POSIX" : "0",
            "perl" : "5.006000"
         }
      },
      "test" : {
         "requires" : {
            "File::Temp" : "0",
            "Test::More" : "1.00"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "repository" : {
         "type" : "git",
         "url" : "http://github.com/jacoby/expect.pm.git",
         "web" : "http://github.com/jacoby/expect.pm"
      }
   },
   "version" : "1.38",
   "x_serialization_backend" : "JSON::PP version 4.06"
}
PK       ! �j�!�  �  C  perl5/x86_64-linux-thread-multi/.meta/Alien-Build-2.33/install.jsonnu ��6�$        {"provides":{"Alien::Build::Plugin::Core::Setup":{"version":2.33,"file":"lib/Alien/Build/Plugin/Core/Setup.pm"},"Alien::Build::Plugin::Extract::ArchiveZip":{"version":2.33,"file":"lib/Alien/Build/Plugin/Extract/ArchiveZip.pm"},"Alien::Build::Plugin::Core::Tail":{"version":2.33,"file":"lib/Alien/Build/Plugin/Core/Tail.pm"},"Alien::Build::Plugin::Fetch::CurlCommand":{"version":2.33,"file":"lib/Alien/Build/Plugin/Fetch/CurlCommand.pm"},"Alien::Build::Plugin::Decode::DirListing":{"version":2.33,"file":"lib/Alien/Build/Plugin/Decode/DirListing.pm"},"Alien::Build::Plugin::Build::MSYS":{"version":2.33,"file":"lib/Alien/Build/Plugin/Build/MSYS.pm"},"Test::Alien":{"version":2.33,"file":"lib/Test/Alien.pm"},"Alien::Build::Interpolate":{"version":2.33,"file":"lib/Alien/Build/Interpolate.pm"},"Alien::Build::Plugin::Extract::Negotiate":{"version":2.33,"file":"lib/Alien/Build/Plugin/Extract/Negotiate.pm"},"Alien::Build::Meta":{"version":2.33,"file":"lib/Alien/Build.pm"},"Alien::Build::Plugin::PkgConfig::LibPkgConf":{"version":2.33,"file":"lib/Alien/Build/Plugin/PkgConfig/LibPkgConf.pm"},"Alien::Build::Plugin::Gather::IsolateDynamic":{"version":2.33,"file":"lib/Alien/Build/Plugin/Gather/IsolateDynamic.pm"},"Test::Alien::Build":{"version":2.33,"file":"lib/Test/Alien/Build.pm"},"Alien::Build::Plugin::Probe::CBuilder":{"version":2.33,"file":"lib/Alien/Build/Plugin/Probe/CBuilder.pm"},"Alien::Build::Interpolate::Default":{"version":2.33,"file":"lib/Alien/Build/Interpolate/Default.pm"},"Alien::Build::Plugin::Fetch::LocalDir":{"version":2.33,"file":"lib/Alien/Build/Plugin/Fetch/LocalDir.pm"},"Alien::Build::Plugin::Probe::CommandLine":{"version":2.33,"file":"lib/Alien/Build/Plugin/Probe/CommandLine.pm"},"Alien::Build::Plugin::PkgConfig::PP":{"version":2.33,"file":"lib/Alien/Build/Plugin/PkgConfig/PP.pm"},"Alien::Build::Plugin::PkgConfig::Negotiate":{"version":2.33,"file":"lib/Alien/Build/Plugin/PkgConfig/Negotiate.pm"},"Alien::Build::MM":{"version":2.33,"file":"lib/Alien/Build/MM.pm"},"Alien::Build::Plugin::Core::Download":{"version":2.33,"file":"lib/Alien/Build/Plugin/Core/Download.pm"},"Alien::Build::TempDir":{"version":2.33,"file":"lib/Alien/Build.pm"},"Alien::Build::Plugin::PkgConfig::CommandLine":{"version":2.33,"file":"lib/Alien/Build/Plugin/PkgConfig/CommandLine.pm"},"Alien::Base::Wrapper":{"version":2.33,"file":"lib/Alien/Base/Wrapper.pm"},"Test::Alien::Synthetic":{"version":2.33,"file":"lib/Test/Alien/Synthetic.pm"},"Alien::Build::Helper":{"version":2.33,"file":"lib/Alien/Build/Interpolate.pm"},"Alien::Build::Interpolate::Helper":{"version":2.33,"file":"lib/Alien/Build/Interpolate.pm"},"Alien::Build":{"version":2.33,"file":"lib/Alien/Build.pm"},"Alien::Build::PluginMeta":{"version":2.33,"file":"lib/Alien/Build/Plugin.pm"},"Alien::Build::Plugin::Prefer::GoodVersion":{"version":2.33,"file":"lib/Alien/Build/Plugin/Prefer/GoodVersion.pm"},"Alien::Build::Plugin::Extract::CommandLine":{"version":2.33,"file":"lib/Alien/Build/Plugin/Extract/CommandLine.pm"},"Alien::Build::Plugin::Core::CleanInstall":{"version":2.33,"file":"lib/Alien/Build/Plugin/Core/CleanInstall.pm"},"Alien::Build::rc":{"version":2.33,"file":"lib/Alien/Build.pm"},"Alien::Build::Plugin":{"version":2.33,"file":"lib/Alien/Build/Plugin.pm"},"alienfile":{"version":2.33,"file":"lib/alienfile.pm"},"Alien::Build::Plugin::Fetch::LWP":{"version":2.33,"file":"lib/Alien/Build/Plugin/Fetch/LWP.pm"},"Alien::Base::PkgConfig":{"version":2.33,"file":"lib/Alien/Base/PkgConfig.pm"},"Alien::Base":{"version":2.33,"file":"lib/Alien/Base.pm"},"Alien::Build::Temp":{"version":2.33,"file":"lib/Alien/Build/Temp.pm"},"Test::Alien::CanPlatypus":{"version":2.33,"file":"lib/Test/Alien/CanPlatypus.pm"},"Alien::Build::Plugin::Decode::DirListingFtpcopy":{"version":2.33,"file":"lib/Alien/Build/Plugin/Decode/DirListingFtpcopy.pm"},"Alien::Build::Plugin::Test::Mock":{"version":2.33,"file":"lib/Alien/Build/Plugin/Test/Mock.pm"},"Alien::Build::Plugin::Decode::HTML":{"version":2.33,"file":"lib/Alien/Build/Plugin/Decode/HTML.pm"},"Alien::Build::Version::Basic":{"version":2.33,"file":"lib/Alien/Build/Version/Basic.pm"},"Alien::Build::Plugin::Decode::Mojo":{"version":2.33,"file":"lib/Alien/Build/Plugin/Decode/Mojo.pm"},"Alien::Build::Plugin::Fetch::NetFTP":{"version":2.33,"file":"lib/Alien/Build/Plugin/Fetch/NetFTP.pm"},"Alien::Build::Plugin::Core::Gather":{"version":2.33,"file":"lib/Alien/Build/Plugin/Core/Gather.pm"},"Alien::Build::Plugin::Build::CMake":{"version":2.33,"file":"lib/Alien/Build/Plugin/Build/CMake.pm"},"Alien::Build::Plugin::Prefer::SortVersions":{"version":2.33,"file":"lib/Alien/Build/Plugin/Prefer/SortVersions.pm"},"Alien::Build::Plugin::Core::Override":{"version":2.33,"file":"lib/Alien/Build/Plugin/Core/Override.pm"},"Alien::Build::Plugin::Build::SearchDep":{"version":2.33,"file":"lib/Alien/Build/Plugin/Build/SearchDep.pm"},"Alien::Role":{"version":2.33,"file":"lib/Alien/Role.pm"},"Alien::Build::Log::Abbreviate":{"version":2.33,"file":"lib/Alien/Build/Log/Abbreviate.pm"},"Alien::Build::Plugin::Core::FFI":{"version":2.33,"file":"lib/Alien/Build/Plugin/Core/FFI.pm"},"Test::Alien::CanCompile":{"version":2.33,"file":"lib/Test/Alien/CanCompile.pm"},"Alien::Build::Log":{"version":2.33,"file":"lib/Alien/Build/Log.pm"},"Alien::Build::Plugin::Prefer::BadVersion":{"version":2.33,"file":"lib/Alien/Build/Plugin/Prefer/BadVersion.pm"},"Alien::Build::Plugin::Core::Legacy":{"version":2.33,"file":"lib/Alien/Build/Plugin/Core/Legacy.pm"},"Alien::Build::Log::Default":{"version":2.33,"file":"lib/Alien/Build/Log/Default.pm"},"Test::Alien::Diag":{"version":2.33,"file":"lib/Test/Alien/Diag.pm"},"Alien::Build::Plugin::Probe::Vcpkg":{"version":2.33,"file":"lib/Alien/Build/Plugin/Probe/Vcpkg.pm"},"Alien::Build::CommandSequence":{"version":2.33,"file":"lib/Alien/Build/CommandSequence.pm"},"Alien::Build::Plugin::Build::Make":{"version":2.33,"file":"lib/Alien/Build/Plugin/Build/Make.pm"},"Alien::Build::Plugin::Fetch::Wget":{"version":2.33,"file":"lib/Alien/Build/Plugin/Fetch/Wget.pm"},"Alien::Build::Plugin::PkgConfig::MakeStatic":{"version":2.33,"file":"lib/Alien/Build/Plugin/PkgConfig/MakeStatic.pm"},"Alien::Build::Plugin::Build::Autoconf":{"version":2.33,"file":"lib/Alien/Build/Plugin/Build/Autoconf.pm"},"Test::Alien::Run":{"version":2.33,"file":"lib/Test/Alien/Run.pm"},"Alien::Build::Util":{"version":2.33,"file":"lib/Alien/Build/Util.pm"},"Alien::Build::Plugin::Build::Copy":{"version":2.33,"file":"lib/Alien/Build/Plugin/Build/Copy.pm"},"Alien::Build::Plugin::Fetch::Local":{"version":2.33,"file":"lib/Alien/Build/Plugin/Fetch/Local.pm"},"Alien::Build::Plugin::Extract::Directory":{"version":2.33,"file":"lib/Alien/Build/Plugin/Extract/Directory.pm"},"Alien::Build::Plugin::Download::Negotiate":{"version":2.33,"file":"lib/Alien/Build/Plugin/Download/Negotiate.pm"},"Alien::Build::Plugin::Fetch::HTTPTiny":{"version":2.33,"file":"lib/Alien/Build/Plugin/Fetch/HTTPTiny.pm"},"Alien::Build::Plugin::Extract::ArchiveTar":{"version":2.33,"file":"lib/Alien/Build/Plugin/Extract/ArchiveTar.pm"}},"target":"Alien::Base::Wrapper","version":2.33,"name":"Alien::Build","dist":"Alien-Build-2.33","pathname":"P/PL/PLICEASE/Alien-Build-2.33.tar.gz"}PK       ! 	X�m�  �  B  perl5/x86_64-linux-thread-multi/.meta/Alien-Build-2.33/MYMETA.jsonnu ��6�$        {
   "abstract" : "Build external dependencies for use in CPAN",
   "author" : [
      "Graham Ollis <plicease@cpan.org>",
      "Joel Berger <joel.a.berger@gmail.com>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "Dist::Zilla version 6.015, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "Alien-Build",
   "no_index" : {
      "directory" : [
         "corpus",
         "example",
         "maint"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "6.64"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::CBuilder" : "0",
            "ExtUtils::MakeMaker" : "6.64",
            "ExtUtils::ParseXS" : "3.30",
            "File::Which" : "0"
         }
      },
      "develop" : {
         "requires" : {
            "FindBin" : "0",
            "Perl::Critic" : "0",
            "Test2::Require::Module" : "0.000060",
            "Test2::Tools::PerlCritic" : "0",
            "Test2::V0" : "0.000060",
            "Test::CPAN::Changes" : "0",
            "Test::EOL" : "0",
            "Test::Fixme" : "0.07",
            "Test::More" : "0.98",
            "Test::NoTabs" : "0",
            "Test::Pod" : "0",
            "Test::Pod::Coverage" : "0",
            "Test::Spelling" : "0",
            "Test::Strict" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "Capture::Tiny" : "0.17",
            "ExtUtils::CBuilder" : "0",
            "ExtUtils::MakeMaker" : "6.64",
            "ExtUtils::ParseXS" : "3.30",
            "FFI::CheckLib" : "0.11",
            "File::Which" : "1.10",
            "File::chdir" : "0",
            "JSON::PP" : "0",
            "List::Util" : "1.33",
            "Path::Tiny" : "0.077",
            "Test2::API" : "1.302096",
            "Text::ParseWords" : "3.26",
            "perl" : "5.008004"
         },
         "suggests" : {
            "Archive::Tar" : "0"
         }
      },
      "test" : {
         "requires" : {
            "Test2::API" : "1.302096",
            "Test2::V0" : "0.000060"
         },
         "suggests" : {
            "Devel::Hide" : "0"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "web" : "https://github.com/PerlAlien/Alien-Build/issues"
      },
      "homepage" : "https://metacpan.org/pod/Alien::Build",
      "repository" : {
         "type" : "git",
         "url" : "git://github.com/PerlAlien/Alien-Build.git",
         "web" : "https://github.com/PerlAlien/Alien-Build"
      },
      "x_IRC" : "irc://irc.perl.org/#native"
   },
   "version" : "2.33",
   "x_contributors" : [
      "Graham Ollis <plicease@cpan.org>",
      "Diab Jerius (DJERIUS)",
      "Roy Storey (KIWIROY)",
      "Ilya Pavlov",
      "David Mertens (run4flat)",
      "Mark Nunberg (mordy, mnunberg)",
      "Christian Walde (Mithaldu)",
      "Brian Wightman (MidLifeXis)",
      "Zaki Mughal (zmughal)",
      "mohawk (mohawk2, ETJ)",
      "Vikas N Kumar (vikasnkumar)",
      "Flavio Poletti (polettix)",
      "Salvador Fandiño (salva)",
      "Gianni Ceccarelli (dakkar)",
      "Pavel Shaydo (zwon, trinitum)",
      "Kang-min Liu (劉康民, gugod)",
      "Nicholas Shipp (nshp)",
      "Juan Julián Merelo Guervós (JJ)",
      "Joel Berger (JBERGER)",
      "Petr Pisar (ppisar)",
      "Lance Wicks (LANCEW)",
      "Ahmad Fatoum (a3f, ATHREEF)",
      "José Joaquín Atria (JJATRIA)",
      "Duke Leto (LETO)",
      "Shoichi Kaji (SKAJI)",
      "Shawn Laffan (SLAFFAN)",
      "Paul Evans (leonerd, PEVANS)",
      "Håkon Hægland (hakonhagland, HAKONH)"
   ],
   "x_generated_by_perl" : "v5.32.0",
   "x_serialization_backend" : "Cpanel::JSON::XS version 4.19",
   "x_spdx_expression" : "Artistic-1.0-Perl OR GPL-1.0-or-later",
   "x_use_unsafe_inc" : 0
}
PK       ! �:�c
  c
  D  perl5/x86_64-linux-thread-multi/.meta/XML-LibXML-2.0206/install.jsonnu ��6�$        {"provides":{"XML::LibXML::PI":{"version":2.0206,"file":"LibXML.pm"},"XML::LibXML::Pattern":{"version":2.0206,"file":"LibXML.pm"},"XML::LibXML::SAX":{"version":2.0206,"file":"lib/XML/LibXML/SAX.pm"},"XML::LibXML::XPathContext":{"version":2.0206,"file":"lib/XML/LibXML/XPathContext.pm"},"XML::LibXML::SAX::AttributeNode":{"version":2.0206,"file":"lib/XML/LibXML/SAX/Generator.pm"},"XML::LibXML::SAX::Generator":{"version":2.0206,"file":"lib/XML/LibXML/SAX/Generator.pm"},"XML::LibXML::XPathExpression":{"version":2.0206,"file":"LibXML.pm"},"XML::LibXML::NodeList":{"version":2.0206,"file":"lib/XML/LibXML/NodeList.pm"},"XML::LibXML::Error":{"version":2.0206,"file":"lib/XML/LibXML/Error.pm"},"XML::LibXML::RegExp":{"version":2.0206,"file":"LibXML.pm"},"XML::LibXML::_SAXParser":{"version":2.0206,"file":"LibXML.pm"},"XML::LibXML::InputCallback":{"version":2.0206,"file":"LibXML.pm"},"XML::LibXML::Devel":{"version":2.0206,"file":"lib/XML/LibXML/Devel.pm"},"XML::LibXML::Boolean":{"version":2.0206,"file":"lib/XML/LibXML/Boolean.pm"},"XML::LibXML::AttributeHash":{"version":2.0206,"file":"lib/XML/LibXML/AttributeHash.pm"},"XML::LibXML":{"version":2.0206,"file":"LibXML.pm"},"XML::LibXML::Literal":{"version":2.0206,"file":"lib/XML/LibXML/Literal.pm"},"XML::LibXML::Reader":{"version":2.0206,"file":"lib/XML/LibXML/Reader.pm"},"XML::LibXML::SAX::Builder":{"version":2.0206,"file":"lib/XML/LibXML/SAX/Builder.pm"},"XML::LibXML::Schema":{"version":2.0206,"file":"LibXML.pm"},"XML::LibXML::Element":{"version":2.0206,"file":"LibXML.pm"},"XML::LibXML::Attr":{"version":2.0206,"file":"LibXML.pm"},"XML::LibXML::Node":{"version":2.0206,"file":"LibXML.pm"},"XML::LibXML::CDATASection":{"version":2.0206,"file":"LibXML.pm"},"XML::LibXML::Number":{"version":2.0206,"file":"lib/XML/LibXML/Number.pm"},"XML::LibXML::Namespace":{"version":2.0206,"file":"LibXML.pm"},"XML::LibXML::ErrNo":{"version":2.0206,"file":"lib/XML/LibXML/ErrNo.pm"},"XML::LibXML::SAX::Parser":{"version":2.0206,"file":"lib/XML/LibXML/SAX/Parser.pm"},"XML::LibXML::Dtd":{"version":2.0206,"file":"LibXML.pm"},"XML::LibXML::NamedNodeMap":{"version":2.0206,"file":"LibXML.pm"},"XML::LibXML::Common":{"version":2.0206,"file":"lib/XML/LibXML/Common.pm"},"XML::LibXML::Comment":{"version":2.0206,"file":"LibXML.pm"},"XML::LibXML::Document":{"version":2.0206,"file":"LibXML.pm"},"XML::LibXML::DocumentFragment":{"version":2.0206,"file":"LibXML.pm"},"XML::LibXML::RelaxNG":{"version":2.0206,"file":"LibXML.pm"},"XML::LibXML::Text":{"version":2.0206,"file":"LibXML.pm"}},"target":"XML::LibXML","version":2.0206,"name":"XML::LibXML","dist":"XML-LibXML-2.0206","pathname":"S/SH/SHLOMIF/XML-LibXML-2.0206.tar.gz"}PK       ! CP���	  �	  C  perl5/x86_64-linux-thread-multi/.meta/XML-LibXML-2.0206/MYMETA.jsonnu ��6�$        {
   "abstract" : "Interface to Gnome libxml2 xml parsing and DOM library",
   "author" : [
      "Petr Pajas <PAJAS@cpan.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.44, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "keywords" : [
      "dom",
      "html",
      "libxml",
      "object oriented",
      "oop",
      "parse",
      "parser",
      "parsing",
      "pullparser",
      "sax",
      "sgml",
      "xml",
      "xpath",
      "XPath",
      "xs"
   ],
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "XML-LibXML",
   "no_index" : {
      "directory" : [
         "t",
         "inc",
         "xt"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "Alien::Base::Wrapper" : "0",
            "Alien::Libxml2" : "0.14",
            "Config" : "0",
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "Carp" : "0",
            "DynaLoader" : "0",
            "Encode" : "0",
            "Exporter" : "5.57",
            "IO::Handle" : "0",
            "Scalar::Util" : "0",
            "Tie::Hash" : "0",
            "XML::NamespaceSupport" : "1.07",
            "XML::SAX" : "0.11",
            "XML::SAX::Base" : "0",
            "XML::SAX::DocumentLocator" : "0",
            "XML::SAX::Exception" : "0",
            "base" : "0",
            "constant" : "0",
            "overload" : "0",
            "parent" : "0",
            "perl" : "5.008001",
            "strict" : "0",
            "vars" : "0",
            "warnings" : "0"
         }
      },
      "test" : {
         "requires" : {
            "Config" : "0",
            "Errno" : "0",
            "IO::File" : "0",
            "IO::Handle" : "0",
            "POSIX" : "0",
            "Scalar::Util" : "0",
            "Test::More" : "0",
            "locale" : "0",
            "utf8" : "0"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "repository" : {
         "type" : "git",
         "url" : "https://github.com/shlomif/perl-XML-LibXML.git",
         "web" : "https://github.com/shlomif/perl-XML-LibXML"
      }
   },
   "version" : "2.0206",
   "x_serialization_backend" : "JSON::PP version 4.04"
}
PK       ! |�F��  �  O  perl5/x86_64-linux-thread-multi/.meta/CPAN-Meta-Requirements-2.143/install.jsonnu ��6�$        {"version":"2.143","pathname":"R/RJ/RJBS/CPAN-Meta-Requirements-2.143.tar.gz","provides":{"CPAN::Meta::Requirements::Range":{"version":"2.143","file":"lib/CPAN/Meta/Requirements/Range.pm"},"CPAN::Meta::Requirements":{"file":"lib/CPAN/Meta/Requirements.pm","version":"2.143"}},"name":"CPAN::Meta::Requirements","target":"CPAN::Meta::Requirements","dist":"CPAN-Meta-Requirements-2.143"}PK       ! s*��  �  N  perl5/x86_64-linux-thread-multi/.meta/CPAN-Meta-Requirements-2.143/MYMETA.jsonnu ��6�$        {
   "abstract" : "a set of version requirements for a CPAN dist",
   "author" : [
      "David Golden <dagolden@cpan.org>",
      "Ricardo Signes <rjbs@cpan.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "Dist::Zilla version 6.030, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "CPAN-Meta-Requirements",
   "no_index" : {
      "directory" : [
         "corpus",
         "examples",
         "t",
         "xt"
      ],
      "package" : [
         "DB"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "6.17"
         }
      },
      "develop" : {
         "requires" : {
            "Dist::Zilla" : "5",
            "Dist::Zilla::Plugin::Authority" : "0",
            "Dist::Zilla::Plugin::AutoPrereqs" : "0",
            "Dist::Zilla::Plugin::BumpVersionAfterRelease" : "0",
            "Dist::Zilla::Plugin::CPANFile" : "0",
            "Dist::Zilla::Plugin::CheckChangesHasContent" : "0",
            "Dist::Zilla::Plugin::CheckMetaResources" : "0",
            "Dist::Zilla::Plugin::CheckPrereqsIndexed" : "0",
            "Dist::Zilla::Plugin::ConfirmRelease" : "0",
            "Dist::Zilla::Plugin::CopyFilesFromBuild::Filtered" : "0",
            "Dist::Zilla::Plugin::ExecDir" : "0",
            "Dist::Zilla::Plugin::Git::Check" : "0",
            "Dist::Zilla::Plugin::Git::CheckFor::CorrectBranch" : "0",
            "Dist::Zilla::Plugin::Git::Commit" : "0",
            "Dist::Zilla::Plugin::Git::Contributors" : "0",
            "Dist::Zilla::Plugin::Git::GatherDir" : "0",
            "Dist::Zilla::Plugin::Git::Push" : "0",
            "Dist::Zilla::Plugin::Git::Tag" : "0",
            "Dist::Zilla::Plugin::GithubMeta" : "0",
            "Dist::Zilla::Plugin::InsertCopyright" : "0",
            "Dist::Zilla::Plugin::License" : "0",
            "Dist::Zilla::Plugin::MakeMaker" : "0",
            "Dist::Zilla::Plugin::MakeMaker::Highlander" : "0.003",
            "Dist::Zilla::Plugin::Manifest" : "0",
            "Dist::Zilla::Plugin::ManifestSkip" : "0",
            "Dist::Zilla::Plugin::MetaJSON" : "0",
            "Dist::Zilla::Plugin::MetaNoIndex" : "0",
            "Dist::Zilla::Plugin::MetaProvides::Package" : "0",
            "Dist::Zilla::Plugin::MetaTests" : "0",
            "Dist::Zilla::Plugin::MetaYAML" : "0",
            "Dist::Zilla::Plugin::MinimumPerl" : "0",
            "Dist::Zilla::Plugin::NextRelease" : "0",
            "Dist::Zilla::Plugin::OnlyCorePrereqs" : "0.014",
            "Dist::Zilla::Plugin::Pod2Readme" : "0",
            "Dist::Zilla::Plugin::PodCoverageTests" : "0",
            "Dist::Zilla::Plugin::PodSyntaxTests" : "0",
            "Dist::Zilla::Plugin::Prereqs" : "0",
            "Dist::Zilla::Plugin::Prereqs::AuthorDeps" : "0",
            "Dist::Zilla::Plugin::PromptIfStale" : "0",
            "Dist::Zilla::Plugin::PruneCruft" : "0",
            "Dist::Zilla::Plugin::RewriteVersion" : "0",
            "Dist::Zilla::Plugin::RunExtraTests" : "0",
            "Dist::Zilla::Plugin::ShareDir" : "0",
            "Dist::Zilla::Plugin::SurgicalPodWeaver" : "0",
            "Dist::Zilla::Plugin::Test::Compile" : "0",
            "Dist::Zilla::Plugin::Test::MinimumVersion" : "0",
            "Dist::Zilla::Plugin::Test::Perl::Critic" : "0",
            "Dist::Zilla::Plugin::Test::PodSpelling" : "0",
            "Dist::Zilla::Plugin::Test::Portability" : "0",
            "Dist::Zilla::Plugin::Test::ReportPrereqs" : "0",
            "Dist::Zilla::Plugin::Test::Version" : "0",
            "Dist::Zilla::Plugin::TestRelease" : "0",
            "Dist::Zilla::Plugin::UploadToCPAN" : "0",
            "File::Spec" : "0",
            "File::Temp" : "0",
            "IO::Handle" : "0",
            "IPC::Open3" : "0",
            "Pod::Coverage::TrustPod" : "0",
            "Pod::Weaver::PluginBundle::DAGOLDEN" : "0",
            "Pod::Wordlist" : "0",
            "Software::License::Perl_5" : "0",
            "Test::CPAN::Meta" : "0",
            "Test::MinimumVersion" : "0",
            "Test::More" : "0",
            "Test::Perl::Critic" : "0",
            "Test::Pod" : "1.41",
            "Test::Pod::Coverage" : "1.08",
            "Test::Portability::Files" : "0",
            "Test::Spelling" : "0.12",
            "Test::Version" : "1"
         }
      },
      "runtime" : {
         "requires" : {
            "B" : "0",
            "Carp" : "0",
            "perl" : "5.010000",
            "strict" : "0",
            "version" : "0.88",
            "warnings" : "0"
         }
      },
      "test" : {
         "recommends" : {
            "CPAN::Meta" : "2.120900"
         },
         "requires" : {
            "ExtUtils::MakeMaker" : "0",
            "File::Spec" : "0",
            "Test::More" : "0.88",
            "version" : "0.88"
         }
      }
   },
   "provides" : {
      "CPAN::Meta::Requirements" : {
         "file" : "lib/CPAN/Meta/Requirements.pm",
         "version" : "2.143"
      },
      "CPAN::Meta::Requirements::Range" : {
         "file" : "lib/CPAN/Meta/Requirements/Range.pm",
         "version" : "2.143"
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "web" : "https://github.com/Perl-Toolchain-Gang/CPAN-Meta-Requirements/issues"
      },
      "homepage" : "https://github.com/Perl-Toolchain-Gang/CPAN-Meta-Requirements",
      "repository" : {
         "type" : "git",
         "url" : "https://github.com/Perl-Toolchain-Gang/CPAN-Meta-Requirements.git",
         "web" : "https://github.com/Perl-Toolchain-Gang/CPAN-Meta-Requirements"
      }
   },
   "version" : "2.143",
   "x_authority" : "cpan:DAGOLDEN",
   "x_contributors" : [
      "Ed J <mohawk2@users.noreply.github.com>",
      "Graham Knop <haarg@haarg.org>",
      "Karen Etheridge <ether@cpan.org>",
      "Leon Timmermans <fawaka@gmail.com>",
      "Paul Howarth <paul@city-fan.org>",
      "Ricardo Signes <rjbs@semiotic.systems>",
      "robario <webmaster@robario.com>",
      "Tatsuhiko Miyagawa <miyagawa@bulknews.net>",
      "Tatsuhiko Miyagawa <miyagawa@gmail.com>"
   ],
   "x_generated_by_perl" : "v5.37.10",
   "x_serialization_backend" : "Cpanel::JSON::XS version 4.36",
   "x_spdx_expression" : "Artistic-1.0-Perl OR GPL-1.0-or-later"
}
PK       ! 5)��   �   D  perl5/x86_64-linux-thread-multi/.meta/Data-Dumper-2.173/install.jsonnu ��6�$        {"provides":{"Data::Dumper":{"version":2.173,"file":"Dumper.pm"}},"target":"Data::Dumper","version":2.173,"name":"Data::Dumper","dist":"Data-Dumper-2.173","pathname":"X/XS/XSAWYERX/Data-Dumper-2.173.tar.gz"}PK       ! ��Qۇ  �  C  perl5/x86_64-linux-thread-multi/.meta/Data-Dumper-2.173/MYMETA.jsonnu ��6�$        {
   "abstract" : "stringified perl data structures, suitable for both printing and C<eval>",
   "author" : [
      "unknown"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "unknown"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "Data-Dumper",
   "no_index" : {
      "directory" : [
         "t",
         "inc"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      }
   },
   "release_status" : "stable",
   "version" : "2.173",
   "x_serialization_backend" : "JSON::PP version 2.27400_02"
}
PK       ! E�kc
  c
  D  perl5/x86_64-linux-thread-multi/.meta/XML-LibXML-2.0208/install.jsonnu ��6�$        {"provides":{"XML::LibXML::PI":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::Pattern":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::SAX":{"version":2.0208,"file":"lib/XML/LibXML/SAX.pm"},"XML::LibXML::XPathContext":{"version":2.0208,"file":"lib/XML/LibXML/XPathContext.pm"},"XML::LibXML::SAX::AttributeNode":{"version":2.0208,"file":"lib/XML/LibXML/SAX/Generator.pm"},"XML::LibXML::SAX::Generator":{"version":2.0208,"file":"lib/XML/LibXML/SAX/Generator.pm"},"XML::LibXML::XPathExpression":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::NodeList":{"version":2.0208,"file":"lib/XML/LibXML/NodeList.pm"},"XML::LibXML::Error":{"version":2.0208,"file":"lib/XML/LibXML/Error.pm"},"XML::LibXML::RegExp":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::_SAXParser":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::InputCallback":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::Devel":{"version":2.0208,"file":"lib/XML/LibXML/Devel.pm"},"XML::LibXML::Boolean":{"version":2.0208,"file":"lib/XML/LibXML/Boolean.pm"},"XML::LibXML::AttributeHash":{"version":2.0208,"file":"lib/XML/LibXML/AttributeHash.pm"},"XML::LibXML":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::Literal":{"version":2.0208,"file":"lib/XML/LibXML/Literal.pm"},"XML::LibXML::Reader":{"version":2.0208,"file":"lib/XML/LibXML/Reader.pm"},"XML::LibXML::SAX::Builder":{"version":2.0208,"file":"lib/XML/LibXML/SAX/Builder.pm"},"XML::LibXML::Schema":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::Element":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::Attr":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::Node":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::CDATASection":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::Number":{"version":2.0208,"file":"lib/XML/LibXML/Number.pm"},"XML::LibXML::Namespace":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::ErrNo":{"version":2.0208,"file":"lib/XML/LibXML/ErrNo.pm"},"XML::LibXML::SAX::Parser":{"version":2.0208,"file":"lib/XML/LibXML/SAX/Parser.pm"},"XML::LibXML::Dtd":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::NamedNodeMap":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::Common":{"version":2.0208,"file":"lib/XML/LibXML/Common.pm"},"XML::LibXML::Comment":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::Document":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::DocumentFragment":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::RelaxNG":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::Text":{"version":2.0208,"file":"LibXML.pm"}},"target":"XML::LibXML","version":2.0208,"name":"XML::LibXML","dist":"XML-LibXML-2.0208","pathname":"S/SH/SHLOMIF/XML-LibXML-2.0208.tar.gz"}PK       ! SEXA�	  �	  C  perl5/x86_64-linux-thread-multi/.meta/XML-LibXML-2.0208/MYMETA.jsonnu ��6�$        {
   "abstract" : "Interface to Gnome libxml2 xml parsing and DOM library",
   "author" : [
      "Petr Pajas <PAJAS@cpan.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.64, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "keywords" : [
      "dom",
      "html",
      "libxml",
      "object oriented",
      "oop",
      "parse",
      "parser",
      "parsing",
      "pullparser",
      "sax",
      "sgml",
      "xml",
      "xpath",
      "XPath",
      "xs"
   ],
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "XML-LibXML",
   "no_index" : {
      "directory" : [
         "t",
         "inc",
         "xt"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "Alien::Base::Wrapper" : "0",
            "Alien::Libxml2" : "0.14",
            "Config" : "0",
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "Carp" : "0",
            "DynaLoader" : "0",
            "Encode" : "0",
            "Exporter" : "5.57",
            "IO::Handle" : "0",
            "Scalar::Util" : "0",
            "Tie::Hash" : "0",
            "XML::NamespaceSupport" : "1.07",
            "XML::SAX" : "0.11",
            "XML::SAX::Base" : "0",
            "XML::SAX::DocumentLocator" : "0",
            "XML::SAX::Exception" : "0",
            "base" : "0",
            "constant" : "0",
            "overload" : "0",
            "parent" : "0",
            "perl" : "5.008001",
            "strict" : "0",
            "vars" : "0",
            "warnings" : "0"
         }
      },
      "test" : {
         "requires" : {
            "Config" : "0",
            "Errno" : "0",
            "IO::File" : "0",
            "IO::Handle" : "0",
            "POSIX" : "0",
            "Scalar::Util" : "0",
            "Test::More" : "0",
            "locale" : "0",
            "utf8" : "0"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "repository" : {
         "type" : "git",
         "url" : "https://github.com/shlomif/perl-XML-LibXML.git",
         "web" : "https://github.com/shlomif/perl-XML-LibXML"
      }
   },
   "version" : "2.0208",
   "x_serialization_backend" : "JSON::PP version 4.06"
}
PK       ! �ҥK�  �  >  perl5/x86_64-linux-thread-multi/.meta/Encode-3.07/install.jsonnu ��6�$        {"provides":{"Encode::utf8":{"version":3.07,"file":"Encode.pm"},"Encode":{"version":3.07,"file":"Encode.pm"},"Encode::Config":{"version":2.05,"file":"lib/Encode/Config.pm"},"Encode::JP::H2Z":{"version":2.02,"file":"lib/Encode/JP/H2Z.pm"},"Encode::Byte":{"version":2.04,"file":"Byte/Byte.pm"},"Encode::CN::HZ":{"version":"2.10","file":"lib/Encode/CN/HZ.pm"},"Encode::KR::2022_KR":{"version":2.04,"file":"lib/Encode/KR/2022_KR.pm"},"encoding":{"version":"3.00","file":"encoding.pm"},"Encode::UTF_EBCDIC":{"version":3.07,"file":"Encode.pm"},"Encode::MIME::Name":{"version":1.03,"file":"lib/Encode/MIME/Name.pm"},"Encode::XS":{"version":3.07,"file":"Encode.pm"},"Encode::EBCDIC":{"version":2.02,"file":"EBCDIC/EBCDIC.pm"},"Encode::GSM0338":{"version":2.08,"file":"lib/Encode/GSM0338.pm"},"Encode::JP":{"version":2.04,"file":"JP/JP.pm"},"Encode::TW":{"version":2.03,"file":"TW/TW.pm"},"Encode::KR":{"version":2.03,"file":"KR/KR.pm"},"Encode::Symbol":{"version":2.02,"file":"Symbol/Symbol.pm"},"Encode::CN":{"version":2.03,"file":"CN/CN.pm"},"Encode::Unicode::UTF7":{"version":"2.10","file":"lib/Encode/Unicode/UTF7.pm"},"Encode::Unicode":{"version":2.18,"file":"Unicode/Unicode.pm"},"Encode::MIME::Header":{"version":2.28,"file":"lib/Encode/MIME/Header.pm"},"Encode::JP::JIS7":{"version":2.08,"file":"lib/Encode/JP/JIS7.pm"},"Encode::Encoding":{"version":2.08,"file":"lib/Encode/Encoding.pm"},"Encode::Encoder":{"version":2.03,"file":"lib/Encode/Encoder.pm"},"Encode::MIME::Header::ISO_2022_JP":{"version":1.09,"file":"lib/Encode/MIME/Header/ISO_2022_JP.pm"},"Encode::Internal":{"version":3.07,"file":"Encode.pm"},"Encode::Alias":{"version":2.24,"file":"lib/Encode/Alias.pm"},"Encode::CJKConstants":{"version":2.02,"file":"lib/Encode/CJKConstants.pm"},"Encode::Guess":{"version":2.08,"file":"lib/Encode/Guess.pm"}},"target":"Encode","version":3.07,"name":"Encode","dist":"Encode-3.07","pathname":"D/DA/DANKOGAI/Encode-3.07.tar.gz"}PK       ! T�;  ;  =  perl5/x86_64-linux-thread-multi/.meta/Encode-3.07/MYMETA.jsonnu ��6�$        {
   "abstract" : "character encodings in Perl",
   "author" : [
      "Dan Kogai <dankogai@dan.co.jp>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.44, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "Encode",
   "no_index" : {
      "directory" : [
         "t",
         "inc"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "Exporter" : "5.57",
            "Storable" : "0",
            "parent" : "0.221"
         }
      },
      "test" : {
         "requires" : {
            "Test::More" : "0.81_01"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "repository" : {
         "url" : "https://github.com/dankogai/p5-encode"
      }
   },
   "version" : "3.07",
   "x_contributors" : [
      "Alex Davies <alex.davies@talktalk.net>",
      "Alex Kapranoff <alex@kapranoff.ru>",
      "Alex Vandiver <alex@chmrr.net>",
      "Andreas J. Koenig <andreas.koenig@anima.de>",
      "Andrew Pennebaker <andrew.pennebaker@networkedinsights.com>",
      "Andy Grundman <andyg@activestate.com>",
      "Anton Tagunov <tagunov@motor.ru>",
      "Autrijus Tang <autrijus@autrijus.org>",
      "Benjamin Goldberg <goldbb2@earthlink.net>",
      "Bjoern Hoehrmann <derhoermi@gmx.net>",
      "Bjoern Jacke <debianbugs@j3e.de>",
      "bulk88 <bulk88@hotmail.com>",
      "Craig A. Berry <craigberry@mac.com>",
      "Curtis Jewell <csjewell@cpan.org>",
      "Dan Kogai <dankogai@dan.co.jp>",
      "Dave Evans <dave@rudolf.org.uk>",
      "David Golden <dagolden@cpan.org>",
      "David Steinbrunner <dsteinbrunner@pobox.com>",
      "Deng Liu <dengliu@ntu.edu.tw>",
      "Dominic Dunlop <domo@computer.org>",
      "drry",
      "Elizabeth Mattijsen <liz@dijkmat.nl>",
      "Flavio Poletti <flavio@polettix.it>",
      "Gerrit P. Haase <gp@familiehaase.de>",
      "Gisle Aas <gisle@ActiveState.com>",
      "Graham Barr <gbarr@pobox.com>",
      "Graham Knop <haarg@haarg.org>",
      "Graham Ollis <perl@wdlabs.com>",
      "Gurusamy Sarathy <gsar@activestate.com>",
      "H.Merijn Brand <h.m.brand@xs4all.nl>",
      "Hugo van der Sanden <hv@crypt.org>",
      "chansen <chansen@cpan.org>",
      "Chris Nandor <pudge@pobox.com>",
      "Inaba Hiroto <inaba@st.rim.or.jp>",
      "Jarkko Hietaniemi <jhi@iki.fi>",
      "Jesse Vincent <jesse@fsck.com>",
      "Jungshik Shin <jshin@mailaps.org>",
      "Karen Etheridge <ether@cpan.org>",
      "Karl Williamson <khw@cpan.org>",
      "Kenichi Ishigaki <ishigaki@cpan.org>",
      "KONNO Hiroharu <hiroharu.konno@bowneglobal.co.jp>",
      "Laszlo Molnar <ml1050@freemail.hu>",
      "Makamaka <makamaka@donzoko.net>",
      "Mark-Jason Dominus <mjd@plover.com>",
      "Masahiro Iuchi <masahiro.iuchi@gmail.com>",
      "MATSUNO Tokuhiro <tokuhirom+cpan@gmail.com>",
      "Mattia Barbon <mbarbon@dsi.unive.it>",
      "Michael G Schwern <schwern@pobox.com>",
      "Michael LaGrasta <michael@lagrasta.com>",
      "Miron Cuperman <miron@hyper.to>",
      "Moritz Lenz <moritz@faui2k3.org>",
      "MORIYAMA Masayuki <msyk@mtg.biglobe.ne.jp>",
      "Nick Ing-Simmons <nick@ing-simmons.net>",
      "Nicholas Clark <nick@ccl4.org>",
      "Olivier Mengué <dolmen@cpan.org>",
      "otsune",
      "Pali <pali@cpan.org>",
      "Paul Marquess <paul_marquess@yahoo.co.uk>",
      "Peter Prymmer <pvhp@best.com>",
      "Peter Rabbitson <ribasushi@cpan.org>",
      "Philip Newton <pne@cpan.org>",
      "Piotr Fusik <pfusik@op.pl>",
      "Rafael Garcia-Suarez <rgarciasuarez@mandriva.com>",
      "Randy Stauner <randy@magnificent-tears.com>",
      "Reini Urban <rurban@cpan.org>",
      "Robin Barker <rmb1@cise.npl.co.uk>",
      "SADAHIRO Tomoyuki <SADAHIRO@cpan.org>",
      "Simon Cozens <simon@netthink.co.uk>",
      "Slaven Rezic <SREZIC@cpan.org>",
      "Spider Boardman <spider@web.zk3.dec.com>",
      "Steve Hay <steve.m.hay@googlemail.com>",
      "Steve Peters <steve@fisharerojo.org>",
      "SUGAWARA Hajime <sugawara@hdt.co.jp>",
      "SUZUKI Norio <ZAP00217@nifty.com>",
      "szr8 <blz.marcel@gmail.com>",
      "Tatsuhiko Miyagawa <miyagawa@bulknews.net>",
      "Tels <perl_dummy@bloodgate.com>",
      "Tony Cook <tony@develop-help.com>",
      "Vadim Konovalov <vkonovalov@peterstar.ru>",
      "Victor <victor@vsespb.ru>",
      "Ville Skyttä <ville.skytta@iki.fi>",
      "Vincent van Dam <vvandam@sandvine.com>",
      "Yitzchak Scott-Thoennes <sthoenna@efn.org>"
   ],
   "x_serialization_backend" : "JSON::PP version 4.04"
}
PK       ! ���6    I  perl5/x86_64-linux-thread-multi/.meta/Template-Toolkit-3.100/install.jsonnu ��6�$        {"provides":{"Template::Base":{"version":"3.100","file":"lib/Template/Base.pm"},"Template::Stash::Context":{"version":"3.100","file":"lib/Template/Stash/Context.pm"},"Template::Config":{"version":"3.100","file":"lib/Template/Config.pm"},"Template::Plugin::Date::Calc":{"version":"3.100","file":"lib/Template/Plugin/Date.pm"},"Template::View":{"version":"3.100","file":"lib/Template/View.pm"},"Template::Perl":{"version":"3.100","file":"lib/Template/Filters.pm"},"Template::Plugin::Procedural":{"version":"3.100","file":"lib/Template/Plugin/Procedural.pm"},"Template::Plugin::Table":{"version":"3.100","file":"lib/Template/Plugin/Table.pm"},"Template::Plugin::Filter":{"version":"3.100","file":"lib/Template/Plugin/Filter.pm"},"Template::Iterator":{"version":"3.100","file":"lib/Template/Iterator.pm"},"Template::Plugin::Pod":{"version":"3.100","file":"lib/Template/Plugin/Pod.pm"},"Template::Constants":{"version":"3.100","file":"lib/Template/Constants.pm"},"Template::VMethods":{"version":"3.100","file":"lib/Template/VMethods.pm"},"Template::Monad::Scalar":{"version":"3.100","file":"lib/Template/Plugin/Scalar.pm"},"Template::Plugin::Datafile":{"version":"3.100","file":"lib/Template/Plugin/Datafile.pm"},"Template::Plugin::URL":{"version":"3.100","file":"lib/Template/Plugin/URL.pm"},"Template::Filters":{"version":"3.100","file":"lib/Template/Filters.pm"},"Template::Namespace::Constants":{"version":"3.100","file":"lib/Template/Namespace/Constants.pm"},"Template::Toolkit":{"version":"3.100","file":"lib/Template/Toolkit.pm"},"Template::Context":{"version":"3.100","file":"lib/Template/Context.pm"},"Template::Directive":{"version":"3.100","file":"lib/Template/Directive.pm"},"Template::Plugin":{"version":"3.100","file":"lib/Template/Plugin.pm"},"Template::TieString":{"version":"3.100","file":"lib/Template/Config.pm"},"Template::Plugin::Wrap":{"version":"3.100","file":"lib/Template/Plugin/Wrap.pm"},"Template::Parser":{"version":"3.100","file":"lib/Template/Parser.pm"},"Template::Grammar":{"version":"3.100","file":"lib/Template/Grammar.pm"},"Template::Plugin::HTML":{"version":"3.100","file":"lib/Template/Plugin/HTML.pm"},"Template::Plugin::Format":{"version":"3.100","file":"lib/Template/Plugin/Format.pm"},"Template::Plugin::Scalar":{"version":"3.100","file":"lib/Template/Plugin/Scalar.pm"},"Template::Plugin::Directory":{"version":"3.100","file":"lib/Template/Plugin/Directory.pm"},"Template::Stash::XS":{"file":"lib/Template/Stash/XS.pm"},"Template::Plugin::Dumper":{"version":"3.100","file":"lib/Template/Plugin/Dumper.pm"},"Template::Plugins":{"version":"3.100","file":"lib/Template/Plugins.pm"},"Template::Plugin::Assert":{"version":"3.100","file":"lib/Template/Plugin/Assert.pm"},"Template::Provider":{"version":"3.100","file":"lib/Template/Provider.pm"},"Template::Stash":{"version":"3.100","file":"lib/Template/Stash.pm"},"Template::Plugin::Image":{"version":"3.100","file":"lib/Template/Plugin/Image.pm"},"Template::Plugin::Date::Manip":{"version":"3.100","file":"lib/Template/Plugin/Date.pm"},"Template::Exception":{"version":"3.100","file":"lib/Template/Exception.pm"},"Template::Plugin::String":{"version":"3.100","file":"lib/Template/Plugin/String.pm"},"Template::Document":{"version":"3.100","file":"lib/Template/Document.pm"},"Template::Plugin::Math":{"version":"3.100","file":"lib/Template/Plugin/Math.pm"},"Template::Service":{"version":"3.100","file":"lib/Template/Service.pm"},"Template::Test":{"version":"3.100","file":"lib/Template/Test.pm"},"Template::Monad::Assert":{"version":"3.100","file":"lib/Template/Plugin/Assert.pm"},"Template::Plugin::Iterator":{"version":"3.100","file":"lib/Template/Plugin/Iterator.pm"},"Template":{"version":"3.100","file":"lib/Template.pm"},"Template::Plugin::Date":{"version":"3.100","file":"lib/Template/Plugin/Date.pm"},"Template::Plugin::File":{"version":"3.100","file":"lib/Template/Plugin/File.pm"},"Template::Plugin::View":{"version":"3.100","file":"lib/Template/Plugin/View.pm"}},"target":"Template::Constants","version":"3.100","name":"Template","dist":"Template-Toolkit-3.100","pathname":"T/TO/TODDR/Template-Toolkit-3.100.tar.gz"}PK       ! `AѦ�  �  H  perl5/x86_64-linux-thread-multi/.meta/Template-Toolkit-3.100/MYMETA.jsonnu ��6�$        {
   "abstract" : "comprehensive template processing system",
   "author" : [
      "Andy Wardley <abw@wardley.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "Template-Toolkit",
   "no_index" : {
      "directory" : [
         "t",
         "inc"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "AppConfig" : "1.56",
            "File::Spec" : "0.8",
            "File::Temp" : "0.12",
            "Scalar::Util" : "0"
         }
      },
      "test" : {
         "requires" : {
            "Test::LeakTrace" : "0"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "web" : "https://github.com/abw/Template2/issues"
      },
      "homepage" : "http://www.template-toolkit.org",
      "repository" : {
         "type" : "git",
         "url" : "https://github.com/abw/Template2.git",
         "web" : "https://github.com/abw/Template2"
      }
   },
   "version" : "3.100"
}
PK       ! :hg  g  Z  perl5/x86_64-linux-thread-multi/.meta/Alien-Build-Plugin-Download-GitLab-0.01/install.jsonnu ��6�$        {"target":"Alien::Build::Plugin::Download::GitLab","pathname":"P/PL/PLICEASE/Alien-Build-Plugin-Download-GitLab-0.01.tar.gz","provides":{"Alien::Build::Plugin::Download::GitLab":{"version":0.01,"file":"lib/Alien/Build/Plugin/Download/GitLab.pm"}},"name":"Alien::Build::Plugin::Download::GitLab","version":0.01,"dist":"Alien-Build-Plugin-Download-GitLab-0.01"}PK       ! �,���  �  Y  perl5/x86_64-linux-thread-multi/.meta/Alien-Build-Plugin-Download-GitLab-0.01/MYMETA.jsonnu ��6�$        {
   "abstract" : "Alien::Build plugin to download from GitLab",
   "author" : [
      "Graham Ollis <plicease@cpan.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "Dist::Zilla version 6.025, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "Alien-Build-Plugin-Download-GitLab",
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "develop" : {
         "recommends" : {
            "Dist::Zilla::Plugin::Author::Plicease::Core" : "0",
            "Dist::Zilla::Plugin::Author::Plicease::Upload" : "0",
            "Dist::Zilla::PluginBundle::Author::Plicease" : "2.71",
            "Perl::Critic::Policy::BuiltinFunctions::ProhibitBooleanGrep" : "0",
            "Perl::Critic::Policy::BuiltinFunctions::ProhibitStringyEval" : "0",
            "Perl::Critic::Policy::BuiltinFunctions::ProhibitStringySplit" : "0",
            "Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidGrep" : "0",
            "Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidMap" : "0",
            "Perl::Critic::Policy::ClassHierarchies::ProhibitExplicitISA" : "0",
            "Perl::Critic::Policy::ClassHierarchies::ProhibitOneArgBless" : "0",
            "Perl::Critic::Policy::CodeLayout::ProhibitHardTabs" : "0",
            "Perl::Critic::Policy::CodeLayout::ProhibitTrailingWhitespace" : "0",
            "Perl::Critic::Policy::CodeLayout::RequireConsistentNewlines" : "0",
            "Perl::Critic::Policy::Community::ArrayAssignAref" : "0",
            "Perl::Critic::Policy::Community::BarewordFilehandles" : "0",
            "Perl::Critic::Policy::Community::ConditionalDeclarations" : "0",
            "Perl::Critic::Policy::Community::ConditionalImplicitReturn" : "0",
            "Perl::Critic::Policy::Community::DeprecatedFeatures" : "0",
            "Perl::Critic::Policy::Community::DiscouragedModules" : "0",
            "Perl::Critic::Policy::Community::DollarAB" : "0",
            "Perl::Critic::Policy::Community::Each" : "0",
            "Perl::Critic::Policy::Community::EmptyReturn" : "0",
            "Perl::Critic::Policy::Community::IndirectObjectNotation" : "0",
            "Perl::Critic::Policy::Community::LexicalForeachIterator" : "0",
            "Perl::Critic::Policy::Community::LoopOnHash" : "0",
            "Perl::Critic::Policy::Community::ModPerl" : "0",
            "Perl::Critic::Policy::Community::OpenArgs" : "0",
            "Perl::Critic::Policy::Community::OverloadOptions" : "0",
            "Perl::Critic::Policy::Community::POSIXImports" : "0",
            "Perl::Critic::Policy::Community::PackageMatchesFilename" : "0",
            "Perl::Critic::Policy::Community::PreferredAlternatives" : "0",
            "Perl::Critic::Policy::Community::StrictWarnings" : "0",
            "Perl::Critic::Policy::Community::Threads" : "0",
            "Perl::Critic::Policy::Community::Wantarray" : "0",
            "Perl::Critic::Policy::Community::WarningsSwitch" : "0",
            "Perl::Critic::Policy::Community::WhileDiamondDefaultAssignment" : "0",
            "Perl::Critic::Policy::ControlStructures::ProhibitLabelsWithSpecialBlockNames" : "0",
            "Perl::Critic::Policy::ControlStructures::ProhibitMutatingListFunctions" : "0",
            "Perl::Critic::Policy::ControlStructures::ProhibitUnreachableCode" : "0",
            "Perl::Critic::Policy::InputOutput::ProhibitBarewordFileHandles" : "0",
            "Perl::Critic::Policy::InputOutput::ProhibitJoinedReadline" : "0",
            "Perl::Critic::Policy::InputOutput::ProhibitTwoArgOpen" : "0",
            "Perl::Critic::Policy::Miscellanea::ProhibitFormats" : "0",
            "Perl::Critic::Policy::Miscellanea::ProhibitUselessNoCritic" : "0",
            "Perl::Critic::Policy::Modules::ProhibitConditionalUseStatements" : "0",
            "Perl::Critic::Policy::Modules::RequireNoMatchVarsWithUseEnglish" : "0",
            "Perl::Critic::Policy::Objects::ProhibitIndirectSyntax" : "0",
            "Perl::Critic::Policy::RegularExpressions::ProhibitUselessTopic" : "0",
            "Perl::Critic::Policy::Subroutines::ProhibitNestedSubs" : "0",
            "Perl::Critic::Policy::ValuesAndExpressions::ProhibitLeadingZeros" : "0",
            "Perl::Critic::Policy::ValuesAndExpressions::ProhibitMixedBooleanOperators" : "0",
            "Perl::Critic::Policy::ValuesAndExpressions::ProhibitSpecialLiteralHeredocTerminator" : "0",
            "Perl::Critic::Policy::ValuesAndExpressions::RequireUpperCaseHeredocTerminator" : "0",
            "Perl::Critic::Policy::Variables::ProhibitPerl4PackageNames" : "0",
            "Perl::Critic::Policy::Variables::ProhibitUnusedVariables" : "0",
            "Software::License::Perl_5" : "0"
         },
         "requires" : {
            "File::Spec" : "0",
            "FindBin" : "0",
            "Perl::Critic" : "0",
            "Test2::Require::Module" : "0.000121",
            "Test2::Tools::PerlCritic" : "0",
            "Test2::V0" : "0.000121",
            "Test::CPAN::Changes" : "0",
            "Test::EOL" : "0",
            "Test::Fixme" : "0.07",
            "Test::More" : "0.98",
            "Test::NoTabs" : "0",
            "Test::Pod" : "0",
            "Test::Pod::Coverage" : "0",
            "Test::Pod::Spelling::CommonMistakes" : "0",
            "Test::Spelling" : "0",
            "Test::Strict" : "0",
            "YAML" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "Alien::Build::Plugin" : "0",
            "JSON::PP" : "0",
            "Path::Tiny" : "0",
            "URI" : "0",
            "URI::Escape" : "0",
            "perl" : "5.008004"
         }
      },
      "test" : {
         "requires" : {
            "Test2::V0" : "0.000121"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "web" : "https://github.com/PerlAlien/Alien-Build-Plugin-Download-GitLab/issues"
      },
      "homepage" : "https://metacpan.org/pod/Alien::Build::Plugin::Download::GitLab",
      "repository" : {
         "type" : "git",
         "url" : "git://github.com/PerlAlien/Alien-Build-Plugin-Download-GitLab.git",
         "web" : "https://github.com/PerlAlien/Alien-Build-Plugin-Download-GitLab"
      },
      "x_IRC" : "irc://irc.perl.org/#native"
   },
   "version" : "0.01",
   "x_generated_by_perl" : "v5.35.10",
   "x_serialization_backend" : "Cpanel::JSON::XS version 4.30",
   "x_spdx_expression" : "Artistic-1.0-Perl OR GPL-1.0-or-later",
   "x_use_unsafe_inc" : 0
}
PK       ! ��   �   B  perl5/x86_64-linux-thread-multi/.meta/HTTP-Tiny-0.088/install.jsonnu ��6�$        {"version":"0.088","name":"HTTP::Tiny","provides":{"HTTP::Tiny":{"version":"0.088","file":"lib/HTTP/Tiny.pm"}},"pathname":"D/DA/DAGOLDEN/HTTP-Tiny-0.088.tar.gz","target":"HTTP::Tiny","dist":"HTTP-Tiny-0.088"}PK       ! p)���  �  A  perl5/x86_64-linux-thread-multi/.meta/HTTP-Tiny-0.088/MYMETA.jsonnu ��6�$        {
   "abstract" : "A small, simple, correct HTTP/1.1 client",
   "author" : [
      "Christian Hansen <chansen@cpan.org>",
      "David Golden <dagolden@cpan.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "Dist::Zilla version 6.030, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "HTTP-Tiny",
   "no_index" : {
      "directory" : [
         "corpus",
         "examples",
         "t",
         "xt"
      ],
      "package" : [
         "DB"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "6.17"
         },
         "suggests" : {
            "JSON::PP" : "2.27300"
         }
      },
      "develop" : {
         "requires" : {
            "Dist::Zilla" : "5",
            "Dist::Zilla::Plugin::Prereqs" : "0",
            "Dist::Zilla::Plugin::ReleaseStatus::FromVersion" : "0",
            "Dist::Zilla::Plugin::RemovePrereqs" : "0",
            "Dist::Zilla::PluginBundle::DAGOLDEN" : "0.072",
            "File::Spec" : "0",
            "File::Temp" : "0",
            "IO::Handle" : "0",
            "IPC::Open3" : "0",
            "Perl::Critic::Policy::Lax::ProhibitStringyEval::ExceptForRequire" : "0",
            "Pod::Coverage::TrustPod" : "0",
            "Pod::Wordlist" : "0",
            "Software::License::Perl_5" : "0",
            "Test::CPAN::Meta" : "0",
            "Test::MinimumVersion" : "0",
            "Test::More" : "0",
            "Test::Perl::Critic" : "0",
            "Test::Pod" : "1.41",
            "Test::Pod::Coverage" : "1.08",
            "Test::Portability::Files" : "0",
            "Test::Spelling" : "0.12",
            "Test::Version" : "1",
            "perl" : "5.006"
         }
      },
      "runtime" : {
         "recommends" : {
            "HTTP::CookieJar" : "0.001",
            "IO::Socket::IP" : "0.32",
            "IO::Socket::SSL" : "1.42",
            "Mozilla::CA" : "20160104",
            "Net::SSLeay" : "1.49"
         },
         "requires" : {
            "Carp" : "0",
            "Fcntl" : "0",
            "IO::Socket" : "0",
            "MIME::Base64" : "0",
            "Socket" : "0",
            "Time::Local" : "0",
            "bytes" : "0",
            "perl" : "5.006",
            "strict" : "0",
            "warnings" : "0"
         },
         "suggests" : {
            "IO::Socket::SSL" : "1.56"
         }
      },
      "test" : {
         "recommends" : {
            "CPAN::Meta" : "2.120900"
         },
         "requires" : {
            "Data::Dumper" : "0",
            "Exporter" : "0",
            "ExtUtils::MakeMaker" : "0",
            "File::Basename" : "0",
            "File::Spec" : "0",
            "File::Temp" : "0",
            "IO::Dir" : "0",
            "IO::File" : "0",
            "IO::Socket::INET" : "0",
            "IPC::Cmd" : "0",
            "Test::More" : "0.96",
            "lib" : "0",
            "open" : "0"
         }
      }
   },
   "provides" : {
      "HTTP::Tiny" : {
         "file" : "lib/HTTP/Tiny.pm",
         "version" : "0.088"
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "web" : "https://github.com/Perl-Toolchain-Gang/HTTP-Tiny/issues"
      },
      "homepage" : "https://github.com/Perl-Toolchain-Gang/HTTP-Tiny",
      "repository" : {
         "type" : "git",
         "url" : "https://github.com/Perl-Toolchain-Gang/HTTP-Tiny.git",
         "web" : "https://github.com/Perl-Toolchain-Gang/HTTP-Tiny"
      }
   },
   "version" : "0.088",
   "x_authority" : "cpan:DAGOLDEN",
   "x_contributors" : [
      "Alan Gardner <gardner@pythian.com>",
      "Alessandro Ghedini <al3xbio@gmail.com>",
      "A. Sinan Unur <nanis@cpan.org>",
      "Brad Gilbert <bgills@cpan.org>",
      "brian m. carlson <sandals@crustytoothpaste.net>",
      "Chris Nehren <apeiron@cpan.org>",
      "Chris Weyl <cweyl@alumni.drew.edu>",
      "Claes Jakobsson <claes@surfar.nu>",
      "Clinton Gormley <clint@traveljury.com>",
      "Craig A. Berry <craigberry@mac.com>",
      "Craig Berry <cberry@cpan.org>",
      "David Golden <xdg@xdg.me>",
      "David Mitchell <davem@iabyn.com>",
      "Dean Pearce <pearce@pythian.com>",
      "Edward Zborowski <ed@rubensteintech.com>",
      "Felipe Gasper <felipe@felipegasper.com>",
      "Graham Knop <haarg@haarg.org>",
      "Greg Kennedy <kennedy.greg@gmail.com>",
      "James E Keenan <jkeenan@cpan.org>",
      "James Raspass <jraspass@gmail.com>",
      "Jeremy Mates <jmates@cpan.org>",
      "Jess Robinson <castaway@desert-island.me.uk>",
      "Karen Etheridge <ether@cpan.org>",
      "Lukas Eklund <leklund@gmail.com>",
      "Martin J. Evans <mjegh@ntlworld.com>",
      "Martin-Louis Bright <mlbright@gmail.com>",
      "Matthew Horsfall <wolfsage@gmail.com>",
      "Michael R. Davis <mrdvt92@users.noreply.github.com>",
      "Mike Doherty <doherty@cpan.org>",
      "Nicolas Rochelemagne <rochelemagne@cpanel.net>",
      "Olaf Alders <olaf@wundersolutions.com>",
      "Olivier Mengué <dolmen@cpan.org>",
      "Petr Písař <ppisar@redhat.com>",
      "sanjay-cpu <snjkmr32@gmail.com>",
      "Serguei Trouchelle <stro@cpan.org>",
      "Shoichi Kaji <skaji@cpan.org>",
      "SkyMarshal <skymarshal1729@gmail.com>",
      "Sören Kornetzki <soeren.kornetzki@delti.com>",
      "Steve Grazzini <steve.grazzini@grantstreet.com>",
      "Stig Palmquist <git@stig.io>",
      "Syohei YOSHIDA <syohex@gmail.com>",
      "Tatsuhiko Miyagawa <miyagawa@bulknews.net>",
      "Tom Hukins <tom@eborcom.com>",
      "Tony Cook <tony@develop-help.com>",
      "Xavier Guimard <yadd@debian.org>"
   ],
   "x_generated_by_perl" : "v5.36.0",
   "x_serialization_backend" : "Cpanel::JSON::XS version 4.29",
   "x_spdx_expression" : "Artistic-1.0-Perl OR GPL-1.0-or-later"
}
PK       ! ��7�   �   G  perl5/x86_64-linux-thread-multi/.meta/CPAN-Meta-YAML-0.018/install.jsonnu ��6�$        {"provides":{"CPAN::Meta::YAML":{"version":"0.018","file":"lib/CPAN/Meta/YAML.pm"}},"target":"CPAN::Meta::YAML","version":"0.018","name":"CPAN::Meta::YAML","dist":"CPAN-Meta-YAML-0.018","pathname":"D/DA/DAGOLDEN/CPAN-Meta-YAML-0.018.tar.gz"}PK       ! &A�  �  F  perl5/x86_64-linux-thread-multi/.meta/CPAN-Meta-YAML-0.018/MYMETA.jsonnu ��6�$        {
   "abstract" : "Read and write a subset of YAML for CPAN Meta files",
   "author" : [
      "Adam Kennedy <adamk@cpan.org>",
      "David Golden <dagolden@cpan.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "Dist::Zilla version 5.042, CPAN::Meta::Converter version 2.150001, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "CPAN-Meta-YAML",
   "no_index" : {
      "directory" : [
         "corpus",
         "examples",
         "t",
         "xt"
      ],
      "package" : [
         "DB"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "6.17"
         }
      },
      "develop" : {
         "requires" : {
            "Dist::Zilla" : "5",
            "Dist::Zilla::Plugin::AppendExternalData" : "0",
            "Dist::Zilla::Plugin::Authority" : "0",
            "Dist::Zilla::Plugin::AutoPrereqs" : "0",
            "Dist::Zilla::Plugin::CheckChangesHasContent" : "0",
            "Dist::Zilla::Plugin::CheckMetaResources" : "0",
            "Dist::Zilla::Plugin::CheckPrereqsIndexed" : "0",
            "Dist::Zilla::Plugin::ConfirmRelease" : "0",
            "Dist::Zilla::Plugin::Doppelgaenger" : "0.007",
            "Dist::Zilla::Plugin::Encoding" : "0",
            "Dist::Zilla::Plugin::ExecDir" : "0",
            "Dist::Zilla::Plugin::Git::Check" : "0",
            "Dist::Zilla::Plugin::Git::CheckFor::CorrectBranch" : "0",
            "Dist::Zilla::Plugin::Git::Commit" : "0",
            "Dist::Zilla::Plugin::Git::Contributors" : "0",
            "Dist::Zilla::Plugin::Git::GatherDir" : "0",
            "Dist::Zilla::Plugin::Git::NextVersion" : "0",
            "Dist::Zilla::Plugin::Git::Push" : "0",
            "Dist::Zilla::Plugin::Git::Tag" : "0",
            "Dist::Zilla::Plugin::GithubMeta" : "0",
            "Dist::Zilla::Plugin::License" : "0",
            "Dist::Zilla::Plugin::MakeMaker" : "0",
            "Dist::Zilla::Plugin::MakeMaker::Highlander" : "0.003",
            "Dist::Zilla::Plugin::Manifest" : "0",
            "Dist::Zilla::Plugin::ManifestSkip" : "0",
            "Dist::Zilla::Plugin::MetaJSON" : "0",
            "Dist::Zilla::Plugin::MetaNoIndex" : "0",
            "Dist::Zilla::Plugin::MetaProvides::Package" : "0",
            "Dist::Zilla::Plugin::MetaResources" : "0",
            "Dist::Zilla::Plugin::MetaTests" : "0",
            "Dist::Zilla::Plugin::MetaYAML" : "0",
            "Dist::Zilla::Plugin::MinimumPerl" : "0",
            "Dist::Zilla::Plugin::NextRelease" : "0",
            "Dist::Zilla::Plugin::PkgVersion" : "0",
            "Dist::Zilla::Plugin::Pod2Readme" : "0",
            "Dist::Zilla::Plugin::PodSyntaxTests" : "0",
            "Dist::Zilla::Plugin::PodWeaver" : "0",
            "Dist::Zilla::Plugin::Prereqs::AuthorDeps" : "0",
            "Dist::Zilla::Plugin::PromptIfStale" : "0",
            "Dist::Zilla::Plugin::PruneCruft" : "0",
            "Dist::Zilla::Plugin::PruneFiles" : "0",
            "Dist::Zilla::Plugin::RemovePrereqs" : "0",
            "Dist::Zilla::Plugin::RunExtraTests" : "0",
            "Dist::Zilla::Plugin::ShareDir" : "0",
            "Dist::Zilla::Plugin::Test::Compile" : "0",
            "Dist::Zilla::Plugin::Test::ReportPrereqs" : "0",
            "Dist::Zilla::Plugin::Test::Version" : "0",
            "Dist::Zilla::Plugin::TestRelease" : "0",
            "Dist::Zilla::Plugin::UploadToCPAN" : "0",
            "File::Spec" : "0",
            "File::Temp" : "0",
            "IO::Handle" : "0",
            "IPC::Open3" : "0",
            "Software::License::Perl_5" : "0",
            "Test::CPAN::Meta" : "0",
            "Test::More" : "0",
            "Test::Pod" : "1.41",
            "Test::Version" : "1",
            "blib" : "1.01"
         }
      },
      "runtime" : {
         "requires" : {
            "B" : "0",
            "Carp" : "0",
            "Exporter" : "0",
            "Fcntl" : "0",
            "Scalar::Util" : "0",
            "perl" : "5.008001",
            "strict" : "0",
            "warnings" : "0"
         }
      },
      "test" : {
         "recommends" : {
            "CPAN::Meta" : "2.120900"
         },
         "requires" : {
            "ExtUtils::MakeMaker" : "0",
            "File::Basename" : "0",
            "File::Find" : "0",
            "File::Spec" : "0",
            "File::Spec::Functions" : "0",
            "File::Temp" : "0.19",
            "IO::Dir" : "0",
            "JSON::PP" : "0",
            "Test::More" : "0.88",
            "base" : "0",
            "lib" : "0",
            "utf8" : "0",
            "vars" : "0"
         }
      }
   },
   "provides" : {
      "CPAN::Meta::YAML" : {
         "file" : "lib/CPAN/Meta/YAML.pm",
         "version" : "0.018"
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "web" : "https://github.com/Perl-Toolchain-Gang/YAML-Tiny/issues"
      },
      "homepage" : "https://github.com/Perl-Toolchain-Gang/CPAN-Meta-YAML",
      "repository" : {
         "type" : "git",
         "url" : "https://github.com/Perl-Toolchain-Gang/CPAN-Meta-YAML.git",
         "web" : "https://github.com/Perl-Toolchain-Gang/CPAN-Meta-YAML"
      }
   },
   "version" : "0.018",
   "x_authority" : "cpan:DAGOLDEN"
}
PK       ! �C!��  �  <  perl5/x86_64-linux-thread-multi/.meta/CPAN-2.28/install.jsonnu ��6�$        {"provides":{"CPAN::Index":{"version":2.12,"file":"lib/CPAN/Index.pm"},"CPAN::Plugin":{"version":0.97,"file":"lib/CPAN/Plugin.pm"},"CPAN::Mirrored::By":{"version":2.27,"file":"lib/CPAN/Mirrors.pm"},"CPAN::HTTP::Client":{"version":1.9601,"file":"lib/CPAN/HTTP/Client.pm"},"CPAN::FTP::netrc":{"version":1.01,"file":"lib/CPAN/FTP/netrc.pm"},"CPAN::Version":{"version":5.5003,"file":"lib/CPAN/Version.pm"},"CPAN::Admin":{"version":5.501,"file":"lib/CPAN/Admin.pm"},"CPAN::Plugin::Specfile":{"version":0.02,"file":"lib/CPAN/Plugin/Specfile.pm"},"CPAN::Distroprefs::Result::Error":{"version":6.0001,"file":"lib/CPAN/Distroprefs.pm"},"CPAN::InfoObj":{"version":5.5,"file":"lib/CPAN/InfoObj.pm"},"CPAN::Exception::RecursiveDependency::na":{"version":5.5001,"file":"lib/CPAN/Exception/RecursiveDependency.pm"},"CPAN::HandleConfig":{"version":5.5011,"file":"lib/CPAN/HandleConfig.pm"},"CPAN::Exception::yaml_process_error":{"version":5.5,"file":"lib/CPAN/Exception/yaml_process_error.pm"},"CPAN::Nox":{"version":5.5001,"file":"lib/CPAN/Nox.pm"},"CPAN::Exception::RecursiveDependency":{"version":5.5001,"file":"lib/CPAN/Exception/RecursiveDependency.pm"},"CPAN::Distroprefs::Result::Warning":{"version":6.0001,"file":"lib/CPAN/Distroprefs.pm"},"CPAN::Distroprefs::Pref":{"version":6.0001,"file":"lib/CPAN/Distroprefs.pm"},"CPAN::Debug":{"version":5.5001,"file":"lib/CPAN/Debug.pm"},"CPAN::Distroprefs::Result::Success":{"version":6.0001,"file":"lib/CPAN/Distroprefs.pm"},"CPAN::Shell":{"version":5.5009,"file":"lib/CPAN/Shell.pm"},"CPAN::Queue::Item":{"version":5.5003,"file":"lib/CPAN/Queue.pm"},"CPAN::CacheMgr":{"version":5.5002,"file":"lib/CPAN/CacheMgr.pm"},"CPAN::Eval":{"version":6.0001,"file":"lib/CPAN/Distroprefs.pm"},"CPAN::Distroprefs":{"version":6.0001,"file":"lib/CPAN/Distroprefs.pm"},"CPAN::Distribution":{"version":2.27,"file":"lib/CPAN/Distribution.pm"},"CPAN::Complete":{"version":5.5001,"file":"lib/CPAN/Complete.pm"},"CPAN::FirstTime":{"version":5.5315,"file":"lib/CPAN/FirstTime.pm"},"App::Cpan":{"version":1.676,"file":"lib/App/Cpan.pm"},"CPAN::Author":{"version":5.5002,"file":"lib/CPAN/Author.pm"},"CPAN::URL":{"version":5.5,"file":"lib/CPAN/URL.pm"},"CPAN::Kwalify":{"version":"5.50","file":"lib/CPAN/Kwalify.pm"},"CPAN::LWP::UserAgent":{"version":1.9601,"file":"lib/CPAN/LWP/UserAgent.pm"},"CPAN::Bundle":{"version":5.5005,"file":"lib/CPAN/Bundle.pm"},"CPAN::FTP":{"version":5.5013,"file":"lib/CPAN/FTP.pm"},"CPAN::HTTP::Credentials":{"version":1.9601,"file":"lib/CPAN/HTTP/Credentials.pm"},"CPAN::Distroprefs::Result::Fatal":{"version":6.0001,"file":"lib/CPAN/Distroprefs.pm"},"CPAN::Distrostatus":{"version":5.5,"file":"lib/CPAN/Distrostatus.pm"},"CPAN::Module":{"version":5.5003,"file":"lib/CPAN/Module.pm"},"CPAN::Distroprefs::Result":{"version":6.0001,"file":"lib/CPAN/Distroprefs.pm"},"CPAN::Exception::blocked_urllist":{"version":1.001,"file":"lib/CPAN/Exception/blocked_urllist.pm"},"CPAN::Tarzip":{"version":5.5013,"file":"lib/CPAN/Tarzip.pm"},"CPAN::Mirrors":{"version":2.27,"file":"lib/CPAN/Mirrors.pm"},"CPAN::Distroprefs::Iterator":{"version":6.0001,"file":"lib/CPAN/Distroprefs.pm"},"CPAN::DeferredCode":{"version":"5.50","file":"lib/CPAN/DeferredCode.pm"},"CPAN::Prompt":{"version":5.5,"file":"lib/CPAN/Prompt.pm"},"CPAN::Exception::yaml_not_installed":{"version":5.5,"file":"lib/CPAN/Exception/yaml_not_installed.pm"},"CPAN::Queue":{"version":5.5003,"file":"lib/CPAN/Queue.pm"},"CPAN":{"version":2.28,"file":"lib/CPAN.pm"}},"target":"CPAN","version":2.28,"name":"CPAN","dist":"CPAN-2.28","pathname":"A/AN/ANDK/CPAN-2.28.tar.gz"}PK       ! �TB�F	  F	  ;  perl5/x86_64-linux-thread-multi/.meta/CPAN-2.28/MYMETA.jsonnu ��6�$        {
   "abstract" : "query, download and build perl modules from CPAN sites",
   "author" : [
      "Andreas Koenig <andreas.koenig.gmwojprw@franz.ak.mind.de>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "keywords" : [
      "CPAN",
      "module",
      "module installation"
   ],
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "CPAN",
   "no_index" : {
      "directory" : [
         "t",
         "inc"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "Archive::Tar" : "0",
            "CPAN::Meta" : "0",
            "CPAN::Meta::Requirements" : "2.121",
            "CPAN::Meta::YAML" : "0",
            "Compress::Zlib" : "0",
            "Data::Dumper" : "0",
            "Digest::MD5" : "0",
            "Digest::SHA" : "0",
            "Exporter" : "0",
            "Exporter::Heavy" : "0",
            "ExtUtils::CBuilder" : "0",
            "File::Copy" : "0",
            "File::Spec" : "0",
            "File::Temp" : "0",
            "HTTP::Tiny" : "0",
            "IO::Compress::Base" : "0",
            "IO::Zlib" : "0",
            "JSON::PP" : "0",
            "LWP::UserAgent" : "0",
            "MIME::Base64" : "0",
            "Module::Build" : "0",
            "Net::FTP" : "0",
            "Net::Ping" : "0",
            "Parse::CPAN::Meta" : "0",
            "Pod::Perldoc" : "0",
            "Pod::Perldoc::ToMan" : "0",
            "Scalar::Util" : "0",
            "Socket" : "0",
            "Term::ReadKey" : "0",
            "Test::Harness" : "2.62",
            "Test::More" : "0",
            "Text::ParseWords" : "0",
            "Text::Wrap" : "0",
            "perl" : "5.006002"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "repository" : {
         "type" : "git",
         "url" : "https://github.com/andk/cpanpm"
      }
   },
   "version" : "2.28",
   "x_serialization_backend" : "JSON::PP version 2.97001"
}
PK       ! �"@6    E  perl5/x86_64-linux-thread-multi/.meta/local-lib-2.000024/install.jsonnu ��6�$        {"provides":{"lib::core::only":{"file":"lib/lib/core/only.pm"},"local::lib":{"version":2.000024,"file":"lib/local/lib.pm"}},"target":"local::lib","version":2.000024,"name":"local::lib","dist":"local-lib-2.000024","pathname":"H/HA/HAARG/local-lib-2.000024.tar.gz"}PK       ! �
��    D  perl5/x86_64-linux-thread-multi/.meta/local-lib-2.000024/MYMETA.jsonnu ��6�$        {
   "abstract" : "create and use a local lib/ for perl modules with PERL5LIB",
   "author" : [
      "mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150005, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "local-lib",
   "no_index" : {
      "directory" : [
         "t",
         "inc"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {}
      },
      "configure" : {
         "requires" : {}
      },
      "develop" : {
         "requires" : {
            "Capture::Tiny" : "0",
            "Module::Build" : "0.36",
            "Test::CPAN::Changes" : "0",
            "Test::EOL" : "0",
            "Test::More" : "0.8101",
            "Test::NoTabs" : "0",
            "Test::Pod" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "perl" : "5.006"
         }
      },
      "test" : {
         "requires" : {
            "Test::More" : "0"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "mailto" : "bug-local-lib@rt.cpan.org",
         "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=local-lib"
      },
      "license" : [
         "http://dev.perl.org/licenses/"
      ],
      "repository" : {
         "type" : "git",
         "url" : "git://github.com/Perl-Toolchain-Gang/local-lib",
         "web" : "https://github.com/Perl-Toolchain-Gang/local-lib"
      },
      "x_IRC" : "irc://irc.perl.org/#local-lib"
   },
   "version" : "2.000024",
   "x_serialization_backend" : "JSON::PP version 2.94"
}
PK       ! ��ZW    >  perl5/x86_64-linux-thread-multi/.meta/IO-Tty-1.20/install.jsonnu ��6�$        {"dist":"IO-Tty-1.20","target":"IO::Tty","pathname":"T/TO/TODDR/IO-Tty-1.20.tar.gz","provides":{"IO::Pty":{"file":"Pty.pm","version":"1.20"},"IO::Tty":{"version":"1.20","file":"Tty.pm"},"IO::Tty::Constant":{"version":"1.20","file":"Tty/Constant.pm"}},"name":"IO::Tty","version":"1.20"}PK       ! �lMh  h  =  perl5/x86_64-linux-thread-multi/.meta/IO-Tty-1.20/MYMETA.jsonnu ��6�$        {
   "abstract" : "Pseudo ttys and constants",
   "author" : [
      "Roland Giersig <RGiersig@cpan.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.64, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "IO-Tty",
   "no_index" : {
      "directory" : [
         "t",
         "inc"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "Test::More" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "web" : "https://github.com/toddr/IO-Tty/issues"
      },
      "license" : [
         "http://dev.perl.org/licenses/"
      ],
      "repository" : {
         "url" : "https://github.com/toddr/IO-Tty"
      }
   },
   "version" : "1.20",
   "x_serialization_backend" : "JSON::PP version 4.07"
}
PK       ! �,s  s  A  perl5/x86_64-linux-thread-multi/.meta/YAML-Syck-1.45/install.jsonnu ��6�$        {"dist":"YAML-Syck-1.45","version":"1.45","provides":{"YAML::Syck":{"version":"1.45","file":"lib/YAML/Syck.pm"},"YAML::Loader::Syck":{"file":"lib/YAML/Loader/Syck.pm"},"YAML::Dumper::Syck":{"file":"lib/YAML/Dumper/Syck.pm"},"JSON::Syck":{"version":"1.45","file":"lib/JSON/Syck.pm"}},"target":"YAML::Syck","pathname":"T/TO/TODDR/YAML-Syck-1.45.tar.gz","name":"YAML::Syck"}PK       ! ���  �  @  perl5/x86_64-linux-thread-multi/.meta/YAML-Syck-1.45/MYMETA.jsonnu ��6�$        {
   "abstract" : "Fast, lightweight YAML loader and dumper",
   "author" : [
      "Todd Rinaldo <toddr@cpan.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.76, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "mit"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "YAML-Syck",
   "no_index" : {
      "directory" : [
         "t",
         "inc"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "Test::More" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "perl" : "5.006"
         }
      }
   },
   "provides" : {
      "JSON::Syck" : {
         "file" : "lib/JSON/Syck.pm",
         "version" : "1.45"
      },
      "YAML::Dumper::Syck" : {
         "file" : "lib/YAML/Dumper/Syck.pm"
      },
      "YAML::Loader::Syck" : {
         "file" : "lib/YAML/Loader/Syck.pm"
      },
      "YAML::Syck" : {
         "file" : "lib/YAML/Syck.pm",
         "version" : "1.45"
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "web" : "https://github.com/toddr/YAML-Syck/issues"
      },
      "homepage" : "https://github.com/toddr/YAML-Syck",
      "license" : [
         "https://dev.perl.org/licenses/"
      ],
      "repository" : {
         "type" : "git",
         "url" : "https://github.com/toddr/YAML-Syck.git",
         "web" : "https://github.com/toddr/YAML-Syck"
      }
   },
   "version" : "1.45",
   "x_serialization_backend" : "JSON::PP version 4.16"
}
PK       ! ����|  |  A  perl5/x86_64-linux-thread-multi/.meta/version-0.9932/install.jsonnu ��6�$        {"dist":"version-0.9932","target":"version","version":0.9932,"provides":{"version::vxs":{"version":0.9932,"file":"vutil/lib/version/vxs.pm"},"version::regex":{"file":"lib/version/regex.pm","version":0.9932},"version":{"file":"lib/version.pm","version":0.9932},"version::vpp":{"file":"vperl/vpp.pm","version":0.9932}},"pathname":"L/LE/LEONT/version-0.9932.tar.gz","name":"version"}PK       ! "utD�  �  @  perl5/x86_64-linux-thread-multi/.meta/version-0.9932/MYMETA.jsonnu ��6�$        {
   "abstract" : "Structured version objects",
   "author" : [
      "John Peacock <jpeacock@cpan.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.70, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "version",
   "no_index" : {
      "directory" : [
         "t",
         "inc"
      ],
      "package" : [
         "charstar"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "perl" : "5.006002"
         }
      },
      "test" : {
         "requires" : {
            "File::Temp" : "0.13",
            "Test::More" : "0.45",
            "base" : "0"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "mailto" : "bug-version@rt.cpan.org",
         "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=version"
      },
      "repository" : {
         "type" : "git",
         "url" : "git://github.com/Perl/version.pm.git",
         "web" : "https://github.com/Perl/version.pm"
      }
   },
   "version" : "0.9932",
   "x_serialization_backend" : "JSON::PP version 4.16"
}
PK       ! &B�m  m  A  perl5/x86_64-linux-thread-multi/.meta/YAML-Syck-1.36/install.jsonnu ��6�$        {"dist":"YAML-Syck-1.36","pathname":"T/TO/TODDR/YAML-Syck-1.36.tar.gz","provides":{"YAML::Loader::Syck":{"file":"lib/YAML/Loader/Syck.pm"},"YAML::Syck":{"version":1.36,"file":"lib/YAML/Syck.pm"},"JSON::Syck":{"version":1.36,"file":"lib/JSON/Syck.pm"},"YAML::Dumper::Syck":{"file":"lib/YAML/Dumper/Syck.pm"}},"name":"YAML::Syck","version":1.36,"target":"YAML::Syck"}PK       ! VL     @  perl5/x86_64-linux-thread-multi/.meta/YAML-Syck-1.36/MYMETA.jsonnu ��6�$        {
   "abstract" : "Fast, lightweight YAML loader and dumper",
   "author" : [
      "Todd Rinaldo <toddr@cpan.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.76, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "mit"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "YAML-Syck",
   "no_index" : {
      "directory" : [
         "t",
         "inc"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "Test::More" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "perl" : "5.006"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "web" : "https://github.com/toddr/YAML-Syck/issues"
      },
      "homepage" : "http://github.com/toddr/YAML-Syck",
      "license" : [
         "http://dev.perl.org/licenses/"
      ],
      "repository" : {
         "url" : "http://github.com/toddr/YAML-Syck"
      }
   },
   "version" : "1.36",
   "x_serialization_backend" : "JSON::PP version 4.16"
}
PK       ! 5J��`  `  I  perl5/x86_64-linux-thread-multi/.meta/Template-Toolkit-3.010/install.jsonnu ��6�$        {"provides":{"Template::Base":{"version":"3.010","file":"lib/Template/Base.pm"},"Template::Stash::Context":{"version":"3.010","file":"lib/Template/Stash/Context.pm"},"Template::Config":{"version":"3.010","file":"lib/Template/Config.pm"},"Template::Plugin::Date::Calc":{"version":"3.010","file":"lib/Template/Plugin/Date.pm"},"Template::View":{"version":"3.010","file":"lib/Template/View.pm"},"Template::Perl":{"version":"3.010","file":"lib/Template/Filters.pm"},"Template::Plugin::Procedural":{"version":"3.010","file":"lib/Template/Plugin/Procedural.pm"},"Template::Plugin::Table":{"version":"3.010","file":"lib/Template/Plugin/Table.pm"},"Template::Plugin::Filter":{"version":"3.010","file":"lib/Template/Plugin/Filter.pm"},"Template::Iterator":{"version":"3.010","file":"lib/Template/Iterator.pm"},"Template::Plugin::Pod":{"version":"3.010","file":"lib/Template/Plugin/Pod.pm"},"Template::Constants":{"version":"3.010","file":"lib/Template/Constants.pm"},"Template::VMethods":{"version":"3.010","file":"lib/Template/VMethods.pm"},"Template::Monad::Scalar":{"version":"3.010","file":"lib/Template/Plugin/Scalar.pm"},"Template::Plugin::Datafile":{"version":"3.010","file":"lib/Template/Plugin/Datafile.pm"},"Template::Plugin::URL":{"version":"3.010","file":"lib/Template/Plugin/URL.pm"},"Template::Filters":{"version":"3.010","file":"lib/Template/Filters.pm"},"Template::Namespace::Constants":{"version":"3.010","file":"lib/Template/Namespace/Constants.pm"},"Template::Toolkit":{"version":"3.010","file":"lib/Template/Toolkit.pm"},"Template::Context":{"version":"3.010","file":"lib/Template/Context.pm"},"Template::Directive":{"version":"3.010","file":"lib/Template/Directive.pm"},"Template::Plugin":{"version":"3.010","file":"lib/Template/Plugin.pm"},"Template::TieString":{"version":"3.010","file":"lib/Template/Config.pm"},"Template::Plugin::Wrap":{"version":"3.010","file":"lib/Template/Plugin/Wrap.pm"},"Template::Parser":{"version":"3.010","file":"lib/Template/Parser.pm"},"Template::Grammar":{"version":"3.010","file":"lib/Template/Grammar.pm"},"Template::Plugin::HTML":{"version":"3.010","file":"lib/Template/Plugin/HTML.pm"},"Template::Plugin::Format":{"version":"3.010","file":"lib/Template/Plugin/Format.pm"},"Template::Plugin::Scalar":{"version":"3.010","file":"lib/Template/Plugin/Scalar.pm"},"Template::Plugin::Directory":{"version":"3.010","file":"lib/Template/Plugin/Directory.pm"},"Template::Stash::XS":{"file":"lib/Template/Stash/XS.pm"},"Template::Plugin::Dumper":{"version":"3.010","file":"lib/Template/Plugin/Dumper.pm"},"Template::Plugins":{"version":"3.010","file":"lib/Template/Plugins.pm"},"Template::Plugin::Assert":{"version":"3.010","file":"lib/Template/Plugin/Assert.pm"},"Template::Provider":{"version":"3.010","file":"lib/Template/Provider.pm"},"Template::Stash":{"version":"3.010","file":"lib/Template/Stash.pm"},"Template::Plugin::Image":{"version":"3.010","file":"lib/Template/Plugin/Image.pm"},"Template::Plugin::Date::Manip":{"version":"3.010","file":"lib/Template/Plugin/Date.pm"},"Template::Exception":{"version":"3.010","file":"lib/Template/Exception.pm"},"Template::Plugin::String":{"version":"3.010","file":"lib/Template/Plugin/String.pm"},"Template::Document":{"version":"3.010","file":"lib/Template/Document.pm"},"Template::Plugin::Math":{"version":"3.010","file":"lib/Template/Plugin/Math.pm"},"Template::Service":{"version":"3.010","file":"lib/Template/Service.pm"},"Template::Test":{"version":"3.010","file":"lib/Template/Test.pm"},"Template::Monad::Assert":{"version":"3.010","file":"lib/Template/Plugin/Assert.pm"},"Template::Plugin::Iterator":{"version":"3.010","file":"lib/Template/Plugin/Iterator.pm"},"Template":{"version":"3.010","file":"lib/Template.pm"},"Template::Plugin::CGI":{"version":"3.010","file":"lib/Template/Plugin/CGI.pm"},"Template::Plugin::Date":{"version":"3.010","file":"lib/Template/Plugin/Date.pm"},"Template::Plugin::File":{"version":"3.010","file":"lib/Template/Plugin/File.pm"},"Template::Plugin::View":{"version":"3.010","file":"lib/Template/Plugin/View.pm"}},"target":"Template::Constants","version":"3.010","name":"Template","dist":"Template-Toolkit-3.010","pathname":"A/AT/ATOOMIC/Template-Toolkit-3.010.tar.gz"}PK       ! �֗��  �  H  perl5/x86_64-linux-thread-multi/.meta/Template-Toolkit-3.010/MYMETA.jsonnu ��6�$        {
   "abstract" : "comprehensive template processing system",
   "author" : [
      "Andy Wardley <abw@wardley.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "Template-Toolkit",
   "no_index" : {
      "directory" : [
         "t",
         "inc"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "AppConfig" : "1.56",
            "File::Spec" : "0.8",
            "File::Temp" : "0.12",
            "Scalar::Util" : "0"
         }
      },
      "test" : {
         "requires" : {
            "CGI" : "4.11",
            "Test::LeakTrace" : "0"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "web" : "https://github.com/abw/Template2/issues"
      },
      "homepage" : "http://www.template-toolkit.org",
      "repository" : {
         "type" : "git",
         "url" : "https://github.com/abw/Template2.git",
         "web" : "https://github.com/abw/Template2"
      }
   },
   "version" : "3.010"
}
PK       ! ��[�    A  perl5/x86_64-linux-thread-multi/.meta/HTML-Tree-5.07/install.jsonnu ��6�$        {"provides":{"HTML::Element::traverse":{"version":5.07,"file":"lib/HTML/Element/traverse.pm"},"HTML::Element":{"version":5.07,"file":"lib/HTML/Element.pm"},"HTML::TreeBuilder":{"version":5.07,"file":"lib/HTML/TreeBuilder.pm"},"HTML::Parse":{"version":5.07,"file":"lib/HTML/Parse.pm"},"HTML::Tree":{"version":5.07,"file":"lib/HTML/Tree.pm"},"HTML::AsSubs":{"version":5.07,"file":"lib/HTML/AsSubs.pm"}},"target":"HTML::TreeBuilder","version":5.07,"name":"HTML::Tree","dist":"HTML-Tree-5.07","pathname":"K/KE/KENTNL/HTML-Tree-5.07.tar.gz"}PK       ! �)h]�B  �B  @  perl5/x86_64-linux-thread-multi/.meta/HTML-Tree-5.07/MYMETA.jsonnu ��6�$        {
   "abstract" : "Work with HTML in a DOM-like tree structure",
   "author" : [
      "Christopher J. Madsen <perl@cjmweb.net>",
      "Jeff Fearn <jfearn@cpan.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "Module::Build version 0.4005, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "HTML-Tree",
   "no_index" : {
      "directory" : [
         "inc",
         "t"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "Encode" : "0",
            "Module::Build" : "0.2808",
            "Test::Fatal" : "0",
            "Test::More" : "0",
            "base" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "Module::Build" : "0.2808"
         }
      },
      "runtime" : {
         "recommends" : {
            "HTML::FormatText" : "0",
            "LWP::UserAgent" : "5.815"
         },
         "requires" : {
            "Carp" : "0",
            "Exporter" : "0",
            "HTML::Entities" : "0",
            "HTML::Parser" : "3.46",
            "HTML::Tagset" : "3.02",
            "Scalar::Util" : "0",
            "integer" : "0",
            "perl" : "5.008"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "repository" : {
         "type" : "git",
         "url" : "git://github.com/kentfredric/HTML-Tree.git"
      }
   },
   "version" : "5.07",
   "x_Dist_Zilla" : {
      "perl" : {
         "version" : "5.026000"
      },
      "plugins" : [
         {
            "class" : "Dist::Zilla::Plugin::Git::GatherDir",
            "config" : {
               "Dist::Zilla::Plugin::Git::GatherDir" : {
                  "include_untracked" : "0"
               }
            },
            "name" : "Git::GatherDir",
            "version" : "2.041"
         },
         {
            "class" : "Dist::Zilla::Plugin::ManifestSkip",
            "name" : "ManifestSkip",
            "version" : "4.300039"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaJSON",
            "name" : "MetaJSON",
            "version" : "4.300039"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaYAML",
            "name" : "MetaYAML",
            "version" : "4.300039"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaConfig",
            "name" : "MetaConfig",
            "version" : "4.300039"
         },
         {
            "class" : "Dist::Zilla::Plugin::License",
            "name" : "License",
            "version" : "4.300039"
         },
         {
            "class" : "Dist::Zilla::Plugin::MatchManifest",
            "name" : "MatchManifest",
            "version" : "4.02"
         },
         {
            "class" : "Dist::Zilla::Plugin::CheckChangesHasContent",
            "name" : "CheckChangesHasContent",
            "version" : "0.010"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::PrereqsFromMeta",
            "name" : "Test::PrereqsFromMeta",
            "version" : "4.23"
         },
         {
            "class" : "Dist::Zilla::Plugin::PodSyntaxTests",
            "name" : "PodSyntaxTests",
            "version" : "4.300039"
         },
         {
            "class" : "Dist::Zilla::Plugin::PodCoverageTests",
            "name" : "PodCoverageTests",
            "version" : "4.300039"
         },
         {
            "class" : "Dist::Zilla::Plugin::ModuleBuild::Custom",
            "name" : "ModuleBuild::Custom",
            "version" : "4.26"
         },
         {
            "class" : "Dist::Zilla::Plugin::RecommendedPrereqs",
            "name" : "RecommendedPrereqs",
            "version" : "4.21"
         },
         {
            "class" : "Dist::Zilla::Plugin::CheckPrereqsIndexed",
            "name" : "CheckPrereqsIndexed",
            "version" : "0.020"
         },
         {
            "class" : "Dist::Zilla::Plugin::OurPkgVersion",
            "name" : "OurPkgVersion",
            "version" : "0.10"
         },
         {
            "class" : "Dist::Zilla::Plugin::TemplateCJM",
            "name" : "TemplateCJM",
            "version" : "5.001"
         },
         {
            "class" : "Dist::Zilla::Plugin::PodWeaver",
            "config" : {
               "Dist::Zilla::Plugin::PodWeaver" : {
                  "finder" : [
                     "FilesToWeave"
                  ],
                  "plugins" : [
                     {
                        "class" : "Pod::Weaver::Plugin::EnsurePod5",
                        "name" : "@CorePrep/EnsurePod5",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Plugin::H1Nester",
                        "name" : "@CorePrep/H1Nester",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Name",
                        "name" : "Name",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Version",
                        "name" : "Version",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Region",
                        "name" : "prelude",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Generic",
                        "name" : "SYNOPSIS",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Generic",
                        "name" : "DESCRIPTION",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Collect",
                        "name" : "ATTRIBUTES",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::AllowOverride",
                        "name" : "Over ATTRIBUTES",
                        "version" : "0.05"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Collect",
                        "name" : "METHODS",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::AllowOverride",
                        "name" : "Over METHODS",
                        "version" : "0.05"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Generic",
                        "name" : "HOW WE REPRESENT TREES",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Collect",
                        "name" : "BASIC METHODS",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Collect",
                        "name" : "STRUCTURE-MODIFYING METHODS",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::AllowOverride",
                        "name" : "Over STRUCTURE-MODIFYING METHODS",
                        "version" : "0.05"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Collect",
                        "name" : "DUMPING METHODS",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Collect",
                        "name" : "SECONDARY STRUCTURAL METHODS",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::AllowOverride",
                        "name" : "Over SECONDARY STRUCTURAL METHODS",
                        "version" : "0.05"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Collect",
                        "name" : "CLASS METHODS",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Collect",
                        "name" : "INTERNAL METHODS",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::AllowOverride",
                        "name" : "Over INTERNAL METHODS",
                        "version" : "0.05"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Collect",
                        "name" : "SUBROUTINES",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Leftovers",
                        "name" : "Leftovers",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Template",
                        "name" : "AUTHOR",
                        "version" : "0.04"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Template",
                        "name" : "COPYRIGHT AND LICENSE",
                        "version" : "0.04"
                     },
                     {
                        "class" : "Pod::Weaver::Section::AllowOverride",
                        "name" : "COPYRIGHT",
                        "version" : "0.05"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Region",
                        "name" : "postlude",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Plugin::EnsureUniqueSections",
                        "name" : "-EnsureUniqueSections",
                        "version" : "0.163250"
                     }
                  ]
               }
            },
            "name" : "PodWeaver",
            "version" : "4.008"
         },
         {
            "class" : "Dist::Zilla::Plugin::FileFinder::Filter",
            "name" : "FilesToWeave",
            "version" : "4.300039"
         },
         {
            "class" : "Dist::Zilla::Plugin::Repository",
            "name" : "Repository",
            "version" : "0.20"
         },
         {
            "class" : "Dist::Zilla::Plugin::NextRelease",
            "name" : "NextRelease",
            "version" : "4.300039"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::NextVersion",
            "config" : {
               "Dist::Zilla::Plugin::Git::NextVersion" : {
                  "first_version" : "0.001",
                  "version_by_branch" : "0",
                  "version_regexp" : "(?^u:^(\\d+\\.[\\d_]+)(?:-TRIAL)?$)"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git --version" : "2.13.1",
                  "repo_root" : "."
               }
            },
            "name" : "Git::NextVersion",
            "version" : "2.041"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Check",
            "config" : {
               "Dist::Zilla::Plugin::Git::Check" : {
                  "untracked_files" : "die"
               },
               "Dist::Zilla::Role::Git::DirtyFiles" : {
                  "allow_dirty" : [
                     "Changes"
                  ],
                  "allow_dirty_match" : [],
                  "changelog" : "Changes"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git --version" : "2.13.1",
                  "repo_root" : "."
               }
            },
            "name" : "@Git/Check",
            "version" : "2.041"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Commit",
            "config" : {
               "Dist::Zilla::Plugin::Git::Commit" : {
                  "add_files_in" : [],
                  "commit_msg" : "Updated Changes for %{MMMM d, yyyy}d%{ trial}t release of %v"
               },
               "Dist::Zilla::Role::Git::DirtyFiles" : {
                  "allow_dirty" : [
                     "Changes"
                  ],
                  "allow_dirty_match" : [],
                  "changelog" : "Changes"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git --version" : "2.13.1",
                  "repo_root" : "."
               },
               "Dist::Zilla::Role::Git::StringFormatter" : {
                  "time_zone" : "local"
               }
            },
            "name" : "@Git/Commit",
            "version" : "2.041"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Tag",
            "config" : {
               "Dist::Zilla::Plugin::Git::Tag" : {
                  "branch" : null,
                  "changelog" : "Changes",
                  "signed" : "0",
                  "tag" : "5.07",
                  "tag_format" : "%v%t",
                  "tag_message" : "Tagged %N %v%{ (trial release)}t"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git --version" : "2.13.1",
                  "repo_root" : "."
               },
               "Dist::Zilla::Role::Git::StringFormatter" : {
                  "time_zone" : "local"
               }
            },
            "name" : "@Git/Tag",
            "version" : "2.041"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Push",
            "config" : {
               "Dist::Zilla::Plugin::Git::Push" : {
                  "push_to" : [
                     "github master"
                  ],
                  "remotes_must_exist" : "1"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git --version" : "2.13.1",
                  "repo_root" : "."
               }
            },
            "name" : "@Git/Push",
            "version" : "2.041"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::CheckFor::CorrectBranch",
            "config" : {
               "Dist::Zilla::Role::Git::Repo" : {
                  "git --version" : "2.13.1",
                  "repo_root" : "."
               }
            },
            "name" : "GitBranch",
            "version" : "0.014"
         },
         {
            "class" : "Dist::Zilla::Plugin::RunExtraTests",
            "name" : "RunExtraTests",
            "version" : "0.029"
         },
         {
            "class" : "Dist::Zilla::Plugin::TestRelease",
            "name" : "TestRelease",
            "version" : "4.300039"
         },
         {
            "class" : "Dist::Zilla::Plugin::UploadToCPAN",
            "name" : "UploadToCPAN",
            "version" : "4.300039"
         },
         {
            "class" : "Dist::Zilla::Plugin::ArchiveRelease",
            "name" : "ArchiveRelease",
            "version" : "4.26"
         },
         {
            "class" : "Dist::Zilla::Plugin::ConfirmRelease",
            "name" : "ConfirmRelease",
            "version" : "4.300039"
         },
         {
            "class" : "Dist::Zilla::Plugin::AutoPrereqs",
            "name" : "AutoPrereqs",
            "version" : "4.300039"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaNoIndex",
            "name" : "MetaNoIndex",
            "version" : "4.300039"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":InstallModules",
            "version" : "4.300039"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":IncModules",
            "version" : "4.300039"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":TestFiles",
            "version" : "4.300039"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":ExecFiles",
            "version" : "4.300039"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":ShareFiles",
            "version" : "4.300039"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":MainModule",
            "version" : "4.300039"
         }
      ],
      "zilla" : {
         "class" : "Dist::Zilla::Dist::Builder",
         "config" : {
            "is_trial" : "0"
         },
         "version" : "4.300039"
      }
   }
}
PK       ! ���/�   �   @  perl5/x86_64-linux-thread-multi/.meta/Try-Tiny-0.31/install.jsonnu ��6�$        {"name":"Try::Tiny","provides":{"Try::Tiny":{"file":"lib/Try/Tiny.pm","version":"0.31"}},"pathname":"E/ET/ETHER/Try-Tiny-0.31.tar.gz","version":"0.31","target":"Try::Tiny","dist":"Try-Tiny-0.31"}PK       ! Cx;;B�  B�  ?  perl5/x86_64-linux-thread-multi/.meta/Try-Tiny-0.31/MYMETA.jsonnu ��6�$        {
   "abstract" : "Minimal try/catch with proper preservation of $@",
   "author" : [
      "יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>",
      "Jesse Luehrs <doy@tozt.net>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "Dist::Zilla version 6.024, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "mit"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "Try-Tiny",
   "no_index" : {
      "directory" : [
         "t",
         "xt"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         },
         "suggests" : {
            "JSON::PP" : "2.27300"
         }
      },
      "develop" : {
         "recommends" : {
            "Dist::Zilla::PluginBundle::Author::ETHER" : "0.161",
            "Dist::Zilla::PluginBundle::Git::VersionManager" : "0.007"
         },
         "requires" : {
            "Capture::Tiny" : "0.12",
            "Encode" : "0",
            "File::Spec" : "0",
            "IO::Handle" : "0",
            "IPC::Open3" : "0",
            "Pod::Coverage::TrustPod" : "0",
            "Pod::Wordlist" : "0",
            "Sub::Name" : "0.08",
            "Sub::Util" : "0",
            "Test::CPAN::Changes" : "0.19",
            "Test::CPAN::Meta" : "0",
            "Test::EOL" : "0",
            "Test::Kwalitee" : "1.21",
            "Test::MinimumVersion" : "0",
            "Test::Mojibake" : "0",
            "Test::More" : "0.96",
            "Test::NoTabs" : "0",
            "Test::Pod" : "1.41",
            "Test::Pod::Coverage" : "1.08",
            "Test::Pod::No404s" : "0",
            "Test::Portability::Files" : "0",
            "Test::Spelling" : "0.12"
         }
      },
      "runtime" : {
         "requires" : {
            "Carp" : "0",
            "Exporter" : "5.57",
            "constant" : "0",
            "perl" : "5.006",
            "strict" : "0",
            "warnings" : "0"
         },
         "suggests" : {
            "Sub::Name" : "0.08",
            "Sub::Util" : "0"
         }
      },
      "test" : {
         "recommends" : {
            "CPAN::Meta" : "2.120900"
         },
         "requires" : {
            "ExtUtils::MakeMaker" : "0",
            "File::Spec" : "0",
            "Test::More" : "0",
            "if" : "0"
         },
         "suggests" : {
            "CPAN::Meta::Check" : "0.011",
            "CPAN::Meta::Requirements" : "0",
            "Capture::Tiny" : "0.12"
         }
      },
      "x_Dist_Zilla" : {
         "requires" : {
            "Dist::Zilla" : "5",
            "Dist::Zilla::Plugin::Authority" : "1.009",
            "Dist::Zilla::Plugin::AutoMetaResources" : "0",
            "Dist::Zilla::Plugin::AutoPrereqs" : "5.038",
            "Dist::Zilla::Plugin::Breaks" : "0",
            "Dist::Zilla::Plugin::BumpVersionAfterRelease::Transitional" : "0.004",
            "Dist::Zilla::Plugin::CheckIssues" : "0",
            "Dist::Zilla::Plugin::CheckMetaResources" : "0",
            "Dist::Zilla::Plugin::CheckPrereqsIndexed" : "0.019",
            "Dist::Zilla::Plugin::CheckSelfDependency" : "0",
            "Dist::Zilla::Plugin::CheckStrictVersion" : "0",
            "Dist::Zilla::Plugin::ConfirmRelease" : "0",
            "Dist::Zilla::Plugin::CopyFilesFromRelease" : "0",
            "Dist::Zilla::Plugin::EnsureLatestPerl" : "0",
            "Dist::Zilla::Plugin::FileFinder::ByName" : "0",
            "Dist::Zilla::Plugin::FileFinder::Filter" : "0",
            "Dist::Zilla::Plugin::GenerateFile::FromShareDir" : "0",
            "Dist::Zilla::Plugin::Git::Check" : "0",
            "Dist::Zilla::Plugin::Git::CheckFor::CorrectBranch" : "0.004",
            "Dist::Zilla::Plugin::Git::CheckFor::MergeConflicts" : "0",
            "Dist::Zilla::Plugin::Git::Commit" : "2.020",
            "Dist::Zilla::Plugin::Git::Contributors" : "0.029",
            "Dist::Zilla::Plugin::Git::Describe" : "0.004",
            "Dist::Zilla::Plugin::Git::GatherDir" : "2.016",
            "Dist::Zilla::Plugin::Git::Push" : "0",
            "Dist::Zilla::Plugin::Git::Remote::Check" : "0",
            "Dist::Zilla::Plugin::Git::Tag" : "0",
            "Dist::Zilla::Plugin::GitHub::Update" : "0.40",
            "Dist::Zilla::Plugin::GithubMeta" : "0.54",
            "Dist::Zilla::Plugin::InstallGuide" : "1.200005",
            "Dist::Zilla::Plugin::Keywords" : "0.004",
            "Dist::Zilla::Plugin::License" : "5.038",
            "Dist::Zilla::Plugin::MakeMaker" : "0",
            "Dist::Zilla::Plugin::Manifest" : "0",
            "Dist::Zilla::Plugin::MetaConfig" : "0",
            "Dist::Zilla::Plugin::MetaJSON" : "0",
            "Dist::Zilla::Plugin::MetaNoIndex" : "0",
            "Dist::Zilla::Plugin::MetaProvides::Package" : "1.15000002",
            "Dist::Zilla::Plugin::MetaTests" : "0",
            "Dist::Zilla::Plugin::MetaYAML" : "0",
            "Dist::Zilla::Plugin::MinimumPerl" : "1.006",
            "Dist::Zilla::Plugin::MojibakeTests" : "0.8",
            "Dist::Zilla::Plugin::NextRelease" : "5.033",
            "Dist::Zilla::Plugin::OnlyCorePrereqs" : "0",
            "Dist::Zilla::Plugin::PodCoverageTests" : "5.040",
            "Dist::Zilla::Plugin::PodSyntaxTests" : "5.040",
            "Dist::Zilla::Plugin::PodWeaver" : "4.008",
            "Dist::Zilla::Plugin::Prereqs" : "0",
            "Dist::Zilla::Plugin::Prereqs::AuthorDeps" : "0.006",
            "Dist::Zilla::Plugin::Prereqs::Soften" : "0",
            "Dist::Zilla::Plugin::PromptIfStale" : "0",
            "Dist::Zilla::Plugin::Readme" : "0",
            "Dist::Zilla::Plugin::ReadmeAnyFromPod" : "0.142180",
            "Dist::Zilla::Plugin::RewriteVersion::Transitional" : "0.006",
            "Dist::Zilla::Plugin::Run::AfterBuild" : "0.041",
            "Dist::Zilla::Plugin::Run::AfterRelease" : "0.038",
            "Dist::Zilla::Plugin::RunExtraTests" : "0.024",
            "Dist::Zilla::Plugin::StaticInstall" : "0.005",
            "Dist::Zilla::Plugin::Substitute" : "0",
            "Dist::Zilla::Plugin::Test::CPAN::Changes" : "0.012",
            "Dist::Zilla::Plugin::Test::ChangesHasContent" : "0",
            "Dist::Zilla::Plugin::Test::CheckBreaks" : "0.018",
            "Dist::Zilla::Plugin::Test::Compile" : "2.039",
            "Dist::Zilla::Plugin::Test::EOL" : "0.17",
            "Dist::Zilla::Plugin::Test::Kwalitee" : "2.10",
            "Dist::Zilla::Plugin::Test::MinimumVersion" : "2.000010",
            "Dist::Zilla::Plugin::Test::NoTabs" : "0.08",
            "Dist::Zilla::Plugin::Test::Pod::No404s" : "1.003",
            "Dist::Zilla::Plugin::Test::PodSpelling" : "2.006003",
            "Dist::Zilla::Plugin::Test::Portability" : "2.000007",
            "Dist::Zilla::Plugin::Test::ReportPrereqs" : "0.022",
            "Dist::Zilla::Plugin::TestRelease" : "0",
            "Dist::Zilla::Plugin::UploadToCPAN" : "0",
            "Dist::Zilla::Plugin::UseUnsafeInc" : "0",
            "Dist::Zilla::PluginBundle::Author::ETHER" : "0.136",
            "Dist::Zilla::PluginBundle::Git::VersionManager" : "0.007",
            "Software::License::MIT" : "0"
         }
      }
   },
   "provides" : {
      "Try::Tiny" : {
         "file" : "lib/Try/Tiny.pm",
         "version" : "0.31"
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "mailto" : "bug-Try-Tiny@rt.cpan.org",
         "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=Try-Tiny"
      },
      "homepage" : "https://github.com/p5sagit/Try-Tiny",
      "repository" : {
         "type" : "git",
         "url" : "https://github.com/p5sagit/Try-Tiny.git",
         "web" : "https://github.com/p5sagit/Try-Tiny"
      }
   },
   "version" : "0.31",
   "x_Dist_Zilla" : {
      "perl" : {
         "version" : "5.035006"
      },
      "plugins" : [
         {
            "class" : "Dist::Zilla::Plugin::FileFinder::Filter",
            "name" : "all_files_but_using_5.10_features",
            "version" : "6.024"
         },
         {
            "class" : "Dist::Zilla::Plugin::Prereqs",
            "config" : {
               "Dist::Zilla::Plugin::Prereqs" : {
                  "phase" : "develop",
                  "type" : "recommends"
               }
            },
            "name" : "@Author::ETHER/pluginbundle version",
            "version" : "6.024"
         },
         {
            "class" : "Dist::Zilla::Plugin::PromptIfStale",
            "config" : {
               "Dist::Zilla::Plugin::PromptIfStale" : {
                  "check_all_plugins" : 0,
                  "check_all_prereqs" : 0,
                  "modules" : [
                     "Dist::Zilla::PluginBundle::Author::ETHER"
                  ],
                  "phase" : "build",
                  "run_under_travis" : 0,
                  "skip" : []
               }
            },
            "name" : "@Author::ETHER/stale modules, build",
            "version" : "0.057"
         },
         {
            "class" : "Dist::Zilla::Plugin::FileFinder::ByName",
            "name" : "@Author::ETHER/Examples",
            "version" : "6.024"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::GatherDir",
            "config" : {
               "Dist::Zilla::Plugin::GatherDir" : {
                  "exclude_filename" : [
                     "CONTRIBUTING",
                     "INSTALL",
                     "LICENCE",
                     "README.pod"
                  ],
                  "exclude_match" : [],
                  "follow_symlinks" : 0,
                  "include_dotfiles" : 0,
                  "prefix" : "",
                  "prune_directory" : [],
                  "root" : "."
               },
               "Dist::Zilla::Plugin::Git::GatherDir" : {
                  "include_untracked" : 0
               }
            },
            "name" : "@Author::ETHER/Git::GatherDir",
            "version" : "2.048"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaYAML",
            "name" : "@Author::ETHER/MetaYAML",
            "version" : "6.024"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaJSON",
            "name" : "@Author::ETHER/MetaJSON",
            "version" : "6.024"
         },
         {
            "class" : "Dist::Zilla::Plugin::Readme",
            "name" : "@Author::ETHER/Readme",
            "version" : "6.024"
         },
         {
            "class" : "Dist::Zilla::Plugin::Manifest",
            "name" : "@Author::ETHER/Manifest",
            "version" : "6.024"
         },
         {
            "class" : "Dist::Zilla::Plugin::License",
            "name" : "@Author::ETHER/License",
            "version" : "6.024"
         },
         {
            "class" : "Dist::Zilla::Plugin::GenerateFile::FromShareDir",
            "config" : {
               "Dist::Zilla::Plugin::GenerateFile::FromShareDir" : {
                  "destination_filename" : "CONTRIBUTING",
                  "dist" : "Dist-Zilla-PluginBundle-Author-ETHER",
                  "encoding" : "UTF-8",
                  "has_xs" : 0,
                  "location" : "build",
                  "source_filename" : "CONTRIBUTING"
               },
               "Dist::Zilla::Role::RepoFileInjector" : {
                  "allow_overwrite" : 1,
                  "repo_root" : ".",
                  "version" : "0.009"
               }
            },
            "name" : "@Author::ETHER/generate CONTRIBUTING",
            "version" : "0.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::InstallGuide",
            "config" : {
               "Dist::Zilla::Role::ModuleMetadata" : {
                  "Module::Metadata" : "1.000037",
                  "version" : "0.006"
               }
            },
            "name" : "@Author::ETHER/InstallGuide",
            "version" : "1.200014"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::Compile",
            "config" : {
               "Dist::Zilla::Plugin::Test::Compile" : {
                  "bail_out_on_fail" : 1,
                  "fail_on_warning" : "author",
                  "fake_home" : 0,
                  "filename" : "xt/author/00-compile.t",
                  "module_finder" : [
                     ":InstallModules"
                  ],
                  "needs_display" : 0,
                  "phase" : "develop",
                  "script_finder" : [
                     ":PerlExecFiles",
                     "@Author::ETHER/Examples"
                  ],
                  "skips" : [],
                  "switch" : []
               }
            },
            "name" : "@Author::ETHER/Test::Compile",
            "version" : "2.058"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::NoTabs",
            "config" : {
               "Dist::Zilla::Plugin::Test::NoTabs" : {
                  "filename" : "xt/author/no-tabs.t",
                  "finder" : [
                     ":InstallModules",
                     ":ExecFiles",
                     "@Author::ETHER/Examples",
                     ":TestFiles",
                     ":ExtraTestFiles"
                  ]
               }
            },
            "name" : "@Author::ETHER/Test::NoTabs",
            "version" : "0.15"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::EOL",
            "config" : {
               "Dist::Zilla::Plugin::Test::EOL" : {
                  "filename" : "xt/author/eol.t",
                  "finder" : [
                     ":ExecFiles",
                     ":ExtraTestFiles",
                     ":InstallModules",
                     ":TestFiles",
                     "@Author::ETHER/Examples"
                  ],
                  "trailing_whitespace" : 1
               }
            },
            "name" : "@Author::ETHER/Test::EOL",
            "version" : "0.19"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaTests",
            "name" : "@Author::ETHER/MetaTests",
            "version" : "6.024"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::CPAN::Changes",
            "config" : {
               "Dist::Zilla::Plugin::Test::CPAN::Changes" : {
                  "changelog" : "Changes"
               }
            },
            "name" : "@Author::ETHER/Test::CPAN::Changes",
            "version" : "0.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::ChangesHasContent",
            "name" : "@Author::ETHER/Test::ChangesHasContent",
            "version" : "0.011"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::MinimumVersion",
            "config" : {
               "Dist::Zilla::Plugin::Test::MinimumVersion" : {
                  "max_target_perl" : "5.006"
               }
            },
            "name" : "@Author::ETHER/Test::MinimumVersion",
            "version" : "2.000010"
         },
         {
            "class" : "Dist::Zilla::Plugin::PodSyntaxTests",
            "name" : "@Author::ETHER/PodSyntaxTests",
            "version" : "6.024"
         },
         {
            "class" : "Dist::Zilla::Plugin::PodCoverageTests",
            "name" : "@Author::ETHER/PodCoverageTests",
            "version" : "6.024"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::PodSpelling",
            "config" : {
               "Dist::Zilla::Plugin::Test::PodSpelling" : {
                  "directories" : [
                     "examples",
                     "lib",
                     "script",
                     "t",
                     "xt"
                  ],
                  "spell_cmd" : "",
                  "stopwords" : [
                     "irc"
                  ],
                  "wordlist" : "Pod::Wordlist"
               }
            },
            "name" : "@Author::ETHER/Test::PodSpelling",
            "version" : "2.007005"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::Pod::No404s",
            "name" : "@Author::ETHER/Test::Pod::No404s",
            "version" : "1.004"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::Kwalitee",
            "config" : {
               "Dist::Zilla::Plugin::Test::Kwalitee" : {
                  "filename" : "xt/author/kwalitee.t",
                  "skiptest" : []
               }
            },
            "name" : "@Author::ETHER/Test::Kwalitee",
            "version" : "2.12"
         },
         {
            "class" : "Dist::Zilla::Plugin::MojibakeTests",
            "name" : "@Author::ETHER/MojibakeTests",
            "version" : "0.8"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::ReportPrereqs",
            "name" : "@Author::ETHER/Test::ReportPrereqs",
            "version" : "0.028"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::Portability",
            "config" : {
               "Dist::Zilla::Plugin::Test::Portability" : {
                  "options" : ""
               }
            },
            "name" : "@Author::ETHER/Test::Portability",
            "version" : "2.001000"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Describe",
            "name" : "@Author::ETHER/Git::Describe",
            "version" : "0.007"
         },
         {
            "class" : "Dist::Zilla::Plugin::PodWeaver",
            "config" : {
               "Dist::Zilla::Plugin::PodWeaver" : {
                  "config_plugins" : [
                     "@Author::ETHER"
                  ],
                  "finder" : [
                     ":InstallModules",
                     ":ExecFiles"
                  ],
                  "plugins" : [
                     {
                        "class" : "Pod::Weaver::Plugin::EnsurePod5",
                        "name" : "@Author::ETHER/EnsurePod5",
                        "version" : "4.018"
                     },
                     {
                        "class" : "Pod::Weaver::Plugin::H1Nester",
                        "name" : "@Author::ETHER/H1Nester",
                        "version" : "4.018"
                     },
                     {
                        "class" : "Pod::Weaver::Plugin::SingleEncoding",
                        "name" : "@Author::ETHER/SingleEncoding",
                        "version" : "4.018"
                     },
                     {
                        "class" : "Pod::Weaver::Plugin::Transformer",
                        "name" : "@Author::ETHER/List",
                        "version" : "4.018"
                     },
                     {
                        "class" : "Pod::Weaver::Plugin::Transformer",
                        "name" : "@Author::ETHER/Verbatim",
                        "version" : "4.018"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Region",
                        "name" : "@Author::ETHER/header",
                        "version" : "4.018"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Name",
                        "name" : "@Author::ETHER/Name",
                        "version" : "4.018"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Version",
                        "name" : "@Author::ETHER/Version",
                        "version" : "4.018"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Region",
                        "name" : "@Author::ETHER/prelude",
                        "version" : "4.018"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Generic",
                        "name" : "SYNOPSIS",
                        "version" : "4.018"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Generic",
                        "name" : "DESCRIPTION",
                        "version" : "4.018"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Generic",
                        "name" : "OVERVIEW",
                        "version" : "4.018"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Collect",
                        "name" : "ATTRIBUTES",
                        "version" : "4.018"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Collect",
                        "name" : "METHODS",
                        "version" : "4.018"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Collect",
                        "name" : "FUNCTIONS",
                        "version" : "4.018"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Collect",
                        "name" : "TYPES",
                        "version" : "4.018"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Leftovers",
                        "name" : "@Author::ETHER/Leftovers",
                        "version" : "4.018"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Region",
                        "name" : "@Author::ETHER/postlude",
                        "version" : "4.018"
                     },
                     {
                        "class" : "Pod::Weaver::Section::GenerateSection",
                        "name" : "@Author::ETHER/generate SUPPORT",
                        "version" : "4.018"
                     },
                     {
                        "class" : "Pod::Weaver::Section::AllowOverride",
                        "name" : "@Author::ETHER/allow override SUPPORT",
                        "version" : "0.05"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Authors",
                        "name" : "@Author::ETHER/Authors",
                        "version" : "4.018"
                     },
                     {
                        "class" : "Pod::Weaver::Section::AllowOverride",
                        "name" : "@Author::ETHER/allow override AUTHOR",
                        "version" : "0.05"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Contributors",
                        "name" : "@Author::ETHER/Contributors",
                        "version" : "0.009"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Legal",
                        "name" : "@Author::ETHER/Legal",
                        "version" : "4.018"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Region",
                        "name" : "@Author::ETHER/footer",
                        "version" : "4.018"
                     }
                  ]
               }
            },
            "name" : "@Author::ETHER/PodWeaver",
            "version" : "4.009"
         },
         {
            "class" : "Dist::Zilla::Plugin::GithubMeta",
            "name" : "@Author::ETHER/GithubMeta",
            "version" : "0.58"
         },
         {
            "class" : "Dist::Zilla::Plugin::AutoMetaResources",
            "name" : "@Author::ETHER/AutoMetaResources",
            "version" : "1.21"
         },
         {
            "class" : "Dist::Zilla::Plugin::Authority",
            "name" : "@Author::ETHER/Authority",
            "version" : "1.009"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaNoIndex",
            "name" : "@Author::ETHER/MetaNoIndex",
            "version" : "6.024"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaProvides::Package",
            "config" : {
               "Dist::Zilla::Plugin::MetaProvides::Package" : {
                  "finder" : [
                     ":InstallModules"
                  ],
                  "finder_objects" : [
                     {
                        "class" : "Dist::Zilla::Plugin::FinderCode",
                        "name" : ":InstallModules",
                        "version" : "6.024"
                     }
                  ],
                  "include_underscores" : 0
               },
               "Dist::Zilla::Role::MetaProvider::Provider" : {
                  "$Dist::Zilla::Role::MetaProvider::Provider::VERSION" : "2.002004",
                  "inherit_missing" : 0,
                  "inherit_version" : 0,
                  "meta_noindex" : 1
               },
               "Dist::Zilla::Role::ModuleMetadata" : {
                  "Module::Metadata" : "1.000037",
                  "version" : "0.006"
               }
            },
            "name" : "@Author::ETHER/MetaProvides::Package",
            "version" : "2.004003"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaConfig",
            "name" : "@Author::ETHER/MetaConfig",
            "version" : "6.024"
         },
         {
            "class" : "Dist::Zilla::Plugin::Keywords",
            "config" : {
               "Dist::Zilla::Plugin::Keywords" : {
                  "keywords" : []
               }
            },
            "name" : "@Author::ETHER/Keywords",
            "version" : "0.007"
         },
         {
            "class" : "Dist::Zilla::Plugin::UseUnsafeInc",
            "config" : {
               "Dist::Zilla::Plugin::UseUnsafeInc" : {
                  "dot_in_INC" : 0
               }
            },
            "name" : "@Author::ETHER/UseUnsafeInc",
            "version" : "0.001"
         },
         {
            "class" : "Dist::Zilla::Plugin::AutoPrereqs",
            "name" : "@Author::ETHER/AutoPrereqs",
            "version" : "6.024"
         },
         {
            "class" : "Dist::Zilla::Plugin::Prereqs::AuthorDeps",
            "name" : "@Author::ETHER/Prereqs::AuthorDeps",
            "version" : "0.007"
         },
         {
            "class" : "Dist::Zilla::Plugin::MinimumPerl",
            "name" : "@Author::ETHER/MinimumPerl",
            "version" : "1.006"
         },
         {
            "class" : "Dist::Zilla::Plugin::MakeMaker",
            "config" : {
               "Dist::Zilla::Role::TestRunner" : {
                  "default_jobs" : 9
               }
            },
            "name" : "@Author::ETHER/MakeMaker",
            "version" : "6.024"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Contributors",
            "config" : {
               "Dist::Zilla::Plugin::Git::Contributors" : {
                  "git_version" : "2.31.1",
                  "include_authors" : 0,
                  "include_releaser" : 1,
                  "order_by" : "commits",
                  "paths" : []
               }
            },
            "name" : "@Author::ETHER/Git::Contributors",
            "version" : "0.036"
         },
         {
            "class" : "Dist::Zilla::Plugin::StaticInstall",
            "config" : {
               "Dist::Zilla::Plugin::StaticInstall" : {
                  "dry_run" : 1,
                  "mode" : "auto"
               }
            },
            "name" : "@Author::ETHER/StaticInstall",
            "version" : "0.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::RunExtraTests",
            "config" : {
               "Dist::Zilla::Role::TestRunner" : {
                  "default_jobs" : 9
               }
            },
            "name" : "@Author::ETHER/RunExtraTests",
            "version" : "0.029"
         },
         {
            "class" : "Dist::Zilla::Plugin::CheckSelfDependency",
            "config" : {
               "Dist::Zilla::Plugin::CheckSelfDependency" : {
                  "finder" : [
                     ":InstallModules"
                  ]
               },
               "Dist::Zilla::Role::ModuleMetadata" : {
                  "Module::Metadata" : "1.000037",
                  "version" : "0.006"
               }
            },
            "name" : "@Author::ETHER/CheckSelfDependency",
            "version" : "0.011"
         },
         {
            "class" : "Dist::Zilla::Plugin::Run::AfterBuild",
            "config" : {
               "Dist::Zilla::Plugin::Run::Role::Runner" : {
                  "fatal_errors" : 1,
                  "quiet" : 1,
                  "run" : [
                     "bash -c \"test -e .ackrc && grep -q -- '--ignore-dir=.latest' .ackrc || echo '--ignore-dir=.latest' >> .ackrc; if [[ `dirname '%d'` != .build ]]; then test -e .ackrc && grep -q -- '--ignore-dir=%d' .ackrc || echo '--ignore-dir=%d' >> .ackrc; fi\""
                  ],
                  "version" : "0.048"
               }
            },
            "name" : "@Author::ETHER/.ackrc",
            "version" : "0.048"
         },
         {
            "class" : "Dist::Zilla::Plugin::Run::AfterBuild",
            "config" : {
               "Dist::Zilla::Plugin::Run::Role::Runner" : {
                  "eval" : [
                     "if ('%d' =~ /^%n-[.[:xdigit:]]+$/) { unlink '.latest'; symlink '%d', '.latest'; }"
                  ],
                  "fatal_errors" : 0,
                  "quiet" : 1,
                  "version" : "0.048"
               }
            },
            "name" : "@Author::ETHER/.latest",
            "version" : "0.048"
         },
         {
            "class" : "Dist::Zilla::Plugin::CheckStrictVersion",
            "name" : "@Author::ETHER/CheckStrictVersion",
            "version" : "0.001"
         },
         {
            "class" : "Dist::Zilla::Plugin::CheckMetaResources",
            "name" : "@Author::ETHER/CheckMetaResources",
            "version" : "0.001"
         },
         {
            "class" : "Dist::Zilla::Plugin::EnsureLatestPerl",
            "config" : {
               "Dist::Zilla::Plugin::EnsureLatestPerl" : {
                  "Module::CoreList" : "5.20211120"
               }
            },
            "name" : "@Author::ETHER/EnsureLatestPerl",
            "version" : "0.008"
         },
         {
            "class" : "Dist::Zilla::Plugin::PromptIfStale",
            "config" : {
               "Dist::Zilla::Plugin::PromptIfStale" : {
                  "check_all_plugins" : 1,
                  "check_all_prereqs" : 1,
                  "modules" : [],
                  "phase" : "release",
                  "run_under_travis" : 0,
                  "skip" : []
               }
            },
            "name" : "@Author::ETHER/stale modules, release",
            "version" : "0.057"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Check",
            "config" : {
               "Dist::Zilla::Plugin::Git::Check" : {
                  "untracked_files" : "die"
               },
               "Dist::Zilla::Role::Git::DirtyFiles" : {
                  "allow_dirty" : [],
                  "allow_dirty_match" : [],
                  "changelog" : "Changes"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.31.1",
                  "repo_root" : "."
               }
            },
            "name" : "@Author::ETHER/initial check",
            "version" : "2.048"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::CheckFor::MergeConflicts",
            "config" : {
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.31.1",
                  "repo_root" : "."
               }
            },
            "name" : "@Author::ETHER/Git::CheckFor::MergeConflicts",
            "version" : "0.014"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::CheckFor::CorrectBranch",
            "config" : {
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.31.1",
                  "repo_root" : "."
               }
            },
            "name" : "@Author::ETHER/Git::CheckFor::CorrectBranch",
            "version" : "0.014"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Remote::Check",
            "name" : "@Author::ETHER/Git::Remote::Check",
            "version" : "0.1.2"
         },
         {
            "class" : "Dist::Zilla::Plugin::CheckPrereqsIndexed",
            "name" : "@Author::ETHER/CheckPrereqsIndexed",
            "version" : "0.021"
         },
         {
            "class" : "Dist::Zilla::Plugin::TestRelease",
            "name" : "@Author::ETHER/TestRelease",
            "version" : "6.024"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Check",
            "config" : {
               "Dist::Zilla::Plugin::Git::Check" : {
                  "untracked_files" : "die"
               },
               "Dist::Zilla::Role::Git::DirtyFiles" : {
                  "allow_dirty" : [],
                  "allow_dirty_match" : [],
                  "changelog" : "Changes"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.31.1",
                  "repo_root" : "."
               }
            },
            "name" : "@Author::ETHER/after tests",
            "version" : "2.048"
         },
         {
            "class" : "Dist::Zilla::Plugin::CheckIssues",
            "name" : "@Author::ETHER/CheckIssues",
            "version" : "0.011"
         },
         {
            "class" : "Dist::Zilla::Plugin::UploadToCPAN",
            "name" : "@Author::ETHER/UploadToCPAN",
            "version" : "6.024"
         },
         {
            "class" : "Dist::Zilla::Plugin::CopyFilesFromRelease",
            "config" : {
               "Dist::Zilla::Plugin::CopyFilesFromRelease" : {
                  "filename" : [
                     "CONTRIBUTING",
                     "INSTALL",
                     "LICENCE",
                     "LICENSE",
                     "ppport.h"
                  ],
                  "match" : []
               }
            },
            "name" : "@Author::ETHER/copy generated files",
            "version" : "0.007"
         },
         {
            "class" : "Dist::Zilla::Plugin::ReadmeAnyFromPod",
            "config" : {
               "Dist::Zilla::Role::FileWatcher" : {
                  "version" : "0.006"
               }
            },
            "name" : "@Author::ETHER/ReadmeAnyFromPod",
            "version" : "0.163250"
         },
         {
            "class" : "Dist::Zilla::Plugin::Prereqs",
            "config" : {
               "Dist::Zilla::Plugin::Prereqs" : {
                  "phase" : "develop",
                  "type" : "recommends"
               }
            },
            "name" : "@Author::ETHER/@Git::VersionManager/pluginbundle version",
            "version" : "6.024"
         },
         {
            "class" : "Dist::Zilla::Plugin::RewriteVersion::Transitional",
            "config" : {
               "Dist::Zilla::Plugin::RewriteVersion" : {
                  "add_tarball_name" : 0,
                  "finders" : [
                     ":ExecFiles",
                     ":InstallModules"
                  ],
                  "global" : 1,
                  "skip_version_provider" : 0
               },
               "Dist::Zilla::Plugin::RewriteVersion::Transitional" : {}
            },
            "name" : "@Author::ETHER/@Git::VersionManager/RewriteVersion::Transitional",
            "version" : "0.009"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaProvides::Update",
            "name" : "@Author::ETHER/@Git::VersionManager/MetaProvides::Update",
            "version" : "0.007"
         },
         {
            "class" : "Dist::Zilla::Plugin::CopyFilesFromRelease",
            "config" : {
               "Dist::Zilla::Plugin::CopyFilesFromRelease" : {
                  "filename" : [
                     "Changes"
                  ],
                  "match" : []
               }
            },
            "name" : "@Author::ETHER/@Git::VersionManager/CopyFilesFromRelease",
            "version" : "0.007"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Commit",
            "config" : {
               "Dist::Zilla::Plugin::Git::Commit" : {
                  "add_files_in" : [
                     "."
                  ],
                  "commit_msg" : "%N-%v%t%n%n%c",
                  "signoff" : 0
               },
               "Dist::Zilla::Role::Git::DirtyFiles" : {
                  "allow_dirty" : [
                     "CONTRIBUTING",
                     "Changes",
                     "INSTALL",
                     "LICENCE",
                     "README.pod"
                  ],
                  "allow_dirty_match" : [],
                  "changelog" : "Changes"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.31.1",
                  "repo_root" : "."
               },
               "Dist::Zilla::Role::Git::StringFormatter" : {
                  "time_zone" : "local"
               }
            },
            "name" : "@Author::ETHER/@Git::VersionManager/release snapshot",
            "version" : "2.048"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Tag",
            "config" : {
               "Dist::Zilla::Plugin::Git::Tag" : {
                  "branch" : null,
                  "changelog" : "Changes",
                  "signed" : 0,
                  "tag" : "v0.31",
                  "tag_format" : "v%V",
                  "tag_message" : "v%v%t"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.31.1",
                  "repo_root" : "."
               },
               "Dist::Zilla::Role::Git::StringFormatter" : {
                  "time_zone" : "local"
               }
            },
            "name" : "@Author::ETHER/@Git::VersionManager/Git::Tag",
            "version" : "2.048"
         },
         {
            "class" : "Dist::Zilla::Plugin::BumpVersionAfterRelease::Transitional",
            "config" : {
               "Dist::Zilla::Plugin::BumpVersionAfterRelease" : {
                  "finders" : [
                     ":InstallModules"
                  ],
                  "global" : 1,
                  "munge_makefile_pl" : 1
               },
               "Dist::Zilla::Plugin::BumpVersionAfterRelease::Transitional" : {}
            },
            "name" : "@Author::ETHER/@Git::VersionManager/BumpVersionAfterRelease::Transitional",
            "version" : "0.009"
         },
         {
            "class" : "Dist::Zilla::Plugin::NextRelease",
            "name" : "@Author::ETHER/@Git::VersionManager/NextRelease",
            "version" : "6.024"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Commit",
            "config" : {
               "Dist::Zilla::Plugin::Git::Commit" : {
                  "add_files_in" : [],
                  "commit_msg" : "increment $VERSION after %v release",
                  "signoff" : 0
               },
               "Dist::Zilla::Role::Git::DirtyFiles" : {
                  "allow_dirty" : [
                     "Build.PL",
                     "Changes",
                     "Makefile.PL"
                  ],
                  "allow_dirty_match" : [
                     "(?^:^lib/.*\\.pm$)"
                  ],
                  "changelog" : "Changes"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.31.1",
                  "repo_root" : "."
               },
               "Dist::Zilla::Role::Git::StringFormatter" : {
                  "time_zone" : "local"
               }
            },
            "name" : "@Author::ETHER/@Git::VersionManager/post-release commit",
            "version" : "2.048"
         },
         {
            "class" : "Dist::Zilla::Plugin::Prereqs",
            "config" : {
               "Dist::Zilla::Plugin::Prereqs" : {
                  "phase" : "x_Dist_Zilla",
                  "type" : "requires"
               }
            },
            "name" : "@Author::ETHER/@Git::VersionManager/prereqs for @Git::VersionManager",
            "version" : "6.024"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Push",
            "config" : {
               "Dist::Zilla::Plugin::Git::Push" : {
                  "push_to" : [
                     "origin"
                  ],
                  "remotes_must_exist" : 1
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.31.1",
                  "repo_root" : "."
               }
            },
            "name" : "@Author::ETHER/Git::Push",
            "version" : "2.048"
         },
         {
            "class" : "Dist::Zilla::Plugin::GitHub::Update",
            "config" : {
               "Dist::Zilla::Plugin::GitHub::Update" : {
                  "metacpan" : 1
               }
            },
            "name" : "@Author::ETHER/GitHub::Update",
            "version" : "0.48"
         },
         {
            "class" : "Dist::Zilla::Plugin::Run::AfterRelease",
            "config" : {
               "Dist::Zilla::Plugin::Run::Role::Runner" : {
                  "fatal_errors" : 0,
                  "quiet" : 0,
                  "run" : [
                     "REDACTED"
                  ],
                  "version" : "0.048"
               }
            },
            "name" : "@Author::ETHER/install release",
            "version" : "0.048"
         },
         {
            "class" : "Dist::Zilla::Plugin::Run::AfterRelease",
            "config" : {
               "Dist::Zilla::Plugin::Run::Role::Runner" : {
                  "eval" : [
                     "print \"release complete!\\xa\""
                  ],
                  "fatal_errors" : 1,
                  "quiet" : 1,
                  "version" : "0.048"
               }
            },
            "name" : "@Author::ETHER/release complete",
            "version" : "0.048"
         },
         {
            "class" : "Dist::Zilla::Plugin::ConfirmRelease",
            "name" : "@Author::ETHER/ConfirmRelease",
            "version" : "6.024"
         },
         {
            "class" : "Dist::Zilla::Plugin::Prereqs",
            "config" : {
               "Dist::Zilla::Plugin::Prereqs" : {
                  "phase" : "x_Dist_Zilla",
                  "type" : "requires"
               }
            },
            "name" : "@Author::ETHER/prereqs for @Author::ETHER",
            "version" : "6.024"
         },
         {
            "class" : "Dist::Zilla::Plugin::Substitute",
            "name" : "Substitute",
            "version" : "0.006"
         },
         {
            "class" : "Dist::Zilla::Plugin::Prereqs::Soften",
            "config" : {
               "Dist::Zilla::Plugin::Prereqs::Soften" : {
                  "copy_to" : [
                     "develop.requires"
                  ],
                  "modules" : [
                     "Capture::Tiny",
                     "Sub::Name",
                     "Sub::Util"
                  ],
                  "modules_from_features" : null,
                  "to_relationship" : "suggests"
               }
            },
            "name" : "Prereqs::Soften",
            "version" : "0.006003"
         },
         {
            "class" : "Dist::Zilla::Plugin::OnlyCorePrereqs",
            "config" : {
               "Dist::Zilla::Plugin::OnlyCorePrereqs" : {
                  "also_disallow" : [],
                  "check_dual_life_versions" : "0",
                  "deprecated_ok" : 0,
                  "phases" : [
                     "configure",
                     "build",
                     "runtime",
                     "test"
                  ],
                  "skips" : [],
                  "starting_version" : "to be determined from perl prereq"
               }
            },
            "name" : "OnlyCorePrereqs",
            "version" : "0.024"
         },
         {
            "class" : "Dist::Zilla::Plugin::Breaks",
            "name" : "Breaks",
            "version" : "0.004"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::CheckBreaks",
            "config" : {
               "Dist::Zilla::Plugin::Test::CheckBreaks" : {
                  "conflicts_module" : [],
                  "no_forced_deps" : 1
               },
               "Dist::Zilla::Role::ModuleMetadata" : {
                  "Module::Metadata" : "1.000037",
                  "version" : "0.006"
               }
            },
            "name" : "Test::CheckBreaks",
            "version" : "0.019"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":InstallModules",
            "version" : "6.024"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":IncModules",
            "version" : "6.024"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":TestFiles",
            "version" : "6.024"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":ExtraTestFiles",
            "version" : "6.024"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":ExecFiles",
            "version" : "6.024"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":PerlExecFiles",
            "version" : "6.024"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":ShareFiles",
            "version" : "6.024"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":MainModule",
            "version" : "6.024"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":AllFiles",
            "version" : "6.024"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":NoFiles",
            "version" : "6.024"
         },
         {
            "class" : "Dist::Zilla::Plugin::VerifyPhases",
            "name" : "@Author::ETHER/PHASE VERIFICATION",
            "version" : "0.016"
         }
      ],
      "zilla" : {
         "class" : "Dist::Zilla::Dist::Builder",
         "config" : {
            "is_trial" : 0
         },
         "version" : "6.024"
      }
   },
   "x_authority" : "cpan:NUFFIN",
   "x_breaks" : {
      "Try::Tiny::Except" : "<= 0.01"
   },
   "x_contributors" : [
      "Karen Etheridge <ether@cpan.org>",
      "Peter Rabbitson <ribasushi@cpan.org>",
      "Ricardo Signes <rjbs@cpan.org>",
      "Mark Fowler <mark@twoshortplanks.com>",
      "Graham Knop <haarg@haarg.org>",
      "Aristotle Pagaltzis <pagaltzis@gmx.de>",
      "Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>",
      "Lukas Mai <l.mai@web.de>",
      "Alex <alex@koban.(none)>",
      "anaxagoras <walkeraj@gmail.com>",
      "Andrew Yates <ayates@haddock.local>",
      "awalker <awalker@sourcefire.com>",
      "chromatic <chromatic@wgz.org>",
      "cm-perl <cm-perl@users.noreply.github.com>",
      "David Lowe <davidl@lokku.com>",
      "Glenn Fowler <cebjyre@cpan.org>",
      "Hans Dieter Pearcey <hdp@weftsoar.net>",
      "Jens Berthold <jens@jebecs.de>",
      "Jonathan Yu <JAWNSY@cpan.org>",
      "Marc Mims <marc@questright.com>",
      "Mark Stosberg <mark@stosberg.com>",
      "Pali <pali@cpan.org>",
      "Paul Howarth <paul@city-fan.org>",
      "Rudolf Leermakers <rudolf@hatsuseno.org>"
   ],
   "x_generated_by_perl" : "v5.35.6",
   "x_serialization_backend" : "Cpanel::JSON::XS version 4.27",
   "x_spdx_expression" : "MIT",
   "x_use_unsafe_inc" : 0
}
PK       ! �JjG�   �   D  perl5/x86_64-linux-thread-multi/.meta/FFI-CheckLib-0.27/install.jsonnu ��6�$        {"provides":{"FFI::CheckLib":{"version":0.27,"file":"lib/FFI/CheckLib.pm"}},"target":"FFI::CheckLib","version":0.27,"name":"FFI::CheckLib","dist":"FFI-CheckLib-0.27","pathname":"P/PL/PLICEASE/FFI-CheckLib-0.27.tar.gz"}PK       ! ����	  �	  C  perl5/x86_64-linux-thread-multi/.meta/FFI-CheckLib-0.27/MYMETA.jsonnu ��6�$        {
   "abstract" : "Check that a library is available for FFI",
   "author" : [
      "Graham Ollis <plicease@cpan.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "Dist::Zilla version 6.014, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "FFI-CheckLib",
   "no_index" : {
      "directory" : [
         "corpus"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "develop" : {
         "requires" : {
            "FindBin" : "0",
            "Test::CPAN::Changes" : "0",
            "Test::EOL" : "0",
            "Test::Fixme" : "0.07",
            "Test::More" : "0.98",
            "Test::NoTabs" : "0",
            "Test::Pod" : "0",
            "Test::Pod::Coverage" : "0",
            "Test::Pod::Spelling::CommonMistakes" : "0",
            "Test::Spelling" : "0",
            "Test::Strict" : "0",
            "YAML" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "perl" : "5.006"
         }
      },
      "test" : {
         "requires" : {
            "Test2::API" : "1.302015",
            "Test2::Require::EnvVar" : "0.000060",
            "Test2::Require::Module" : "0.000060",
            "Test2::V0" : "0.000060"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "web" : "https://github.com/Perl5-FFI/FFI-CheckLib/issues"
      },
      "homepage" : "https://metacpan.org/pod/FFI::CheckLib",
      "repository" : {
         "type" : "git",
         "url" : "git://github.com/Perl5-FFI/FFI-CheckLib.git",
         "web" : "https://github.com/Perl5-FFI/FFI-CheckLib"
      },
      "x_IRC" : "irc://irc.perl.org/#native"
   },
   "version" : "0.27",
   "x_contributors" : [
      "Graham Ollis <plicease@cpan.org>",
      "Bakkiaraj Murugesan (bakkiaraj)",
      "Dan Book (grinnz, DBOOK)",
      "Ilya Pavlov (Ilya, ILUX)",
      "Shawn Laffan (SLAFFAN)",
      "Petr Pisar (ppisar)"
   ],
   "x_generated_by_perl" : "v5.30.0",
   "x_serialization_backend" : "JSON::XS version 4.02",
   "x_spdx_expression" : "Artistic-1.0-Perl OR GPL-1.0-or-later",
   "x_use_unsafe_inc" : 0
}
PK       ! ����    E  perl5/x86_64-linux-thread-multi/.meta/local-lib-2.000029/install.jsonnu ��6�$        {"dist":"local-lib-2.000029","target":"local::lib","name":"local::lib","provides":{"lib::core::only":{"file":"lib/lib/core/only.pm"},"local::lib":{"file":"lib/local/lib.pm","version":2.000029}},"pathname":"H/HA/HAARG/local-lib-2.000029.tar.gz","version":2.000029}PK       ! ��B    D  perl5/x86_64-linux-thread-multi/.meta/local-lib-2.000029/MYMETA.jsonnu ��6�$        {
   "abstract" : "create and use a local lib/ for perl modules with PERL5LIB",
   "author" : [
      "mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.64, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "local-lib",
   "no_index" : {
      "directory" : [
         "t",
         "inc"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {}
      },
      "configure" : {
         "requires" : {}
      },
      "develop" : {
         "requires" : {
            "Capture::Tiny" : "0",
            "Module::Build" : "0.36",
            "Test::CPAN::Changes" : "0",
            "Test::EOL" : "0",
            "Test::More" : "0.8101",
            "Test::NoTabs" : "0",
            "Test::Pod" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "perl" : "5.006"
         }
      },
      "test" : {
         "requires" : {
            "Test::More" : "0"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "mailto" : "bug-local-lib@rt.cpan.org",
         "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=local-lib"
      },
      "license" : [
         "http://dev.perl.org/licenses/"
      ],
      "repository" : {
         "type" : "git",
         "url" : "git://github.com/Perl-Toolchain-Gang/local-lib",
         "web" : "https://github.com/Perl-Toolchain-Gang/local-lib"
      },
      "x_IRC" : "irc://irc.perl.org/#local-lib"
   },
   "version" : "2.000029",
   "x_serialization_backend" : "JSON::PP version 4.07"
}
PK       ! h���    >  perl5/x86_64-linux-thread-multi/.meta/IO-Tty-1.14/install.jsonnu ��6�$        {"provides":{"IO::Tty::Constant":{"version":1.14,"file":"Tty/Constant.pm"},"IO::Pty":{"version":1.14,"file":"Pty.pm"},"IO::Tty":{"version":1.14,"file":"Tty.pm"}},"target":"IO::Tty","version":1.14,"name":"IO::Tty","dist":"IO-Tty-1.14","pathname":"T/TO/TODDR/IO-Tty-1.14.tar.gz"}PK       ! ��+�  �  =  perl5/x86_64-linux-thread-multi/.meta/IO-Tty-1.14/MYMETA.jsonnu ��6�$        {
   "abstract" : "Pseudo ttys and constants",
   "author" : [
      "Roland Giersig <RGiersig@cpan.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "IO-Tty",
   "no_index" : {
      "directory" : [
         "t",
         "inc"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "Test::More" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "repository" : {
         "url" : "https://github.com/toddr/IO-Tty"
      }
   },
   "version" : "1.14",
   "x_serialization_backend" : "JSON::PP version 4.02"
}
PK       ! �ͫ�   �   >  perl5/x86_64-linux-thread-multi/.meta/Net-IP-1.26/install.jsonnu ��6�$        {"provides":{"Net::IP":{"version":1.26,"file":"IP.pm"}},"target":"Net::IP","version":1.26,"name":"Net::IP","dist":"Net-IP-1.26","pathname":"M/MA/MANU/Net-IP-1.26.tar.gz"}PK       ! J8a  a  =  perl5/x86_64-linux-thread-multi/.meta/Net-IP-1.26/MYMETA.jsonnu ��6�$        {
   "abstract" : "Perl extension for manipulating IPv4/IPv6 addresses",
   "author" : [
      "Manuel Valente <manuel.valente@gmail.com>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 6.57_05, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "unknown"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "Net-IP",
   "no_index" : {
      "directory" : [
         "t",
         "inc"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "runtime" : {
         "requires" : {}
      }
   },
   "release_status" : "stable",
   "version" : "1.26"
}
PK       ! ���|  |  A  perl5/x86_64-linux-thread-multi/.meta/version-0.9928/install.jsonnu ��6�$        {"provides":{"version::regex":{"version":0.9928,"file":"lib/version/regex.pm"},"version::vxs":{"version":0.9928,"file":"vutil/lib/version/vxs.pm"},"version":{"version":0.9928,"file":"lib/version.pm"},"version::vpp":{"version":0.9928,"file":"vperl/vpp.pm"}},"target":"version","version":0.9928,"name":"version","dist":"version-0.9928","pathname":"L/LE/LEONT/version-0.9928.tar.gz"}PK       ! ˏ��  �  @  perl5/x86_64-linux-thread-multi/.meta/version-0.9928/MYMETA.jsonnu ��6�$        {
   "abstract" : "Structured version objects",
   "author" : [
      "John Peacock <jpeacock@cpan.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.44, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "version",
   "no_index" : {
      "directory" : [
         "t",
         "inc"
      ],
      "package" : [
         "charstar"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "perl" : "5.006002"
         }
      },
      "test" : {
         "requires" : {
            "File::Temp" : "0.13",
            "Test::More" : "0.45",
            "base" : "0"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "mailto" : "bug-version@rt.cpan.org",
         "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=version"
      },
      "repository" : {
         "type" : "git",
         "url" : "git://github.com/Perl/version.pm.git",
         "web" : "https://github.com/Perl/version.pm"
      }
   },
   "version" : "0.9928",
   "x_serialization_backend" : "JSON::PP version 4.04"
}
PK       ! ���s  s  A  perl5/x86_64-linux-thread-multi/.meta/YAML-Syck-1.46/install.jsonnu ��6�$        {"target":"YAML::Syck","provides":{"YAML::Dumper::Syck":{"file":"lib/YAML/Dumper/Syck.pm"},"YAML::Syck":{"version":"1.46","file":"lib/YAML/Syck.pm"},"JSON::Syck":{"file":"lib/JSON/Syck.pm","version":"1.46"},"YAML::Loader::Syck":{"file":"lib/YAML/Loader/Syck.pm"}},"version":"1.46","name":"YAML::Syck","dist":"YAML-Syck-1.46","pathname":"T/TO/TODDR/YAML-Syck-1.46.tar.gz"}PK       ! �p�  �  @  perl5/x86_64-linux-thread-multi/.meta/YAML-Syck-1.46/MYMETA.jsonnu ��6�$        {
   "abstract" : "Fast, lightweight YAML loader and dumper",
   "author" : [
      "Todd Rinaldo <toddr@cpan.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.76, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "mit"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "YAML-Syck",
   "no_index" : {
      "directory" : [
         "t",
         "inc"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "Test::More" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "perl" : "5.006"
         }
      }
   },
   "provides" : {
      "JSON::Syck" : {
         "file" : "lib/JSON/Syck.pm",
         "version" : "1.46"
      },
      "YAML::Dumper::Syck" : {
         "file" : "lib/YAML/Dumper/Syck.pm"
      },
      "YAML::Loader::Syck" : {
         "file" : "lib/YAML/Loader/Syck.pm"
      },
      "YAML::Syck" : {
         "file" : "lib/YAML/Syck.pm",
         "version" : "1.46"
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "web" : "https://github.com/toddr/YAML-Syck/issues"
      },
      "homepage" : "https://github.com/toddr/YAML-Syck",
      "license" : [
         "https://dev.perl.org/licenses/"
      ],
      "repository" : {
         "type" : "git",
         "url" : "https://github.com/toddr/YAML-Syck.git",
         "web" : "https://github.com/toddr/YAML-Syck"
      }
   },
   "version" : "1.46",
   "x_serialization_backend" : "JSON::PP version 4.16"
}
PK       ! ���b  b  J  perl5/x86_64-linux-thread-multi/.meta/ExtUtils-MakeMaker-7.50/install.jsonnu ��6�$        {"provides":{"MY":{"version":"7.50","file":"lib/ExtUtils/MakeMaker.pm"},"ExtUtils::MM_MacOS":{"version":"7.50","file":"lib/ExtUtils/MM_MacOS.pm"},"ExtUtils::Command":{"version":"7.50","file":"lib/ExtUtils/Command.pm"},"ExtUtils::MM":{"version":"7.50","file":"lib/ExtUtils/MM.pm"},"MM":{"version":"7.50","file":"lib/ExtUtils/MM.pm"},"ExtUtils::MM_UWIN":{"version":"7.50","file":"lib/ExtUtils/MM_UWIN.pm"},"ExtUtils::MM_NW5":{"version":"7.50","file":"lib/ExtUtils/MM_NW5.pm"},"ExtUtils::Mksymlists":{"version":"7.50","file":"lib/ExtUtils/Mksymlists.pm"},"ExtUtils::MM_QNX":{"version":"7.50","file":"lib/ExtUtils/MM_QNX.pm"},"ExtUtils::MakeMaker::Config":{"version":"7.50","file":"lib/ExtUtils/MakeMaker/Config.pm"},"ExtUtils::MakeMaker::version::regex":{"version":"7.50","file":"lib/ExtUtils/MakeMaker/version/regex.pm"},"ExtUtils::MM_Unix":{"version":"7.50","file":"lib/ExtUtils/MM_Unix.pm"},"ExtUtils::MM_Darwin":{"version":"7.50","file":"lib/ExtUtils/MM_Darwin.pm"},"ExtUtils::MM_OS390":{"version":"7.50","file":"lib/ExtUtils/MM_OS390.pm"},"ExtUtils::MakeMaker":{"version":"7.50","file":"lib/ExtUtils/MakeMaker.pm"},"ExtUtils::MM_Win32":{"version":"7.50","file":"lib/ExtUtils/MM_Win32.pm"},"ExtUtils::MM_VOS":{"version":"7.50","file":"lib/ExtUtils/MM_VOS.pm"},"ExtUtils::testlib":{"version":"7.50","file":"lib/ExtUtils/testlib.pm"},"ExtUtils::MakeMaker::version":{"version":"7.50","file":"lib/ExtUtils/MakeMaker/version.pm"},"ExtUtils::Command::MM":{"version":"7.50","file":"lib/ExtUtils/Command/MM.pm"},"ExtUtils::MM_BeOS":{"version":"7.50","file":"lib/ExtUtils/MM_BeOS.pm"},"ExtUtils::MM_Any":{"version":"7.50","file":"lib/ExtUtils/MM_Any.pm"},"ExtUtils::MakeMaker::version::vpp":{"version":"7.50","file":"lib/ExtUtils/MakeMaker/version/vpp.pm"},"ExtUtils::MM_VMS":{"version":"7.50","file":"lib/ExtUtils/MM_VMS.pm"},"ExtUtils::MY":{"version":"7.50","file":"lib/ExtUtils/MY.pm"},"ExtUtils::MM_Cygwin":{"version":"7.50","file":"lib/ExtUtils/MM_Cygwin.pm"},"ExtUtils::MM_DOS":{"version":"7.50","file":"lib/ExtUtils/MM_DOS.pm"},"ExtUtils::MakeMaker::_version":{"version":"7.50","file":"lib/ExtUtils/MM_Unix.pm"},"ExtUtils::Liblist::Kid":{"version":"7.50","file":"lib/ExtUtils/Liblist/Kid.pm"},"ExtUtils::MM_OS2":{"version":"7.50","file":"lib/ExtUtils/MM_OS2.pm"},"ExtUtils::MakeMaker::Locale":{"version":"7.50","file":"lib/ExtUtils/MakeMaker/Locale.pm"},"ExtUtils::MM_Win95":{"version":"7.50","file":"lib/ExtUtils/MM_Win95.pm"},"ExtUtils::MakeMaker::charstar":{"version":"7.50","file":"lib/ExtUtils/MakeMaker/version/vpp.pm"},"ExtUtils::MM_AIX":{"version":"7.50","file":"lib/ExtUtils/MM_AIX.pm"},"ExtUtils::Liblist":{"version":"7.50","file":"lib/ExtUtils/Liblist.pm"},"ExtUtils::Mkbootstrap":{"version":"7.50","file":"lib/ExtUtils/Mkbootstrap.pm"}},"target":"ExtUtils::MakeMaker","version":"7.50","name":"ExtUtils::MakeMaker","dist":"ExtUtils-MakeMaker-7.50","pathname":"B/BI/BINGOS/ExtUtils-MakeMaker-7.50.tar.gz"}PK       ! ���    I  perl5/x86_64-linux-thread-multi/.meta/ExtUtils-MakeMaker-7.50/MYMETA.jsonnu ��6�$        {
   "abstract" : "Create a module Makefile",
   "author" : [
      "Michael G Schwern <schwern@pobox.com>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.50, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "ExtUtils-MakeMaker",
   "no_index" : {
      "directory" : [
         "t",
         "inc",
         "bundled",
         "my"
      ],
      "package" : [
         "DynaLoader",
         "in",
         "version"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {}
      },
      "configure" : {
         "requires" : {}
      },
      "runtime" : {
         "requires" : {
            "Data::Dumper" : "0",
            "Encode" : "0",
            "File::Basename" : "0",
            "File::Spec" : "0.8",
            "Pod::Man" : "0",
            "perl" : "5.006"
         }
      },
      "test" : {
         "requires" : {}
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "web" : "http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker"
      },
      "homepage" : "https://metacpan.org/release/ExtUtils-MakeMaker",
      "license" : [
         "http://dev.perl.org/licenses/"
      ],
      "repository" : {
         "url" : "http://github.com/Perl-Toolchain-Gang/ExtUtils-MakeMaker"
      },
      "x_MailingList" : "makemaker@perl.org"
   },
   "version" : "7.50"
}
PK       ! Q��  �  C  perl5/x86_64-linux-thread-multi/.meta/IO-Stringy-2.113/install.jsonnu ��6�$        {"provides":{"IO::WrapTie":{"version":"2.113","file":"lib/IO/WrapTie.pm"},"IO::Stringy":{"version":"2.113","file":"lib/IO/Stringy.pm"},"IO::Scalar":{"version":"2.113","file":"lib/IO/Scalar.pm"},"IO::ScalarArray":{"version":"2.113","file":"lib/IO/ScalarArray.pm"},"IO::InnerFile":{"version":"2.113","file":"lib/IO/InnerFile.pm"},"IO::Wrap":{"version":"2.113","file":"lib/IO/Wrap.pm"},"IO::Lines":{"version":"2.113","file":"lib/IO/Lines.pm"},"IO::AtomicFile":{"version":"2.113","file":"lib/IO/AtomicFile.pm"}},"target":"IO::Scalar","version":"2.113","name":"IO::Stringy","dist":"IO-Stringy-2.113","pathname":"C/CA/CAPOEIRAB/IO-Stringy-2.113.tar.gz"}PK       ! %�,��L  �L  B  perl5/x86_64-linux-thread-multi/.meta/IO-Stringy-2.113/MYMETA.jsonnu ��6�$        {
   "abstract" : "I/O on in-core objects like strings and arrays",
   "author" : [
      "Erik Dorfman <eryq@cpan.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "Dist::Zilla version 6.012, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "IO-Stringy",
   "no_index" : {
      "directory" : [
         "eg",
         "examples",
         "inc",
         "share",
         "t",
         "xt"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "develop" : {
         "requires" : {
            "Dist::Zilla" : "0",
            "File::Spec" : "0",
            "IO::Handle" : "0",
            "IPC::Open3" : "0",
            "Pod::Coverage::TrustPod" : "0",
            "Test::CPAN::Changes" : "0.4",
            "Test::CheckManifest" : "1.29",
            "Test::Kwalitee" : "1.22",
            "Test::More" : "0.88",
            "Test::Pod" : "1.41",
            "Test::Pod::Coverage" : "1.08",
            "Test::Pod::Spelling::CommonMistakes" : "1.000",
            "Test::Spelling" : "0.12",
            "Test::TrailingSpace" : "0",
            "Test::Version" : "1"
         }
      },
      "runtime" : {
         "requires" : {
            "Carp" : "0",
            "Exporter" : "5.57",
            "File::Spec" : "0",
            "FileHandle" : "0",
            "IO::File" : "0",
            "IO::Handle" : "0",
            "Symbol" : "0",
            "overload" : "0",
            "parent" : "0",
            "strict" : "0",
            "warnings" : "0"
         }
      },
      "test" : {
         "recommends" : {
            "CPAN::Meta" : "2.120900"
         },
         "requires" : {
            "ExtUtils::MakeMaker" : "0",
            "File::Basename" : "0",
            "File::Spec" : "0",
            "File::Temp" : "0",
            "FileHandle" : "0",
            "IO::File" : "0",
            "IO::Handle" : "0",
            "Symbol" : "0",
            "Test::More" : "0.88",
            "Test::Tester" : "0",
            "strict" : "0",
            "warnings" : "0"
         }
      }
   },
   "provides" : {
      "IO::AtomicFile" : {
         "file" : "lib/IO/AtomicFile.pm",
         "version" : "2.113"
      },
      "IO::InnerFile" : {
         "file" : "lib/IO/InnerFile.pm",
         "version" : "2.113"
      },
      "IO::Lines" : {
         "file" : "lib/IO/Lines.pm",
         "version" : "2.113"
      },
      "IO::Scalar" : {
         "file" : "lib/IO/Scalar.pm",
         "version" : "2.113"
      },
      "IO::ScalarArray" : {
         "file" : "lib/IO/ScalarArray.pm",
         "version" : "2.113"
      },
      "IO::Stringy" : {
         "file" : "lib/IO/Stringy.pm",
         "version" : "2.113"
      },
      "IO::Wrap" : {
         "file" : "lib/IO/Wrap.pm",
         "version" : "2.113"
      },
      "IO::WrapTie" : {
         "file" : "lib/IO/WrapTie.pm",
         "version" : "2.113"
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "web" : "https://github.com/genio/IO-Stringy/issues"
      },
      "homepage" : "https://github.com/genio/IO-Stringy",
      "repository" : {
         "type" : "git",
         "url" : "https://github.com/genio/IO-Stringy.git",
         "web" : "https://github.com/genio/IO-Stringy"
      }
   },
   "version" : "2.113",
   "x_Dist_Zilla" : {
      "perl" : {
         "version" : "5.030000"
      },
      "plugins" : [
         {
            "class" : "Dist::Zilla::Plugin::Git::GatherDir",
            "config" : {
               "Dist::Zilla::Plugin::GatherDir" : {
                  "exclude_filename" : [
                     "LICENSE",
                     "META.json",
                     "Makefile.PL",
                     "README.md",
                     "t/00-report-prereqs.t"
                  ],
                  "exclude_match" : [],
                  "follow_symlinks" : 0,
                  "include_dotfiles" : 0,
                  "prefix" : "",
                  "prune_directory" : [],
                  "root" : "."
               },
               "Dist::Zilla::Plugin::Git::GatherDir" : {
                  "include_untracked" : 0
               }
            },
            "name" : "Git::GatherDir",
            "version" : "2.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaYAML",
            "name" : "@Starter/MetaYAML",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaJSON",
            "name" : "@Starter/MetaJSON",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::License",
            "name" : "@Starter/License",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::Pod2Readme",
            "name" : "@Starter/Pod2Readme",
            "version" : "0.004"
         },
         {
            "class" : "Dist::Zilla::Plugin::PodSyntaxTests",
            "name" : "@Starter/PodSyntaxTests",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::ReportPrereqs",
            "name" : "@Starter/Test::ReportPrereqs",
            "version" : "0.027"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::Compile",
            "config" : {
               "Dist::Zilla::Plugin::Test::Compile" : {
                  "bail_out_on_fail" : 0,
                  "fail_on_warning" : "author",
                  "fake_home" : 0,
                  "filename" : "xt/author/00-compile.t",
                  "module_finder" : [
                     ":InstallModules"
                  ],
                  "needs_display" : 0,
                  "phase" : "develop",
                  "script_finder" : [
                     ":PerlExecFiles"
                  ],
                  "skips" : [],
                  "switch" : []
               }
            },
            "name" : "@Starter/Test::Compile",
            "version" : "2.058"
         },
         {
            "class" : "Dist::Zilla::Plugin::MakeMaker::Awesome",
            "config" : {
               "Dist::Zilla::Plugin::MakeMaker" : {
                  "make_path" : "gmake",
                  "version" : "6.012"
               },
               "Dist::Zilla::Role::TestRunner" : {
                  "default_jobs" : 1,
                  "version" : "6.012"
               }
            },
            "name" : "@Starter/MakeMaker::Awesome",
            "version" : "0.48"
         },
         {
            "class" : "Dist::Zilla::Plugin::Manifest",
            "name" : "@Starter/Manifest",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::PruneCruft",
            "name" : "@Starter/PruneCruft",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::ManifestSkip",
            "name" : "@Starter/ManifestSkip",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::RunExtraTests",
            "config" : {
               "Dist::Zilla::Role::TestRunner" : {
                  "default_jobs" : 1
               }
            },
            "name" : "@Starter/RunExtraTests",
            "version" : "0.029"
         },
         {
            "class" : "Dist::Zilla::Plugin::RewriteVersion",
            "config" : {
               "Dist::Zilla::Plugin::RewriteVersion" : {
                  "add_tarball_name" : 0,
                  "finders" : [
                     ":ExecFiles",
                     ":InstallModules"
                  ],
                  "global" : 1,
                  "skip_version_provider" : 0
               }
            },
            "name" : "@Starter/RewriteVersion",
            "version" : "0.018"
         },
         {
            "class" : "Dist::Zilla::Plugin::NextRelease",
            "name" : "@Starter/NextRelease",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::BumpVersionAfterRelease",
            "config" : {
               "Dist::Zilla::Plugin::BumpVersionAfterRelease" : {
                  "finders" : [
                     ":ExecFiles",
                     ":InstallModules"
                  ],
                  "global" : 0,
                  "munge_makefile_pl" : 1
               }
            },
            "name" : "@Starter/BumpVersionAfterRelease",
            "version" : "0.018"
         },
         {
            "class" : "Dist::Zilla::Plugin::TestRelease",
            "name" : "@Starter/TestRelease",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::ConfirmRelease",
            "name" : "@Starter/ConfirmRelease",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::UploadToCPAN",
            "name" : "@Starter/UploadToCPAN",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaConfig",
            "name" : "@Starter/MetaConfig",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaNoIndex",
            "name" : "@Starter/MetaNoIndex",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaProvides::Package",
            "config" : {
               "Dist::Zilla::Plugin::MetaProvides::Package" : {
                  "finder_objects" : [
                     {
                        "class" : "Dist::Zilla::Plugin::FinderCode",
                        "name" : "@Starter/MetaProvides::Package/AUTOVIV/:InstallModulesPM",
                        "version" : "6.012"
                     }
                  ],
                  "include_underscores" : 0
               },
               "Dist::Zilla::Role::MetaProvider::Provider" : {
                  "$Dist::Zilla::Role::MetaProvider::Provider::VERSION" : "2.002004",
                  "inherit_missing" : 1,
                  "inherit_version" : 1,
                  "meta_noindex" : 1
               },
               "Dist::Zilla::Role::ModuleMetadata" : {
                  "Module::Metadata" : "1.000036",
                  "version" : "0.006"
               }
            },
            "name" : "@Starter/MetaProvides::Package",
            "version" : "2.004003"
         },
         {
            "class" : "Dist::Zilla::Plugin::ShareDir",
            "name" : "@Starter/ShareDir",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::ExecDir",
            "name" : "@Starter/ExecDir",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::ReadmeAnyFromPod",
            "config" : {
               "Dist::Zilla::Role::FileWatcher" : {
                  "version" : "0.006"
               }
            },
            "name" : "Markdown_Readme",
            "version" : "0.163250"
         },
         {
            "class" : "Dist::Zilla::Plugin::Prereqs::FromCPANfile",
            "name" : "Prereqs::FromCPANfile",
            "version" : "0.08"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Contributors",
            "config" : {
               "Dist::Zilla::Plugin::Git::Contributors" : {
                  "git_version" : "2.16.1.windows.1",
                  "include_authors" : 0,
                  "include_releaser" : 1,
                  "order_by" : "name",
                  "paths" : []
               }
            },
            "name" : "Git::Contributors",
            "version" : "0.035"
         },
         {
            "class" : "Dist::Zilla::Plugin::GithubMeta",
            "name" : "GithubMeta",
            "version" : "0.58"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Check",
            "config" : {
               "Dist::Zilla::Plugin::Git::Check" : {
                  "untracked_files" : "die"
               },
               "Dist::Zilla::Role::Git::DirtyFiles" : {
                  "allow_dirty" : [
                     "Changes",
                     "dist.ini"
                  ],
                  "allow_dirty_match" : [],
                  "changelog" : "Changes"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.16.1.windows.1",
                  "repo_root" : "."
               }
            },
            "name" : "@Git/Check",
            "version" : "2.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Commit",
            "config" : {
               "Dist::Zilla::Plugin::Git::Commit" : {
                  "add_files_in" : [],
                  "commit_msg" : "v%V%n%n%c"
               },
               "Dist::Zilla::Role::Git::DirtyFiles" : {
                  "allow_dirty" : [
                     "Changes",
                     "dist.ini"
                  ],
                  "allow_dirty_match" : [],
                  "changelog" : "Changes"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.16.1.windows.1",
                  "repo_root" : "."
               },
               "Dist::Zilla::Role::Git::StringFormatter" : {
                  "time_zone" : "local"
               }
            },
            "name" : "@Git/Commit",
            "version" : "2.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Tag",
            "config" : {
               "Dist::Zilla::Plugin::Git::Tag" : {
                  "branch" : null,
                  "changelog" : "Changes",
                  "signed" : 0,
                  "tag" : "v2.113",
                  "tag_format" : "v%V",
                  "tag_message" : "v%V"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.16.1.windows.1",
                  "repo_root" : "."
               },
               "Dist::Zilla::Role::Git::StringFormatter" : {
                  "time_zone" : "local"
               }
            },
            "name" : "@Git/Tag",
            "version" : "2.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Push",
            "config" : {
               "Dist::Zilla::Plugin::Git::Push" : {
                  "push_to" : [
                     "origin"
                  ],
                  "remotes_must_exist" : 1
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.16.1.windows.1",
                  "repo_root" : "."
               }
            },
            "name" : "@Git/Push",
            "version" : "2.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::CheckChangeLog",
            "name" : "CheckChangeLog",
            "version" : "0.05"
         },
         {
            "class" : "Dist::Zilla::Plugin::CheckChangesHasContent",
            "name" : "CheckChangesHasContent",
            "version" : "0.011"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::ChangesHasContent",
            "name" : "Test::ChangesHasContent",
            "version" : "0.011"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::Kwalitee",
            "config" : {
               "Dist::Zilla::Plugin::Test::Kwalitee" : {
                  "filename" : "xt/release/kwalitee.t",
                  "skiptest" : [
                     "no_symlinks"
                  ]
               }
            },
            "name" : "Test::Kwalitee",
            "version" : "2.12"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::Version",
            "name" : "Test::Version",
            "version" : "1.09"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::Pod::Coverage::Configurable",
            "name" : "Test::Pod::Coverage::Configurable",
            "version" : "0.07"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::PodSpelling",
            "config" : {
               "Dist::Zilla::Plugin::Test::PodSpelling" : {
                  "directories" : [
                     "bin",
                     "lib"
                  ],
                  "spell_cmd" : "",
                  "stopwords" : [
                     "BUF",
                     "Doru",
                     "FOO",
                     "Foo",
                     "NBYTES",
                     "POS",
                     "SCALARREF",
                     "SLAVECLASS",
                     "ZeeGee",
                     "aref",
                     "dfs",
                     "getline",
                     "getlines",
                     "getpos",
                     "ing",
                     "reblessed",
                     "setpos",
                     "sref",
                     "tieable",
                     "wraphandle"
                  ],
                  "wordlist" : "Pod::Wordlist"
               }
            },
            "name" : "Test::PodSpelling",
            "version" : "2.007005"
         },
         {
            "class" : "Dist::Zilla::Plugin::CopyFilesFromBuild",
            "name" : "CopyFilesFromBuild",
            "version" : "0.170880"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":InstallModules",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":IncModules",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":TestFiles",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":ExtraTestFiles",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":ExecFiles",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":PerlExecFiles",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":ShareFiles",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":MainModule",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":AllFiles",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":NoFiles",
            "version" : "6.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : "@Starter/MetaProvides::Package/AUTOVIV/:InstallModulesPM",
            "version" : "6.012"
         }
      ],
      "zilla" : {
         "class" : "Dist::Zilla::Dist::Builder",
         "config" : {
            "is_trial" : 0
         },
         "version" : "6.012"
      }
   },
   "x_contributors" : [
      "Chase Whitener <capoeirab@cpan.org>",
      "Dianne Skoll <dskoll@cpan.org>"
   ],
   "x_generated_by_perl" : "v5.30.0",
   "x_serialization_backend" : "Cpanel::JSON::XS version 4.11"
}
PK       ! ����   �   E  perl5/x86_64-linux-thread-multi/.meta/XML-SAX-Expat-0.51/install.jsonnu ��6�$        {"provides":{"XML::SAX::Expat":{"version":0.51,"file":"Expat.pm"}},"target":"XML::SAX::Expat","version":0.51,"name":"XML::SAX::Expat","dist":"XML-SAX-Expat-0.51","pathname":"B/BJ/BJOERN/XML-SAX-Expat-0.51.tar.gz"}PK       ! Z-�k  k  D  perl5/x86_64-linux-thread-multi/.meta/XML-SAX-Expat-0.51/MYMETA.jsonnu ��6�$        {
   "abstract" : "SAX Driver for Expat",
   "author" : [
      "Robin Berjon"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 6.6302, CPAN::Meta::Converter version 2.132830, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "XML-SAX-Expat",
   "no_index" : {
      "directory" : [
         "t",
         "inc"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "XML::NamespaceSupport" : "0.03",
            "XML::Parser" : "2.27",
            "XML::SAX" : "0.03",
            "XML::SAX::Base" : "1.00"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "repository" : {
         "url" : "https://github.com/hoehrmann/XML-SAX-Expat"
      }
   },
   "version" : "0.51"
}
PK       ! �Z���  �  C  perl5/x86_64-linux-thread-multi/.meta/Alien-Build-2.83/install.jsonnu ��6�$        {"version":2.83,"name":"Alien::Build","dist":"Alien-Build-2.83","target":"Alien::Build::MM","pathname":"P/PL/PLICEASE/Alien-Build-2.83.tar.gz","provides":{"Alien::Build::Plugin::PkgConfig::Negotiate":{"version":2.83,"file":"lib/Alien/Build/Plugin/PkgConfig/Negotiate.pm"},"Alien::Build::Plugin::Fetch::CurlCommand":{"version":2.83,"file":"lib/Alien/Build/Plugin/Fetch/CurlCommand.pm"},"Alien::Build::Plugin::Digest::SHAPP":{"version":2.83,"file":"lib/Alien/Build/Plugin/Digest/SHAPP.pm"},"Alien::Build::Plugin::Build::Autoconf":{"version":2.83,"file":"lib/Alien/Build/Plugin/Build/Autoconf.pm"},"Alien::Util":{"version":2.83,"file":"lib/Alien/Util.pm"},"Alien::Build::Plugin::Decode::Mojo":{"version":2.83,"file":"lib/Alien/Build/Plugin/Decode/Mojo.pm"},"Alien::Build::Plugin::Build::SearchDep":{"file":"lib/Alien/Build/Plugin/Build/SearchDep.pm","version":2.83},"Alien::Build::Plugin::Extract::Negotiate":{"version":2.83,"file":"lib/Alien/Build/Plugin/Extract/Negotiate.pm"},"Alien::Build::Log":{"version":2.83,"file":"lib/Alien/Build/Log.pm"},"Alien::Build::Plugin::Core::Tail":{"file":"lib/Alien/Build/Plugin/Core/Tail.pm","version":2.83},"Alien::Build::Plugin::Extract::ArchiveTar":{"version":2.83,"file":"lib/Alien/Build/Plugin/Extract/ArchiveTar.pm"},"Alien::Build::Log::Abbreviate":{"file":"lib/Alien/Build/Log/Abbreviate.pm","version":2.83},"Alien::Build::Plugin":{"file":"lib/Alien/Build/Plugin.pm","version":2.83},"Alien::Build::Plugin::Prefer::SortVersions":{"version":2.83,"file":"lib/Alien/Build/Plugin/Prefer/SortVersions.pm"},"Alien::Build::MM":{"file":"lib/Alien/Build/MM.pm","version":2.83},"Alien::Build::Plugin::Build::MSYS":{"version":2.83,"file":"lib/Alien/Build/Plugin/Build/MSYS.pm"},"Alien::Build::Plugin::PkgConfig::CommandLine":{"version":2.83,"file":"lib/Alien/Build/Plugin/PkgConfig/CommandLine.pm"},"Alien::Build::CommandSequence":{"version":2.83,"file":"lib/Alien/Build/CommandSequence.pm"},"Alien::Build::Plugin::Digest::Negotiate":{"file":"lib/Alien/Build/Plugin/Digest/Negotiate.pm","version":2.83},"Alien::Build::Util":{"version":2.83,"file":"lib/Alien/Build/Util.pm"},"Alien::Build::Plugin::Decode::HTML":{"version":2.83,"file":"lib/Alien/Build/Plugin/Decode/HTML.pm"},"Alien::Build::Meta":{"version":2.83,"file":"lib/Alien/Build.pm"},"Alien::Build::Plugin::Extract::Directory":{"version":2.83,"file":"lib/Alien/Build/Plugin/Extract/Directory.pm"},"Alien::Build::Plugin::Decode::DirListing":{"version":2.83,"file":"lib/Alien/Build/Plugin/Decode/DirListing.pm"},"Alien::Base::PkgConfig":{"file":"lib/Alien/Base/PkgConfig.pm","version":2.83},"Alien::Build::Plugin::PkgConfig::PP":{"file":"lib/Alien/Build/Plugin/PkgConfig/PP.pm","version":2.83},"Alien::Build::Plugin::PkgConfig::MakeStatic":{"version":2.83,"file":"lib/Alien/Build/Plugin/PkgConfig/MakeStatic.pm"},"Alien::Build::Plugin::Build::Copy":{"version":2.83,"file":"lib/Alien/Build/Plugin/Build/Copy.pm"},"Alien::Build::TempDir":{"version":2.83,"file":"lib/Alien/Build.pm"},"Alien::Build::Plugin::Fetch::LWP":{"version":2.83,"file":"lib/Alien/Build/Plugin/Fetch/LWP.pm"},"Alien::Build::Plugin::Digest::SHA":{"file":"lib/Alien/Build/Plugin/Digest/SHA.pm","version":2.83},"Alien::Build::Plugin::Core::Setup":{"version":2.83,"file":"lib/Alien/Build/Plugin/Core/Setup.pm"},"Alien::Build::Plugin::Prefer::BadVersion":{"version":2.83,"file":"lib/Alien/Build/Plugin/Prefer/BadVersion.pm"},"Alien::Build::Plugin::Decode::DirListingFtpcopy":{"file":"lib/Alien/Build/Plugin/Decode/DirListingFtpcopy.pm","version":2.83},"Alien::Build::Plugin::Probe::Vcpkg":{"version":2.83,"file":"lib/Alien/Build/Plugin/Probe/Vcpkg.pm"},"Alien::Build::Plugin::Extract::ArchiveZip":{"file":"lib/Alien/Build/Plugin/Extract/ArchiveZip.pm","version":2.83},"Alien::Build::Plugin::Test::Mock":{"file":"lib/Alien/Build/Plugin/Test/Mock.pm","version":2.83},"Alien::Build::Log::Default":{"file":"lib/Alien/Build/Log/Default.pm","version":2.83},"Alien::Build::Helper":{"version":2.83,"file":"lib/Alien/Build/Interpolate.pm"},"Test::Alien::Build":{"version":2.83,"file":"lib/Test/Alien/Build.pm"},"Alien::Build::Plugin::Build::Make":{"version":2.83,"file":"lib/Alien/Build/Plugin/Build/Make.pm"},"Alien::Build::Plugin::Gather::IsolateDynamic":{"version":2.83,"file":"lib/Alien/Build/Plugin/Gather/IsolateDynamic.pm"},"Alien::Build::Version::Basic":{"file":"lib/Alien/Build/Version/Basic.pm","version":2.83},"Alien::Build::Plugin::Probe::CBuilder":{"file":"lib/Alien/Build/Plugin/Probe/CBuilder.pm","version":2.83},"Alien::Base::Wrapper":{"version":2.83,"file":"lib/Alien/Base/Wrapper.pm"},"Test::Alien::CanCompile":{"version":2.83,"file":"lib/Test/Alien/CanCompile.pm"},"Alien::Build::Plugin::Core::Legacy":{"version":2.83,"file":"lib/Alien/Build/Plugin/Core/Legacy.pm"},"Alien::Build::Plugin::Fetch::HTTPTiny":{"version":2.83,"file":"lib/Alien/Build/Plugin/Fetch/HTTPTiny.pm"},"Test::Alien::Synthetic":{"file":"lib/Test/Alien/Synthetic.pm","version":2.83},"Alien::Role":{"version":2.83,"file":"lib/Alien/Role.pm"},"Test::Alien":{"file":"lib/Test/Alien.pm","version":2.83},"Alien::Build::Plugin::Core::Gather":{"version":2.83,"file":"lib/Alien/Build/Plugin/Core/Gather.pm"},"Alien::Build::Plugin::Build::CMake":{"file":"lib/Alien/Build/Plugin/Build/CMake.pm","version":2.83},"Alien::Build::Plugin::Extract::CommandLine":{"version":2.83,"file":"lib/Alien/Build/Plugin/Extract/CommandLine.pm"},"Alien::Build::Temp":{"file":"lib/Alien/Build/Temp.pm","version":2.83},"Test::Alien::CanPlatypus":{"version":2.83,"file":"lib/Test/Alien/CanPlatypus.pm"},"Alien::Build::Plugin::Fetch::Local":{"version":2.83,"file":"lib/Alien/Build/Plugin/Fetch/Local.pm"},"Alien::Base":{"version":2.83,"file":"lib/Alien/Base.pm"},"Test::Alien::Run":{"file":"lib/Test/Alien/Run.pm","version":2.83},"Alien::Build::Plugin::Download::Negotiate":{"file":"lib/Alien/Build/Plugin/Download/Negotiate.pm","version":2.83},"Alien::Build::Plugin::Fetch::NetFTP":{"file":"lib/Alien/Build/Plugin/Fetch/NetFTP.pm","version":2.83},"Alien::Build::Plugin::Core::Download":{"version":2.83,"file":"lib/Alien/Build/Plugin/Core/Download.pm"},"Alien::Build::Interpolate::Helper":{"file":"lib/Alien/Build/Interpolate.pm","version":2.83},"Alien::Build::Interpolate":{"file":"lib/Alien/Build/Interpolate.pm","version":2.83},"Alien::Build::Plugin::Fetch::LocalDir":{"file":"lib/Alien/Build/Plugin/Fetch/LocalDir.pm","version":2.83},"Alien::Build::PluginMeta":{"version":2.83,"file":"lib/Alien/Build/Plugin.pm"},"Test::Alien::Diag":{"version":2.83,"file":"lib/Test/Alien/Diag.pm"},"Alien::Build::Plugin::Core::FFI":{"version":2.83,"file":"lib/Alien/Build/Plugin/Core/FFI.pm"},"Alien::Build::rc":{"file":"lib/Alien/Build.pm","version":2.83},"Alien::Build::Plugin::Probe::CommandLine":{"version":2.83,"file":"lib/Alien/Build/Plugin/Probe/CommandLine.pm"},"Alien::Build::Plugin::Core::CleanInstall":{"file":"lib/Alien/Build/Plugin/Core/CleanInstall.pm","version":2.83},"Alien::Build::Interpolate::Default":{"version":2.83,"file":"lib/Alien/Build/Interpolate/Default.pm"},"Alien::Build::Plugin::Core::Override":{"version":2.83,"file":"lib/Alien/Build/Plugin/Core/Override.pm"},"Alien::Build::Plugin::Extract::File":{"file":"lib/Alien/Build/Plugin/Extract/File.pm","version":2.83},"Alien::Build::Plugin::Fetch::Wget":{"file":"lib/Alien/Build/Plugin/Fetch/Wget.pm","version":2.83},"alienfile":{"version":2.83,"file":"lib/alienfile.pm"},"Alien::Build::Plugin::PkgConfig::LibPkgConf":{"file":"lib/Alien/Build/Plugin/PkgConfig/LibPkgConf.pm","version":2.83},"Alien::Build::Plugin::Prefer::GoodVersion":{"version":2.83,"file":"lib/Alien/Build/Plugin/Prefer/GoodVersion.pm"},"Alien::Build":{"file":"lib/Alien/Build.pm","version":2.83}}}PK       ! )E�"  �"  B  perl5/x86_64-linux-thread-multi/.meta/Alien-Build-2.83/MYMETA.jsonnu ��6�$        {
   "abstract" : "Build external dependencies for use in CPAN",
   "author" : [
      "Graham Ollis <plicease@cpan.org>",
      "Joel Berger <joel.a.berger@gmail.com>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "Dist::Zilla version 6.025, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "Alien-Build",
   "no_index" : {
      "directory" : [
         "corpus",
         "example",
         "maint"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "6.64"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::CBuilder" : "0",
            "ExtUtils::MakeMaker" : "6.64",
            "ExtUtils::ParseXS" : "3.30",
            "File::Which" : "0"
         }
      },
      "develop" : {
         "recommends" : {
            "Dist::Zilla::Plugin::Author::Plicease::Thanks" : "0",
            "Dist::Zilla::Plugin::Author::Plicease::Upload" : "0",
            "Dist::Zilla::Plugin::DynamicPrereqs" : "0",
            "Dist::Zilla::Plugin::GatherFile" : "0",
            "Dist::Zilla::Plugin::MetaNoIndex" : "0",
            "Dist::Zilla::Plugin::Prereqs" : "0",
            "Dist::Zilla::Plugin::PruneFiles" : "0",
            "Dist::Zilla::Plugin::RemovePrereqs" : "0",
            "Dist::Zilla::PluginBundle::Author::Plicease" : "2.75",
            "Perl::Critic::Policy::BuiltinFunctions::ProhibitBooleanGrep" : "0",
            "Perl::Critic::Policy::BuiltinFunctions::ProhibitStringyEval" : "0",
            "Perl::Critic::Policy::BuiltinFunctions::ProhibitStringySplit" : "0",
            "Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidGrep" : "0",
            "Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidMap" : "0",
            "Perl::Critic::Policy::ClassHierarchies::ProhibitExplicitISA" : "0",
            "Perl::Critic::Policy::ClassHierarchies::ProhibitOneArgBless" : "0",
            "Perl::Critic::Policy::CodeLayout::ProhibitHardTabs" : "0",
            "Perl::Critic::Policy::CodeLayout::ProhibitTrailingWhitespace" : "0",
            "Perl::Critic::Policy::CodeLayout::RequireConsistentNewlines" : "0",
            "Perl::Critic::Policy::Community::ArrayAssignAref" : "0",
            "Perl::Critic::Policy::Community::BarewordFilehandles" : "0",
            "Perl::Critic::Policy::Community::ConditionalDeclarations" : "0",
            "Perl::Critic::Policy::Community::ConditionalImplicitReturn" : "0",
            "Perl::Critic::Policy::Community::DeprecatedFeatures" : "0",
            "Perl::Critic::Policy::Community::DiscouragedModules" : "0",
            "Perl::Critic::Policy::Community::DollarAB" : "0",
            "Perl::Critic::Policy::Community::Each" : "0",
            "Perl::Critic::Policy::Community::EmptyReturn" : "0",
            "Perl::Critic::Policy::Community::IndirectObjectNotation" : "0",
            "Perl::Critic::Policy::Community::LexicalForeachIterator" : "0",
            "Perl::Critic::Policy::Community::LoopOnHash" : "0",
            "Perl::Critic::Policy::Community::ModPerl" : "0",
            "Perl::Critic::Policy::Community::OpenArgs" : "0",
            "Perl::Critic::Policy::Community::OverloadOptions" : "0",
            "Perl::Critic::Policy::Community::POSIXImports" : "0",
            "Perl::Critic::Policy::Community::PackageMatchesFilename" : "0",
            "Perl::Critic::Policy::Community::PreferredAlternatives" : "0",
            "Perl::Critic::Policy::Community::StrictWarnings" : "0",
            "Perl::Critic::Policy::Community::Threads" : "0",
            "Perl::Critic::Policy::Community::Wantarray" : "0",
            "Perl::Critic::Policy::Community::WarningsSwitch" : "0",
            "Perl::Critic::Policy::Community::WhileDiamondDefaultAssignment" : "0",
            "Perl::Critic::Policy::ControlStructures::ProhibitLabelsWithSpecialBlockNames" : "0",
            "Perl::Critic::Policy::ControlStructures::ProhibitMutatingListFunctions" : "0",
            "Perl::Critic::Policy::ControlStructures::ProhibitUnreachableCode" : "0",
            "Perl::Critic::Policy::InputOutput::ProhibitBarewordFileHandles" : "0",
            "Perl::Critic::Policy::InputOutput::ProhibitJoinedReadline" : "0",
            "Perl::Critic::Policy::InputOutput::ProhibitTwoArgOpen" : "0",
            "Perl::Critic::Policy::Miscellanea::ProhibitFormats" : "0",
            "Perl::Critic::Policy::Miscellanea::ProhibitUselessNoCritic" : "0",
            "Perl::Critic::Policy::Modules::ProhibitConditionalUseStatements" : "0",
            "Perl::Critic::Policy::Modules::RequireNoMatchVarsWithUseEnglish" : "0",
            "Perl::Critic::Policy::Objects::ProhibitIndirectSyntax" : "0",
            "Perl::Critic::Policy::RegularExpressions::ProhibitUselessTopic" : "0",
            "Perl::Critic::Policy::Subroutines::ProhibitNestedSubs" : "0",
            "Perl::Critic::Policy::ValuesAndExpressions::ProhibitLeadingZeros" : "0",
            "Perl::Critic::Policy::ValuesAndExpressions::ProhibitMixedBooleanOperators" : "0",
            "Perl::Critic::Policy::ValuesAndExpressions::ProhibitSpecialLiteralHeredocTerminator" : "0",
            "Perl::Critic::Policy::ValuesAndExpressions::RequireUpperCaseHeredocTerminator" : "0",
            "Perl::Critic::Policy::Variables::ProhibitPerl4PackageNames" : "0",
            "Perl::Critic::Policy::Variables::ProhibitUnusedVariables" : "0",
            "Software::License::Perl_5" : "0"
         },
         "requires" : {
            "FindBin" : "0",
            "Perl::Critic" : "0",
            "Test2::Require::EnvVar" : "0.000121",
            "Test2::Require::Module" : "0.000121",
            "Test2::Tools::PerlCritic" : "0",
            "Test2::V0" : "0.000121",
            "Test::CPAN::Changes" : "0",
            "Test::EOL" : "0",
            "Test::Fixme" : "0.07",
            "Test::More" : "0.98",
            "Test::NoTabs" : "0",
            "Test::Pod" : "0",
            "Test::Pod::Coverage" : "0",
            "Test::Pod::LinkCheck::Lite" : "0",
            "Test::Spelling" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "Capture::Tiny" : "0.17",
            "Digest::SHA" : "0",
            "ExtUtils::CBuilder" : "0",
            "ExtUtils::MakeMaker" : "6.64",
            "ExtUtils::ParseXS" : "3.30",
            "FFI::CheckLib" : "0.11",
            "File::Which" : "1.10",
            "File::chdir" : "0",
            "JSON::PP" : "0",
            "List::Util" : "1.33",
            "Path::Tiny" : "0.077",
            "Test2::API" : "1.302096",
            "Text::ParseWords" : "3.26",
            "parent" : "0",
            "perl" : "5.008004"
         },
         "suggests" : {
            "Archive::Tar" : "0"
         }
      },
      "test" : {
         "requires" : {
            "Test2::API" : "1.302096",
            "Test2::V0" : "0.000121"
         },
         "suggests" : {
            "Devel::Hide" : "0"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "web" : "https://github.com/PerlAlien/Alien-Build/issues"
      },
      "homepage" : "https://metacpan.org/pod/Alien::Build",
      "repository" : {
         "type" : "git",
         "url" : "git://github.com/PerlAlien/Alien-Build.git",
         "web" : "https://github.com/PerlAlien/Alien-Build"
      },
      "x_IRC" : "irc://irc.perl.org/#native"
   },
   "version" : "2.83",
   "x_contributors" : [
      "Graham Ollis <plicease@cpan.org>",
      "Diab Jerius (DJERIUS)",
      "Roy Storey (KIWIROY)",
      "Ilya Pavlov",
      "David Mertens (run4flat)",
      "Mark Nunberg (mordy, mnunberg)",
      "Christian Walde (Mithaldu)",
      "Brian Wightman (MidLifeXis)",
      "Zaki Mughal (zmughal)",
      "mohawk (mohawk2, ETJ)",
      "Vikas N Kumar (vikasnkumar)",
      "Flavio Poletti (polettix)",
      "Salvador Fandiño (salva)",
      "Gianni Ceccarelli (dakkar)",
      "Pavel Shaydo (zwon, trinitum)",
      "Kang-min Liu (劉康民, gugod)",
      "Nicholas Shipp (nshp)",
      "Juan Julián Merelo Guervós (JJ)",
      "Joel Berger (JBERGER)",
      "Petr Písař (ppisar)",
      "Lance Wicks (LANCEW)",
      "Ahmad Fatoum (a3f, ATHREEF)",
      "José Joaquín Atria (JJATRIA)",
      "Duke Leto (LETO)",
      "Shoichi Kaji (SKAJI)",
      "Shawn Laffan (SLAFFAN)",
      "Paul Evans (leonerd, PEVANS)",
      "Håkon Hægland (hakonhagland, HAKONH)",
      "nick nauwelaerts (INPHOBIA)",
      "Florian Weimer"
   ],
   "x_generated_by_perl" : "v5.37.4",
   "x_serialization_backend" : "Cpanel::JSON::XS version 4.32",
   "x_spdx_expression" : "Artistic-1.0-Perl OR GPL-1.0-or-later",
   "x_use_unsafe_inc" : 0
}
PK       ! P&�k4  4  D  perl5/x86_64-linux-thread-multi/.meta/HTTP-Message-6.26/install.jsonnu ��6�$        {"provides":{"HTTP::Headers::Util":{"version":6.26,"file":"lib/HTTP/Headers/Util.pm"},"HTTP::Config":{"version":6.26,"file":"lib/HTTP/Config.pm"},"HTTP::Headers::ETag":{"version":6.26,"file":"lib/HTTP/Headers/ETag.pm"},"HTTP::Status":{"version":6.26,"file":"lib/HTTP/Status.pm"},"HTTP::Message":{"version":6.26,"file":"lib/HTTP/Message.pm"},"HTTP::Request::Common":{"version":6.26,"file":"lib/HTTP/Request/Common.pm"},"HTTP::Headers::Auth":{"version":6.26,"file":"lib/HTTP/Headers/Auth.pm"},"HTTP::Response":{"version":6.26,"file":"lib/HTTP/Response.pm"},"HTTP::Headers":{"version":6.26,"file":"lib/HTTP/Headers.pm"},"HTTP::Request":{"version":6.26,"file":"lib/HTTP/Request.pm"}},"target":"HTTP::Status","version":6.26,"name":"HTTP::Message","dist":"HTTP-Message-6.26","pathname":"O/OA/OALDERS/HTTP-Message-6.26.tar.gz"}PK       ! >F�x  x  C  perl5/x86_64-linux-thread-multi/.meta/HTTP-Message-6.26/MYMETA.jsonnu ��6�$        {
   "abstract" : "HTTP style message (base class)",
   "author" : [
      "Gisle Aas <gisle@activestate.com>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "Dist::Zilla version 6.015, CPAN::Meta::Converter version 2.150010",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : 2
   },
   "name" : "HTTP-Message",
   "no_index" : {
      "directory" : [
         "examples",
         "t",
         "xt"
      ]
   },
   "prereqs" : {
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0",
            "perl" : "5.006"
         },
         "suggests" : {
            "JSON::PP" : "2.27300"
         }
      },
      "develop" : {
         "requires" : {
            "Clone" : "0",
            "File::Spec" : "0",
            "IO::Handle" : "0",
            "IPC::Open3" : "0",
            "Test::CPAN::Changes" : "0.19",
            "Test::Mojibake" : "0",
            "Test::More" : "0.96",
            "Test::Pod" : "1.41",
            "Test::Portability::Files" : "0",
            "Test::Version" : "1",
            "perl" : "5.006"
         }
      },
      "runtime" : {
         "requires" : {
            "Carp" : "0",
            "Compress::Raw::Zlib" : "0",
            "Encode" : "3.01",
            "Encode::Locale" : "1",
            "Exporter" : "5.57",
            "HTTP::Date" : "6",
            "IO::Compress::Bzip2" : "2.021",
            "IO::Compress::Deflate" : "0",
            "IO::Compress::Gzip" : "0",
            "IO::HTML" : "0",
            "IO::Uncompress::Bunzip2" : "2.021",
            "IO::Uncompress::Gunzip" : "0",
            "IO::Uncompress::Inflate" : "0",
            "IO::Uncompress::RawInflate" : "0",
            "LWP::MediaTypes" : "6",
            "MIME::Base64" : "2.1",
            "MIME::QuotedPrint" : "0",
            "URI" : "1.10",
            "base" : "0",
            "perl" : "5.008001",
            "strict" : "0",
            "warnings" : "0"
         },
         "suggests" : {
            "Clone" : "0"
         }
      },
      "test" : {
         "recommends" : {
            "CPAN::Meta" : "2.120900"
         },
         "requires" : {
            "ExtUtils::MakeMaker" : "0",
            "File::Spec" : "0",
            "PerlIO::encoding" : "0",
            "Test::More" : "0.88",
            "Time::Local" : "0",
            "Try::Tiny" : "0",
            "lib" : "0",
            "overload" : "0",
            "perl" : "5.008001"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "web" : "https://github.com/libwww-perl/HTTP-Message/issues"
      },
      "homepage" : "https://github.com/libwww-perl/HTTP-Message",
      "repository" : {
         "type" : "git",
         "url" : "https://github.com/libwww-perl/HTTP-Message.git",
         "web" : "https://github.com/libwww-perl/HTTP-Message"
      },
      "x_IRC" : "irc://irc.perl.org/#lwp",
      "x_MailingList" : "mailto:libwww@perl.org"
   },
   "version" : "6.26",
   "x_Dist_Zilla" : {
      "perl" : {
         "version" : "5.030002"
      },
      "plugins" : [
         {
            "class" : "Dist::Zilla::Plugin::MetaResources",
            "name" : "MetaResources",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::Prereqs",
            "config" : {
               "Dist::Zilla::Plugin::Prereqs" : {
                  "phase" : "runtime",
                  "type" : "requires"
               }
            },
            "name" : "Prereqs",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::PromptIfStale",
            "config" : {
               "Dist::Zilla::Plugin::PromptIfStale" : {
                  "check_all_plugins" : 0,
                  "check_all_prereqs" : 0,
                  "modules" : [
                     "Dist::Zilla::PluginBundle::Author::OALDERS"
                  ],
                  "phase" : "build",
                  "run_under_travis" : 0,
                  "skip" : []
               }
            },
            "name" : "@Author::OALDERS/stale modules, build",
            "version" : "0.057"
         },
         {
            "class" : "Dist::Zilla::Plugin::PromptIfStale",
            "config" : {
               "Dist::Zilla::Plugin::PromptIfStale" : {
                  "check_all_plugins" : 1,
                  "check_all_prereqs" : 1,
                  "modules" : [],
                  "phase" : "release",
                  "run_under_travis" : 0,
                  "skip" : []
               }
            },
            "name" : "@Author::OALDERS/stale modules, release",
            "version" : "0.057"
         },
         {
            "class" : "Dist::Zilla::Plugin::OALDERS::TidyAll",
            "name" : "@Author::OALDERS/OALDERS::TidyAll",
            "version" : "0.000028"
         },
         {
            "class" : "Dist::Zilla::Plugin::AutoPrereqs",
            "name" : "@Author::OALDERS/AutoPrereqs",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::CheckChangesHasContent",
            "name" : "@Author::OALDERS/CheckChangesHasContent",
            "version" : "0.011"
         },
         {
            "class" : "Dist::Zilla::Plugin::MakeMaker",
            "config" : {
               "Dist::Zilla::Role::TestRunner" : {
                  "default_jobs" : "4"
               }
            },
            "name" : "@Author::OALDERS/MakeMaker",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::CPANFile",
            "name" : "@Author::OALDERS/CPANFile",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::ContributorsFile",
            "name" : "@Author::OALDERS/ContributorsFile",
            "version" : "0.3.0"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaJSON",
            "name" : "@Author::OALDERS/MetaJSON",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaYAML",
            "name" : "@Author::OALDERS/MetaYAML",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::Manifest",
            "name" : "@Author::OALDERS/Manifest",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaNoIndex",
            "name" : "@Author::OALDERS/MetaNoIndex",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaConfig",
            "name" : "@Author::OALDERS/MetaConfig",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaResources",
            "name" : "@Author::OALDERS/MetaResources",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::License",
            "name" : "@Author::OALDERS/License",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::InstallGuide",
            "config" : {
               "Dist::Zilla::Role::ModuleMetadata" : {
                  "Module::Metadata" : "1.000036",
                  "version" : "0.006"
               }
            },
            "name" : "@Author::OALDERS/InstallGuide",
            "version" : "1.200013"
         },
         {
            "class" : "Dist::Zilla::Plugin::ExecDir",
            "name" : "@Author::OALDERS/ExecDir",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::MojibakeTests",
            "name" : "@Author::OALDERS/MojibakeTests",
            "version" : "0.8"
         },
         {
            "class" : "Dist::Zilla::Plugin::PodSyntaxTests",
            "name" : "@Author::OALDERS/PodSyntaxTests",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::CPAN::Changes",
            "config" : {
               "Dist::Zilla::Plugin::Test::CPAN::Changes" : {
                  "changelog" : "Changes"
               }
            },
            "name" : "@Author::OALDERS/Test::CPAN::Changes",
            "version" : "0.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::Portability",
            "config" : {
               "Dist::Zilla::Plugin::Test::Portability" : {
                  "options" : ""
               }
            },
            "name" : "@Author::OALDERS/Test::Portability",
            "version" : "2.001000"
         },
         {
            "class" : "Dist::Zilla::Plugin::TestRelease",
            "name" : "@Author::OALDERS/TestRelease",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::ReportPrereqs",
            "name" : "@Author::OALDERS/Test::ReportPrereqs",
            "version" : "0.028"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::Version",
            "name" : "@Author::OALDERS/Test::Version",
            "version" : "1.09"
         },
         {
            "class" : "Dist::Zilla::Plugin::RunExtraTests",
            "config" : {
               "Dist::Zilla::Role::TestRunner" : {
                  "default_jobs" : "4"
               }
            },
            "name" : "@Author::OALDERS/RunExtraTests",
            "version" : "0.029"
         },
         {
            "class" : "Dist::Zilla::Plugin::MinimumPerl",
            "name" : "@Author::OALDERS/MinimumPerl",
            "version" : "1.006"
         },
         {
            "class" : "Dist::Zilla::Plugin::PodWeaver",
            "config" : {
               "Dist::Zilla::Plugin::PodWeaver" : {
                  "finder" : [
                     ":InstallModules",
                     ":ExecFiles"
                  ],
                  "plugins" : [
                     {
                        "class" : "Pod::Weaver::Plugin::EnsurePod5",
                        "name" : "@CorePrep/EnsurePod5",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Plugin::H1Nester",
                        "name" : "@CorePrep/H1Nester",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Plugin::SingleEncoding",
                        "name" : "@Default/SingleEncoding",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Name",
                        "name" : "@Default/Name",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Version",
                        "name" : "@Default/Version",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Region",
                        "name" : "@Default/prelude",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Generic",
                        "name" : "SYNOPSIS",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Generic",
                        "name" : "DESCRIPTION",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Generic",
                        "name" : "OVERVIEW",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Collect",
                        "name" : "ATTRIBUTES",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Collect",
                        "name" : "METHODS",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Collect",
                        "name" : "FUNCTIONS",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Leftovers",
                        "name" : "@Default/Leftovers",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Region",
                        "name" : "@Default/postlude",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Authors",
                        "name" : "@Default/Authors",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Legal",
                        "name" : "@Default/Legal",
                        "version" : "4.015"
                     }
                  ]
               }
            },
            "name" : "@Author::OALDERS/PodWeaver",
            "version" : "4.008"
         },
         {
            "class" : "Dist::Zilla::Plugin::PruneCruft",
            "name" : "@Author::OALDERS/PruneCruft",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::CopyFilesFromBuild",
            "name" : "@Author::OALDERS/CopyFilesFromBuild",
            "version" : "0.170880"
         },
         {
            "class" : "Dist::Zilla::Plugin::GithubMeta",
            "name" : "@Author::OALDERS/GithubMeta",
            "version" : "0.58"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::GatherDir",
            "config" : {
               "Dist::Zilla::Plugin::GatherDir" : {
                  "exclude_filename" : [
                     "Install",
                     "LICENSE",
                     "META.json",
                     "Makefile.PL",
                     "README.md",
                     "cpanfile"
                  ],
                  "exclude_match" : [],
                  "follow_symlinks" : 0,
                  "include_dotfiles" : 0,
                  "prefix" : "",
                  "prune_directory" : [],
                  "root" : "."
               },
               "Dist::Zilla::Plugin::Git::GatherDir" : {
                  "include_untracked" : 0
               }
            },
            "name" : "@Author::OALDERS/Git::GatherDir",
            "version" : "2.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::CopyFilesFromRelease",
            "config" : {
               "Dist::Zilla::Plugin::CopyFilesFromRelease" : {
                  "filename" : [
                     "Install"
                  ],
                  "match" : []
               }
            },
            "name" : "@Author::OALDERS/CopyFilesFromRelease",
            "version" : "0.007"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Check",
            "config" : {
               "Dist::Zilla::Plugin::Git::Check" : {
                  "untracked_files" : "die"
               },
               "Dist::Zilla::Role::Git::DirtyFiles" : {
                  "allow_dirty" : [
                     "Changes",
                     "Install",
                     "LICENSE",
                     "META.json",
                     "Makefile.PL",
                     "README.md",
                     "cpanfile",
                     "dist.ini"
                  ],
                  "allow_dirty_match" : [],
                  "changelog" : "Changes"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.28.0",
                  "repo_root" : "."
               }
            },
            "name" : "@Author::OALDERS/Git::Check",
            "version" : "2.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Contributors",
            "config" : {
               "Dist::Zilla::Plugin::Git::Contributors" : {
                  "git_version" : "2.28.0",
                  "include_authors" : 0,
                  "include_releaser" : 1,
                  "order_by" : "name",
                  "paths" : []
               }
            },
            "name" : "@Author::OALDERS/Git::Contributors",
            "version" : "0.035"
         },
         {
            "class" : "Dist::Zilla::Plugin::ReadmeAnyFromPod",
            "config" : {
               "Dist::Zilla::Role::FileWatcher" : {
                  "version" : "0.006"
               }
            },
            "name" : "@Author::OALDERS/ReadmeMdInBuild",
            "version" : "0.163250"
         },
         {
            "class" : "Dist::Zilla::Plugin::StaticInstall",
            "config" : {
               "Dist::Zilla::Plugin::StaticInstall" : {
                  "dry_run" : 0,
                  "mode" : "on"
               }
            },
            "name" : "@Author::OALDERS/StaticInstall",
            "version" : "0.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::ShareDir",
            "name" : "@Author::OALDERS/ShareDir",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::TravisCI::StatusBadge",
            "name" : "@Author::OALDERS/TravisCI::StatusBadge",
            "version" : "0.007"
         },
         {
            "class" : "Dist::Zilla::Plugin::CheckIssues",
            "name" : "@Author::OALDERS/CheckIssues",
            "version" : "0.011"
         },
         {
            "class" : "Dist::Zilla::Plugin::ConfirmRelease",
            "name" : "@Author::OALDERS/ConfirmRelease",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::UploadToCPAN",
            "name" : "@Author::OALDERS/UploadToCPAN",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::RewriteVersion::Transitional",
            "config" : {
               "Dist::Zilla::Plugin::RewriteVersion" : {
                  "add_tarball_name" : 0,
                  "finders" : [
                     ":ExecFiles",
                     ":InstallModules"
                  ],
                  "global" : 0,
                  "skip_version_provider" : 0
               },
               "Dist::Zilla::Plugin::RewriteVersion::Transitional" : {}
            },
            "name" : "@Author::OALDERS/@Git::VersionManager/RewriteVersion::Transitional",
            "version" : "0.009"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaProvides::Update",
            "name" : "@Author::OALDERS/@Git::VersionManager/MetaProvides::Update",
            "version" : "0.007"
         },
         {
            "class" : "Dist::Zilla::Plugin::CopyFilesFromRelease",
            "config" : {
               "Dist::Zilla::Plugin::CopyFilesFromRelease" : {
                  "filename" : [
                     "Changes"
                  ],
                  "match" : []
               }
            },
            "name" : "@Author::OALDERS/@Git::VersionManager/CopyFilesFromRelease",
            "version" : "0.007"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Commit",
            "config" : {
               "Dist::Zilla::Plugin::Git::Commit" : {
                  "add_files_in" : [],
                  "commit_msg" : "v%V%n%n%c"
               },
               "Dist::Zilla::Role::Git::DirtyFiles" : {
                  "allow_dirty" : [
                     "Changes",
                     "Install",
                     "LICENSE",
                     "META.json",
                     "Makefile.PL",
                     "README.md",
                     "cpanfile",
                     "dist.ini"
                  ],
                  "allow_dirty_match" : [],
                  "changelog" : "Changes"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.28.0",
                  "repo_root" : "."
               },
               "Dist::Zilla::Role::Git::StringFormatter" : {
                  "time_zone" : "local"
               }
            },
            "name" : "@Author::OALDERS/@Git::VersionManager/release snapshot",
            "version" : "2.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Tag",
            "config" : {
               "Dist::Zilla::Plugin::Git::Tag" : {
                  "branch" : null,
                  "changelog" : "Changes",
                  "signed" : 0,
                  "tag" : "v6.26",
                  "tag_format" : "v%V",
                  "tag_message" : "v%V"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.28.0",
                  "repo_root" : "."
               },
               "Dist::Zilla::Role::Git::StringFormatter" : {
                  "time_zone" : "local"
               }
            },
            "name" : "@Author::OALDERS/@Git::VersionManager/Git::Tag",
            "version" : "2.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::BumpVersionAfterRelease::Transitional",
            "config" : {
               "Dist::Zilla::Plugin::BumpVersionAfterRelease" : {
                  "finders" : [
                     ":ExecFiles",
                     ":InstallModules"
                  ],
                  "global" : 0,
                  "munge_makefile_pl" : 1
               },
               "Dist::Zilla::Plugin::BumpVersionAfterRelease::Transitional" : {}
            },
            "name" : "@Author::OALDERS/@Git::VersionManager/BumpVersionAfterRelease::Transitional",
            "version" : "0.009"
         },
         {
            "class" : "Dist::Zilla::Plugin::NextRelease",
            "name" : "@Author::OALDERS/@Git::VersionManager/NextRelease",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Commit",
            "config" : {
               "Dist::Zilla::Plugin::Git::Commit" : {
                  "add_files_in" : [],
                  "commit_msg" : "increment $VERSION after %v release"
               },
               "Dist::Zilla::Role::Git::DirtyFiles" : {
                  "allow_dirty" : [
                     "Build.PL",
                     "Changes",
                     "Makefile.PL"
                  ],
                  "allow_dirty_match" : [
                     "(?^:^lib/.*\\.pm$)"
                  ],
                  "changelog" : "Changes"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.28.0",
                  "repo_root" : "."
               },
               "Dist::Zilla::Role::Git::StringFormatter" : {
                  "time_zone" : "local"
               }
            },
            "name" : "@Author::OALDERS/@Git::VersionManager/post-release commit",
            "version" : "2.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Push",
            "config" : {
               "Dist::Zilla::Plugin::Git::Push" : {
                  "push_to" : [
                     "origin"
                  ],
                  "remotes_must_exist" : 1
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.28.0",
                  "repo_root" : "."
               }
            },
            "name" : "@Author::OALDERS/Git::Push",
            "version" : "2.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::Prereqs::Soften",
            "config" : {
               "Dist::Zilla::Plugin::Prereqs::Soften" : {
                  "copy_to" : [
                     "develop.requires"
                  ],
                  "modules" : [
                     "Clone"
                  ],
                  "modules_from_features" : null,
                  "to_relationship" : "suggests"
               }
            },
            "name" : "Prereqs::Soften",
            "version" : "0.006003"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::Compile",
            "config" : {
               "Dist::Zilla::Plugin::Test::Compile" : {
                  "bail_out_on_fail" : "1",
                  "fail_on_warning" : "author",
                  "fake_home" : 0,
                  "filename" : "xt/author/00-compile.t",
                  "module_finder" : [
                     ":InstallModules"
                  ],
                  "needs_display" : 0,
                  "phase" : "develop",
                  "script_finder" : [
                     ":PerlExecFiles"
                  ],
                  "skips" : [],
                  "switch" : []
               }
            },
            "name" : "Test::Compile",
            "version" : "2.058"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::ChangesHasContent",
            "name" : "Test::ChangesHasContent",
            "version" : "0.011"
         },
         {
            "class" : "Dist::Zilla::Plugin::Substitute",
            "name" : "Substitute",
            "version" : "0.006"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":InstallModules",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":IncModules",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":TestFiles",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":ExtraTestFiles",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":ExecFiles",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":PerlExecFiles",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":ShareFiles",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":MainModule",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":AllFiles",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":NoFiles",
            "version" : "6.015"
         }
      ],
      "zilla" : {
         "class" : "Dist::Zilla::Dist::Builder",
         "config" : {
            "is_trial" : 0
         },
         "version" : "6.015"
      }
   },
   "x_contributors" : [
      "Adam Kennedy <adamk@cpan.org>",
      "Adam Sjogren <asjo@koldfront.dk>",
      "Alexey Tourbin <at@altlinux.ru>",
      "Alex Kapranoff <ka@nadoby.ru>",
      "amire80 <amir.aharoni@gmail.com>",
      "Andreas J. Koenig <andreas.koenig@anima.de>",
      "Bill Mann <wfmann@alum.mit.edu>",
      "Brendan Byrd <GitHub@ResonatorSoft.org>",
      "Bron Gondwana <brong@fastmail.fm>",
      "Chase Whitener <capoeirab@cpan.org>",
      "Christopher J. Madsen <cjm@cpan.org>",
      "chromatic <chromatic@wgz.org>",
      "Dan Book <grinnz@grinnz.com>",
      "Daniel Hedlund <Daniel.Hedlund@eprize.com>",
      "David E. Wheeler <david@justatheory.com>",
      "DAVIDRW <davidrw@cpan.org>",
      "David Steinbrunner <dsteinbrunner@MountainBook-Pro.local>",
      "Dorian Taylor <dorian.taylor.lists@gmail.com>",
      "Father Chrysostomos <sprout@cpan.org>",
      "Felipe Gasper <felipe@felipegasper.com>",
      "FWILES <FWILES@cpan.org>",
      "Gavin Peters <gpeters@deepsky.com>",
      "Gisle Aas <gisle@aas.no>",
      "Graeme Thompson <Graeme.Thompson@mobilecohesion.com>",
      "Graham Knop <haarg@haarg.org>",
      "Hans-H. Froehlich <hfroehlich@co-de-co.de>",
      "Ian Kilgore <iank@cpan.org>",
      "Jacob J <waif@chaos2.org>",
      "Jakub Wilk <jwilk@jwilk.net>",
      "jefflee <shaohua@gmail.com>",
      "Jerome Eteve <jerome@broadbean.com>",
      "john9art <john9art@yahoo.com>",
      "jonasbn <jonasbn@gmail.com>",
      "Karen Etheridge <ether@cpan.org>",
      "Lars Dɪᴇᴄᴋᴏᴡ 迪拉斯 <daxim@cpan.org>",
      "Mark Overmeer <mark@overmeer.net>",
      "Mark Stosberg <mark@stosberg.com>",
      "Martin H. Sluka <fany@cpan.org>",
      "Matthew Chae <mschae@cpan.org>",
      "Michael Schout <mschout@gkg.net>",
      "Mickey Nasriachi <mickey@cpan.org>",
      "Mike Schilli <github@perlmeister.com>",
      "murphy <murphy@genome.chop.edu>",
      "Olaf Alders <olaf@wundersolutions.com>",
      "Olivier Mengué <dolmen@cpan.org>",
      "Ondrej Hanak <ondrej.hanak@ubs.com>",
      "openstrike <git@openstrike.co.uk>",
      "Peter Rabbitson <ribasushi@cpan.org>",
      "phrstbrn <phrstbrn@gmail.com>",
      "Robert Rothenberg <robrwo+github@gmail.com>",
      "Robert Rothenberg <rrwo@cpan.org>",
      "Robert Stone <talby@trap.mtview.ca.us>",
      "Rolf Grossmann <rg@progtech.net>",
      "ruff <ruff@ukrpost.net>",
      "sasao <sasao@yugen.org>",
      "Saturday Walkers Club <swc@walkingclub.org.uk>",
      "Sean M. Burke <sburke@cpan.org>",
      "Slaven Rezic <slaven@rezic.de>",
      "Spiros Denaxas <s.denaxas@gmail.com>",
      "Steve Hay <SteveHay@planit.com>",
      "Tatsuhiko Miyagawa <miyagawa@bulknews.net>",
      "Tatsuhiko Miyagawa <miyagawa@gmail.com>",
      "Theo van Hoesel <Th.J.v.Hoesel@THEMA-MEDIA.nl>",
      "Tigran <tigrankhachikyan@gmail.com>",
      "Tobias Leich <email@froggs.de>",
      "Todd Lipcon <todd@amiestreet.com>",
      "tokuhirom <tokuhirom@gmail.com>",
      "Tom Hukins <tom@eborcom.com>",
      "Tony Finch <dot@dotat.at>",
      "Toru Yamaguchi <zigorou@cpan.org>",
      "uid39246 <uid39246>",
      "Ville Skyttä <ville.skytta@iki.fi>",
      "William Storey <wstorey@maxmind.com>",
      "Yuri Karaban <tech@askold.net>",
      "Zakariyya Mughal <zaki.mughal@gmail.com>",
      "Zefram <zefram@fysh.org>"
   ],
   "x_generated_by_perl" : "v5.30.2",
   "x_serialization_backend" : "JSON::PP version 2.97001",
   "x_spdx_expression" : "Artistic-1.0-Perl OR GPL-1.0-or-later",
   "x_static_install" : 1
}
PK       ! ���   �   B  perl5/x86_64-linux-thread-multi/.meta/HTTP-Tiny-0.076/install.jsonnu ��6�$        {"provides":{"HTTP::Tiny":{"version":"0.076","file":"lib/HTTP/Tiny.pm"}},"target":"HTTP::Tiny","version":"0.076","name":"HTTP::Tiny","dist":"HTTP-Tiny-0.076","pathname":"D/DA/DAGOLDEN/HTTP-Tiny-0.076.tar.gz"}PK       ! B}���  �  A  perl5/x86_64-linux-thread-multi/.meta/HTTP-Tiny-0.076/MYMETA.jsonnu ��6�$        {
   "abstract" : "A small, simple, correct HTTP/1.1 client",
   "author" : [
      "Christian Hansen <chansen@cpan.org>",
      "David Golden <dagolden@cpan.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "Dist::Zilla version 6.012, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "HTTP-Tiny",
   "no_index" : {
      "directory" : [
         "corpus",
         "examples",
         "t",
         "xt"
      ],
      "package" : [
         "DB"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "6.17"
         },
         "suggests" : {
            "JSON::PP" : "2.27300"
         }
      },
      "develop" : {
         "requires" : {
            "Dist::Zilla" : "5",
            "Dist::Zilla::Plugin::Prereqs" : "0",
            "Dist::Zilla::Plugin::ReleaseStatus::FromVersion" : "0",
            "Dist::Zilla::Plugin::RemovePrereqs" : "0",
            "Dist::Zilla::PluginBundle::DAGOLDEN" : "0.072",
            "File::Spec" : "0",
            "File::Temp" : "0",
            "IO::Handle" : "0",
            "IPC::Open3" : "0",
            "Perl::Critic::Policy::Lax::ProhibitStringyEval::ExceptForRequire" : "0",
            "Pod::Coverage::TrustPod" : "0",
            "Pod::Wordlist" : "0",
            "Software::License::Perl_5" : "0",
            "Test::CPAN::Meta" : "0",
            "Test::MinimumVersion" : "0",
            "Test::More" : "0",
            "Test::Perl::Critic" : "0",
            "Test::Pod" : "1.41",
            "Test::Pod::Coverage" : "1.08",
            "Test::Portability::Files" : "0",
            "Test::Spelling" : "0.12",
            "Test::Version" : "1",
            "perl" : "5.006"
         }
      },
      "runtime" : {
         "recommends" : {
            "HTTP::CookieJar" : "0.001",
            "IO::Socket::IP" : "0.32",
            "IO::Socket::SSL" : "1.42",
            "Mozilla::CA" : "20160104",
            "Net::SSLeay" : "1.49"
         },
         "requires" : {
            "Carp" : "0",
            "Fcntl" : "0",
            "IO::Socket" : "0",
            "MIME::Base64" : "0",
            "Socket" : "0",
            "Time::Local" : "0",
            "bytes" : "0",
            "perl" : "5.006",
            "strict" : "0",
            "warnings" : "0"
         },
         "suggests" : {
            "IO::Socket::SSL" : "1.56"
         }
      },
      "test" : {
         "recommends" : {
            "CPAN::Meta" : "2.120900"
         },
         "requires" : {
            "Data::Dumper" : "0",
            "Exporter" : "0",
            "ExtUtils::MakeMaker" : "0",
            "File::Basename" : "0",
            "File::Spec" : "0",
            "File::Temp" : "0",
            "IO::Dir" : "0",
            "IO::File" : "0",
            "IO::Socket::INET" : "0",
            "IPC::Cmd" : "0",
            "Test::More" : "0.96",
            "lib" : "0",
            "open" : "0"
         }
      }
   },
   "provides" : {
      "HTTP::Tiny" : {
         "file" : "lib/HTTP/Tiny.pm",
         "version" : "0.076"
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "web" : "https://github.com/chansen/p5-http-tiny/issues"
      },
      "homepage" : "https://github.com/chansen/p5-http-tiny",
      "repository" : {
         "type" : "git",
         "url" : "https://github.com/chansen/p5-http-tiny.git",
         "web" : "https://github.com/chansen/p5-http-tiny"
      }
   },
   "version" : "0.076",
   "x_authority" : "cpan:DAGOLDEN",
   "x_contributors" : [
      "Alan Gardner <gardner@pythian.com>",
      "Alessandro Ghedini <al3xbio@gmail.com>",
      "A. Sinan Unur <nanis@cpan.org>",
      "Brad Gilbert <bgills@cpan.org>",
      "brian m. carlson <sandals@crustytoothpaste.net>",
      "Chris Nehren <apeiron@cpan.org>",
      "Chris Weyl <cweyl@alumni.drew.edu>",
      "Claes Jakobsson <claes@surfar.nu>",
      "Clinton Gormley <clint@traveljury.com>",
      "Craig A. Berry <craigberry@mac.com>",
      "Craig Berry <cberry@cpan.org>",
      "David Golden <xdg@xdg.me>",
      "David Mitchell <davem@iabyn.com>",
      "Dean Pearce <pearce@pythian.com>",
      "Edward Zborowski <ed@rubensteintech.com>",
      "Felipe Gasper <felipe@felipegasper.com>",
      "James Raspass <jraspass@gmail.com>",
      "Jeremy Mates <jmates@cpan.org>",
      "Jess Robinson <castaway@desert-island.me.uk>",
      "Karen Etheridge <ether@cpan.org>",
      "Lukas Eklund <leklund@gmail.com>",
      "Martin J. Evans <mjegh@ntlworld.com>",
      "Martin-Louis Bright <mlbright@gmail.com>",
      "Mike Doherty <doherty@cpan.org>",
      "Nicolas Rochelemagne <rochelemagne@cpanel.net>",
      "Olaf Alders <olaf@wundersolutions.com>",
      "Olivier Mengué <dolmen@cpan.org>",
      "Petr Písař <ppisar@redhat.com>",
      "Serguei Trouchelle <stro@cpan.org>",
      "Shoichi Kaji <skaji@cpan.org>",
      "SkyMarshal <skymarshal1729@gmail.com>",
      "Sören Kornetzki <soeren.kornetzki@delti.com>",
      "Steve Grazzini <steve.grazzini@grantstreet.com>",
      "Syohei YOSHIDA <syohex@gmail.com>",
      "Tatsuhiko Miyagawa <miyagawa@bulknews.net>",
      "Tom Hukins <tom@eborcom.com>",
      "Tony Cook <tony@develop-help.com>"
   ],
   "x_generated_by_perl" : "v5.28.0",
   "x_serialization_backend" : "Cpanel::JSON::XS version 4.04"
}
PK       ! D�Ч�   �   E  perl5/x86_64-linux-thread-multi/.meta/Alien-Libxml2-0.19/install.jsonnu ��6�$        {"dist":"Alien-Libxml2-0.19","version":0.19,"name":"Alien::Libxml2","provides":{"Alien::Libxml2":{"version":0.19,"file":"lib/Alien/Libxml2.pm"}},"pathname":"P/PL/PLICEASE/Alien-Libxml2-0.19.tar.gz","target":"Alien::Libxml2"}PK       ! 	,H��  �  D  perl5/x86_64-linux-thread-multi/.meta/Alien-Libxml2-0.19/MYMETA.jsonnu ��6�$        {
   "abstract" : "Install the C libxml2 library on your system",
   "author" : [
      "Graham Ollis <plicease@cpan.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "Dist::Zilla version 6.025, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "Alien-Libxml2",
   "prereqs" : {
      "build" : {
         "requires" : {
            "Alien::Build" : "2.37",
            "Alien::Build::MM" : "0.32",
            "ExtUtils::MakeMaker" : "6.52"
         }
      },
      "configure" : {
         "requires" : {
            "Alien::Build" : "2.37",
            "Alien::Build::MM" : "2.37",
            "Alien::Build::Plugin::Build::SearchDep" : "0.35",
            "Alien::Build::Plugin::Download::GitLab" : "0",
            "Alien::Build::Plugin::Prefer::BadVersion" : "1.05",
            "Alien::Build::Plugin::Probe::Vcpkg" : "0",
            "ExtUtils::CBuilder" : "0",
            "ExtUtils::MakeMaker" : "6.52"
         }
      },
      "develop" : {
         "recommends" : {
            "Alien::Build::Plugin::Probe::Vcpkg" : "0",
            "Dist::Zilla::Plugin::AlienBase::Doc" : "0",
            "Dist::Zilla::Plugin::AlienBuild" : "0.11",
            "Dist::Zilla::Plugin::Author::Plicease::Thanks" : "0",
            "Dist::Zilla::Plugin::Author::Plicease::Upload" : "0",
            "Dist::Zilla::Plugin::Prereqs" : "0",
            "Dist::Zilla::Plugin::PruneFiles" : "0",
            "Dist::Zilla::Plugin::RemovePrereqs" : "0",
            "Dist::Zilla::PluginBundle::Author::Plicease" : "2.69",
            "Perl::Critic::Policy::BuiltinFunctions::ProhibitBooleanGrep" : "0",
            "Perl::Critic::Policy::BuiltinFunctions::ProhibitStringyEval" : "0",
            "Perl::Critic::Policy::BuiltinFunctions::ProhibitStringySplit" : "0",
            "Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidGrep" : "0",
            "Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidMap" : "0",
            "Perl::Critic::Policy::ClassHierarchies::ProhibitExplicitISA" : "0",
            "Perl::Critic::Policy::ClassHierarchies::ProhibitOneArgBless" : "0",
            "Perl::Critic::Policy::CodeLayout::ProhibitHardTabs" : "0",
            "Perl::Critic::Policy::CodeLayout::ProhibitTrailingWhitespace" : "0",
            "Perl::Critic::Policy::CodeLayout::RequireConsistentNewlines" : "0",
            "Perl::Critic::Policy::ControlStructures::ProhibitLabelsWithSpecialBlockNames" : "0",
            "Perl::Critic::Policy::ControlStructures::ProhibitMutatingListFunctions" : "0",
            "Perl::Critic::Policy::ControlStructures::ProhibitUnreachableCode" : "0",
            "Perl::Critic::Policy::Freenode::ArrayAssignAref" : "0",
            "Perl::Critic::Policy::Freenode::BarewordFilehandles" : "0",
            "Perl::Critic::Policy::Freenode::ConditionalDeclarations" : "0",
            "Perl::Critic::Policy::Freenode::ConditionalImplicitReturn" : "0",
            "Perl::Critic::Policy::Freenode::DeprecatedFeatures" : "0",
            "Perl::Critic::Policy::Freenode::DiscouragedModules" : "0",
            "Perl::Critic::Policy::Freenode::DollarAB" : "0",
            "Perl::Critic::Policy::Freenode::Each" : "0",
            "Perl::Critic::Policy::Freenode::EmptyReturn" : "0",
            "Perl::Critic::Policy::Freenode::IndirectObjectNotation" : "0",
            "Perl::Critic::Policy::Freenode::LexicalForeachIterator" : "0",
            "Perl::Critic::Policy::Freenode::LoopOnHash" : "0",
            "Perl::Critic::Policy::Freenode::ModPerl" : "0",
            "Perl::Critic::Policy::Freenode::OpenArgs" : "0",
            "Perl::Critic::Policy::Freenode::OverloadOptions" : "0",
            "Perl::Critic::Policy::Freenode::POSIXImports" : "0",
            "Perl::Critic::Policy::Freenode::PackageMatchesFilename" : "0",
            "Perl::Critic::Policy::Freenode::PreferredAlternatives" : "0",
            "Perl::Critic::Policy::Freenode::StrictWarnings" : "0",
            "Perl::Critic::Policy::Freenode::Threads" : "0",
            "Perl::Critic::Policy::Freenode::Wantarray" : "0",
            "Perl::Critic::Policy::Freenode::WarningsSwitch" : "0",
            "Perl::Critic::Policy::Freenode::WhileDiamondDefaultAssignment" : "0",
            "Perl::Critic::Policy::InputOutput::ProhibitBarewordFileHandles" : "0",
            "Perl::Critic::Policy::InputOutput::ProhibitJoinedReadline" : "0",
            "Perl::Critic::Policy::InputOutput::ProhibitTwoArgOpen" : "0",
            "Perl::Critic::Policy::Miscellanea::ProhibitFormats" : "0",
            "Perl::Critic::Policy::Miscellanea::ProhibitUselessNoCritic" : "0",
            "Perl::Critic::Policy::Modules::ProhibitConditionalUseStatements" : "0",
            "Perl::Critic::Policy::Modules::RequireNoMatchVarsWithUseEnglish" : "0",
            "Perl::Critic::Policy::Objects::ProhibitIndirectSyntax" : "0",
            "Perl::Critic::Policy::RegularExpressions::ProhibitUselessTopic" : "0",
            "Perl::Critic::Policy::Subroutines::ProhibitNestedSubs" : "0",
            "Perl::Critic::Policy::ValuesAndExpressions::ProhibitLeadingZeros" : "0",
            "Perl::Critic::Policy::ValuesAndExpressions::ProhibitMixedBooleanOperators" : "0",
            "Perl::Critic::Policy::ValuesAndExpressions::ProhibitSpecialLiteralHeredocTerminator" : "0",
            "Perl::Critic::Policy::ValuesAndExpressions::RequireUpperCaseHeredocTerminator" : "0",
            "Perl::Critic::Policy::Variables::ProhibitPerl4PackageNames" : "0",
            "Perl::Critic::Policy::Variables::ProhibitUnusedVariables" : "0",
            "Software::License::Perl_5" : "0"
         },
         "requires" : {
            "File::Spec" : "0",
            "FindBin" : "0",
            "Perl::Critic" : "0",
            "Test2::Require::Module" : "0.000121",
            "Test2::Tools::PerlCritic" : "0",
            "Test2::V0" : "0.000121",
            "Test::CPAN::Changes" : "0",
            "Test::EOL" : "0",
            "Test::Fixme" : "0.07",
            "Test::More" : "0.98",
            "Test::NoTabs" : "0",
            "Test::Pod" : "0",
            "Test::Pod::Coverage" : "0",
            "Test::Pod::Spelling::CommonMistakes" : "0",
            "Test::Spelling" : "0",
            "Test::Strict" : "0",
            "YAML" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "Alien::Base" : "2.37",
            "Alien::Build" : "0.25",
            "perl" : "5.006"
         }
      },
      "test" : {
         "requires" : {
            "Test2::V0" : "0.000121",
            "Test::Alien" : "0"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "web" : "https://github.com/PerlAlien/Alien-Libxml2/issues"
      },
      "homepage" : "https://metacpan.org/pod/Alien::Libxml2",
      "repository" : {
         "type" : "git",
         "url" : "git://github.com/PerlAlien/Alien-Libxml2.git",
         "web" : "https://github.com/PerlAlien/Alien-Libxml2"
      },
      "x_IRC" : "irc://irc.perl.org/#native"
   },
   "version" : "0.19",
   "x_alienfile" : {
      "generated_by" : "Dist::Zilla::Plugin::AlienBuild version 0.32",
      "requires" : {
         "share" : {
            "Config" : "0",
            "HTTP::Tiny" : "0.044",
            "IO::Socket::SSL" : "1.56",
            "Mozilla::CA" : "0",
            "Net::SSLeay" : "1.49",
            "URI" : "0"
         },
         "system" : {}
      }
   },
   "x_contributors" : [
      "Graham Ollis <plicease@cpan.org>",
      "Shlomi Fish (shlomif)"
   ],
   "x_generated_by_perl" : "v5.36.0",
   "x_serialization_backend" : "Cpanel::JSON::XS version 4.30",
   "x_spdx_expression" : "Artistic-1.0-Perl OR GPL-1.0-or-later",
   "x_use_unsafe_inc" : 0
}
PK       ! Z�X��   �   E  perl5/x86_64-linux-thread-multi/.meta/Alien-Libxml2-0.16/install.jsonnu ��6�$        {"provides":{"Alien::Libxml2":{"version":0.16,"file":"lib/Alien/Libxml2.pm"}},"target":"Alien::Libxml2","version":0.16,"name":"Alien::Libxml2","dist":"Alien-Libxml2-0.16","pathname":"P/PL/PLICEASE/Alien-Libxml2-0.16.tar.gz"}PK       ! w=.  .  D  perl5/x86_64-linux-thread-multi/.meta/Alien-Libxml2-0.16/MYMETA.jsonnu ��6�$        {
   "abstract" : "Install the C libxml2 library on your system",
   "author" : [
      "Graham Ollis <plicease@cpan.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "Dist::Zilla version 6.014, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "Alien-Libxml2",
   "prereqs" : {
      "build" : {
         "requires" : {
            "Alien::Build" : "0.32",
            "Alien::Build::MM" : "0.32",
            "ExtUtils::MakeMaker" : "6.52"
         }
      },
      "configure" : {
         "requires" : {
            "Alien::Build" : "2.12",
            "Alien::Build::MM" : "2.12",
            "Alien::Build::Plugin::Build::SearchDep" : "0.35",
            "Alien::Build::Plugin::Prefer::BadVersion" : "1.05",
            "Alien::Build::Plugin::Probe::Vcpkg" : "0",
            "ExtUtils::CBuilder" : "0",
            "ExtUtils::MakeMaker" : "6.52"
         }
      },
      "develop" : {
         "requires" : {
            "File::Spec" : "0",
            "FindBin" : "0",
            "Test::CPAN::Changes" : "0",
            "Test::EOL" : "0",
            "Test::Fixme" : "0.07",
            "Test::More" : "0.98",
            "Test::NoTabs" : "0",
            "Test::Pod" : "0",
            "Test::Pod::Coverage" : "0",
            "Test::Pod::Spelling::CommonMistakes" : "0",
            "Test::Spelling" : "0",
            "Test::Strict" : "0",
            "YAML" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "Alien::Base" : "2.12",
            "Alien::Build" : "0.25",
            "perl" : "5.006"
         }
      },
      "test" : {
         "requires" : {
            "Test2::V0" : "0.000060",
            "Test::Alien" : "0"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "web" : "https://github.com/Perl5-Alien/Alien-Libxml2/issues"
      },
      "homepage" : "https://metacpan.org/pod/Alien::Libxml2",
      "repository" : {
         "type" : "git",
         "url" : "git://github.com/Perl5-Alien/Alien-Libxml2.git",
         "web" : "https://github.com/Perl5-Alien/Alien-Libxml2"
      },
      "x_IRC" : "irc://irc.perl.org/#native"
   },
   "version" : "0.16",
   "x_alienfile" : {
      "generated_by" : "Dist::Zilla::Plugin::AlienBuild version 0.30",
      "requires" : {
         "share" : {
            "Archive::Tar" : "0",
            "Config" : "0",
            "HTTP::Tiny" : "0.044",
            "IO::Zlib" : "0",
            "Mojo::DOM58" : "1.00",
            "Sort::Versions" : "0",
            "URI" : "0",
            "URI::Escape" : "0"
         },
         "system" : {}
      }
   },
   "x_contributors" : [
      "Graham Ollis <plicease@cpan.org>",
      "Shlomi Fish (shlomif)"
   ],
   "x_generated_by_perl" : "v5.31.10",
   "x_serialization_backend" : "Cpanel::JSON::XS version 4.19",
   "x_spdx_expression" : "Artistic-1.0-Perl OR GPL-1.0-or-later",
   "x_use_unsafe_inc" : 0
}
PK       ! ��^zs  s  A  perl5/x86_64-linux-thread-multi/.meta/YAML-Syck-1.47/install.jsonnu ��6�$        {"pathname":"T/TO/TODDR/YAML-Syck-1.47.tar.gz","dist":"YAML-Syck-1.47","target":"YAML::Syck","provides":{"JSON::Syck":{"file":"lib/JSON/Syck.pm","version":"1.47"},"YAML::Dumper::Syck":{"file":"lib/YAML/Dumper/Syck.pm"},"YAML::Loader::Syck":{"file":"lib/YAML/Loader/Syck.pm"},"YAML::Syck":{"version":"1.47","file":"lib/YAML/Syck.pm"}},"version":"1.47","name":"YAML::Syck"}PK       ! o����  �  @  perl5/x86_64-linux-thread-multi/.meta/YAML-Syck-1.47/MYMETA.jsonnu ��6�$        {
   "abstract" : "Fast, lightweight YAML loader and dumper",
   "author" : [
      "Todd Rinaldo <toddr@cpan.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.76, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "mit"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "YAML-Syck",
   "no_index" : {
      "directory" : [
         "t",
         "inc"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "Test::More" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "perl" : "5.006"
         }
      }
   },
   "provides" : {
      "JSON::Syck" : {
         "file" : "lib/JSON/Syck.pm",
         "version" : "1.47"
      },
      "YAML::Dumper::Syck" : {
         "file" : "lib/YAML/Dumper/Syck.pm"
      },
      "YAML::Loader::Syck" : {
         "file" : "lib/YAML/Loader/Syck.pm"
      },
      "YAML::Syck" : {
         "file" : "lib/YAML/Syck.pm",
         "version" : "1.47"
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "web" : "https://github.com/toddr/YAML-Syck/issues"
      },
      "homepage" : "https://github.com/toddr/YAML-Syck",
      "license" : [
         "https://dev.perl.org/licenses/"
      ],
      "repository" : {
         "type" : "git",
         "url" : "https://github.com/toddr/YAML-Syck.git",
         "web" : "https://github.com/toddr/YAML-Syck"
      }
   },
   "version" : "1.47",
   "x_serialization_backend" : "JSON::PP version 4.16"
}
PK       !  u��F  F  I  perl5/x86_64-linux-thread-multi/.meta/Template-Toolkit-3.106/install.jsonnu ��6�$        {"dist":"Template-Toolkit-3.106","version":3.106,"provides":{"Template::Plugin::String":{"version":3.106,"file":"lib/Template/Plugin/String.pm"},"Template::Plugin::List":{"file":"lib/Template/Plugin/List.pm","version":3.106},"Template::App::ttree":{"file":"lib/Template/App/ttree.pm","version":3.106},"Template":{"version":3.106,"file":"lib/Template.pm"},"Template::Directive":{"version":3.106,"file":"lib/Template/Directive.pm"},"Template::Plugin::View":{"file":"lib/Template/Plugin/View.pm","version":3.106},"Template::Plugin::Iterator":{"file":"lib/Template/Plugin/Iterator.pm","version":3.106},"Template::Stash::XS":{"file":"lib/Template/Stash/XS.pm"},"Template::Plugin::Format":{"file":"lib/Template/Plugin/Format.pm","version":3.106},"Template::Plugin::Datafile":{"file":"lib/Template/Plugin/Datafile.pm","version":3.106},"Template::Monad::Assert":{"version":3.106,"file":"lib/Template/Plugin/Assert.pm"},"Template::Plugin::URL":{"version":3.106,"file":"lib/Template/Plugin/URL.pm"},"Template::Namespace::Constants":{"file":"lib/Template/Namespace/Constants.pm","version":3.106},"Template::Filters":{"file":"lib/Template/Filters.pm","version":3.106},"Template::Plugin::Assert":{"file":"lib/Template/Plugin/Assert.pm","version":3.106},"Template::Plugin::Date::Manip":{"version":3.106,"file":"lib/Template/Plugin/Date.pm"},"Template::Constants":{"file":"lib/Template/Constants.pm","version":3.106},"Template::Exception":{"version":3.106,"file":"lib/Template/Exception.pm"},"Template::Parser":{"version":3.106,"file":"lib/Template/Parser.pm"},"Template::Plugin::Table":{"file":"lib/Template/Plugin/Table.pm","version":3.106},"Template::Toolkit":{"file":"lib/Template/Toolkit.pm","version":3.106},"Template::Monad::Scalar":{"version":3.106,"file":"lib/Template/Plugin/Scalar.pm"},"Template::Provider":{"version":3.106,"file":"lib/Template/Provider.pm"},"Template::Grammar":{"version":3.106,"file":"lib/Template/Grammar.pm"},"Template::VMethods":{"file":"lib/Template/VMethods.pm","version":3.106},"Template::Plugin::Image":{"file":"lib/Template/Plugin/Image.pm","version":3.106},"Template::Iterator":{"file":"lib/Template/Iterator.pm","version":3.106},"Template::Document":{"version":3.106,"file":"lib/Template/Document.pm"},"Template::Plugin::Scalar":{"file":"lib/Template/Plugin/Scalar.pm","version":3.106},"Template::Plugin::File":{"version":3.106,"file":"lib/Template/Plugin/File.pm"},"Template::Plugin::Pod":{"version":3.106,"file":"lib/Template/Plugin/Pod.pm"},"Template::Stash::Context":{"file":"lib/Template/Stash/Context.pm","version":3.106},"Template::Plugin::Date::Calc":{"file":"lib/Template/Plugin/Date.pm","version":3.106},"Template::Perl":{"version":3.106,"file":"lib/Template/Filters.pm"},"Template::View":{"file":"lib/Template/View.pm","version":3.106},"Template::Config":{"version":3.106,"file":"lib/Template/Config.pm"},"Template::Test":{"file":"lib/Template/Test.pm","version":3.106},"Template::Plugin":{"file":"lib/Template/Plugin.pm","version":3.106},"Template::Plugin::HTML":{"file":"lib/Template/Plugin/HTML.pm","version":3.106},"Template::Stash":{"version":3.106,"file":"lib/Template/Stash.pm"},"Template::Plugin::Wrap":{"file":"lib/Template/Plugin/Wrap.pm","version":3.106},"Template::Plugin::Dumper":{"version":3.106,"file":"lib/Template/Plugin/Dumper.pm"},"Template::Context":{"file":"lib/Template/Context.pm","version":3.106},"Template::Plugins":{"version":3.106,"file":"lib/Template/Plugins.pm"},"Template::Base":{"version":3.106,"file":"lib/Template/Base.pm"},"Template::Plugin::Procedural":{"file":"lib/Template/Plugin/Procedural.pm","version":3.106},"Template::Plugin::Date":{"version":3.106,"file":"lib/Template/Plugin/Date.pm"},"Template::Service":{"version":3.106,"file":"lib/Template/Service.pm"},"Template::Plugin::Directory":{"version":3.106,"file":"lib/Template/Plugin/Directory.pm"},"Template::TieString":{"version":3.106,"file":"lib/Template/Config.pm"},"Template::Plugin::Filter":{"file":"lib/Template/Plugin/Filter.pm","version":3.106},"Template::Plugin::Math":{"version":3.106,"file":"lib/Template/Plugin/Math.pm"}},"name":"Template","pathname":"T/TO/TODDR/Template-Toolkit-3.106.tar.gz","target":"Template::Constants"}PK       ! ���    H  perl5/x86_64-linux-thread-multi/.meta/Template-Toolkit-3.106/MYMETA.jsonnu ��6�$        {
   "abstract" : "comprehensive template processing system",
   "author" : [
      "Andy Wardley <abw@wardley.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.76, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "Template-Toolkit",
   "no_index" : {
      "directory" : [
         "t",
         "inc"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "6.48"
         }
      },
      "runtime" : {
         "requires" : {
            "AppConfig" : "1.56",
            "File::Spec" : "0.8",
            "File::Temp" : "0.12",
            "Scalar::Util" : "0",
            "perl" : "5.010"
         }
      },
      "test" : {
         "requires" : {
            "Test::LeakTrace" : "0"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "web" : "https://github.com/abw/Template2/issues"
      },
      "homepage" : "http://www.template-toolkit.org",
      "repository" : {
         "type" : "git",
         "url" : "https://github.com/abw/Template2.git",
         "web" : "https://github.com/abw/Template2"
      }
   },
   "version" : "3.106",
   "x_serialization_backend" : "JSON::PP version 4.16"
}
PK       ! ����   �   D  perl5/x86_64-linux-thread-multi/.meta/Capture-Tiny-0.48/install.jsonnu ��6�$        {"provides":{"Capture::Tiny":{"version":"0.48","file":"lib/Capture/Tiny.pm"}},"target":"Capture::Tiny","version":"0.48","name":"Capture::Tiny","dist":"Capture-Tiny-0.48","pathname":"D/DA/DAGOLDEN/Capture-Tiny-0.48.tar.gz"}PK       ! ][�҆  �  C  perl5/x86_64-linux-thread-multi/.meta/Capture-Tiny-0.48/MYMETA.jsonnu ��6�$        {
   "abstract" : "Capture STDOUT and STDERR from Perl, XS or external programs",
   "author" : [
      "David Golden <dagolden@cpan.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "Dist::Zilla version 6.012, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "apache_2_0"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "Capture-Tiny",
   "no_index" : {
      "directory" : [
         "corpus",
         "examples",
         "t",
         "xt"
      ],
      "package" : [
         "DB"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "6.17"
         }
      },
      "develop" : {
         "requires" : {
            "Dist::Zilla" : "5",
            "Dist::Zilla::Plugin::OSPrereqs" : "0",
            "Dist::Zilla::Plugin::Prereqs" : "0",
            "Dist::Zilla::Plugin::ReleaseStatus::FromVersion" : "0",
            "Dist::Zilla::Plugin::RemovePrereqs" : "0",
            "Dist::Zilla::PluginBundle::DAGOLDEN" : "0.072",
            "File::Spec" : "0",
            "File::Temp" : "0",
            "IO::Handle" : "0",
            "IPC::Open3" : "0",
            "Pod::Coverage::TrustPod" : "0",
            "Pod::Wordlist" : "0",
            "Software::License::Apache_2_0" : "0",
            "Test::CPAN::Meta" : "0",
            "Test::MinimumVersion" : "0",
            "Test::More" : "0",
            "Test::Perl::Critic" : "0",
            "Test::Pod" : "1.41",
            "Test::Pod::Coverage" : "1.08",
            "Test::Portability::Files" : "0",
            "Test::Spelling" : "0.12",
            "Test::Version" : "1"
         }
      },
      "runtime" : {
         "requires" : {
            "Carp" : "0",
            "Exporter" : "0",
            "File::Spec" : "0",
            "File::Temp" : "0",
            "IO::Handle" : "0",
            "Scalar::Util" : "0",
            "perl" : "5.006",
            "strict" : "0",
            "warnings" : "0"
         }
      },
      "test" : {
         "recommends" : {
            "CPAN::Meta" : "2.120900"
         },
         "requires" : {
            "ExtUtils::MakeMaker" : "0",
            "File::Spec" : "0",
            "IO::File" : "0",
            "Test::More" : "0.62",
            "lib" : "0"
         }
      }
   },
   "provides" : {
      "Capture::Tiny" : {
         "file" : "lib/Capture/Tiny.pm",
         "version" : "0.48"
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "web" : "https://github.com/dagolden/Capture-Tiny/issues"
      },
      "homepage" : "https://github.com/dagolden/Capture-Tiny",
      "repository" : {
         "type" : "git",
         "url" : "https://github.com/dagolden/Capture-Tiny.git",
         "web" : "https://github.com/dagolden/Capture-Tiny"
      }
   },
   "version" : "0.48",
   "x_authority" : "cpan:DAGOLDEN",
   "x_contributors" : [
      "Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>",
      "David E. Wheeler <david@justatheory.com>",
      "fecundf <not.com+github@gmail.com>",
      "Graham Knop <haarg@haarg.org>",
      "Peter Rabbitson <ribasushi@cpan.org>"
   ],
   "x_generated_by_perl" : "v5.26.1",
   "x_serialization_backend" : "Cpanel::JSON::XS version 3.0239"
}
PK       ! ��R�c
  c
  D  perl5/x86_64-linux-thread-multi/.meta/XML-LibXML-2.0209/install.jsonnu ��6�$        {"provides":{"XML::LibXML::PI":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::Pattern":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::SAX":{"version":2.0209,"file":"lib/XML/LibXML/SAX.pm"},"XML::LibXML::XPathContext":{"version":2.0209,"file":"lib/XML/LibXML/XPathContext.pm"},"XML::LibXML::SAX::AttributeNode":{"version":2.0209,"file":"lib/XML/LibXML/SAX/Generator.pm"},"XML::LibXML::SAX::Generator":{"version":2.0209,"file":"lib/XML/LibXML/SAX/Generator.pm"},"XML::LibXML::XPathExpression":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::NodeList":{"version":2.0209,"file":"lib/XML/LibXML/NodeList.pm"},"XML::LibXML::Error":{"version":2.0209,"file":"lib/XML/LibXML/Error.pm"},"XML::LibXML::RegExp":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::_SAXParser":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::InputCallback":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::Devel":{"version":2.0209,"file":"lib/XML/LibXML/Devel.pm"},"XML::LibXML::Boolean":{"version":2.0209,"file":"lib/XML/LibXML/Boolean.pm"},"XML::LibXML::AttributeHash":{"version":2.0209,"file":"lib/XML/LibXML/AttributeHash.pm"},"XML::LibXML":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::Literal":{"version":2.0209,"file":"lib/XML/LibXML/Literal.pm"},"XML::LibXML::Reader":{"version":2.0209,"file":"lib/XML/LibXML/Reader.pm"},"XML::LibXML::SAX::Builder":{"version":2.0209,"file":"lib/XML/LibXML/SAX/Builder.pm"},"XML::LibXML::Schema":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::Element":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::Attr":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::Node":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::CDATASection":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::Number":{"version":2.0209,"file":"lib/XML/LibXML/Number.pm"},"XML::LibXML::Namespace":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::ErrNo":{"version":2.0209,"file":"lib/XML/LibXML/ErrNo.pm"},"XML::LibXML::SAX::Parser":{"version":2.0209,"file":"lib/XML/LibXML/SAX/Parser.pm"},"XML::LibXML::Dtd":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::NamedNodeMap":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::Common":{"version":2.0209,"file":"lib/XML/LibXML/Common.pm"},"XML::LibXML::Comment":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::Document":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::DocumentFragment":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::RelaxNG":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::Text":{"version":2.0209,"file":"LibXML.pm"}},"target":"XML::LibXML","version":2.0209,"name":"XML::LibXML","dist":"XML-LibXML-2.0209","pathname":"S/SH/SHLOMIF/XML-LibXML-2.0209.tar.gz"}PK       ! ΅J��	  �	  C  perl5/x86_64-linux-thread-multi/.meta/XML-LibXML-2.0209/MYMETA.jsonnu ��6�$        {
   "abstract" : "Interface to Gnome libxml2 xml parsing and DOM library",
   "author" : [
      "Petr Pajas <PAJAS@cpan.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.70, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "keywords" : [
      "dom",
      "html",
      "libxml",
      "object oriented",
      "oop",
      "parse",
      "parser",
      "parsing",
      "pullparser",
      "sax",
      "sgml",
      "xml",
      "xpath",
      "XPath",
      "xs"
   ],
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "XML-LibXML",
   "no_index" : {
      "directory" : [
         "t",
         "inc",
         "xt"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "Alien::Base::Wrapper" : "0",
            "Alien::Libxml2" : "0.14",
            "Config" : "0",
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "Carp" : "0",
            "DynaLoader" : "0",
            "Encode" : "0",
            "Exporter" : "5.57",
            "IO::Handle" : "0",
            "Scalar::Util" : "0",
            "Tie::Hash" : "0",
            "XML::NamespaceSupport" : "1.07",
            "XML::SAX" : "0.11",
            "XML::SAX::Base" : "0",
            "XML::SAX::DocumentLocator" : "0",
            "XML::SAX::Exception" : "0",
            "base" : "0",
            "constant" : "0",
            "overload" : "0",
            "parent" : "0",
            "perl" : "5.008001",
            "strict" : "0",
            "vars" : "0",
            "warnings" : "0"
         }
      },
      "test" : {
         "requires" : {
            "Config" : "0",
            "Errno" : "0",
            "IO::File" : "0",
            "IO::Handle" : "0",
            "POSIX" : "0",
            "Scalar::Util" : "0",
            "Test::More" : "0",
            "locale" : "0",
            "utf8" : "0"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "repository" : {
         "type" : "git",
         "url" : "https://github.com/shlomif/perl-XML-LibXML.git",
         "web" : "https://github.com/shlomif/perl-XML-LibXML"
      }
   },
   "version" : "2.0209",
   "x_serialization_backend" : "JSON::PP version 4.16"
}
PK       ! ���u!  !  O  perl5/x86_64-linux-thread-multi/.meta/CPAN-Meta-Requirements-2.140/install.jsonnu ��6�$        {"provides":{"CPAN::Meta::Requirements":{"version":"2.140","file":"lib/CPAN/Meta/Requirements.pm"}},"target":"CPAN::Meta::Requirements","version":"2.140","name":"CPAN::Meta::Requirements","dist":"CPAN-Meta-Requirements-2.140","pathname":"D/DA/DAGOLDEN/CPAN-Meta-Requirements-2.140.tar.gz"}PK       ! keTu    N  perl5/x86_64-linux-thread-multi/.meta/CPAN-Meta-Requirements-2.140/MYMETA.jsonnu ��6�$        {
   "abstract" : "a set of version requirements for a CPAN dist",
   "author" : [
      "David Golden <dagolden@cpan.org>",
      "Ricardo Signes <rjbs@cpan.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "Dist::Zilla version 5.042, CPAN::Meta::Converter version 2.150001, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "CPAN-Meta-Requirements",
   "no_index" : {
      "directory" : [
         "corpus",
         "examples",
         "t",
         "xt"
      ],
      "package" : [
         "DB"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "6.17"
         }
      },
      "develop" : {
         "requires" : {
            "Dist::Zilla" : "5",
            "Dist::Zilla::Plugin::Authority" : "0",
            "Dist::Zilla::Plugin::AutoPrereqs" : "0",
            "Dist::Zilla::Plugin::BumpVersionAfterRelease" : "0",
            "Dist::Zilla::Plugin::CPANFile" : "0",
            "Dist::Zilla::Plugin::CheckChangesHasContent" : "0",
            "Dist::Zilla::Plugin::CheckMetaResources" : "0",
            "Dist::Zilla::Plugin::CheckPrereqsIndexed" : "0",
            "Dist::Zilla::Plugin::ConfirmRelease" : "0",
            "Dist::Zilla::Plugin::CopyFilesFromBuild::Filtered" : "0",
            "Dist::Zilla::Plugin::ExecDir" : "0",
            "Dist::Zilla::Plugin::Git::Check" : "0",
            "Dist::Zilla::Plugin::Git::CheckFor::CorrectBranch" : "0",
            "Dist::Zilla::Plugin::Git::Commit" : "0",
            "Dist::Zilla::Plugin::Git::Contributors" : "0",
            "Dist::Zilla::Plugin::Git::GatherDir" : "0",
            "Dist::Zilla::Plugin::Git::Push" : "0",
            "Dist::Zilla::Plugin::Git::Tag" : "0",
            "Dist::Zilla::Plugin::GithubMeta" : "0",
            "Dist::Zilla::Plugin::InsertCopyright" : "0",
            "Dist::Zilla::Plugin::License" : "0",
            "Dist::Zilla::Plugin::MakeMaker" : "0",
            "Dist::Zilla::Plugin::MakeMaker::Highlander" : "0.003",
            "Dist::Zilla::Plugin::Manifest" : "0",
            "Dist::Zilla::Plugin::ManifestSkip" : "0",
            "Dist::Zilla::Plugin::MetaJSON" : "0",
            "Dist::Zilla::Plugin::MetaNoIndex" : "0",
            "Dist::Zilla::Plugin::MetaProvides::Package" : "0",
            "Dist::Zilla::Plugin::MetaTests" : "0",
            "Dist::Zilla::Plugin::MetaYAML" : "0",
            "Dist::Zilla::Plugin::MinimumPerl" : "0",
            "Dist::Zilla::Plugin::NextRelease" : "0",
            "Dist::Zilla::Plugin::OnlyCorePrereqs" : "0.014",
            "Dist::Zilla::Plugin::Pod2Readme" : "0",
            "Dist::Zilla::Plugin::PodCoverageTests" : "0",
            "Dist::Zilla::Plugin::PodSyntaxTests" : "0",
            "Dist::Zilla::Plugin::Prereqs" : "0",
            "Dist::Zilla::Plugin::Prereqs::AuthorDeps" : "0",
            "Dist::Zilla::Plugin::PromptIfStale" : "0",
            "Dist::Zilla::Plugin::PruneCruft" : "0",
            "Dist::Zilla::Plugin::RewriteVersion" : "0",
            "Dist::Zilla::Plugin::RunExtraTests" : "0",
            "Dist::Zilla::Plugin::ShareDir" : "0",
            "Dist::Zilla::Plugin::SurgicalPodWeaver" : "0",
            "Dist::Zilla::Plugin::Test::Compile" : "0",
            "Dist::Zilla::Plugin::Test::MinimumVersion" : "0",
            "Dist::Zilla::Plugin::Test::Perl::Critic" : "0",
            "Dist::Zilla::Plugin::Test::PodSpelling" : "0",
            "Dist::Zilla::Plugin::Test::Portability" : "0",
            "Dist::Zilla::Plugin::Test::ReportPrereqs" : "0",
            "Dist::Zilla::Plugin::Test::Version" : "0",
            "Dist::Zilla::Plugin::TestRelease" : "0",
            "Dist::Zilla::Plugin::UploadToCPAN" : "0",
            "English" : "0",
            "File::Spec" : "0",
            "File::Temp" : "0",
            "IO::Handle" : "0",
            "IPC::Open3" : "0",
            "Pod::Coverage::TrustPod" : "0",
            "Pod::Wordlist" : "0",
            "Software::License::Perl_5" : "0",
            "Test::CPAN::Meta" : "0",
            "Test::More" : "0",
            "Test::Pod" : "1.41",
            "Test::Pod::Coverage" : "1.08",
            "Test::Spelling" : "0.12",
            "Test::Version" : "1",
            "blib" : "1.01"
         }
      },
      "runtime" : {
         "requires" : {
            "B" : "0",
            "Carp" : "0",
            "perl" : "5.006",
            "strict" : "0",
            "version" : "0.88",
            "warnings" : "0"
         }
      },
      "test" : {
         "recommends" : {
            "CPAN::Meta" : "2.120900"
         },
         "requires" : {
            "ExtUtils::MakeMaker" : "0",
            "File::Spec" : "0",
            "Test::More" : "0.88",
            "version" : "0.88"
         }
      }
   },
   "provides" : {
      "CPAN::Meta::Requirements" : {
         "file" : "lib/CPAN/Meta/Requirements.pm",
         "version" : "2.140"
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "web" : "https://github.com/Perl-Toolchain-Gang/CPAN-Meta-Requirements/issues"
      },
      "homepage" : "https://github.com/Perl-Toolchain-Gang/CPAN-Meta-Requirements",
      "repository" : {
         "type" : "git",
         "url" : "https://github.com/Perl-Toolchain-Gang/CPAN-Meta-Requirements.git",
         "web" : "https://github.com/Perl-Toolchain-Gang/CPAN-Meta-Requirements"
      }
   },
   "version" : "2.140",
   "x_authority" : "cpan:DAGOLDEN",
   "x_contributors" : [
      "Ed J <mohawk2@users.noreply.github.com>",
      "Karen Etheridge <ether@cpan.org>",
      "Leon Timmermans <fawaka@gmail.com>",
      "robario <webmaster@robario.com>"
   ]
}
PK       ! ����  �  I  perl5/x86_64-linux-thread-multi/.meta/Scalar-List-Utils-1.55/install.jsonnu ��6�$        {"provides":{"Scalar::Util":{"version":1.55,"file":"lib/Scalar/Util.pm"},"List::Util::XS":{"version":1.55,"file":"lib/List/Util/XS.pm"},"List::Util":{"version":1.55,"file":"lib/List/Util.pm"},"Sub::Util":{"version":1.55,"file":"lib/Sub/Util.pm"}},"target":"List::Util","version":1.55,"name":"List::Util","dist":"Scalar-List-Utils-1.55","pathname":"P/PE/PEVANS/Scalar-List-Utils-1.55.tar.gz"}PK       !  ����  �  H  perl5/x86_64-linux-thread-multi/.meta/Scalar-List-Utils-1.55/MYMETA.jsonnu ��6�$        {
   "abstract" : "Common Scalar and List utility subroutines",
   "author" : [
      "Graham Barr <gbarr@cpan.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "Scalar-List-Utils",
   "no_index" : {
      "directory" : [
         "t",
         "inc"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "perl" : "5.006"
         }
      },
      "test" : {
         "requires" : {
            "Test::More" : "0"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "mailto" : "bug-Scalar-List-Utils@rt.cpan.org",
         "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=Scalar-List-Utils"
      },
      "repository" : {
         "type" : "git",
         "url" : "https://github.com/Scalar-List-Utils/Scalar-List-Utils.git",
         "web" : "https://github.com/Scalar-List-Utils/Scalar-List-Utils"
      }
   },
   "version" : "1.55",
   "x_serialization_backend" : "JSON::PP version 4.04"
}
PK       ! �����  �  H  perl5/x86_64-linux-thread-multi/.meta/ExtUtils-ParseXS-3.35/install.jsonnu ��6�$        {"provides":{"ExtUtils::ParseXS::CountLines":{"version":3.35,"file":"lib/ExtUtils/ParseXS/CountLines.pm"},"ExtUtils::Typemaps":{"version":3.35,"file":"lib/ExtUtils/Typemaps.pm"},"ExtUtils::ParseXS":{"version":3.35,"file":"lib/ExtUtils/ParseXS.pm"},"ExtUtils::Typemaps::InputMap":{"version":3.35,"file":"lib/ExtUtils/Typemaps/InputMap.pm"},"ExtUtils::Typemaps::Cmd":{"version":3.35,"file":"lib/ExtUtils/Typemaps/Cmd.pm"},"ExtUtils::Typemaps::Type":{"version":3.35,"file":"lib/ExtUtils/Typemaps/Type.pm"},"ExtUtils::Typemaps::OutputMap":{"version":3.35,"file":"lib/ExtUtils/Typemaps/OutputMap.pm"},"ExtUtils::ParseXS::Constants":{"version":3.35,"file":"lib/ExtUtils/ParseXS/Constants.pm"},"ExtUtils::ParseXS::Eval":{"version":3.35,"file":"lib/ExtUtils/ParseXS/Eval.pm"},"ExtUtils::ParseXS::Utilities":{"version":3.35,"file":"lib/ExtUtils/ParseXS/Utilities.pm"}},"target":"ExtUtils::ParseXS","version":3.35,"name":"ExtUtils::ParseXS","dist":"ExtUtils-ParseXS-3.35","pathname":"S/SM/SMUELLER/ExtUtils-ParseXS-3.35.tar.gz"}PK       ! �K���  �  G  perl5/x86_64-linux-thread-multi/.meta/ExtUtils-ParseXS-3.35/MYMETA.jsonnu ��6�$        {
   "abstract" : "converts Perl XS code into C code",
   "author" : [
      "Ken Williams <ken@mathforum.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter version 2.150005, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "unknown"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "ExtUtils-ParseXS",
   "no_index" : {
      "directory" : [
         "t",
         "inc"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "6.46"
         }
      },
      "runtime" : {
         "requires" : {
            "Carp" : "0",
            "Cwd" : "0",
            "DynaLoader" : "0",
            "Exporter" : "5.57",
            "ExtUtils::CBuilder" : "0",
            "ExtUtils::MakeMaker" : "6.46",
            "File::Basename" : "0",
            "File::Spec" : "0",
            "Symbol" : "0",
            "Test::More" : "0.47"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "web" : "http://rt.perl.org/rt3/"
      },
      "repository" : {
         "type" : "git",
         "url" : "git://perl5.git.perl.org/gitroot/perl.git"
      }
   },
   "version" : "3.35",
   "x_serialization_backend" : "JSON::PP version 2.27300"
}
PK       ! t���   �   B  perl5/x86_64-linux-thread-multi/.meta/File-Which-1.23/install.jsonnu ��6�$        {"provides":{"File::Which":{"version":1.23,"file":"lib/File/Which.pm"}},"target":"File::Which","version":1.23,"name":"File::Which","dist":"File-Which-1.23","pathname":"P/PL/PLICEASE/File-Which-1.23.tar.gz"}PK       ! I�,\�  �  A  perl5/x86_64-linux-thread-multi/.meta/File-Which-1.23/MYMETA.jsonnu ��6�$        {
   "abstract" : "Perl implementation of the which utility as an API",
   "author" : [
      "Per Einar Ellefsen <pereinar@cpan.org>",
      "Adam Kennedy <adamk@cpan.org>",
      "Graham Ollis <plicease@cpan.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "Dist::Zilla version 6.012, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "File-Which",
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "develop" : {
         "requires" : {
            "FindBin" : "0",
            "Test::EOL" : "0",
            "Test::Fixme" : "0.07",
            "Test::More" : "0.47",
            "Test::NoTabs" : "0",
            "Test::Pod" : "0",
            "Test::Pod::Coverage" : "0",
            "Test::Pod::Spelling::CommonMistakes" : "0",
            "Test::Spelling" : "0",
            "Test::Strict" : "0",
            "YAML" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "perl" : "5.006"
         }
      },
      "test" : {
         "requires" : {
            "Test::More" : "0.47"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "web" : "https://github.com/plicease/File-Which/issues"
      },
      "homepage" : "https://metacpan.org/pod/File::Which",
      "repository" : {
         "type" : "git",
         "url" : "git://github.com/plicease/File-Which.git",
         "web" : "https://github.com/plicease/File-Which"
      }
   },
   "version" : "1.23",
   "x_generated_by_perl" : "v5.29.6",
   "x_serialization_backend" : "Cpanel::JSON::XS version 4.08",
   "x_use_unsafe_inc" : 0
}
PK       ! y���   �   D  perl5/x86_64-linux-thread-multi/.meta/common-sense-3.75/install.jsonnu ��6�$        {"provides":{"common::sense":{"version":3.75,"file":"sense.pm.PL"}},"target":"common::sense","version":3.75,"name":"common::sense","dist":"common-sense-3.75","pathname":"M/ML/MLEHMANN/common-sense-3.75.tar.gz"}PK       ! �0m�    C  perl5/x86_64-linux-thread-multi/.meta/common-sense-3.75/MYMETA.jsonnu ��6�$        {
   "abstract" : "unknown",
   "author" : [
      "unknown"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150001, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "unknown"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "common-sense",
   "no_index" : {
      "directory" : [
         "t",
         "inc"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      }
   },
   "release_status" : "stable",
   "version" : 3.75
}
PK       ! �s�3�
  �
  D  perl5/x86_64-linux-thread-multi/.meta/XML-LibXML-2.0210/install.jsonnu ��6�$        {"version":"2.0210","name":"XML::LibXML","dist":"XML-LibXML-2.0210","target":"XML::LibXML","pathname":"S/SH/SHLOMIF/XML-LibXML-2.0210.tar.gz","provides":{"XML::LibXML::Document":{"version":"2.0210","file":"LibXML.pm"},"XML::LibXML::Attr":{"version":"2.0210","file":"LibXML.pm"},"XML::LibXML::SAX::Parser":{"file":"lib/XML/LibXML/SAX/Parser.pm","version":"2.0210"},"XML::LibXML::Common":{"file":"lib/XML/LibXML/Common.pm","version":"2.0210"},"XML::LibXML::SAX::Builder":{"version":"2.0210","file":"lib/XML/LibXML/SAX/Builder.pm"},"XML::LibXML::Error":{"version":"2.0210","file":"lib/XML/LibXML/Error.pm"},"XML::LibXML::Element":{"file":"LibXML.pm","version":"2.0210"},"XML::LibXML::Devel":{"version":"2.0210","file":"lib/XML/LibXML/Devel.pm"},"XML::LibXML::SAX::AttributeNode":{"version":"2.0210","file":"lib/XML/LibXML/SAX/Generator.pm"},"XML::LibXML::RelaxNG":{"file":"LibXML.pm","version":"2.0210"},"XML::LibXML::SAX":{"file":"lib/XML/LibXML/SAX.pm","version":"2.0210"},"XML::LibXML::Comment":{"file":"LibXML.pm","version":"2.0210"},"XML::LibXML::CDATASection":{"version":"2.0210","file":"LibXML.pm"},"XML::LibXML::NodeList":{"version":"2.0210","file":"lib/XML/LibXML/NodeList.pm"},"XML::LibXML::ErrNo":{"file":"lib/XML/LibXML/ErrNo.pm","version":"2.0210"},"XML::LibXML::XPathExpression":{"version":"2.0210","file":"LibXML.pm"},"XML::LibXML::Boolean":{"file":"lib/XML/LibXML/Boolean.pm","version":"2.0210"},"XML::LibXML::NamedNodeMap":{"version":"2.0210","file":"LibXML.pm"},"XML::LibXML::DocumentFragment":{"version":"2.0210","file":"LibXML.pm"},"XML::LibXML::Node":{"file":"LibXML.pm","version":"2.0210"},"XML::LibXML::Reader":{"version":"2.0210","file":"lib/XML/LibXML/Reader.pm"},"XML::LibXML::Schema":{"version":"2.0210","file":"LibXML.pm"},"XML::LibXML::Pattern":{"file":"LibXML.pm","version":"2.0210"},"XML::LibXML::Namespace":{"version":"2.0210","file":"LibXML.pm"},"XML::LibXML::SAX::Generator":{"file":"lib/XML/LibXML/SAX/Generator.pm","version":"2.0210"},"XML::LibXML::Text":{"version":"2.0210","file":"LibXML.pm"},"XML::LibXML::Dtd":{"file":"LibXML.pm","version":"2.0210"},"XML::LibXML::InputCallback":{"file":"LibXML.pm","version":"2.0210"},"XML::LibXML::RegExp":{"file":"LibXML.pm","version":"2.0210"},"XML::LibXML":{"version":"2.0210","file":"LibXML.pm"},"XML::LibXML::XPathContext":{"file":"lib/XML/LibXML/XPathContext.pm","version":"2.0210"},"XML::LibXML::_SAXParser":{"version":"2.0210","file":"LibXML.pm"},"XML::LibXML::Literal":{"file":"lib/XML/LibXML/Literal.pm","version":"2.0210"},"XML::LibXML::AttributeHash":{"file":"lib/XML/LibXML/AttributeHash.pm","version":"2.0210"},"XML::LibXML::Number":{"version":"2.0210","file":"lib/XML/LibXML/Number.pm"},"XML::LibXML::PI":{"version":"2.0210","file":"LibXML.pm"}}}PK       ! �M�	  �	  C  perl5/x86_64-linux-thread-multi/.meta/XML-LibXML-2.0210/MYMETA.jsonnu ��6�$        {
   "abstract" : "Interface to Gnome libxml2 xml parsing and DOM library",
   "author" : [
      "Petr Pajas <PAJAS@cpan.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.70, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "keywords" : [
      "dom",
      "html",
      "libxml",
      "object oriented",
      "oop",
      "parse",
      "parser",
      "parsing",
      "pullparser",
      "sax",
      "sgml",
      "xml",
      "xpath",
      "XPath",
      "xs"
   ],
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "XML-LibXML",
   "no_index" : {
      "directory" : [
         "t",
         "inc",
         "xt"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "Alien::Base::Wrapper" : "0",
            "Alien::Libxml2" : "0.14",
            "Config" : "0",
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "Carp" : "0",
            "DynaLoader" : "0",
            "Encode" : "0",
            "Exporter" : "5.57",
            "IO::Handle" : "0",
            "Scalar::Util" : "0",
            "Tie::Hash" : "0",
            "XML::NamespaceSupport" : "1.07",
            "XML::SAX" : "0.11",
            "XML::SAX::Base" : "0",
            "XML::SAX::DocumentLocator" : "0",
            "XML::SAX::Exception" : "0",
            "base" : "0",
            "constant" : "0",
            "overload" : "0",
            "parent" : "0",
            "perl" : "5.008001",
            "strict" : "0",
            "vars" : "0",
            "warnings" : "0"
         }
      },
      "test" : {
         "requires" : {
            "Config" : "0",
            "Errno" : "0",
            "IO::File" : "0",
            "IO::Handle" : "0",
            "POSIX" : "0",
            "Scalar::Util" : "0",
            "Test::More" : "0",
            "locale" : "0",
            "utf8" : "0"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "repository" : {
         "type" : "git",
         "url" : "https://github.com/shlomif/perl-XML-LibXML.git",
         "web" : "https://github.com/shlomif/perl-XML-LibXML"
      }
   },
   "version" : "2.0210",
   "x_serialization_backend" : "JSON::PP version 4.16"
}
PK       ! �XHN    ;  perl5/x86_64-linux-thread-multi/.meta/HDB-1.05/install.jsonnu ��6�$        {"provides":{"HDB::Parser":{"version":"1.0","file":"lib/HDB/Parser.pm"},"HDB::Encode":{"version":"1.0","file":"lib/HDB/Encode.pm"},"HDB::CORE":{"version":"1.0","file":"lib/HDB/CORE.pm"},"HDB::MOD::mysql":{"version":"1.0","file":"lib/HDB/MOD/mysql.pm"},"HDB::TABLE":{"version":1.05,"file":"lib/HDB.pm"},"HDB::CMDS":{"version":1.05,"file":"lib/HDB.pm"},"HDB::MOD::oracle":{"version":"1.0","file":"lib/HDB/MOD/oracle.pm"},"DBI":{"version":"1.0","file":"lib/HDB/MOD.pm"},"DBD":{"version":"1.0","file":"lib/HDB/MOD.pm"},"HDB::MOD":{"version":"1.0","file":"lib/HDB/MOD.pm"},"HDB":{"version":1.05,"file":"lib/HDB.pm"},"HDB::MOD::sqlite":{"version":"1.0","file":"lib/HDB/MOD/sqlite.pm"},"HDB::Object":{"version":0.02,"file":"lib/HDB/Object.pm"},"HDB::CMDS::TieHandle":{"version":"1.0","file":"lib/HDB/CMDS.pm"},"HDB::Object::Loader::TieHandler":{"version":0.02,"file":"lib/HDB/Object.pm"},"HDB::Object::Loader":{"version":0.02,"file":"lib/HDB/Object.pm"}},"target":"DBD","version":1.05,"name":"HDB","dist":"HDB-1.05","pathname":"G/GM/GMPASSOS/HDB-1.05.tar.gz"}PK       ! �y�n�  �  :  perl5/x86_64-linux-thread-multi/.meta/HDB-1.05/MYMETA.jsonnu ��6�$        {
   "abstract" : "Hybrid Database - Handles multiple databases with the same interface.",
   "author" : [
      "Graciliano M. P. <gm@virtuasites.com.br>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.50, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "unknown"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "HDB",
   "no_index" : {
      "directory" : [
         "t",
         "inc"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "DBI" : "1.13"
         }
      }
   },
   "release_status" : "stable",
   "version" : "1.05"
}
PK       ! �*�e  e  D  perl5/x86_64-linux-thread-multi/.meta/File-chdir-0.1010/install.jsonnu ��6�$        {"provides":{"File::chdir::ARRAY":{"version":"0.1010","file":"lib/File/chdir.pm"},"File::chdir::SCALAR":{"version":"0.1010","file":"lib/File/chdir.pm"},"File::chdir":{"version":"0.1010","file":"lib/File/chdir.pm"}},"target":"File::chdir","version":"0.1010","name":"File::chdir","dist":"File-chdir-0.1010","pathname":"D/DA/DAGOLDEN/File-chdir-0.1010.tar.gz"}PK       ! �Yb�    C  perl5/x86_64-linux-thread-multi/.meta/File-chdir-0.1010/MYMETA.jsonnu ��6�$        {
   "abstract" : "a more sensible way to change directories",
   "author" : [
      "David Golden <dagolden@cpan.org>",
      "Michael G. Schwern <schwern@pobox.com>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "Dist::Zilla version 5.031, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "File-chdir",
   "no_index" : {
      "directory" : [
         "t",
         "xt",
         "examples",
         "corpus"
      ],
      "package" : [
         "DB"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "6.17"
         }
      },
      "develop" : {
         "requires" : {
            "Dist::Zilla" : "5",
            "Dist::Zilla::PluginBundle::DAGOLDEN" : "0.072",
            "File::Spec" : "0",
            "File::Temp" : "0",
            "IO::Handle" : "0",
            "IPC::Open3" : "0",
            "Pod::Coverage::TrustPod" : "0",
            "Test::CPAN::Meta" : "0",
            "Test::More" : "0",
            "Test::Pod" : "1.41",
            "Test::Pod::Coverage" : "1.08",
            "Test::Spelling" : "0.12",
            "Test::Version" : "1"
         }
      },
      "runtime" : {
         "requires" : {
            "Carp" : "0",
            "Cwd" : "3.16",
            "Exporter" : "0",
            "File::Spec::Functions" : "3.27",
            "perl" : "5.006",
            "strict" : "0",
            "vars" : "0"
         }
      },
      "test" : {
         "recommends" : {
            "CPAN::Meta" : "2.120900"
         },
         "requires" : {
            "ExtUtils::MakeMaker" : "0",
            "File::Spec" : "0",
            "Test::More" : "0",
            "warnings" : "0"
         }
      }
   },
   "provides" : {
      "File::chdir" : {
         "file" : "lib/File/chdir.pm",
         "version" : "0.1010"
      },
      "File::chdir::ARRAY" : {
         "file" : "lib/File/chdir.pm",
         "version" : "0.1010"
      },
      "File::chdir::SCALAR" : {
         "file" : "lib/File/chdir.pm",
         "version" : "0.1010"
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "web" : "https://github.com/dagolden/File-chdir/issues"
      },
      "homepage" : "https://github.com/dagolden/File-chdir",
      "repository" : {
         "type" : "git",
         "url" : "https://github.com/dagolden/File-chdir.git",
         "web" : "https://github.com/dagolden/File-chdir"
      }
   },
   "version" : "0.1010",
   "x_authority" : "cpan:DAGOLDEN",
   "x_contributors" : [
      "Joel Berger <joel.a.berger@gmail.com>"
   ]
}
PK       ! ����   �   H  perl5/x86_64-linux-thread-multi/.meta/Canary-Stability-2013/install.jsonnu ��6�$        {"provides":{"Canary::Stability":{"version":2013,"file":"Stability.pm"}},"target":"Canary::Stability","version":2013,"name":"Canary::Stability","dist":"Canary-Stability-2013","pathname":"M/ML/MLEHMANN/Canary-Stability-2013.tar.gz"}PK       ! �L�G  G  G  perl5/x86_64-linux-thread-multi/.meta/Canary-Stability-2013/MYMETA.jsonnu ��6�$        {
   "abstract" : "unknown",
   "author" : [
      "unknown"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "unknown"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "Canary-Stability",
   "no_index" : {
      "directory" : [
         "t",
         "inc"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      }
   },
   "release_status" : "stable",
   "version" : "2013",
   "x_serialization_backend" : "JSON::PP version 2.27300"
}
PK       ! �*<[�   �   B  perl5/x86_64-linux-thread-multi/.meta/XML-Simple-2.25/install.jsonnu ��6�$        {"provides":{"XML::Simple":{"version":2.25,"file":"lib/XML/Simple.pm"}},"target":"XML::Simple","version":2.25,"name":"XML::Simple","dist":"XML-Simple-2.25","pathname":"G/GR/GRANTM/XML-Simple-2.25.tar.gz"}PK       ! �;��K  K  A  perl5/x86_64-linux-thread-multi/.meta/XML-Simple-2.25/MYMETA.jsonnu ��6�$        {
   "abstract" : "An API for simple XML files",
   "author" : [
      "Grant McLean <grantm@cpan.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "Dist::Zilla version 5.043, CPAN::Meta::Converter version 2.150005, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "XML-Simple",
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "develop" : {
         "requires" : {
            "Test::Pod" : "1.41"
         }
      },
      "runtime" : {
         "requires" : {
            "XML::NamespaceSupport" : "1.04",
            "XML::SAX" : "0.15",
            "XML::SAX::Expat" : "0",
            "perl" : "5.008"
         }
      },
      "test" : {
         "requires" : {
            "File::Temp" : "0",
            "Test::More" : "0.88"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "repository" : {
         "type" : "git",
         "url" : "git://github.com/grantm/xml-simple.git",
         "web" : "https://github.com/grantm/xml-simple"
      }
   },
   "version" : "2.25"
}
PK       ! o^�'�  �  I  perl5/x86_64-linux-thread-multi/.meta/Template-Toolkit-3.009/install.jsonnu ��6�$        {"provides":{"Template::Base":{"version":3.009,"file":"lib/Template/Base.pm"},"Template::Stash::Context":{"version":3.009,"file":"lib/Template/Stash/Context.pm"},"Template::Config":{"version":3.009,"file":"lib/Template/Config.pm"},"Template::Plugin::Date::Calc":{"version":3.009,"file":"lib/Template/Plugin/Date.pm"},"Template::View":{"version":3.009,"file":"lib/Template/View.pm"},"Template::Perl":{"version":3.009,"file":"lib/Template/Filters.pm"},"Template::Plugin::Procedural":{"version":3.009,"file":"lib/Template/Plugin/Procedural.pm"},"Template::Plugin::Table":{"version":3.009,"file":"lib/Template/Plugin/Table.pm"},"Template::Plugin::Filter":{"version":3.009,"file":"lib/Template/Plugin/Filter.pm"},"Template::Iterator":{"version":3.009,"file":"lib/Template/Iterator.pm"},"Template::Plugin::Pod":{"version":3.009,"file":"lib/Template/Plugin/Pod.pm"},"Template::Constants":{"version":3.009,"file":"lib/Template/Constants.pm"},"Template::VMethods":{"version":3.009,"file":"lib/Template/VMethods.pm"},"Template::Monad::Scalar":{"version":3.009,"file":"lib/Template/Plugin/Scalar.pm"},"Template::Plugin::Datafile":{"version":3.009,"file":"lib/Template/Plugin/Datafile.pm"},"Template::Plugin::URL":{"version":3.009,"file":"lib/Template/Plugin/URL.pm"},"Template::Filters":{"version":3.009,"file":"lib/Template/Filters.pm"},"Template::Namespace::Constants":{"version":3.009,"file":"lib/Template/Namespace/Constants.pm"},"Template::Toolkit":{"version":3.009,"file":"lib/Template/Toolkit.pm"},"Template::Context":{"version":3.009,"file":"lib/Template/Context.pm"},"Template::Directive":{"version":3.009,"file":"lib/Template/Directive.pm"},"Template::Plugin":{"version":3.009,"file":"lib/Template/Plugin.pm"},"Template::TieString":{"version":3.009,"file":"lib/Template/Config.pm"},"Template::Plugin::Wrap":{"version":3.009,"file":"lib/Template/Plugin/Wrap.pm"},"Template::Parser":{"version":3.009,"file":"lib/Template/Parser.pm"},"Template::Grammar":{"version":3.009,"file":"lib/Template/Grammar.pm"},"Template::Plugin::HTML":{"version":3.009,"file":"lib/Template/Plugin/HTML.pm"},"Template::Plugin::Format":{"version":3.009,"file":"lib/Template/Plugin/Format.pm"},"Template::Plugin::Scalar":{"version":3.009,"file":"lib/Template/Plugin/Scalar.pm"},"Template::Plugin::Directory":{"version":3.009,"file":"lib/Template/Plugin/Directory.pm"},"Template::Stash::XS":{"file":"lib/Template/Stash/XS.pm"},"Template::Plugin::Dumper":{"version":3.009,"file":"lib/Template/Plugin/Dumper.pm"},"Template::Plugins":{"version":3.009,"file":"lib/Template/Plugins.pm"},"Template::Plugin::Assert":{"version":3.009,"file":"lib/Template/Plugin/Assert.pm"},"Template::Provider":{"version":3.009,"file":"lib/Template/Provider.pm"},"Template::Stash":{"version":3.009,"file":"lib/Template/Stash.pm"},"Template::Plugin::Image":{"version":3.009,"file":"lib/Template/Plugin/Image.pm"},"Template::Plugin::Date::Manip":{"version":3.009,"file":"lib/Template/Plugin/Date.pm"},"Template::Exception":{"version":3.009,"file":"lib/Template/Exception.pm"},"Template::Plugin::String":{"version":3.009,"file":"lib/Template/Plugin/String.pm"},"Template::Document":{"version":3.009,"file":"lib/Template/Document.pm"},"Template::Plugin::Math":{"version":3.009,"file":"lib/Template/Plugin/Math.pm"},"Template::Service":{"version":3.009,"file":"lib/Template/Service.pm"},"Template::Test":{"version":3.009,"file":"lib/Template/Test.pm"},"Template::Monad::Assert":{"version":3.009,"file":"lib/Template/Plugin/Assert.pm"},"Template::Plugin::Iterator":{"version":3.009,"file":"lib/Template/Plugin/Iterator.pm"},"Template":{"version":3.009,"file":"lib/Template.pm"},"Template::Plugin::CGI":{"version":3.009,"file":"lib/Template/Plugin/CGI.pm"},"Template::Plugin::Date":{"version":3.009,"file":"lib/Template/Plugin/Date.pm"},"Template::Plugin::File":{"version":3.009,"file":"lib/Template/Plugin/File.pm"},"Template::Plugin::View":{"version":3.009,"file":"lib/Template/Plugin/View.pm"}},"target":"Template::Constants","version":3.009,"name":"Template","dist":"Template-Toolkit-3.009","pathname":"A/AT/ATOOMIC/Template-Toolkit-3.009.tar.gz"}PK       ! 1g�a�  �  H  perl5/x86_64-linux-thread-multi/.meta/Template-Toolkit-3.009/MYMETA.jsonnu ��6�$        {
   "abstract" : "comprehensive template processing system",
   "author" : [
      "Andy Wardley <abw@wardley.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "Template-Toolkit",
   "no_index" : {
      "directory" : [
         "t",
         "inc"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "AppConfig" : "1.56",
            "File::Spec" : "0.8",
            "File::Temp" : "0.12",
            "Scalar::Util" : "0"
         }
      },
      "test" : {
         "requires" : {
            "CGI" : "4.11",
            "Test::LeakTrace" : "0"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "web" : "https://github.com/abw/Template2/issues"
      },
      "homepage" : "http://www.template-toolkit.org",
      "repository" : {
         "type" : "git",
         "url" : "https://github.com/abw/Template2.git",
         "web" : "https://github.com/abw/Template2"
      }
   },
   "version" : "3.009"
}
PK       ! �s0�  �  G  perl5/x86_64-linux-thread-multi/.meta/Types-Serialiser-1.0/install.jsonnu ��6�$        {"provides":{"JSON::PP::Boolean":{"version":"1.0","file":"Serialiser.pm"},"Types::Serialiser":{"version":"1.0","file":"Serialiser.pm"},"Types::Serialiser::BooleanBase":{"version":"1.0","file":"Serialiser.pm"},"Types::Serialiser::Error":{"version":"1.0","file":"Serialiser.pm"}},"target":"Types::Serialiser","version":"1.0","name":"Types::Serialiser","dist":"Types-Serialiser-1.0","pathname":"M/ML/MLEHMANN/Types-Serialiser-1.0.tar.gz"}PK       ! ��O$l  l  F  perl5/x86_64-linux-thread-multi/.meta/Types-Serialiser-1.0/MYMETA.jsonnu ��6�$        {
   "abstract" : "unknown",
   "author" : [
      "unknown"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 6.8, CPAN::Meta::Converter version 2.120921, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "unknown"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "Types-Serialiser",
   "no_index" : {
      "directory" : [
         "t",
         "inc"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "common::sense" : "0"
         }
      }
   },
   "release_status" : "stable",
   "version" : "1.0"
}
PK       ! 鸞,�   �   ?  perl5/x86_64-linux-thread-multi/.meta/JSON-XS-4.03/install.jsonnu ��6�$        {"pathname":"M/ML/MLEHMANN/JSON-XS-4.03.tar.gz","provides":{"JSON::XS":{"file":"XS.pm","version":4.03}},"name":"JSON::XS","version":4.03,"target":"JSON::XS","dist":"JSON-XS-4.03"}PK       ! Poe�  �  >  perl5/x86_64-linux-thread-multi/.meta/JSON-XS-4.03/MYMETA.jsonnu ��6�$        {
   "abstract" : "unknown",
   "author" : [
      "unknown"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150001, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "unknown"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "JSON-XS",
   "no_index" : {
      "directory" : [
         "t",
         "inc"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "Canary::Stability" : "0",
            "ExtUtils::MakeMaker" : "6.52"
         }
      },
      "runtime" : {
         "requires" : {
            "Types::Serialiser" : "0",
            "common::sense" : "0"
         }
      }
   },
   "release_status" : "stable",
   "version" : "4.03"
}
PK       ! wv�|�   �   C  perl5/x86_64-linux-thread-multi/.meta/Test-Fatal-0.016/install.jsonnu ��6�$        {"provides":{"Test::Fatal":{"version":0.016,"file":"lib/Test/Fatal.pm"}},"target":"Test::Fatal","version":0.016,"name":"Test::Fatal","dist":"Test-Fatal-0.016","pathname":"R/RJ/RJBS/Test-Fatal-0.016.tar.gz"}PK       ! �>�o�J  �J  B  perl5/x86_64-linux-thread-multi/.meta/Test-Fatal-0.016/MYMETA.jsonnu ��6�$        {
   "abstract" : "incredibly simple helpers for testing code with exceptions",
   "author" : [
      "Ricardo Signes <rjbs@cpan.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "Dist::Zilla version 6.015, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "Test-Fatal",
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "develop" : {
         "requires" : {
            "Encode" : "0",
            "Test::Pod" : "1.41"
         }
      },
      "runtime" : {
         "requires" : {
            "Carp" : "0",
            "Exporter" : "5.57",
            "Test::Builder" : "0",
            "Try::Tiny" : "0.07",
            "strict" : "0",
            "warnings" : "0"
         }
      },
      "test" : {
         "recommends" : {
            "CPAN::Meta" : "2.120900"
         },
         "requires" : {
            "ExtUtils::MakeMaker" : "0",
            "File::Spec" : "0",
            "Test::Builder::Tester" : "0",
            "Test::More" : "0.65",
            "overload" : "0"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "web" : "https://github.com/rjbs/Test-Fatal/issues"
      },
      "homepage" : "https://github.com/rjbs/Test-Fatal",
      "repository" : {
         "type" : "git",
         "url" : "https://github.com/rjbs/Test-Fatal.git",
         "web" : "https://github.com/rjbs/Test-Fatal"
      }
   },
   "version" : "0.016",
   "x_Dist_Zilla" : {
      "perl" : {
         "version" : "5.032000"
      },
      "plugins" : [
         {
            "class" : "Dist::Zilla::Plugin::Git::GatherDir",
            "config" : {
               "Dist::Zilla::Plugin::GatherDir" : {
                  "exclude_filename" : [],
                  "exclude_match" : [],
                  "follow_symlinks" : 0,
                  "include_dotfiles" : 0,
                  "prefix" : "",
                  "prune_directory" : [],
                  "root" : "."
               },
               "Dist::Zilla::Plugin::Git::GatherDir" : {
                  "include_untracked" : 0
               }
            },
            "name" : "@RJBS/Git::GatherDir",
            "version" : "2.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::CheckPrereqsIndexed",
            "name" : "@RJBS/CheckPrereqsIndexed",
            "version" : "0.020"
         },
         {
            "class" : "Dist::Zilla::Plugin::CheckExtraTests",
            "name" : "@RJBS/CheckExtraTests",
            "version" : "0.029"
         },
         {
            "class" : "Dist::Zilla::Plugin::PromptIfStale",
            "config" : {
               "Dist::Zilla::Plugin::PromptIfStale" : {
                  "check_all_plugins" : 0,
                  "check_all_prereqs" : 0,
                  "modules" : [
                     "Dist::Zilla::PluginBundle::RJBS"
                  ],
                  "phase" : "build",
                  "run_under_travis" : 0,
                  "skip" : []
               }
            },
            "name" : "@RJBS/RJBS-Outdated",
            "version" : "0.057"
         },
         {
            "class" : "Dist::Zilla::Plugin::PromptIfStale",
            "config" : {
               "Dist::Zilla::Plugin::PromptIfStale" : {
                  "check_all_plugins" : 1,
                  "check_all_prereqs" : 0,
                  "modules" : [],
                  "phase" : "release",
                  "run_under_travis" : 0,
                  "skip" : []
               }
            },
            "name" : "@RJBS/CPAN-Outdated",
            "version" : "0.057"
         },
         {
            "class" : "Dist::Zilla::Plugin::PruneCruft",
            "name" : "@RJBS/@Filter/PruneCruft",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::ManifestSkip",
            "name" : "@RJBS/@Filter/ManifestSkip",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaYAML",
            "name" : "@RJBS/@Filter/MetaYAML",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::License",
            "name" : "@RJBS/@Filter/License",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::Readme",
            "name" : "@RJBS/@Filter/Readme",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::ExecDir",
            "name" : "@RJBS/@Filter/ExecDir",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::ShareDir",
            "name" : "@RJBS/@Filter/ShareDir",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::Manifest",
            "name" : "@RJBS/@Filter/Manifest",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::TestRelease",
            "name" : "@RJBS/@Filter/TestRelease",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::ConfirmRelease",
            "name" : "@RJBS/@Filter/ConfirmRelease",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::UploadToCPAN",
            "name" : "@RJBS/@Filter/UploadToCPAN",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::MakeMaker",
            "config" : {
               "Dist::Zilla::Role::TestRunner" : {
                  "default_jobs" : 9
               }
            },
            "name" : "@RJBS/MakeMaker",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::AutoPrereqs",
            "name" : "@RJBS/AutoPrereqs",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::NextVersion",
            "config" : {
               "Dist::Zilla::Plugin::Git::NextVersion" : {
                  "first_version" : "0.001",
                  "version_by_branch" : 0,
                  "version_regexp" : "(?^:^([0-9]+\\.[0-9]+)$)"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.24.3 (Apple Git-128)",
                  "repo_root" : "."
               }
            },
            "name" : "@RJBS/Git::NextVersion",
            "version" : "2.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::PkgVersion",
            "name" : "@RJBS/PkgVersion",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaConfig",
            "name" : "@RJBS/MetaConfig",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaJSON",
            "name" : "@RJBS/MetaJSON",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::NextRelease",
            "name" : "@RJBS/NextRelease",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::ChangesHasContent",
            "name" : "@RJBS/Test::ChangesHasContent",
            "version" : "0.011"
         },
         {
            "class" : "Dist::Zilla::Plugin::PodSyntaxTests",
            "name" : "@RJBS/PodSyntaxTests",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::ReportPrereqs",
            "name" : "@RJBS/Test::ReportPrereqs",
            "version" : "0.027"
         },
         {
            "class" : "Dist::Zilla::Plugin::Prereqs",
            "config" : {
               "Dist::Zilla::Plugin::Prereqs" : {
                  "phase" : "test",
                  "type" : "requires"
               }
            },
            "name" : "@RJBS/TestMoreWithSubtests",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::PodWeaver",
            "config" : {
               "Dist::Zilla::Plugin::PodWeaver" : {
                  "config_plugins" : [
                     "@RJBS"
                  ],
                  "finder" : [
                     ":InstallModules",
                     ":ExecFiles"
                  ],
                  "plugins" : [
                     {
                        "class" : "Pod::Weaver::Plugin::EnsurePod5",
                        "name" : "@CorePrep/EnsurePod5",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Plugin::H1Nester",
                        "name" : "@CorePrep/H1Nester",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Plugin::SingleEncoding",
                        "name" : "@RJBS/SingleEncoding",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Name",
                        "name" : "@RJBS/Name",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Version",
                        "name" : "@RJBS/Version",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Region",
                        "name" : "@RJBS/Prelude",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Generic",
                        "name" : "@RJBS/Synopsis",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Generic",
                        "name" : "@RJBS/Description",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Generic",
                        "name" : "@RJBS/Overview",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Generic",
                        "name" : "@RJBS/Stability",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Collect",
                        "name" : "Attributes",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Collect",
                        "name" : "Methods",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Collect",
                        "name" : "Functions",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Leftovers",
                        "name" : "@RJBS/Leftovers",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Region",
                        "name" : "@RJBS/postlude",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Authors",
                        "name" : "@RJBS/Authors",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Contributors",
                        "name" : "@RJBS/Contributors",
                        "version" : "0.009"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Legal",
                        "name" : "@RJBS/Legal",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Plugin::Transformer",
                        "name" : "@RJBS/List",
                        "version" : "4.015"
                     }
                  ]
               }
            },
            "name" : "@RJBS/PodWeaver",
            "version" : "4.008"
         },
         {
            "class" : "Dist::Zilla::Plugin::GithubMeta",
            "name" : "@RJBS/GithubMeta",
            "version" : "0.58"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Check",
            "config" : {
               "Dist::Zilla::Plugin::Git::Check" : {
                  "untracked_files" : "die"
               },
               "Dist::Zilla::Role::Git::DirtyFiles" : {
                  "allow_dirty" : [
                     "Changes",
                     "dist.ini"
                  ],
                  "allow_dirty_match" : [],
                  "changelog" : "Changes"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.24.3 (Apple Git-128)",
                  "repo_root" : "."
               }
            },
            "name" : "@RJBS/@Git/Check",
            "version" : "2.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Commit",
            "config" : {
               "Dist::Zilla::Plugin::Git::Commit" : {
                  "add_files_in" : [],
                  "commit_msg" : "v%V%n%n%c"
               },
               "Dist::Zilla::Role::Git::DirtyFiles" : {
                  "allow_dirty" : [
                     "Changes",
                     "dist.ini"
                  ],
                  "allow_dirty_match" : [],
                  "changelog" : "Changes"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.24.3 (Apple Git-128)",
                  "repo_root" : "."
               },
               "Dist::Zilla::Role::Git::StringFormatter" : {
                  "time_zone" : "local"
               }
            },
            "name" : "@RJBS/@Git/Commit",
            "version" : "2.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Tag",
            "config" : {
               "Dist::Zilla::Plugin::Git::Tag" : {
                  "branch" : null,
                  "changelog" : "Changes",
                  "signed" : 0,
                  "tag" : "0.016",
                  "tag_format" : "%v",
                  "tag_message" : "v%V"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.24.3 (Apple Git-128)",
                  "repo_root" : "."
               },
               "Dist::Zilla::Role::Git::StringFormatter" : {
                  "time_zone" : "local"
               }
            },
            "name" : "@RJBS/@Git/Tag",
            "version" : "2.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Push",
            "config" : {
               "Dist::Zilla::Plugin::Git::Push" : {
                  "push_to" : [
                     "origin :",
                     "github :"
                  ],
                  "remotes_must_exist" : 0
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.24.3 (Apple Git-128)",
                  "repo_root" : "."
               }
            },
            "name" : "@RJBS/@Git/Push",
            "version" : "2.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Contributors",
            "config" : {
               "Dist::Zilla::Plugin::Git::Contributors" : {
                  "git_version" : "2.24.3 (Apple Git-128)",
                  "include_authors" : 0,
                  "include_releaser" : 1,
                  "order_by" : "name",
                  "paths" : []
               }
            },
            "name" : "@RJBS/Git::Contributors",
            "version" : "0.035"
         },
         {
            "class" : "Dist::Zilla::Plugin::RemovePrereqs",
            "config" : {
               "Dist::Zilla::Plugin::RemovePrereqs" : {
                  "modules_to_remove" : [
                     "Test::More"
                  ]
               }
            },
            "name" : "RemovePrereqs",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::Prereqs",
            "config" : {
               "Dist::Zilla::Plugin::Prereqs" : {
                  "phase" : "test",
                  "type" : "requires"
               }
            },
            "name" : "TestRequires",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":InstallModules",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":IncModules",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":TestFiles",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":ExtraTestFiles",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":ExecFiles",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":PerlExecFiles",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":ShareFiles",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":MainModule",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":AllFiles",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":NoFiles",
            "version" : "6.015"
         }
      ],
      "zilla" : {
         "class" : "Dist::Zilla::Dist::Builder",
         "config" : {
            "is_trial" : 0
         },
         "version" : "6.015"
      }
   },
   "x_contributors" : [
      "David Golden <dagolden@cpan.org>",
      "Graham Knop <haarg@haarg.org>",
      "Jesse Luehrs <doy@tozt.net>",
      "Joel Bernstein <joel@fysh.org>",
      "Karen Etheridge <ether@cpan.org>"
   ],
   "x_generated_by_perl" : "v5.32.0",
   "x_serialization_backend" : "Cpanel::JSON::XS version 4.19",
   "x_spdx_expression" : "Artistic-1.0-Perl OR GPL-1.0-or-later"
}
PK       ! <�"X  X  C  perl5/x86_64-linux-thread-multi/.meta/Getopt-Long-2.52/install.jsonnu ��6�$        {"provides":{"Getopt::Long":{"version":2.52,"file":"lib/Getopt/Long.pm"},"Getopt::Long::CallBack":{"version":2.52,"file":"lib/Getopt/Long.pm"},"Getopt::Long::Parser":{"version":2.52,"file":"lib/Getopt/Long.pm"}},"target":"Getopt::Long","version":2.52,"name":"Getopt::Long","dist":"Getopt-Long-2.52","pathname":"J/JV/JV/Getopt-Long-2.52.tar.gz"}PK       ! Zb�{�  �  B  perl5/x86_64-linux-thread-multi/.meta/Getopt-Long-2.52/MYMETA.jsonnu ��6�$        {
   "abstract" : "Module to handle parsing command line options",
   "author" : [
      "Johan Vromans (jvromans@squirrel.nl)"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.46, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "unknown"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "Getopt-Long",
   "no_index" : {
      "directory" : [
         "t",
         "inc"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "Pod::Usage" : "1.14"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "repository" : {
         "type" : "git",
         "url" : "https://github.com/sciurius/perl-Getopt-Long.git",
         "web" : "https://github.com/sciurius/perl-Getopt-Long"
      }
   },
   "version" : "2.52",
   "x_serialization_backend" : "JSON::PP version 4.04"
}
PK       ! �}    E  perl5/x86_64-linux-thread-multi/.meta/WWW-Mechanize-2.02/install.jsonnu ��6�$        {"provides":{"WWW::Mechanize::Image":{"version":"2.02","file":"lib/WWW/Mechanize/Image.pm"},"WWW::Mechanize::Link":{"version":"2.02","file":"lib/WWW/Mechanize/Link.pm"},"WWW::Mechanize":{"version":"2.02","file":"lib/WWW/Mechanize.pm"}},"target":"WWW::Mechanize","version":"2.02","name":"WWW::Mechanize","dist":"WWW-Mechanize-2.02","pathname":"O/OA/OALDERS/WWW-Mechanize-2.02.tar.gz"}PK       ! ��	  	  D  perl5/x86_64-linux-thread-multi/.meta/WWW-Mechanize-2.02/MYMETA.jsonnu ��6�$        {
   "abstract" : "Handy web browsing in a Perl object",
   "author" : [
      "Andy Lester <andy at petdance.com>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "Dist::Zilla version 6.015, CPAN::Meta::Converter version 2.150010",
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : 2
   },
   "name" : "WWW-Mechanize",
   "no_index" : {
      "directory" : [
         "examples",
         "t",
         "xt"
      ]
   },
   "prereqs" : {
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         },
         "suggests" : {
            "JSON::PP" : "2.27300"
         }
      },
      "develop" : {
         "recommends" : {
            "Dist::Zilla::PluginBundle::Git::VersionManager" : "0.007"
         },
         "requires" : {
            "Code::TidyAll" : "0.71",
            "Code::TidyAll::Plugin::SortLines::Naturally" : "0.000003",
            "Code::TidyAll::Plugin::Test::Vars" : "0.04",
            "Code::TidyAll::Plugin::UniqueLines" : "0.000003",
            "Encode" : "0",
            "LWP::Protocol::https" : "6.07",
            "Parallel::ForkManager" : "1.19",
            "Perl::Critic" : "1.132",
            "Perl::Tidy" : "20180220",
            "Pod::Coverage::TrustPod" : "0",
            "Test::Code::TidyAll" : "0.50",
            "Test::EOL" : "0",
            "Test::Mojibake" : "0",
            "Test::More" : "0.88",
            "Test::Needs" : "0",
            "Test::Pod" : "1.41",
            "Test::Pod::Coverage" : "1.08",
            "Test::Portability::Files" : "0",
            "Test::RequiresInternet" : "0",
            "Test::Vars" : "0.014",
            "Test::Version" : "1",
            "constant" : "0",
            "lib" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "Carp" : "0",
            "Getopt::Long" : "0",
            "HTML::Form" : "1.00",
            "HTML::HeadParser" : "0",
            "HTML::TokeParser" : "0",
            "HTML::TreeBuilder" : "5",
            "HTTP::Cookies" : "0",
            "HTTP::Request" : "1.30",
            "HTTP::Request::Common" : "0",
            "LWP::UserAgent" : "6.45",
            "Pod::Usage" : "0",
            "Scalar::Util" : "1.14",
            "Tie::RefHash" : "0",
            "URI::URL" : "0",
            "URI::file" : "0",
            "base" : "0",
            "perl" : "5.006",
            "strict" : "0",
            "warnings" : "0"
         }
      },
      "test" : {
         "recommends" : {
            "CPAN::Meta" : "2.120900"
         },
         "requires" : {
            "CGI" : "4.32",
            "Exporter" : "0",
            "ExtUtils::MakeMaker" : "0",
            "File::Spec" : "0",
            "File::Temp" : "0",
            "FindBin" : "0",
            "HTTP::Daemon" : "6.12",
            "HTTP::Response" : "0",
            "HTTP::Server::Simple::CGI" : "0",
            "LWP" : "0",
            "LWP::Simple" : "0",
            "Path::Tiny" : "0",
            "Test::Deep" : "0",
            "Test::Exception" : "0",
            "Test::Fatal" : "0",
            "Test::Memory::Cycle" : "1.06",
            "Test::More" : "0.96",
            "Test::NoWarnings" : "1.04",
            "Test::Output" : "0",
            "Test::Taint" : "1.08",
            "Test::Warnings" : "0",
            "URI" : "0",
            "URI::Escape" : "0",
            "bytes" : "0",
            "lib" : "0"
         }
      }
   },
   "provides" : {
      "WWW::Mechanize" : {
         "file" : "lib/WWW/Mechanize.pm",
         "version" : "2.02"
      },
      "WWW::Mechanize::Image" : {
         "file" : "lib/WWW/Mechanize/Image.pm",
         "version" : "2.02"
      },
      "WWW::Mechanize::Link" : {
         "file" : "lib/WWW/Mechanize/Link.pm",
         "version" : "2.02"
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "web" : "https://github.com/libwww-perl/WWW-Mechanize/issues"
      },
      "homepage" : "https://github.com/libwww-perl/WWW-Mechanize",
      "repository" : {
         "type" : "git",
         "url" : "https://github.com/libwww-perl/WWW-Mechanize.git",
         "web" : "https://github.com/libwww-perl/WWW-Mechanize"
      }
   },
   "version" : "2.02",
   "x_Dist_Zilla" : {
      "perl" : {
         "version" : "5.030002"
      },
      "plugins" : [
         {
            "class" : "Dist::Zilla::Plugin::PromptIfStale",
            "config" : {
               "Dist::Zilla::Plugin::PromptIfStale" : {
                  "check_all_plugins" : 0,
                  "check_all_prereqs" : 0,
                  "modules" : [
                     "Dist::Zilla::PluginBundle::Author::OALDERS"
                  ],
                  "phase" : "build",
                  "run_under_travis" : 0,
                  "skip" : []
               }
            },
            "name" : "@Author::OALDERS/stale modules, build",
            "version" : "0.057"
         },
         {
            "class" : "Dist::Zilla::Plugin::PromptIfStale",
            "config" : {
               "Dist::Zilla::Plugin::PromptIfStale" : {
                  "check_all_plugins" : 1,
                  "check_all_prereqs" : 1,
                  "modules" : [],
                  "phase" : "release",
                  "run_under_travis" : 0,
                  "skip" : []
               }
            },
            "name" : "@Author::OALDERS/stale modules, release",
            "version" : "0.057"
         },
         {
            "class" : "Dist::Zilla::Plugin::OALDERS::TidyAll",
            "name" : "@Author::OALDERS/OALDERS::TidyAll",
            "version" : "0.000028"
         },
         {
            "class" : "Dist::Zilla::Plugin::AutoPrereqs",
            "name" : "@Author::OALDERS/AutoPrereqs",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::MakeMaker",
            "config" : {
               "Dist::Zilla::Role::TestRunner" : {
                  "default_jobs" : "4"
               }
            },
            "name" : "@Author::OALDERS/MakeMaker",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::CPANFile",
            "name" : "@Author::OALDERS/CPANFile",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::ContributorsFile",
            "name" : "@Author::OALDERS/ContributorsFile",
            "version" : "0.3.0"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaJSON",
            "name" : "@Author::OALDERS/MetaJSON",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaYAML",
            "name" : "@Author::OALDERS/MetaYAML",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::Manifest",
            "name" : "@Author::OALDERS/Manifest",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaNoIndex",
            "name" : "@Author::OALDERS/MetaNoIndex",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaConfig",
            "name" : "@Author::OALDERS/MetaConfig",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaResources",
            "name" : "@Author::OALDERS/MetaResources",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::License",
            "name" : "@Author::OALDERS/License",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::InstallGuide",
            "config" : {
               "Dist::Zilla::Role::ModuleMetadata" : {
                  "Module::Metadata" : "1.000037",
                  "version" : "0.006"
               }
            },
            "name" : "@Author::OALDERS/InstallGuide",
            "version" : "1.200013"
         },
         {
            "class" : "Dist::Zilla::Plugin::Prereqs",
            "config" : {
               "Dist::Zilla::Plugin::Prereqs" : {
                  "phase" : "develop",
                  "type" : "requires"
               }
            },
            "name" : "@Author::OALDERS/Modules for use with tidyall",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::ExecDir",
            "name" : "@Author::OALDERS/ExecDir",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::MojibakeTests",
            "name" : "@Author::OALDERS/MojibakeTests",
            "version" : "0.8"
         },
         {
            "class" : "Dist::Zilla::Plugin::PodSyntaxTests",
            "name" : "@Author::OALDERS/PodSyntaxTests",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::EOL",
            "config" : {
               "Dist::Zilla::Plugin::Test::EOL" : {
                  "filename" : "xt/author/eol.t",
                  "finder" : [
                     ":ExecFiles",
                     ":InstallModules",
                     ":TestFiles"
                  ],
                  "trailing_whitespace" : 1
               }
            },
            "name" : "@Author::OALDERS/Test::EOL",
            "version" : "0.19"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::Pod::Coverage::Configurable",
            "name" : "@Author::OALDERS/Test::Pod::Coverage::Configurable",
            "version" : "0.07"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::Portability",
            "config" : {
               "Dist::Zilla::Plugin::Test::Portability" : {
                  "options" : ""
               }
            },
            "name" : "@Author::OALDERS/Test::Portability",
            "version" : "2.001000"
         },
         {
            "class" : "Dist::Zilla::Plugin::TestRelease",
            "name" : "@Author::OALDERS/TestRelease",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::ReportPrereqs",
            "name" : "@Author::OALDERS/Test::ReportPrereqs",
            "version" : "0.028"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::TidyAll",
            "name" : "@Author::OALDERS/Test::TidyAll",
            "version" : "0.04"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::Version",
            "name" : "@Author::OALDERS/Test::Version",
            "version" : "1.09"
         },
         {
            "class" : "Dist::Zilla::Plugin::RunExtraTests",
            "config" : {
               "Dist::Zilla::Role::TestRunner" : {
                  "default_jobs" : "4"
               }
            },
            "name" : "@Author::OALDERS/RunExtraTests",
            "version" : "0.029"
         },
         {
            "class" : "Dist::Zilla::Plugin::PodWeaver",
            "config" : {
               "Dist::Zilla::Plugin::PodWeaver" : {
                  "finder" : [
                     ":InstallModules",
                     ":ExecFiles"
                  ],
                  "plugins" : [
                     {
                        "class" : "Pod::Weaver::Plugin::EnsurePod5",
                        "name" : "@CorePrep/EnsurePod5",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Plugin::H1Nester",
                        "name" : "@CorePrep/H1Nester",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Plugin::SingleEncoding",
                        "name" : "@Default/SingleEncoding",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Name",
                        "name" : "@Default/Name",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Version",
                        "name" : "@Default/Version",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Region",
                        "name" : "@Default/prelude",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Generic",
                        "name" : "SYNOPSIS",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Generic",
                        "name" : "DESCRIPTION",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Generic",
                        "name" : "OVERVIEW",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Collect",
                        "name" : "ATTRIBUTES",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Collect",
                        "name" : "METHODS",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Collect",
                        "name" : "FUNCTIONS",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Leftovers",
                        "name" : "@Default/Leftovers",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Region",
                        "name" : "@Default/postlude",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Authors",
                        "name" : "@Default/Authors",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Legal",
                        "name" : "@Default/Legal",
                        "version" : "4.015"
                     }
                  ]
               }
            },
            "name" : "@Author::OALDERS/PodWeaver",
            "version" : "4.008"
         },
         {
            "class" : "Dist::Zilla::Plugin::PruneCruft",
            "name" : "@Author::OALDERS/PruneCruft",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::CopyFilesFromBuild",
            "name" : "@Author::OALDERS/CopyFilesFromBuild",
            "version" : "0.170880"
         },
         {
            "class" : "Dist::Zilla::Plugin::GithubMeta",
            "name" : "@Author::OALDERS/GithubMeta",
            "version" : "0.58"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::GatherDir",
            "config" : {
               "Dist::Zilla::Plugin::GatherDir" : {
                  "exclude_filename" : [
                     "Install",
                     "LICENSE",
                     "META.json",
                     "Makefile.PL",
                     "README.md",
                     "cpanfile"
                  ],
                  "exclude_match" : [],
                  "follow_symlinks" : 0,
                  "include_dotfiles" : 0,
                  "prefix" : "",
                  "prune_directory" : [],
                  "root" : "."
               },
               "Dist::Zilla::Plugin::Git::GatherDir" : {
                  "include_untracked" : 0
               }
            },
            "name" : "@Author::OALDERS/Git::GatherDir",
            "version" : "2.047"
         },
         {
            "class" : "Dist::Zilla::Plugin::CopyFilesFromRelease",
            "config" : {
               "Dist::Zilla::Plugin::CopyFilesFromRelease" : {
                  "filename" : [
                     "Install"
                  ],
                  "match" : []
               }
            },
            "name" : "@Author::OALDERS/CopyFilesFromRelease",
            "version" : "0.007"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Check",
            "config" : {
               "Dist::Zilla::Plugin::Git::Check" : {
                  "untracked_files" : "die"
               },
               "Dist::Zilla::Role::Git::DirtyFiles" : {
                  "allow_dirty" : [
                     "Changes",
                     "Install",
                     "LICENSE",
                     "META.json",
                     "Makefile.PL",
                     "README.md",
                     "cpanfile",
                     "dist.ini"
                  ],
                  "allow_dirty_match" : [],
                  "changelog" : "Changes"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.28.0",
                  "repo_root" : "."
               }
            },
            "name" : "@Author::OALDERS/Git::Check",
            "version" : "2.047"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Contributors",
            "config" : {
               "Dist::Zilla::Plugin::Git::Contributors" : {
                  "git_version" : "2.28.0",
                  "include_authors" : 0,
                  "include_releaser" : 1,
                  "order_by" : "name",
                  "paths" : []
               }
            },
            "name" : "@Author::OALDERS/Git::Contributors",
            "version" : "0.035"
         },
         {
            "class" : "Dist::Zilla::Plugin::ReadmeAnyFromPod",
            "config" : {
               "Dist::Zilla::Role::FileWatcher" : {
                  "version" : "0.006"
               }
            },
            "name" : "@Author::OALDERS/ReadmeMdInBuild",
            "version" : "0.163250"
         },
         {
            "class" : "Dist::Zilla::Plugin::StaticInstall",
            "config" : {
               "Dist::Zilla::Plugin::StaticInstall" : {
                  "dry_run" : 0,
                  "mode" : "on"
               }
            },
            "name" : "@Author::OALDERS/StaticInstall",
            "version" : "0.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::ShareDir",
            "name" : "@Author::OALDERS/ShareDir",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::TravisCI::StatusBadge",
            "name" : "@Author::OALDERS/TravisCI::StatusBadge",
            "version" : "0.009"
         },
         {
            "class" : "Dist::Zilla::Plugin::CheckIssues",
            "name" : "@Author::OALDERS/CheckIssues",
            "version" : "0.011"
         },
         {
            "class" : "Dist::Zilla::Plugin::ConfirmRelease",
            "name" : "@Author::OALDERS/ConfirmRelease",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::UploadToCPAN",
            "name" : "@Author::OALDERS/UploadToCPAN",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::Prereqs",
            "config" : {
               "Dist::Zilla::Plugin::Prereqs" : {
                  "phase" : "develop",
                  "type" : "recommends"
               }
            },
            "name" : "@Author::OALDERS/@Git::VersionManager/pluginbundle version",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::RewriteVersion::Transitional",
            "config" : {
               "Dist::Zilla::Plugin::RewriteVersion" : {
                  "add_tarball_name" : 0,
                  "finders" : [
                     ":ExecFiles",
                     ":InstallModules"
                  ],
                  "global" : 0,
                  "skip_version_provider" : 0
               },
               "Dist::Zilla::Plugin::RewriteVersion::Transitional" : {}
            },
            "name" : "@Author::OALDERS/@Git::VersionManager/RewriteVersion::Transitional",
            "version" : "0.009"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaProvides::Update",
            "name" : "@Author::OALDERS/@Git::VersionManager/MetaProvides::Update",
            "version" : "0.007"
         },
         {
            "class" : "Dist::Zilla::Plugin::CopyFilesFromRelease",
            "config" : {
               "Dist::Zilla::Plugin::CopyFilesFromRelease" : {
                  "filename" : [
                     "Changes"
                  ],
                  "match" : []
               }
            },
            "name" : "@Author::OALDERS/@Git::VersionManager/CopyFilesFromRelease",
            "version" : "0.007"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Commit",
            "config" : {
               "Dist::Zilla::Plugin::Git::Commit" : {
                  "add_files_in" : [],
                  "commit_msg" : "v%V%n%n%c",
                  "signoff" : 0
               },
               "Dist::Zilla::Role::Git::DirtyFiles" : {
                  "allow_dirty" : [
                     "Changes",
                     "Install",
                     "LICENSE",
                     "META.json",
                     "Makefile.PL",
                     "README.md",
                     "cpanfile",
                     "dist.ini"
                  ],
                  "allow_dirty_match" : [],
                  "changelog" : "Changes"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.28.0",
                  "repo_root" : "."
               },
               "Dist::Zilla::Role::Git::StringFormatter" : {
                  "time_zone" : "local"
               }
            },
            "name" : "@Author::OALDERS/@Git::VersionManager/release snapshot",
            "version" : "2.047"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Tag",
            "config" : {
               "Dist::Zilla::Plugin::Git::Tag" : {
                  "branch" : null,
                  "changelog" : "Changes",
                  "signed" : 0,
                  "tag" : "v2.02",
                  "tag_format" : "v%V",
                  "tag_message" : "v%V"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.28.0",
                  "repo_root" : "."
               },
               "Dist::Zilla::Role::Git::StringFormatter" : {
                  "time_zone" : "local"
               }
            },
            "name" : "@Author::OALDERS/@Git::VersionManager/Git::Tag",
            "version" : "2.047"
         },
         {
            "class" : "Dist::Zilla::Plugin::BumpVersionAfterRelease::Transitional",
            "config" : {
               "Dist::Zilla::Plugin::BumpVersionAfterRelease" : {
                  "finders" : [
                     ":ExecFiles",
                     ":InstallModules"
                  ],
                  "global" : 0,
                  "munge_makefile_pl" : 1
               },
               "Dist::Zilla::Plugin::BumpVersionAfterRelease::Transitional" : {}
            },
            "name" : "@Author::OALDERS/@Git::VersionManager/BumpVersionAfterRelease::Transitional",
            "version" : "0.009"
         },
         {
            "class" : "Dist::Zilla::Plugin::NextRelease",
            "name" : "@Author::OALDERS/@Git::VersionManager/NextRelease",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Commit",
            "config" : {
               "Dist::Zilla::Plugin::Git::Commit" : {
                  "add_files_in" : [],
                  "commit_msg" : "increment $VERSION after %v release",
                  "signoff" : 0
               },
               "Dist::Zilla::Role::Git::DirtyFiles" : {
                  "allow_dirty" : [
                     "Build.PL",
                     "Changes",
                     "Makefile.PL"
                  ],
                  "allow_dirty_match" : [
                     "(?^:^lib/.*\\.pm$)"
                  ],
                  "changelog" : "Changes"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.28.0",
                  "repo_root" : "."
               },
               "Dist::Zilla::Role::Git::StringFormatter" : {
                  "time_zone" : "local"
               }
            },
            "name" : "@Author::OALDERS/@Git::VersionManager/post-release commit",
            "version" : "2.047"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Push",
            "config" : {
               "Dist::Zilla::Plugin::Git::Push" : {
                  "push_to" : [
                     "origin"
                  ],
                  "remotes_must_exist" : 1
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.28.0",
                  "repo_root" : "."
               }
            },
            "name" : "@Author::OALDERS/Git::Push",
            "version" : "2.047"
         },
         {
            "class" : "Dist::Zilla::Plugin::ExecDir",
            "name" : "ExecDir",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::RunExtraTests",
            "config" : {
               "Dist::Zilla::Role::TestRunner" : {
                  "default_jobs" : "4"
               }
            },
            "name" : "RunExtraTests",
            "version" : "0.029"
         },
         {
            "class" : "Dist::Zilla::Plugin::Prereqs",
            "config" : {
               "Dist::Zilla::Plugin::Prereqs" : {
                  "phase" : "runtime",
                  "type" : "requires"
               }
            },
            "name" : "RuntimeRequires",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::Prereqs",
            "config" : {
               "Dist::Zilla::Plugin::Prereqs" : {
                  "phase" : "test",
                  "type" : "requires"
               }
            },
            "name" : "TestRequires",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::Prereqs",
            "config" : {
               "Dist::Zilla::Plugin::Prereqs" : {
                  "phase" : "develop",
                  "type" : "requires"
               }
            },
            "name" : "DevelopRequires",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaProvides::Package",
            "config" : {
               "Dist::Zilla::Plugin::MetaProvides::Package" : {
                  "finder_objects" : [
                     {
                        "class" : "Dist::Zilla::Plugin::FinderCode",
                        "name" : "MetaProvides::Package/AUTOVIV/:InstallModulesPM",
                        "version" : "6.015"
                     }
                  ],
                  "include_underscores" : 0
               },
               "Dist::Zilla::Role::MetaProvider::Provider" : {
                  "$Dist::Zilla::Role::MetaProvider::Provider::VERSION" : "2.002004",
                  "inherit_missing" : 1,
                  "inherit_version" : 1,
                  "meta_noindex" : 1
               },
               "Dist::Zilla::Role::ModuleMetadata" : {
                  "Module::Metadata" : "1.000037",
                  "version" : "0.006"
               }
            },
            "name" : "MetaProvides::Package",
            "version" : "2.004003"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":InstallModules",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":IncModules",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":TestFiles",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":ExtraTestFiles",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":ExecFiles",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":PerlExecFiles",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":ShareFiles",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":MainModule",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":AllFiles",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":NoFiles",
            "version" : "6.015"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : "MetaProvides::Package/AUTOVIV/:InstallModulesPM",
            "version" : "6.015"
         }
      ],
      "zilla" : {
         "class" : "Dist::Zilla::Dist::Builder",
         "config" : {
            "is_trial" : 0
         },
         "version" : "6.015"
      }
   },
   "x_contributors" : [
      "Alexandr Ciornii <alexchorny@gmail.com>",
      "Andrew Grangaard <granny-github@ofb.net>",
      "Andy Lester <andy@petdance.com>",
      "Bernhard Wagner <gitcommit@bernhardwagner.net>",
      "Chase Whitener <capoeirab@cpan.org>",
      "dakkar <dakkar@thenautilus.net>",
      "Dave Doyle <dave.s.doyle@gmail.com>",
      "David Precious <davidp@preshweb.co.uk>",
      "David Steinbrunner <dsteinbrunner@pobox.com>",
      "Desmond Daignault <nawglan@gmail.com>",
      "Ed Avis <eda@waniasset.com>",
      "Evan Zacks <zackse@gmail.com>",
      "Ferenc Erki <erkiferenc@gmail.com>",
      "Flavio Poletti <flavio@polettix.it>",
      "Florian Schlichting <fsfs@debian.org>",
      "Gabor Szabo <szabgab@gmail.com>",
      "Gareth Tunley <gjtunley@gmail.com>",
      "gregor herrmann <gregoa@debian.org>",
      "Grigor Karavardanyan <k.grigor@yahoo.com>",
      "James Raspass <jraspass@gmail.com>",
      "Jason May <jasonmay@bestpractical.com>",
      "Jesse Vincent <jesse@bestpractical.com>",
      "John Beppu <john.beppu@gmail.com>",
      "Jozef Kutej <jozef@kutej.net>",
      "Julien Fiegehenn <simbabque@cpan.org>",
      "Karen Etheridge <ether@cpan.org>",
      "Kirrily 'Skud' Robert <skud@infotrope.net>",
      "Kivanc Yazan <kivancyazan@gmail.com>",
      "Lars Dɪᴇᴄᴋᴏᴡ 迪拉斯 <daxim@cpan.org>",
      "Mark Stosberg <mark@summersault.com>",
      "Martin H. Sluka <martin@sluka.de>",
      "Matthew Chae <mschae@cpan.org>",
      "Matt S Trout <mst@shadowcat.co.uk>",
      "Max Maischein <corion@cpan.org>",
      "Mohammad S Anwar <mohammad.anwar@yahoo.com>",
      "Neil Bowers <neil@bowers.com>",
      "Nik LaBelle <nalabelle@gmail.com>",
      "Olaf Alders <olaf@wundersolutions.com>",
      "Philippe Bruhat (BooK) <book@cpan.org>",
      "Ricardo Signes <rjbs@cpan.org>",
      "Schuyler Langdon <schuyler@velargo.com>",
      "Sergey Romanov <sromanov-dev@yandex.ru>",
      "Shoichi Kaji <skaji@cpan.org>",
      "Steve Scaffidi <stephen@scaffidi.net>",
      "Stuart Johnston <saj_git@thecommune.net>",
      "sunnavy <sunnavy@bestpractical.com>",
      "Varadinsky <varadinsky@yahoo.com>",
      "Ville Skyttä <ville.skytta@iki.fi>",
      "Zefram <zefram@fysh.org>",
      "積丹尼 Dan Jacobson <jidanni@jidanni.org>"
   ],
   "x_generated_by_perl" : "v5.30.2",
   "x_serialization_backend" : "JSON::PP version 2.97001",
   "x_spdx_expression" : "Artistic-1.0-Perl OR GPL-1.0-or-later",
   "x_static_install" : 1
}
PK       ! P��Da
  a
  D  perl5/x86_64-linux-thread-multi/.meta/XML-LibXML-2.0213/install.jsonnu ��6�$        {"dist":"XML-LibXML-2.0213","provides":{"XML::LibXML::Attr":{"file":"LibXML.pm","version":2.0213},"XML::LibXML::Reader":{"file":"lib/XML/LibXML/Reader.pm","version":2.0213},"XML::LibXML::PI":{"version":2.0213,"file":"LibXML.pm"},"XML::LibXML::RegExp":{"version":2.0213,"file":"LibXML.pm"},"XML::LibXML::Dtd":{"version":2.0213,"file":"LibXML.pm"},"XML::LibXML::XPathContext":{"version":2.0213,"file":"lib/XML/LibXML/XPathContext.pm"},"XML::LibXML::SAX":{"version":2.0213,"file":"lib/XML/LibXML/SAX.pm"},"XML::LibXML::Node":{"file":"LibXML.pm","version":2.0213},"XML::LibXML::DocumentFragment":{"version":2.0213,"file":"LibXML.pm"},"XML::LibXML::SAX::Builder":{"file":"lib/XML/LibXML/SAX/Builder.pm","version":2.0213},"XML::LibXML::Comment":{"version":2.0213,"file":"LibXML.pm"},"XML::LibXML::XPathExpression":{"version":2.0213,"file":"LibXML.pm"},"XML::LibXML::ErrNo":{"file":"lib/XML/LibXML/ErrNo.pm","version":2.0213},"XML::LibXML::AttributeHash":{"version":2.0213,"file":"lib/XML/LibXML/AttributeHash.pm"},"XML::LibXML::Namespace":{"file":"LibXML.pm","version":2.0213},"XML::LibXML::_SAXParser":{"file":"LibXML.pm","version":2.0213},"XML::LibXML::SAX::AttributeNode":{"version":2.0213,"file":"lib/XML/LibXML/SAX/Generator.pm"},"XML::LibXML":{"file":"LibXML.pm","version":2.0213},"XML::LibXML::Common":{"version":2.0213,"file":"lib/XML/LibXML/Common.pm"},"XML::LibXML::SAX::Generator":{"version":2.0213,"file":"lib/XML/LibXML/SAX/Generator.pm"},"XML::LibXML::NodeList":{"version":2.0213,"file":"lib/XML/LibXML/NodeList.pm"},"XML::LibXML::Schema":{"version":2.0213,"file":"LibXML.pm"},"XML::LibXML::Literal":{"version":2.0213,"file":"lib/XML/LibXML/Literal.pm"},"XML::LibXML::NamedNodeMap":{"version":2.0213,"file":"LibXML.pm"},"XML::LibXML::Text":{"file":"LibXML.pm","version":2.0213},"XML::LibXML::RelaxNG":{"version":2.0213,"file":"LibXML.pm"},"XML::LibXML::Boolean":{"version":2.0213,"file":"lib/XML/LibXML/Boolean.pm"},"XML::LibXML::Devel":{"file":"lib/XML/LibXML/Devel.pm","version":2.0213},"XML::LibXML::Element":{"version":2.0213,"file":"LibXML.pm"},"XML::LibXML::Document":{"file":"LibXML.pm","version":2.0213},"XML::LibXML::CDATASection":{"version":2.0213,"file":"LibXML.pm"},"XML::LibXML::SAX::Parser":{"version":2.0213,"file":"lib/XML/LibXML/SAX/Parser.pm"},"XML::LibXML::InputCallback":{"version":2.0213,"file":"LibXML.pm"},"XML::LibXML::Pattern":{"version":2.0213,"file":"LibXML.pm"},"XML::LibXML::Number":{"version":2.0213,"file":"lib/XML/LibXML/Number.pm"},"XML::LibXML::Error":{"version":2.0213,"file":"lib/XML/LibXML/Error.pm"}},"version":2.0213,"target":"XML::LibXML","pathname":"T/TO/TODDR/XML-LibXML-2.0213.tar.gz","name":"XML::LibXML"}PK       ! �&
  &
  C  perl5/x86_64-linux-thread-multi/.meta/XML-LibXML-2.0213/MYMETA.jsonnu ��6�$        {
   "abstract" : "Interface to Gnome libxml2 xml parsing and DOM library",
   "author" : [
      "Petr Pajas <PAJAS@cpan.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.76, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "keywords" : [
      "dom",
      "html",
      "libxml",
      "object oriented",
      "oop",
      "parse",
      "parser",
      "parsing",
      "pullparser",
      "sax",
      "sgml",
      "xml",
      "xpath",
      "XPath",
      "xs"
   ],
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "XML-LibXML",
   "no_index" : {
      "directory" : [
         "t",
         "inc",
         "xt"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "Alien::Base::Wrapper" : "0",
            "Alien::Libxml2" : "0.14",
            "Config" : "0",
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "Carp" : "0",
            "DynaLoader" : "0",
            "Encode" : "0",
            "Exporter" : "5.57",
            "IO::Handle" : "0",
            "Scalar::Util" : "0",
            "Tie::Hash" : "0",
            "XML::NamespaceSupport" : "1.07",
            "XML::SAX" : "0.11",
            "XML::SAX::Base" : "0",
            "XML::SAX::DocumentLocator" : "0",
            "XML::SAX::Exception" : "0",
            "base" : "0",
            "constant" : "0",
            "overload" : "0",
            "parent" : "0",
            "perl" : "5.008001",
            "strict" : "0",
            "warnings" : "0"
         }
      },
      "test" : {
         "requires" : {
            "Config" : "0",
            "Errno" : "0",
            "IO::File" : "0",
            "IO::Handle" : "0",
            "POSIX" : "0",
            "Scalar::Util" : "0",
            "Test::More" : "0",
            "locale" : "0",
            "utf8" : "0"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "web" : "https://github.com/cpan-authors/XML-LibXML/issues"
      },
      "repository" : {
         "type" : "git",
         "url" : "https://github.com/cpan-authors/XML-LibXML.git",
         "web" : "https://github.com/cpan-authors/XML-LibXML"
      }
   },
   "version" : "2.0213",
   "x_serialization_backend" : "JSON::PP version 4.16"
}
PK       ! z�K�   �   @  perl5/x86_64-linux-thread-multi/.meta/Try-Tiny-0.30/install.jsonnu ��6�$        {"provides":{"Try::Tiny":{"version":"0.30","file":"lib/Try/Tiny.pm"}},"target":"Try::Tiny","version":"0.30","name":"Try::Tiny","dist":"Try-Tiny-0.30","pathname":"E/ET/ETHER/Try-Tiny-0.30.tar.gz"}PK       ! X�\H��  ��  ?  perl5/x86_64-linux-thread-multi/.meta/Try-Tiny-0.30/MYMETA.jsonnu ��6�$        {
   "abstract" : "Minimal try/catch with proper preservation of $@",
   "author" : [
      "יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>",
      "Jesse Luehrs <doy@tozt.net>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "Dist::Zilla version 6.010, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "license" : [
      "mit"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "Try-Tiny",
   "no_index" : {
      "directory" : [
         "t",
         "xt"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         },
         "suggests" : {
            "JSON::PP" : "2.27300"
         }
      },
      "develop" : {
         "recommends" : {
            "Dist::Zilla::PluginBundle::Author::ETHER" : "0.132"
         },
         "requires" : {
            "Capture::Tiny" : "0.12",
            "Encode" : "0",
            "File::Spec" : "0",
            "IO::Handle" : "0",
            "IPC::Open3" : "0",
            "Pod::Coverage::TrustPod" : "0",
            "Pod::Wordlist" : "0",
            "Sub::Name" : "0.08",
            "Sub::Util" : "0",
            "Test::CPAN::Changes" : "0.19",
            "Test::CPAN::Meta" : "0",
            "Test::EOL" : "0",
            "Test::Kwalitee" : "1.21",
            "Test::MinimumVersion" : "0",
            "Test::Mojibake" : "0",
            "Test::More" : "0.96",
            "Test::NoTabs" : "0",
            "Test::Pod" : "1.41",
            "Test::Pod::Coverage" : "1.08",
            "Test::Pod::No404s" : "0",
            "Test::Portability::Files" : "0",
            "Test::Spelling" : "0.12"
         },
         "suggests" : {
            "Dist::Zilla" : "5",
            "Dist::Zilla::Plugin::Authority" : "1.009",
            "Dist::Zilla::Plugin::AutoMetaResources" : "0",
            "Dist::Zilla::Plugin::AutoPrereqs" : "5.038",
            "Dist::Zilla::Plugin::Breaks" : "0",
            "Dist::Zilla::Plugin::BumpVersionAfterRelease::Transitional" : "0.004",
            "Dist::Zilla::Plugin::CheckIssues" : "0",
            "Dist::Zilla::Plugin::CheckMetaResources" : "0",
            "Dist::Zilla::Plugin::CheckPrereqsIndexed" : "0.019",
            "Dist::Zilla::Plugin::CheckSelfDependency" : "0",
            "Dist::Zilla::Plugin::CheckStrictVersion" : "0",
            "Dist::Zilla::Plugin::ConfirmRelease" : "0",
            "Dist::Zilla::Plugin::CopyFilesFromRelease" : "0",
            "Dist::Zilla::Plugin::EnsureLatestPerl" : "0",
            "Dist::Zilla::Plugin::FileFinder::ByName" : "0",
            "Dist::Zilla::Plugin::FileFinder::Filter" : "0",
            "Dist::Zilla::Plugin::GenerateFile::FromShareDir" : "0",
            "Dist::Zilla::Plugin::Git::Check" : "0",
            "Dist::Zilla::Plugin::Git::CheckFor::CorrectBranch" : "0.004",
            "Dist::Zilla::Plugin::Git::CheckFor::MergeConflicts" : "0",
            "Dist::Zilla::Plugin::Git::Commit" : "2.020",
            "Dist::Zilla::Plugin::Git::Contributors" : "0.029",
            "Dist::Zilla::Plugin::Git::Describe" : "0.004",
            "Dist::Zilla::Plugin::Git::GatherDir" : "2.016",
            "Dist::Zilla::Plugin::Git::Push" : "0",
            "Dist::Zilla::Plugin::Git::Remote::Check" : "0",
            "Dist::Zilla::Plugin::Git::Tag" : "0",
            "Dist::Zilla::Plugin::GitHub::Update" : "0.40",
            "Dist::Zilla::Plugin::GithubMeta" : "0.54",
            "Dist::Zilla::Plugin::InstallGuide" : "1.200005",
            "Dist::Zilla::Plugin::Keywords" : "0.004",
            "Dist::Zilla::Plugin::License" : "5.038",
            "Dist::Zilla::Plugin::MakeMaker" : "0",
            "Dist::Zilla::Plugin::Manifest" : "0",
            "Dist::Zilla::Plugin::MetaConfig" : "0",
            "Dist::Zilla::Plugin::MetaJSON" : "0",
            "Dist::Zilla::Plugin::MetaNoIndex" : "0",
            "Dist::Zilla::Plugin::MetaProvides::Package" : "1.15000002",
            "Dist::Zilla::Plugin::MetaTests" : "0",
            "Dist::Zilla::Plugin::MetaYAML" : "0",
            "Dist::Zilla::Plugin::MinimumPerl" : "1.006",
            "Dist::Zilla::Plugin::MojibakeTests" : "0.8",
            "Dist::Zilla::Plugin::NextRelease" : "5.033",
            "Dist::Zilla::Plugin::OnlyCorePrereqs" : "0",
            "Dist::Zilla::Plugin::PodCoverageTests" : "5.040",
            "Dist::Zilla::Plugin::PodSyntaxTests" : "5.040",
            "Dist::Zilla::Plugin::PodWeaver" : "4.005",
            "Dist::Zilla::Plugin::Prereqs" : "0",
            "Dist::Zilla::Plugin::Prereqs::AuthorDeps" : "0.006",
            "Dist::Zilla::Plugin::Prereqs::Soften" : "0",
            "Dist::Zilla::Plugin::PromptIfStale" : "0",
            "Dist::Zilla::Plugin::Readme" : "0",
            "Dist::Zilla::Plugin::ReadmeAnyFromPod" : "0.142180",
            "Dist::Zilla::Plugin::RewriteVersion::Transitional" : "0.004",
            "Dist::Zilla::Plugin::Run::AfterBuild" : "0.041",
            "Dist::Zilla::Plugin::Run::AfterRelease" : "0.038",
            "Dist::Zilla::Plugin::RunExtraTests" : "0.024",
            "Dist::Zilla::Plugin::StaticInstall" : "0.005",
            "Dist::Zilla::Plugin::Substitute" : "0",
            "Dist::Zilla::Plugin::Test::CPAN::Changes" : "0.012",
            "Dist::Zilla::Plugin::Test::ChangesHasContent" : "0",
            "Dist::Zilla::Plugin::Test::CheckBreaks" : "0.018",
            "Dist::Zilla::Plugin::Test::Compile" : "2.039",
            "Dist::Zilla::Plugin::Test::EOL" : "0.17",
            "Dist::Zilla::Plugin::Test::Kwalitee" : "2.10",
            "Dist::Zilla::Plugin::Test::MinimumVersion" : "2.000003",
            "Dist::Zilla::Plugin::Test::NoTabs" : "0.08",
            "Dist::Zilla::Plugin::Test::Pod::No404s" : "1.003",
            "Dist::Zilla::Plugin::Test::PodSpelling" : "2.006003",
            "Dist::Zilla::Plugin::Test::Portability" : "2.000007",
            "Dist::Zilla::Plugin::Test::ReportPrereqs" : "0.022",
            "Dist::Zilla::Plugin::TestRelease" : "0",
            "Dist::Zilla::Plugin::UploadToCPAN" : "0",
            "Dist::Zilla::Plugin::UseUnsafeInc" : "0",
            "Dist::Zilla::PluginBundle::Author::ETHER" : "0.119",
            "Dist::Zilla::PluginBundle::Git::VersionManager" : "0",
            "Software::License::MIT" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "Carp" : "0",
            "Exporter" : "5.57",
            "constant" : "0",
            "perl" : "5.006",
            "strict" : "0",
            "warnings" : "0"
         },
         "suggests" : {
            "Sub::Name" : "0.08",
            "Sub::Util" : "0"
         }
      },
      "test" : {
         "recommends" : {
            "CPAN::Meta" : "2.120900"
         },
         "requires" : {
            "ExtUtils::MakeMaker" : "0",
            "File::Spec" : "0",
            "Test::More" : "0",
            "if" : "0"
         },
         "suggests" : {
            "CPAN::Meta::Check" : "0.011",
            "CPAN::Meta::Requirements" : "0",
            "Capture::Tiny" : "0.12"
         }
      }
   },
   "provides" : {
      "Try::Tiny" : {
         "file" : "lib/Try/Tiny.pm",
         "version" : "0.30"
      }
   },
   "release_status" : "stable",
   "resources" : {
      "bugtracker" : {
         "mailto" : "bug-Try-Tiny@rt.cpan.org",
         "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=Try-Tiny"
      },
      "homepage" : "https://github.com/p5sagit/Try-Tiny",
      "repository" : {
         "type" : "git",
         "url" : "https://github.com/p5sagit/Try-Tiny.git",
         "web" : "https://github.com/p5sagit/Try-Tiny"
      }
   },
   "version" : "0.30",
   "x_Dist_Zilla" : {
      "perl" : {
         "version" : "5.027006"
      },
      "plugins" : [
         {
            "class" : "Dist::Zilla::Plugin::FileFinder::Filter",
            "name" : "all_files_but_using_5.10_features",
            "version" : "6.010"
         },
         {
            "class" : "Dist::Zilla::Plugin::PromptIfStale",
            "config" : {
               "Dist::Zilla::Plugin::PromptIfStale" : {
                  "check_all_plugins" : 0,
                  "check_all_prereqs" : 0,
                  "modules" : [
                     "Dist::Zilla::PluginBundle::Author::ETHER"
                  ],
                  "phase" : "build",
                  "run_under_travis" : 0,
                  "skip" : []
               }
            },
            "name" : "@Author::ETHER/stale modules, build",
            "version" : "0.054"
         },
         {
            "class" : "Dist::Zilla::Plugin::PromptIfStale",
            "config" : {
               "Dist::Zilla::Plugin::PromptIfStale" : {
                  "check_all_plugins" : 1,
                  "check_all_prereqs" : 1,
                  "modules" : [],
                  "phase" : "release",
                  "run_under_travis" : 0,
                  "skip" : []
               }
            },
            "name" : "@Author::ETHER/stale modules, release",
            "version" : "0.054"
         },
         {
            "class" : "Dist::Zilla::Plugin::FileFinder::ByName",
            "name" : "@Author::ETHER/Examples",
            "version" : "6.010"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::GatherDir",
            "config" : {
               "Dist::Zilla::Plugin::GatherDir" : {
                  "exclude_filename" : [
                     "CONTRIBUTING",
                     "INSTALL",
                     "LICENCE",
                     "README.pod"
                  ],
                  "exclude_match" : [],
                  "follow_symlinks" : 0,
                  "include_dotfiles" : 0,
                  "prefix" : "",
                  "prune_directory" : [],
                  "root" : "."
               },
               "Dist::Zilla::Plugin::Git::GatherDir" : {
                  "include_untracked" : 0
               }
            },
            "name" : "@Author::ETHER/Git::GatherDir",
            "version" : "2.043"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaYAML",
            "name" : "@Author::ETHER/MetaYAML",
            "version" : "6.010"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaJSON",
            "name" : "@Author::ETHER/MetaJSON",
            "version" : "6.010"
         },
         {
            "class" : "Dist::Zilla::Plugin::Readme",
            "name" : "@Author::ETHER/Readme",
            "version" : "6.010"
         },
         {
            "class" : "Dist::Zilla::Plugin::Manifest",
            "name" : "@Author::ETHER/Manifest",
            "version" : "6.010"
         },
         {
            "class" : "Dist::Zilla::Plugin::License",
            "name" : "@Author::ETHER/License",
            "version" : "6.010"
         },
         {
            "class" : "Dist::Zilla::Plugin::GenerateFile::FromShareDir",
            "config" : {
               "Dist::Zilla::Plugin::GenerateFile::FromShareDir" : {
                  "destination_filename" : "CONTRIBUTING",
                  "dist" : "Dist-Zilla-PluginBundle-Author-ETHER",
                  "encoding" : "UTF-8",
                  "has_xs" : 0,
                  "location" : "build",
                  "source_filename" : "CONTRIBUTING"
               },
               "Dist::Zilla::Role::RepoFileInjector" : {
                  "allow_overwrite" : 1,
                  "repo_root" : ".",
                  "version" : "0.007"
               }
            },
            "name" : "@Author::ETHER/generate CONTRIBUTING",
            "version" : "0.013"
         },
         {
            "class" : "Dist::Zilla::Plugin::InstallGuide",
            "name" : "@Author::ETHER/InstallGuide",
            "version" : "1.200007"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::Compile",
            "config" : {
               "Dist::Zilla::Plugin::Test::Compile" : {
                  "bail_out_on_fail" : 1,
                  "fail_on_warning" : "author",
                  "fake_home" : 0,
                  "filename" : "xt/author/00-compile.t",
                  "module_finder" : [
                     ":InstallModules"
                  ],
                  "needs_display" : 0,
                  "phase" : "develop",
                  "script_finder" : [
                     ":PerlExecFiles",
                     "@Author::ETHER/Examples"
                  ],
                  "skips" : [],
                  "switch" : []
               }
            },
            "name" : "@Author::ETHER/Test::Compile",
            "version" : "2.058"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::NoTabs",
            "config" : {
               "Dist::Zilla::Plugin::Test::NoTabs" : {
                  "filename" : "xt/author/no-tabs.t",
                  "finder" : [
                     ":InstallModules",
                     ":ExecFiles",
                     "@Author::ETHER/Examples",
                     ":TestFiles",
                     ":ExtraTestFiles"
                  ]
               }
            },
            "name" : "@Author::ETHER/Test::NoTabs",
            "version" : "0.15"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::EOL",
            "config" : {
               "Dist::Zilla::Plugin::Test::EOL" : {
                  "filename" : "xt/author/eol.t",
                  "finder" : [
                     ":ExecFiles",
                     ":ExtraTestFiles",
                     ":InstallModules",
                     ":TestFiles",
                     "@Author::ETHER/Examples"
                  ],
                  "trailing_whitespace" : 1
               }
            },
            "name" : "@Author::ETHER/Test::EOL",
            "version" : "0.19"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaTests",
            "name" : "@Author::ETHER/MetaTests",
            "version" : "6.010"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::CPAN::Changes",
            "config" : {
               "Dist::Zilla::Plugin::Test::CPAN::Changes" : {
                  "changelog" : "Changes"
               }
            },
            "name" : "@Author::ETHER/Test::CPAN::Changes",
            "version" : "0.012"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::ChangesHasContent",
            "name" : "@Author::ETHER/Test::ChangesHasContent",
            "version" : "0.011"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::MinimumVersion",
            "name" : "@Author::ETHER/Test::MinimumVersion",
            "version" : "2.000007"
         },
         {
            "class" : "Dist::Zilla::Plugin::PodSyntaxTests",
            "name" : "@Author::ETHER/PodSyntaxTests",
            "version" : "6.010"
         },
         {
            "class" : "Dist::Zilla::Plugin::PodCoverageTests",
            "name" : "@Author::ETHER/PodCoverageTests",
            "version" : "6.010"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::PodSpelling",
            "config" : {
               "Dist::Zilla::Plugin::Test::PodSpelling" : {
                  "directories" : [
                     "examples",
                     "lib",
                     "script",
                     "t",
                     "xt"
                  ],
                  "spell_cmd" : "",
                  "stopwords" : [
                     "irc"
                  ],
                  "wordlist" : "Pod::Wordlist"
               }
            },
            "name" : "@Author::ETHER/Test::PodSpelling",
            "version" : "2.007005"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::Pod::No404s",
            "name" : "@Author::ETHER/Test::Pod::No404s",
            "version" : "1.004"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::Kwalitee",
            "config" : {
               "Dist::Zilla::Plugin::Test::Kwalitee" : {
                  "filename" : "xt/author/kwalitee.t",
                  "skiptest" : []
               }
            },
            "name" : "@Author::ETHER/Test::Kwalitee",
            "version" : "2.12"
         },
         {
            "class" : "Dist::Zilla::Plugin::MojibakeTests",
            "name" : "@Author::ETHER/MojibakeTests",
            "version" : "0.8"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::ReportPrereqs",
            "name" : "@Author::ETHER/Test::ReportPrereqs",
            "version" : "0.027"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::Portability",
            "config" : {
               "Dist::Zilla::Plugin::Test::Portability" : {
                  "options" : ""
               }
            },
            "name" : "@Author::ETHER/Test::Portability",
            "version" : "2.001000"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Describe",
            "name" : "@Author::ETHER/Git::Describe",
            "version" : "0.007"
         },
         {
            "class" : "Dist::Zilla::Plugin::PodWeaver",
            "config" : {
               "Dist::Zilla::Plugin::PodWeaver" : {
                  "config_plugins" : [
                     "@Author::ETHER"
                  ],
                  "finder" : [
                     ":InstallModules",
                     ":ExecFiles"
                  ],
                  "plugins" : [
                     {
                        "class" : "Pod::Weaver::Plugin::EnsurePod5",
                        "name" : "@Author::ETHER/EnsurePod5",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Plugin::H1Nester",
                        "name" : "@Author::ETHER/H1Nester",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Plugin::SingleEncoding",
                        "name" : "@Author::ETHER/SingleEncoding",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Plugin::Transformer",
                        "name" : "@Author::ETHER/List",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Plugin::Transformer",
                        "name" : "@Author::ETHER/Verbatim",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Region",
                        "name" : "@Author::ETHER/header",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Name",
                        "name" : "@Author::ETHER/Name",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Version",
                        "name" : "@Author::ETHER/Version",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Region",
                        "name" : "@Author::ETHER/prelude",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Generic",
                        "name" : "SYNOPSIS",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Generic",
                        "name" : "DESCRIPTION",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Generic",
                        "name" : "OVERVIEW",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Collect",
                        "name" : "ATTRIBUTES",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Collect",
                        "name" : "METHODS",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Collect",
                        "name" : "FUNCTIONS",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Collect",
                        "name" : "TYPES",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Leftovers",
                        "name" : "@Author::ETHER/Leftovers",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Region",
                        "name" : "@Author::ETHER/postlude",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::GenerateSection",
                        "name" : "@Author::ETHER/generate SUPPORT",
                        "version" : "1.06"
                     },
                     {
                        "class" : "Pod::Weaver::Section::AllowOverride",
                        "name" : "@Author::ETHER/allow override SUPPORT",
                        "version" : "0.05"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Authors",
                        "name" : "@Author::ETHER/Authors",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Contributors",
                        "name" : "@Author::ETHER/Contributors",
                        "version" : "0.009"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Legal",
                        "name" : "@Author::ETHER/Legal",
                        "version" : "4.015"
                     },
                     {
                        "class" : "Pod::Weaver::Section::Region",
                        "name" : "@Author::ETHER/footer",
                        "version" : "4.015"
                     }
                  ]
               }
            },
            "name" : "@Author::ETHER/PodWeaver",
            "version" : "4.008"
         },
         {
            "class" : "Dist::Zilla::Plugin::GithubMeta",
            "name" : "@Author::ETHER/GithubMeta",
            "version" : "0.54"
         },
         {
            "class" : "Dist::Zilla::Plugin::AutoMetaResources",
            "name" : "@Author::ETHER/AutoMetaResources",
            "version" : "1.21"
         },
         {
            "class" : "Dist::Zilla::Plugin::Authority",
            "name" : "@Author::ETHER/Authority",
            "version" : "1.009"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaNoIndex",
            "name" : "@Author::ETHER/MetaNoIndex",
            "version" : "6.010"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaProvides::Package",
            "config" : {
               "Dist::Zilla::Plugin::MetaProvides::Package" : {
                  "finder" : [
                     ":InstallModules"
                  ],
                  "finder_objects" : [
                     {
                        "class" : "Dist::Zilla::Plugin::FinderCode",
                        "name" : ":InstallModules",
                        "version" : "6.010"
                     }
                  ],
                  "include_underscores" : 0
               },
               "Dist::Zilla::Role::MetaProvider::Provider" : {
                  "$Dist::Zilla::Role::MetaProvider::Provider::VERSION" : "2.002004",
                  "inherit_missing" : 0,
                  "inherit_version" : 0,
                  "meta_noindex" : 1
               },
               "Dist::Zilla::Role::ModuleMetadata" : {
                  "Module::Metadata" : "1.000033",
                  "version" : "0.004"
               }
            },
            "name" : "@Author::ETHER/MetaProvides::Package",
            "version" : "2.004003"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaConfig",
            "name" : "@Author::ETHER/MetaConfig",
            "version" : "6.010"
         },
         {
            "class" : "Dist::Zilla::Plugin::Keywords",
            "config" : {
               "Dist::Zilla::Plugin::Keywords" : {
                  "keywords" : []
               }
            },
            "name" : "@Author::ETHER/Keywords",
            "version" : "0.007"
         },
         {
            "class" : "Dist::Zilla::Plugin::UseUnsafeInc",
            "config" : {
               "Dist::Zilla::Plugin::UseUnsafeInc" : {
                  "dot_in_INC" : 0
               }
            },
            "name" : "@Author::ETHER/UseUnsafeInc",
            "version" : "0.001"
         },
         {
            "class" : "Dist::Zilla::Plugin::AutoPrereqs",
            "name" : "@Author::ETHER/AutoPrereqs",
            "version" : "6.010"
         },
         {
            "class" : "Dist::Zilla::Plugin::Prereqs::AuthorDeps",
            "name" : "@Author::ETHER/Prereqs::AuthorDeps",
            "version" : "0.006"
         },
         {
            "class" : "Dist::Zilla::Plugin::MinimumPerl",
            "name" : "@Author::ETHER/MinimumPerl",
            "version" : "1.006"
         },
         {
            "class" : "Dist::Zilla::Plugin::Prereqs",
            "config" : {
               "Dist::Zilla::Plugin::Prereqs" : {
                  "phase" : "develop",
                  "type" : "recommends"
               }
            },
            "name" : "@Author::ETHER/pluginbundle_version",
            "version" : "6.010"
         },
         {
            "class" : "Dist::Zilla::Plugin::MakeMaker",
            "config" : {
               "Dist::Zilla::Role::TestRunner" : {
                  "default_jobs" : 9
               }
            },
            "name" : "@Author::ETHER/MakeMaker",
            "version" : "6.010"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Contributors",
            "config" : {
               "Dist::Zilla::Plugin::Git::Contributors" : {
                  "git_version" : "2.14.2",
                  "include_authors" : 0,
                  "include_releaser" : 1,
                  "order_by" : "commits",
                  "paths" : []
               }
            },
            "name" : "@Author::ETHER/Git::Contributors",
            "version" : "0.032"
         },
         {
            "class" : "Dist::Zilla::Plugin::StaticInstall",
            "config" : {
               "Dist::Zilla::Plugin::StaticInstall" : {
                  "dry_run" : 1,
                  "mode" : "auto"
               }
            },
            "name" : "@Author::ETHER/StaticInstall",
            "version" : "0.011"
         },
         {
            "class" : "Dist::Zilla::Plugin::RunExtraTests",
            "config" : {
               "Dist::Zilla::Role::TestRunner" : {
                  "default_jobs" : 9
               }
            },
            "name" : "@Author::ETHER/RunExtraTests",
            "version" : "0.029"
         },
         {
            "class" : "Dist::Zilla::Plugin::CheckSelfDependency",
            "config" : {
               "Dist::Zilla::Plugin::CheckSelfDependency" : {
                  "finder" : [
                     ":InstallModules"
                  ]
               },
               "Dist::Zilla::Role::ModuleMetadata" : {
                  "Module::Metadata" : "1.000033",
                  "version" : "0.004"
               }
            },
            "name" : "@Author::ETHER/CheckSelfDependency",
            "version" : "0.011"
         },
         {
            "class" : "Dist::Zilla::Plugin::Run::AfterBuild",
            "config" : {
               "Dist::Zilla::Plugin::Run::Role::Runner" : {
                  "fatal_errors" : 1,
                  "quiet" : 1,
                  "run" : [
                     "bash -c \"test -e .ackrc && grep -q -- '--ignore-dir=.latest' .ackrc || echo '--ignore-dir=.latest' >> .ackrc; if [[ `dirname '%d'` != .build ]]; then test -e .ackrc && grep -q -- '--ignore-dir=%d' .ackrc || echo '--ignore-dir=%d' >> .ackrc; fi\""
                  ],
                  "version" : "0.046"
               }
            },
            "name" : "@Author::ETHER/.ackrc",
            "version" : "0.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::Run::AfterBuild",
            "config" : {
               "Dist::Zilla::Plugin::Run::Role::Runner" : {
                  "eval" : [
                     "if ('%d' =~ /^%n-[.[:xdigit:]]+$/) { unlink '.latest'; symlink '%d', '.latest'; }"
                  ],
                  "fatal_errors" : 0,
                  "quiet" : 1,
                  "version" : "0.046"
               }
            },
            "name" : "@Author::ETHER/.latest",
            "version" : "0.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::CheckStrictVersion",
            "name" : "@Author::ETHER/CheckStrictVersion",
            "version" : "0.001"
         },
         {
            "class" : "Dist::Zilla::Plugin::CheckMetaResources",
            "name" : "@Author::ETHER/CheckMetaResources",
            "version" : "0.001"
         },
         {
            "class" : "Dist::Zilla::Plugin::EnsureLatestPerl",
            "config" : {
               "Dist::Zilla::Plugin::EnsureLatestPerl" : {
                  "Module::CoreList" : "5.20171120"
               }
            },
            "name" : "@Author::ETHER/EnsureLatestPerl",
            "version" : "0.006"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Check",
            "config" : {
               "Dist::Zilla::Plugin::Git::Check" : {
                  "untracked_files" : "die"
               },
               "Dist::Zilla::Role::Git::DirtyFiles" : {
                  "allow_dirty" : [],
                  "allow_dirty_match" : [],
                  "changelog" : "Changes"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.14.2",
                  "repo_root" : "."
               }
            },
            "name" : "@Author::ETHER/initial check",
            "version" : "2.043"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::CheckFor::MergeConflicts",
            "config" : {
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.14.2",
                  "repo_root" : "."
               }
            },
            "name" : "@Author::ETHER/Git::CheckFor::MergeConflicts",
            "version" : "0.014"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::CheckFor::CorrectBranch",
            "config" : {
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.14.2",
                  "repo_root" : "."
               }
            },
            "name" : "@Author::ETHER/Git::CheckFor::CorrectBranch",
            "version" : "0.014"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Remote::Check",
            "name" : "@Author::ETHER/Git::Remote::Check",
            "version" : "0.1.2"
         },
         {
            "class" : "Dist::Zilla::Plugin::CheckPrereqsIndexed",
            "name" : "@Author::ETHER/CheckPrereqsIndexed",
            "version" : "0.020"
         },
         {
            "class" : "Dist::Zilla::Plugin::TestRelease",
            "name" : "@Author::ETHER/TestRelease",
            "version" : "6.010"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Check",
            "config" : {
               "Dist::Zilla::Plugin::Git::Check" : {
                  "untracked_files" : "die"
               },
               "Dist::Zilla::Role::Git::DirtyFiles" : {
                  "allow_dirty" : [],
                  "allow_dirty_match" : [],
                  "changelog" : "Changes"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.14.2",
                  "repo_root" : "."
               }
            },
            "name" : "@Author::ETHER/after tests",
            "version" : "2.043"
         },
         {
            "class" : "Dist::Zilla::Plugin::CheckIssues",
            "name" : "@Author::ETHER/CheckIssues",
            "version" : "0.010"
         },
         {
            "class" : "Dist::Zilla::Plugin::UploadToCPAN",
            "name" : "@Author::ETHER/UploadToCPAN",
            "version" : "6.010"
         },
         {
            "class" : "Dist::Zilla::Plugin::CopyFilesFromRelease",
            "config" : {
               "Dist::Zilla::Plugin::CopyFilesFromRelease" : {
                  "filename" : [
                     "CONTRIBUTING",
                     "INSTALL",
                     "LICENCE",
                     "LICENSE",
                     "ppport.h"
                  ],
                  "match" : []
               }
            },
            "name" : "@Author::ETHER/copy generated files",
            "version" : "0.007"
         },
         {
            "class" : "Dist::Zilla::Plugin::ReadmeAnyFromPod",
            "config" : {
               "Dist::Zilla::Role::FileWatcher" : {
                  "version" : "0.006"
               }
            },
            "name" : "@Author::ETHER/ReadmeAnyFromPod",
            "version" : "0.163250"
         },
         {
            "class" : "Dist::Zilla::Plugin::RewriteVersion::Transitional",
            "config" : {
               "Dist::Zilla::Plugin::RewriteVersion" : {
                  "add_tarball_name" : 0,
                  "finders" : [
                     ":ExecFiles",
                     ":InstallModules"
                  ],
                  "global" : 1,
                  "skip_version_provider" : 0
               },
               "Dist::Zilla::Plugin::RewriteVersion::Transitional" : {}
            },
            "name" : "@Author::ETHER/@Git::VersionManager/RewriteVersion::Transitional",
            "version" : "0.008"
         },
         {
            "class" : "Dist::Zilla::Plugin::MetaProvides::Update",
            "name" : "@Author::ETHER/@Git::VersionManager/MetaProvides::Update",
            "version" : "0.003"
         },
         {
            "class" : "Dist::Zilla::Plugin::CopyFilesFromRelease",
            "config" : {
               "Dist::Zilla::Plugin::CopyFilesFromRelease" : {
                  "filename" : [
                     "Changes"
                  ],
                  "match" : []
               }
            },
            "name" : "@Author::ETHER/@Git::VersionManager/CopyFilesFromRelease",
            "version" : "0.007"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Commit",
            "config" : {
               "Dist::Zilla::Plugin::Git::Commit" : {
                  "add_files_in" : [
                     "."
                  ],
                  "commit_msg" : "%N-%v%t%n%n%c"
               },
               "Dist::Zilla::Role::Git::DirtyFiles" : {
                  "allow_dirty" : [
                     "CONTRIBUTING",
                     "Changes",
                     "INSTALL",
                     "LICENCE",
                     "README.pod"
                  ],
                  "allow_dirty_match" : [],
                  "changelog" : "Changes"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.14.2",
                  "repo_root" : "."
               },
               "Dist::Zilla::Role::Git::StringFormatter" : {
                  "time_zone" : "local"
               }
            },
            "name" : "@Author::ETHER/@Git::VersionManager/release snapshot",
            "version" : "2.043"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Tag",
            "config" : {
               "Dist::Zilla::Plugin::Git::Tag" : {
                  "branch" : null,
                  "changelog" : "Changes",
                  "signed" : 0,
                  "tag" : "v0.30",
                  "tag_format" : "v%v",
                  "tag_message" : "v%v%t"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.14.2",
                  "repo_root" : "."
               },
               "Dist::Zilla::Role::Git::StringFormatter" : {
                  "time_zone" : "local"
               }
            },
            "name" : "@Author::ETHER/@Git::VersionManager/Git::Tag",
            "version" : "2.043"
         },
         {
            "class" : "Dist::Zilla::Plugin::BumpVersionAfterRelease::Transitional",
            "config" : {
               "Dist::Zilla::Plugin::BumpVersionAfterRelease" : {
                  "finders" : [
                     ":ExecFiles",
                     ":InstallModules"
                  ],
                  "global" : 1,
                  "munge_makefile_pl" : 1
               },
               "Dist::Zilla::Plugin::BumpVersionAfterRelease::Transitional" : {}
            },
            "name" : "@Author::ETHER/@Git::VersionManager/BumpVersionAfterRelease::Transitional",
            "version" : "0.008"
         },
         {
            "class" : "Dist::Zilla::Plugin::NextRelease",
            "name" : "@Author::ETHER/@Git::VersionManager/NextRelease",
            "version" : "6.010"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Commit",
            "config" : {
               "Dist::Zilla::Plugin::Git::Commit" : {
                  "add_files_in" : [],
                  "commit_msg" : "increment $VERSION after %v release"
               },
               "Dist::Zilla::Role::Git::DirtyFiles" : {
                  "allow_dirty" : [
                     "Build.PL",
                     "Changes",
                     "Makefile.PL"
                  ],
                  "allow_dirty_match" : [
                     "(?^:^lib/.*\\.pm$)"
                  ],
                  "changelog" : "Changes"
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.14.2",
                  "repo_root" : "."
               },
               "Dist::Zilla::Role::Git::StringFormatter" : {
                  "time_zone" : "local"
               }
            },
            "name" : "@Author::ETHER/@Git::VersionManager/post-release commit",
            "version" : "2.043"
         },
         {
            "class" : "Dist::Zilla::Plugin::Prereqs",
            "config" : {
               "Dist::Zilla::Plugin::Prereqs" : {
                  "phase" : "develop",
                  "type" : "suggests"
               }
            },
            "name" : "@Author::ETHER/@Git::VersionManager/prereqs for @Git::VersionManager",
            "version" : "6.010"
         },
         {
            "class" : "Dist::Zilla::Plugin::Git::Push",
            "config" : {
               "Dist::Zilla::Plugin::Git::Push" : {
                  "push_to" : [
                     "origin"
                  ],
                  "remotes_must_exist" : 1
               },
               "Dist::Zilla::Role::Git::Repo" : {
                  "git_version" : "2.14.2",
                  "repo_root" : "."
               }
            },
            "name" : "@Author::ETHER/Git::Push",
            "version" : "2.043"
         },
         {
            "class" : "Dist::Zilla::Plugin::GitHub::Update",
            "config" : {
               "Dist::Zilla::Plugin::GitHub::Update" : {
                  "metacpan" : 1
               }
            },
            "name" : "@Author::ETHER/GitHub::Update",
            "version" : "0.44"
         },
         {
            "class" : "Dist::Zilla::Plugin::Run::AfterRelease",
            "config" : {
               "Dist::Zilla::Plugin::Run::Role::Runner" : {
                  "fatal_errors" : 0,
                  "quiet" : 0,
                  "run" : [
                     "REDACTED"
                  ],
                  "version" : "0.046"
               }
            },
            "name" : "@Author::ETHER/install release",
            "version" : "0.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::Run::AfterRelease",
            "config" : {
               "Dist::Zilla::Plugin::Run::Role::Runner" : {
                  "eval" : [
                     "print \"release complete!\\xa\""
                  ],
                  "fatal_errors" : 1,
                  "quiet" : 1,
                  "version" : "0.046"
               }
            },
            "name" : "@Author::ETHER/release complete",
            "version" : "0.046"
         },
         {
            "class" : "Dist::Zilla::Plugin::ConfirmRelease",
            "name" : "@Author::ETHER/ConfirmRelease",
            "version" : "6.010"
         },
         {
            "class" : "Dist::Zilla::Plugin::Prereqs",
            "config" : {
               "Dist::Zilla::Plugin::Prereqs" : {
                  "phase" : "develop",
                  "type" : "suggests"
               }
            },
            "name" : "@Author::ETHER/prereqs for @Author::ETHER",
            "version" : "6.010"
         },
         {
            "class" : "Dist::Zilla::Plugin::Substitute",
            "name" : "Substitute",
            "version" : "0.006"
         },
         {
            "class" : "Dist::Zilla::Plugin::Prereqs::Soften",
            "config" : {
               "Dist::Zilla::Plugin::Prereqs::Soften" : {
                  "copy_to" : [
                     "develop.requires"
                  ],
                  "modules" : [
                     "Capture::Tiny",
                     "Sub::Name",
                     "Sub::Util"
                  ],
                  "modules_from_features" : null,
                  "to_relationship" : "suggests"
               }
            },
            "name" : "Prereqs::Soften",
            "version" : "0.006003"
         },
         {
            "class" : "Dist::Zilla::Plugin::OnlyCorePrereqs",
            "config" : {
               "Dist::Zilla::Plugin::OnlyCorePrereqs" : {
                  "also_disallow" : [],
                  "check_dual_life_versions" : "0",
                  "deprecated_ok" : 0,
                  "phases" : [
                     "configure",
                     "build",
                     "runtime",
                     "test"
                  ],
                  "skips" : [],
                  "starting_version" : "to be determined from perl prereq"
               }
            },
            "name" : "OnlyCorePrereqs",
            "version" : "0.024"
         },
         {
            "class" : "Dist::Zilla::Plugin::Breaks",
            "name" : "Breaks",
            "version" : "0.004"
         },
         {
            "class" : "Dist::Zilla::Plugin::Test::CheckBreaks",
            "config" : {
               "Dist::Zilla::Plugin::Test::CheckBreaks" : {
                  "conflicts_module" : [],
                  "no_forced_deps" : 1
               },
               "Dist::Zilla::Role::ModuleMetadata" : {
                  "Module::Metadata" : "1.000033",
                  "version" : "0.004"
               }
            },
            "name" : "Test::CheckBreaks",
            "version" : "0.019"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":InstallModules",
            "version" : "6.010"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":IncModules",
            "version" : "6.010"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":TestFiles",
            "version" : "6.010"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":ExtraTestFiles",
            "version" : "6.010"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":ExecFiles",
            "version" : "6.010"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":PerlExecFiles",
            "version" : "6.010"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":ShareFiles",
            "version" : "6.010"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":MainModule",
            "version" : "6.010"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":AllFiles",
            "version" : "6.010"
         },
         {
            "class" : "Dist::Zilla::Plugin::FinderCode",
            "name" : ":NoFiles",
            "version" : "6.010"
         },
         {
            "class" : "Dist::Zilla::Plugin::VerifyPhases",
            "name" : "@Author::ETHER/PHASE VERIFICATION",
            "version" : "0.016"
         }
      ],
      "zilla" : {
         "class" : "Dist::Zilla::Dist::Builder",
         "config" : {
            "is_trial" : 0
         },
         "version" : "6.010"
      }
   },
   "x_authority" : "cpan:NUFFIN",
   "x_breaks" : {
      "Try::Tiny::Except" : "<= 0.01"
   },
   "x_contributors" : [
      "Karen Etheridge <ether@cpan.org>",
      "Peter Rabbitson <ribasushi@cpan.org>",
      "Ricardo Signes <rjbs@cpan.org>",
      "Mark Fowler <mark@twoshortplanks.com>",
      "Graham Knop <haarg@haarg.org>",
      "Lukas Mai <l.mai@web.de>",
      "Aristotle Pagaltzis <pagaltzis@gmx.de>",
      "Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>",
      "Paul Howarth <paul@city-fan.org>",
      "Rudolf Leermakers <rudolf@hatsuseno.org>",
      "anaxagoras <walkeraj@gmail.com>",
      "awalker <awalker@sourcefire.com>",
      "chromatic <chromatic@wgz.org>",
      "Alex <alex@koban.(none)>",
      "cm-perl <cm-perl@users.noreply.github.com>",
      "Andrew Yates <ayates@haddock.local>",
      "David Lowe <davidl@lokku.com>",
      "Glenn Fowler <cebjyre@cpan.org>",
      "Hans Dieter Pearcey <hdp@weftsoar.net>",
      "Jens Berthold <jens@jebecs.de>",
      "Jonathan Yu <JAWNSY@cpan.org>",
      "Marc Mims <marc@questright.com>",
      "Mark Stosberg <mark@stosberg.com>",
      "Pali <pali@cpan.org>"
   ],
   "x_serialization_backend" : "Cpanel::JSON::XS version 3.0239",
   "x_use_unsafe_inc" : 0
}
PK       ! :+c
  c
  D  perl5/x86_64-linux-thread-multi/.meta/XML-LibXML-2.0207/install.jsonnu ��6�$        {"provides":{"XML::LibXML::PI":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::Pattern":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::SAX":{"version":2.0207,"file":"lib/XML/LibXML/SAX.pm"},"XML::LibXML::XPathContext":{"version":2.0207,"file":"lib/XML/LibXML/XPathContext.pm"},"XML::LibXML::SAX::AttributeNode":{"version":2.0207,"file":"lib/XML/LibXML/SAX/Generator.pm"},"XML::LibXML::SAX::Generator":{"version":2.0207,"file":"lib/XML/LibXML/SAX/Generator.pm"},"XML::LibXML::XPathExpression":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::NodeList":{"version":2.0207,"file":"lib/XML/LibXML/NodeList.pm"},"XML::LibXML::Error":{"version":2.0207,"file":"lib/XML/LibXML/Error.pm"},"XML::LibXML::RegExp":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::_SAXParser":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::InputCallback":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::Devel":{"version":2.0207,"file":"lib/XML/LibXML/Devel.pm"},"XML::LibXML::Boolean":{"version":2.0207,"file":"lib/XML/LibXML/Boolean.pm"},"XML::LibXML::AttributeHash":{"version":2.0207,"file":"lib/XML/LibXML/AttributeHash.pm"},"XML::LibXML":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::Literal":{"version":2.0207,"file":"lib/XML/LibXML/Literal.pm"},"XML::LibXML::Reader":{"version":2.0207,"file":"lib/XML/LibXML/Reader.pm"},"XML::LibXML::SAX::Builder":{"version":2.0207,"file":"lib/XML/LibXML/SAX/Builder.pm"},"XML::LibXML::Schema":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::Element":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::Attr":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::Node":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::CDATASection":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::Number":{"version":2.0207,"file":"lib/XML/LibXML/Number.pm"},"XML::LibXML::Namespace":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::ErrNo":{"version":2.0207,"file":"lib/XML/LibXML/ErrNo.pm"},"XML::LibXML::SAX::Parser":{"version":2.0207,"file":"lib/XML/LibXML/SAX/Parser.pm"},"XML::LibXML::Dtd":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::NamedNodeMap":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::Common":{"version":2.0207,"file":"lib/XML/LibXML/Common.pm"},"XML::LibXML::Comment":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::Document":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::DocumentFragment":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::RelaxNG":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::Text":{"version":2.0207,"file":"LibXML.pm"}},"target":"XML::LibXML","version":2.0207,"name":"XML::LibXML","dist":"XML-LibXML-2.0207","pathname":"S/SH/SHLOMIF/XML-LibXML-2.0207.tar.gz"}PK       ! ]G#�	  �	  C  perl5/x86_64-linux-thread-multi/.meta/XML-LibXML-2.0207/MYMETA.jsonnu ��6�$        {
   "abstract" : "Interface to Gnome libxml2 xml parsing and DOM library",
   "author" : [
      "Petr Pajas <PAJAS@cpan.org>"
   ],
   "dynamic_config" : 0,
   "generated_by" : "ExtUtils::MakeMaker version 7.60, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240",
   "keywords" : [
      "dom",
      "html",
      "libxml",
      "object oriented",
      "oop",
      "parse",
      "parser",
      "parsing",
      "pullparser",
      "sax",
      "sgml",
      "xml",
      "xpath",
      "XPath",
      "xs"
   ],
   "license" : [
      "perl_5"
   ],
   "meta-spec" : {
      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
      "version" : "2"
   },
   "name" : "XML-LibXML",
   "no_index" : {
      "directory" : [
         "t",
         "inc",
         "xt"
      ]
   },
   "prereqs" : {
      "build" : {
         "requires" : {
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "configure" : {
         "requires" : {
            "Alien::Base::Wrapper" : "0",
            "Alien::Libxml2" : "0.14",
            "Config" : "0",
            "ExtUtils::MakeMaker" : "0"
         }
      },
      "runtime" : {
         "requires" : {
            "Carp" : "0",
            "DynaLoader" : "0",
            "Encode" : "0",
            "Exporter" : "5.57",
            "IO::Handle" : "0",
            "Scalar::Util" : "0",
            "Tie::Hash" : "0",
            "XML::NamespaceSupport" : "1.07",
            "XML::SAX" : "0.11",
            "XML::SAX::Base" : "0",
            "XML::SAX::DocumentLocator" : "0",
            "XML::SAX::Exception" : "0",
            "base" : "0",
            "constant" : "0",
            "overload" : "0",
            "parent" : "0",
            "perl" : "5.008001",
            "strict" : "0",
            "vars" : "0",
            "warnings" : "0"
         }
      },
      "test" : {
         "requires" : {
            "Config" : "0",
            "Errno" : "0",
            "IO::File" : "0",
            "IO::Handle" : "0",
            "POSIX" : "0",
            "Scalar::Util" : "0",
            "Test::More" : "0",
            "locale" : "0",
            "utf8" : "0"
         }
      }
   },
   "release_status" : "stable",
   "resources" : {
      "repository" : {
         "type" : "git",
         "url" : "https://github.com/shlomif/perl-XML-LibXML.git",
         "web" : "https://github.com/shlomif/perl-XML-LibXML"
      }
   },
   "version" : "2.0207",
   "x_serialization_backend" : "JSON::PP version 4.06"
}
PK       ! ��@I  I    perl5/Digest/HMAC.pmnu ��6�$        package Digest::HMAC;
$VERSION = "1.03";

use strict;

# OO interface

sub new
{
    my($class, $key, $hasher, $block_size) =  @_;
    $block_size ||= 64;
    $key = $hasher->new->add($key)->digest if length($key) > $block_size;

    my $self = bless {}, $class;
    $self->{k_ipad} = $key ^ (chr(0x36) x $block_size);
    $self->{k_opad} = $key ^ (chr(0x5c) x $block_size);
    $self->{hasher} = $hasher->new->add($self->{k_ipad});
    $self;
}

sub reset
{
    my $self = shift;
    $self->{hasher}->reset->add($self->{k_ipad});
    $self;
}

sub add     { my $self = shift; $self->{hasher}->add(@_);     $self; }
sub addfile { my $self = shift; $self->{hasher}->addfile(@_); $self; }

sub _digest
{
    my $self = shift;
    my $inner_digest = $self->{hasher}->digest;
    $self->{hasher}->reset->add($self->{k_opad}, $inner_digest);
}

sub digest    { shift->_digest->digest;    }
sub hexdigest { shift->_digest->hexdigest; }
sub b64digest { shift->_digest->b64digest; }


# Functional interface

require Exporter;
*import = \&Exporter::import;
use vars qw(@EXPORT_OK);
@EXPORT_OK = qw(hmac hmac_hex);

sub hmac
{
    my($data, $key, $hash_func, $block_size) = @_;
    $block_size ||= 64;
    $key = &$hash_func($key) if length($key) > $block_size;

    my $k_ipad = $key ^ (chr(0x36) x $block_size);
    my $k_opad = $key ^ (chr(0x5c) x $block_size);

    &$hash_func($k_opad, &$hash_func($k_ipad, $data));
}

sub hmac_hex { unpack("H*", &hmac); }

1;

__END__

=head1 NAME

Digest::HMAC - Keyed-Hashing for Message Authentication

=head1 SYNOPSIS

 # Functional style
 use Digest::HMAC qw(hmac hmac_hex);
 $digest = hmac($data, $key, \&myhash);
 print hmac_hex($data, $key, \&myhash);

 # OO style
 use Digest::HMAC;
 $hmac = Digest::HMAC->new($key, "Digest::MyHash");

 $hmac->add($data);
 $hmac->addfile(*FILE);

 $digest = $hmac->digest;
 $digest = $hmac->hexdigest;
 $digest = $hmac->b64digest;

=head1 DESCRIPTION

HMAC is used for message integrity checks between two parties that
share a secret key, and works in combination with some other Digest
algorithm, usually MD5 or SHA-1.  The HMAC mechanism is described in
RFC 2104.

HMAC follow the common C<Digest::> interface, but the constructor
takes the secret key and the name of some other simple C<Digest::>
as argument.

The hmac() and hmac_hex() functions and the Digest::HMAC->new() constructor
takes an optional $blocksize argument as well.  The HMAC algorithm assumes the
digester to hash by iterating a basic compression function on blocks of data
and the $blocksize should match the byte-length of such blocks.

The default $blocksize is 64 which is suitable for the MD5 and SHA-1 digest
functions.  For stronger algorithms the blocksize probably needs to be
increased.

=head1 SEE ALSO

L<Digest::HMAC_MD5>, L<Digest::HMAC_SHA1>

RFC 2104

=head1 AUTHORS

Graham Barr <gbarr@ti.com>, Gisle Aas <gisle@aas.no>

=cut
PK       ! ?�\H�  �    perl5/Digest/HMAC_SHA1.pmnu ��6�$        package Digest::HMAC_SHA1;
$VERSION="1.03";

use strict;
use Digest::SHA qw(sha1);
use Digest::HMAC qw(hmac);

# OO interface
use vars qw(@ISA);
@ISA=qw(Digest::HMAC);
sub new
{
    my $class = shift;
    $class->SUPER::new($_[0], "Digest::SHA", 64);  # Digest::SHA defaults to SHA-1
}

# Functional interface
require Exporter;
*import = \&Exporter::import;
use vars qw(@EXPORT_OK);
@EXPORT_OK=qw(hmac_sha1 hmac_sha1_hex);

sub hmac_sha1
{
    hmac($_[0], $_[1], \&sha1, 64);
}

sub hmac_sha1_hex
{
    unpack("H*", &hmac_sha1)
}

1;

__END__

=head1 NAME

Digest::HMAC_SHA1 - Keyed-Hashing for Message Authentication

=head1 SYNOPSIS

 # Functional style
 use Digest::HMAC_SHA1 qw(hmac_sha1 hmac_sha1_hex);
 $digest = hmac_sha1($data, $key);
 print hmac_sha1_hex($data, $key);

 # OO style
 use Digest::HMAC_SHA1;
 $hmac = Digest::HMAC_SHA1->new($key);

 $hmac->add($data);
 $hmac->addfile(*FILE);

 $digest = $hmac->digest;
 $digest = $hmac->hexdigest;
 $digest = $hmac->b64digest;

=head1 DESCRIPTION

This module provide HMAC-SHA-1 hashing.

=head1 SEE ALSO

L<Digest::HMAC>, L<Digest::SHA>, L<Digest::HMAC_MD5>

=head1 AUTHOR

Gisle Aas <gisle@aas.no>

=cut
PK       ! ��[QZ  Z    perl5/Digest/HMAC_MD5.pmnu ��6�$        package Digest::HMAC_MD5;
$VERSION="1.01";

use strict;
use Digest::MD5  qw(md5);
use Digest::HMAC qw(hmac);

# OO interface
use vars qw(@ISA);
@ISA=qw(Digest::HMAC);
sub new
{
    my $class = shift;
    $class->SUPER::new($_[0], "Digest::MD5", 64);
}

# Functional interface
require Exporter;
*import = \&Exporter::import;
use vars qw(@EXPORT_OK);
@EXPORT_OK=qw(hmac_md5 hmac_md5_hex);

sub hmac_md5
{
    hmac($_[0], $_[1], \&md5, 64);
}

sub hmac_md5_hex
{
    unpack("H*", &hmac_md5)
}

1;

__END__

=head1 NAME

Digest::HMAC_MD5 - Keyed-Hashing for Message Authentication

=head1 SYNOPSIS

 # Functional style
 use Digest::HMAC_MD5 qw(hmac_md5 hmac_md5_hex);
 $digest = hmac_md5($data, $key);
 print hmac_md5_hex($data, $key);

 # OO style
 use Digest::HMAC_MD5;
 $hmac = Digest::HMAC_MD5->new($key);

 $hmac->add($data);
 $hmac->addfile(*FILE);

 $digest = $hmac->digest;
 $digest = $hmac->hexdigest;
 $digest = $hmac->b64digest;

=head1 DESCRIPTION

This module provide HMAC-MD5 hashing.

=head1 SEE ALSO

L<Digest::HMAC>, L<Digest::MD5>, L<Digest::HMAC_SHA1>

=head1 AUTHOR

Gisle Aas <gisle@aas.no>

=cut
PK       ! ���ެT  �T    perl5/LWP.pmnu ��6�$        package LWP;

our $VERSION = '6.49';

require LWP::UserAgent;  # this should load everything you need

sub Version { $VERSION; }

1;

__END__

=pod

=encoding utf-8

=head1 NAME

LWP - The World-Wide Web library for Perl

=head1 SYNOPSIS

  use LWP;
  print "This is libwww-perl-$LWP::VERSION\n";


=head1 DESCRIPTION

The libwww-perl collection is a set of Perl modules which provides a
simple and consistent application programming interface (API) to the
World-Wide Web.  The main focus of the library is to provide classes
and functions that allow you to write WWW clients. The library also
contain modules that are of more general use and even classes that
help you implement simple HTTP servers.

Most modules in this library provide an object oriented API.  The user
agent, requests sent and responses received from the WWW server are
all represented by objects.  This makes a simple and powerful
interface to these services.  The interface is easy to extend
and customize for your own needs.

The main features of the library are:

=over 3

=item *

Contains various reusable components (modules) that can be
used separately or together.

=item *

Provides an object oriented model of HTTP-style communication.  Within
this framework we currently support access to C<http>, C<https>, C<gopher>,
C<ftp>, C<news>, C<file>, and C<mailto> resources.

=item *

Provides a full object oriented interface or
a very simple procedural interface.

=item *

Supports the basic and digest authorization schemes.

=item *

Supports transparent redirect handling.

=item *

Supports access through proxy servers.

=item *

Provides parser for F<robots.txt> files and a framework for constructing robots.

=item *

Supports parsing of HTML forms.

=item *

Implements HTTP content negotiation algorithm that can
be used both in protocol modules and in server scripts (like CGI
scripts).

=item *

Supports HTTP cookies.

=item *

Some simple command line clients, for instance C<lwp-request> and C<lwp-download>.

=back


=head1 HTTP STYLE COMMUNICATION


The libwww-perl library is based on HTTP style communication. This
section tries to describe what that means.

Let us start with this quote from the HTTP specification document
<URL:http://www.w3.org/Protocols/>:

=over 3

=item *

The HTTP protocol is based on a request/response paradigm. A client
establishes a connection with a server and sends a request to the
server in the form of a request method, URI, and protocol version,
followed by a MIME-like message containing request modifiers, client
information, and possible body content. The server responds with a
status line, including the message's protocol version and a success or
error code, followed by a MIME-like message containing server
information, entity meta-information, and possible body content.

=back

What this means to libwww-perl is that communication always take place
through these steps: First a I<request> object is created and
configured. This object is then passed to a server and we get a
I<response> object in return that we can examine. A request is always
independent of any previous requests, i.e. the service is stateless.
The same simple model is used for any kind of service we want to
access.

For example, if we want to fetch a document from a remote file server,
then we send it a request that contains a name for that document and
the response will contain the document itself.  If we access a search
engine, then the content of the request will contain the query
parameters and the response will contain the query result.  If we want
to send a mail message to somebody then we send a request object which
contains our message to the mail server and the response object will
contain an acknowledgment that tells us that the message has been
accepted and will be forwarded to the recipient(s).

It is as simple as that!


=head2 The Request Object

The libwww-perl request object has the class name L<HTTP::Request>.
The fact that the class name uses C<HTTP::> as a
prefix only implies that we use the HTTP model of communication.  It
does not limit the kind of services we can try to pass this I<request>
to.  For instance, we will send L<HTTP::Request>s both to ftp and
gopher servers, as well as to the local file system.

The main attributes of the request objects are:

=over 3

=item *

B<method> is a short string that tells what kind of
request this is.  The most common methods are B<GET>, B<PUT>,
B<POST> and B<HEAD>.

=item *

B<uri> is a string denoting the protocol, server and
the name of the "document" we want to access.  The B<uri> might
also encode various other parameters.

=item *

B<headers> contains additional information about the
request and can also used to describe the content.  The headers
are a set of keyword/value pairs.

=item *

B<content> is an arbitrary amount of data.

=back

=head2 The Response Object

The libwww-perl response object has the class name L<HTTP::Response>.
The main attributes of objects of this class are:

=over 3

=item *

B<code> is a numerical value that indicates the overall
outcome of the request.

=item *

B<message> is a short, human readable string that
corresponds to the I<code>.

=item *

B<headers> contains additional information about the
response and describe the content.

=item *

B<content> is an arbitrary amount of data.

=back

Since we don't want to handle all possible I<code> values directly in
our programs, a libwww-perl response object has methods that can be
used to query what kind of response this is.  The most commonly used
response classification methods are:

=over 3

=item is_success()

The request was successfully received, understood or accepted.

=item is_error()

The request failed.  The server or the resource might not be
available, access to the resource might be denied or other things might
have failed for some reason.

=back

=head2 The User Agent

Let us assume that we have created a I<request> object. What do we
actually do with it in order to receive a I<response>?

The answer is that you pass it to a I<user agent> object and this
object takes care of all the things that need to be done
(like low-level communication and error handling) and returns
a I<response> object. The user agent represents your
application on the network and provides you with an interface that
can accept I<requests> and return I<responses>.

The user agent is an interface layer between
your application code and the network.  Through this interface you are
able to access the various servers on the network.

The class name for the user agent is L<LWP::UserAgent>.  Every
libwww-perl application that wants to communicate should create at
least one object of this class. The main method provided by this
object is request(). This method takes an L<HTTP::Request> object as
argument and (eventually) returns a L<HTTP::Response> object.

The user agent has many other attributes that let you
configure how it will interact with the network and with your
application.

=over 3

=item *

B<timeout> specifies how much time we give remote servers to
respond before the library disconnects and creates an
internal I<timeout> response.

=item *

B<agent> specifies the name that your application uses when it
presents itself on the network.

=item *

B<from> can be set to the e-mail address of the person
responsible for running the application.  If this is set, then the
address will be sent to the servers with every request.

=item *

B<parse_head> specifies whether we should initialize response
headers from the E<lt>head> section of HTML documents.

=item *

B<proxy> and B<no_proxy> specify if and when to go through
a proxy server. <URL:http://www.w3.org/History/1994/WWW/Proxies/>

=item *

B<credentials> provides a way to set up user names and
passwords needed to access certain services.

=back

Many applications want even more control over how they interact
with the network and they get this by sub-classing
L<LWP::UserAgent>.  The library includes a
sub-class, L<LWP::RobotUA>, for robot applications.

=head2 An Example

This example shows how the user agent, a request and a response are
represented in actual perl code:

  # Create a user agent object
  use LWP::UserAgent;
  my $ua = LWP::UserAgent->new;
  $ua->agent("MyApp/0.1 ");

  # Create a request
  my $req = HTTP::Request->new(POST => 'http://search.cpan.org/search');
  $req->content_type('application/x-www-form-urlencoded');
  $req->content('query=libwww-perl&mode=dist');

  # Pass request to the user agent and get a response back
  my $res = $ua->request($req);

  # Check the outcome of the response
  if ($res->is_success) {
      print $res->content;
  }
  else {
      print $res->status_line, "\n";
  }

The $ua is created once when the application starts up.  New request
objects should normally created for each request sent.


=head1 NETWORK SUPPORT

This section discusses the various protocol schemes and
the HTTP style methods that headers may be used for each.

For all requests, a "User-Agent" header is added and initialized from
the $ua->agent attribute before the request is handed to the network
layer.  In the same way, a "From" header is initialized from the
$ua->from attribute.

For all responses, the library adds a header called "Client-Date".
This header holds the time when the response was received by
your application.  The format and semantics of the header are the
same as the server created "Date" header.  You may also encounter other
"Client-XXX" headers.  They are all generated by the library
internally and are not received from the servers.

=head2 HTTP Requests

HTTP requests are just handed off to an HTTP server and it
decides what happens.  Few servers implement methods beside the usual
"GET", "HEAD", "POST" and "PUT", but CGI-scripts may implement
any method they like.

If the server is not available then the library will generate an
internal error response.

The library automatically adds a "Host" and a "Content-Length" header
to the HTTP request before it is sent over the network.

For a GET request you might want to add a "If-Modified-Since" or
"If-None-Match" header to make the request conditional.

For a POST request you should add the "Content-Type" header.  When you
try to emulate HTML E<lt>FORM> handling you should usually let the value
of the "Content-Type" header be "application/x-www-form-urlencoded".
See L<lwpcook> for examples of this.

The libwww-perl HTTP implementation currently support the HTTP/1.1
and HTTP/1.0 protocol.

The library allows you to access proxy server through HTTP.  This
means that you can set up the library to forward all types of request
through the HTTP protocol module.  See L<LWP::UserAgent> for
documentation of this.


=head2 HTTPS Requests

HTTPS requests are HTTP requests over an encrypted network connection
using the SSL protocol developed by Netscape.  Everything about HTTP
requests above also apply to HTTPS requests.  In addition the library
will add the headers "Client-SSL-Cipher", "Client-SSL-Cert-Subject" and
"Client-SSL-Cert-Issuer" to the response.  These headers denote the
encryption method used and the name of the server owner.

The request can contain the header "If-SSL-Cert-Subject" in order to
make the request conditional on the content of the server certificate.
If the certificate subject does not match, no request is sent to the
server and an internally generated error response is returned.  The
value of the "If-SSL-Cert-Subject" header is interpreted as a Perl
regular expression.


=head2 FTP Requests

The library currently supports GET, HEAD and PUT requests.  GET
retrieves a file or a directory listing from an FTP server.  PUT
stores a file on a ftp server.

You can specify a ftp account for servers that want this in addition
to user name and password.  This is specified by including an "Account"
header in the request.

User name/password can be specified using basic authorization or be
encoded in the URL.  Failed logins return an UNAUTHORIZED response with
"WWW-Authenticate: Basic" and can be treated like basic authorization
for HTTP.

The library supports ftp ASCII transfer mode by specifying the "type=a"
parameter in the URL. It also supports transfer of ranges for FTP transfers
using the "Range" header.

Directory listings are by default returned unprocessed (as returned
from the ftp server) with the content media type reported to be
"text/ftp-dir-listing". The L<File::Listing> module provides methods
for parsing of these directory listing.

The ftp module is also able to convert directory listings to HTML and
this can be requested via the standard HTTP content negotiation
mechanisms (add an "Accept: text/html" header in the request if you
want this).

For normal file retrievals, the "Content-Type" is guessed based on the
file name suffix. See L<LWP::MediaTypes>.

The "If-Modified-Since" request header works for servers that implement
the C<MDTM> command.  It will probably not work for directory listings though.

Example:

  $req = HTTP::Request->new(GET => 'ftp://me:passwd@ftp.some.where.com/');
  $req->header(Accept => "text/html, */*;q=0.1");

=head2 News Requests

Access to the USENET News system is implemented through the NNTP
protocol.  The name of the news server is obtained from the
NNTP_SERVER environment variable and defaults to "news".  It is not
possible to specify the hostname of the NNTP server in news: URLs.

The library supports GET and HEAD to retrieve news articles through the
NNTP protocol.  You can also post articles to newsgroups by using
(surprise!) the POST method.

GET on newsgroups is not implemented yet.

Examples:

  $req = HTTP::Request->new(GET => 'news:abc1234@a.sn.no');

  $req = HTTP::Request->new(POST => 'news:comp.lang.perl.test');
  $req->header(Subject => 'This is a test',
               From    => 'me@some.where.org');
  $req->content(<<EOT);
  This is the content of the message that we are sending to
  the world.
  EOT


=head2 Gopher Request

The library supports the GET and HEAD methods for gopher requests.  All
request header values are ignored.  HEAD cheats and returns a
response without even talking to server.

Gopher menus are always converted to HTML.

The response "Content-Type" is generated from the document type
encoded (as the first letter) in the request URL path itself.

Example:

  $req = HTTP::Request->new(GET => 'gopher://gopher.sn.no/');


=head2 File Request

The library supports GET and HEAD methods for file requests.  The
"If-Modified-Since" header is supported.  All other headers are
ignored.  The I<host> component of the file URL must be empty or set
to "localhost".  Any other I<host> value will be treated as an error.

Directories are always converted to an HTML document.  For normal
files, the "Content-Type" and "Content-Encoding" in the response are
guessed based on the file suffix.

Example:

  $req = HTTP::Request->new(GET => 'file:/etc/passwd');


=head2 Mailto Request

You can send (aka "POST") mail messages using the library.  All
headers specified for the request are passed on to the mail system.
The "To" header is initialized from the mail address in the URL.

Example:

  $req = HTTP::Request->new(POST => 'mailto:libwww@perl.org');
  $req->header(Subject => "subscribe");
  $req->content("Please subscribe me to the libwww-perl mailing list!\n");

=head2 CPAN Requests

URLs with scheme C<cpan:> are redirected to a suitable CPAN
mirror.  If you have your own local mirror of CPAN you might tell LWP
to use it for C<cpan:> URLs by an assignment like this:

  $LWP::Protocol::cpan::CPAN = "file:/local/CPAN/";

Suitable CPAN mirrors are also picked up from the configuration for
the CPAN.pm, so if you have used that module a suitable mirror should
be picked automatically.  If neither of these apply, then a redirect
to the generic CPAN http location is issued.

Example request to download the newest perl:

  $req = HTTP::Request->new(GET => "cpan:src/latest.tar.gz");


=head1 OVERVIEW OF CLASSES AND PACKAGES

This table should give you a quick overview of the classes provided by the
library. Indentation shows class inheritance.

 LWP::MemberMixin   -- Access to member variables of Perl5 classes
   LWP::UserAgent   -- WWW user agent class
     LWP::RobotUA   -- When developing a robot applications
   LWP::Protocol          -- Interface to various protocol schemes
     LWP::Protocol::http  -- http:// access
     LWP::Protocol::file  -- file:// access
     LWP::Protocol::ftp   -- ftp:// access
     ...

 LWP::Authen::Basic -- Handle 401 and 407 responses
 LWP::Authen::Digest

 HTTP::Headers      -- MIME/RFC822 style header (used by HTTP::Message)
 HTTP::Message      -- HTTP style message
   HTTP::Request    -- HTTP request
   HTTP::Response   -- HTTP response
 HTTP::Daemon       -- A HTTP server class

 WWW::RobotRules    -- Parse robots.txt files
   WWW::RobotRules::AnyDBM_File -- Persistent RobotRules

 Net::HTTP          -- Low level HTTP client

The following modules provide various functions and definitions.

 LWP                -- This file.  Library version number and documentation.
 LWP::MediaTypes    -- MIME types configuration (text/html etc.)
 LWP::Simple        -- Simplified procedural interface for common functions
 HTTP::Status       -- HTTP status code (200 OK etc)
 HTTP::Date         -- Date parsing module for HTTP date formats
 HTTP::Negotiate    -- HTTP content negotiation calculation
 File::Listing      -- Parse directory listings
 HTML::Form         -- Processing for <form>s in HTML documents


=head1 MORE DOCUMENTATION

All modules contain detailed information on the interfaces they
provide.  The L<lwpcook> manpage is the libwww-perl cookbook that contain
examples of typical usage of the library.  You might want to take a
look at how the scripts L<lwp-request>, L<lwp-download>, L<lwp-dump>
and L<lwp-mirror> are implemented.

=head1 ENVIRONMENT

The following environment variables are used by LWP:

=over

=item HOME

The L<LWP::MediaTypes> functions will look for the F<.media.types> and
F<.mime.types> files relative to you home directory.

=item http_proxy

=item ftp_proxy

=item xxx_proxy

=item no_proxy

These environment variables can be set to enable communication through
a proxy server.  See the description of the C<env_proxy> method in
L<LWP::UserAgent>.

=item PERL_LWP_ENV_PROXY

If set to a TRUE value, then the L<LWP::UserAgent> will by default call
C<env_proxy> during initialization.  This makes LWP honor the proxy variables
described above.

=item PERL_LWP_SSL_VERIFY_HOSTNAME

The default C<verify_hostname> setting for L<LWP::UserAgent>.  If
not set the default will be 1.  Set it as 0 to disable hostname
verification (the default prior to libwww-perl 5.840.

=item PERL_LWP_SSL_CA_FILE

=item PERL_LWP_SSL_CA_PATH

The file and/or directory
where the trusted Certificate Authority certificates
is located.  See L<LWP::UserAgent> for details.

=item PERL_HTTP_URI_CLASS

Used to decide what URI objects to instantiate.  The default is L<URI>.
You might want to set it to L<URI::URL> for compatibility with old times.

=back

=head1 AUTHORS

LWP was made possible by contributions from Adam Newby, Albert
Dvornik, Alexandre Duret-Lutz, Andreas Gustafsson, Andreas König,
Andrew Pimlott, Andy Lester, Ben Coleman, Benjamin Low, Ben Low, Ben
Tilly, Blair Zajac, Bob Dalgleish, BooK, Brad Hughes, Brian
J. Murrell, Brian McCauley, Charles C. Fu, Charles Lane, Chris Nandor,
Christian Gilmore, Chris W. Unger, Craig Macdonald, Dale Couch, Dan
Kubb, Dave Dunkin, Dave W. Smith, David Coppit, David Dick, David
D. Kilzer, Doug MacEachern, Edward Avis, erik, Gary Shea, Gisle Aas,
Graham Barr, Gurusamy Sarathy, Hans de Graaff, Harald Joerg, Harry
Bochner, Hugo, Ilya Zakharevich, INOUE Yoshinari, Ivan Panchenko, Jack
Shirazi, James Tillman, Jan Dubois, Jared Rhine, Jim Stern, Joao
Lopes, John Klar, Johnny Lee, Josh Kronengold, Josh Rai, Joshua
Chamas, Joshua Hoblitt, Kartik Subbarao, Keiichiro Nagano, Ken
Williams, KONISHI Katsuhiro, Lee T Lindley, Liam Quinn, Marc Hedlund,
Marc Langheinrich, Mark D. Anderson, Marko Asplund, Mark Stosberg,
Markus B Krüger, Markus Laker, Martijn Koster, Martin Thurn, Matthew
Eldridge, Matthew.van.Eerde, Matt Sergeant, Michael A. Chase, Michael
Quaranta, Michael Thompson, Mike Schilli, Moshe Kaminsky, Nathan
Torkington, Nicolai Langfeldt, Norton Allen, Olly Betts, Paul
J. Schinder, peterm, Philip Guenther, Daniel Buenzli, Pon Hwa Lin,
Radoslaw Zielinski, Radu Greab, Randal L. Schwartz, Richard Chen,
Robin Barker, Roy Fielding, Sander van Zoest, Sean M. Burke,
shildreth, Slaven Rezic, Steve A Fink, Steve Hay, Steven Butler,
Steve_Kilbane, Takanori Ugai, Thomas Lotterer, Tim Bunce, Tom Hughes,
Tony Finch, Ville Skyttä, Ward Vandewege, William York, Yale Huang,
and Yitzchak Scott-Thoennes.

LWP owes a lot in motivation, design, and code, to the libwww-perl
library for Perl4 by Roy Fielding, which included work from Alberto
Accomazzi, James Casey, Brooks Cutter, Martijn Koster, Oscar
Nierstrasz, Mel Melchner, Gertjan van Oosten, Jared Rhine, Jack
Shirazi, Gene Spafford, Marc VanHeyningen, Steven E. Brenner, Marion
Hakanson, Waldemar Kebsch, Tony Sanders, and Larry Wall; see the
libwww-perl-0.40 library for details.

=head1 COPYRIGHT

  Copyright 1995-2009, Gisle Aas
  Copyright 1995, Martijn Koster

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

=head1 AVAILABILITY

The latest version of this library is likely to be available from CPAN
as well as:

  http://github.com/libwww-perl/libwww-perl

The best place to discuss this code is on the <libwww@perl.org>
mailing list.

=cut
PK       ! ���ri  ri    perl5/CPAN/Meta/YAML.pmnu ��6�$        use 5.008001; # sane UTF-8 support
use strict;
use warnings;
package CPAN::Meta::YAML; # git description: v1.68-2-gcc5324e
# XXX-INGY is 5.8.1 too old/broken for utf8?
# XXX-XDG Lancaster consensus was that it was sufficient until
# proven otherwise
$CPAN::Meta::YAML::VERSION = '0.018';
; # original $VERSION removed by Doppelgaenger

#####################################################################
# The CPAN::Meta::YAML API.
#
# These are the currently documented API functions/methods and
# exports:

use Exporter;
our @ISA       = qw{ Exporter  };
our @EXPORT    = qw{ Load Dump };
our @EXPORT_OK = qw{ LoadFile DumpFile freeze thaw };

###
# Functional/Export API:

sub Dump {
    return CPAN::Meta::YAML->new(@_)->_dump_string;
}

# XXX-INGY Returning last document seems a bad behavior.
# XXX-XDG I think first would seem more natural, but I don't know
# that it's worth changing now
sub Load {
    my $self = CPAN::Meta::YAML->_load_string(@_);
    if ( wantarray ) {
        return @$self;
    } else {
        # To match YAML.pm, return the last document
        return $self->[-1];
    }
}

# XXX-INGY Do we really need freeze and thaw?
# XXX-XDG I don't think so.  I'd support deprecating them.
BEGIN {
    *freeze = \&Dump;
    *thaw   = \&Load;
}

sub DumpFile {
    my $file = shift;
    return CPAN::Meta::YAML->new(@_)->_dump_file($file);
}

sub LoadFile {
    my $file = shift;
    my $self = CPAN::Meta::YAML->_load_file($file);
    if ( wantarray ) {
        return @$self;
    } else {
        # Return only the last document to match YAML.pm,
        return $self->[-1];
    }
}


###
# Object Oriented API:

# Create an empty CPAN::Meta::YAML object
# XXX-INGY Why do we use ARRAY object?
# NOTE: I get it now, but I think it's confusing and not needed.
# Will change it on a branch later, for review.
#
# XXX-XDG I don't support changing it yet.  It's a very well-documented
# "API" of CPAN::Meta::YAML.  I'd support deprecating it, but Adam suggested
# we not change it until YAML.pm's own OO API is established so that
# users only have one API change to digest, not two
sub new {
    my $class = shift;
    bless [ @_ ], $class;
}

# XXX-INGY It probably doesn't matter, and it's probably too late to
# change, but 'read/write' are the wrong names. Read and Write
# are actions that take data from storage to memory
# characters/strings. These take the data to/from storage to native
# Perl objects, which the terms dump and load are meant. As long as
# this is a legacy quirk to CPAN::Meta::YAML it's ok, but I'd prefer not
# to add new {read,write}_* methods to this API.

sub read_string {
    my $self = shift;
    $self->_load_string(@_);
}

sub write_string {
    my $self = shift;
    $self->_dump_string(@_);
}

sub read {
    my $self = shift;
    $self->_load_file(@_);
}

sub write {
    my $self = shift;
    $self->_dump_file(@_);
}


#####################################################################
# Constants

# Printed form of the unprintable characters in the lowest range
# of ASCII characters, listed by ASCII ordinal position.
my @UNPRINTABLE = qw(
    0    x01  x02  x03  x04  x05  x06  a
    b    t    n    v    f    r    x0E  x0F
    x10  x11  x12  x13  x14  x15  x16  x17
    x18  x19  x1A  e    x1C  x1D  x1E  x1F
);

# Printable characters for escapes
my %UNESCAPES = (
    0 => "\x00", z => "\x00", N    => "\x85",
    a => "\x07", b => "\x08", t    => "\x09",
    n => "\x0a", v => "\x0b", f    => "\x0c",
    r => "\x0d", e => "\x1b", '\\' => '\\',
);

# XXX-INGY
# I(ngy) need to decide if these values should be quoted in
# CPAN::Meta::YAML or not. Probably yes.

# These 3 values have special meaning when unquoted and using the
# default YAML schema. They need quotes if they are strings.
my %QUOTE = map { $_ => 1 } qw{
    null true false
};

# The commented out form is simpler, but overloaded the Perl regex
# engine due to recursion and backtracking problems on strings
# larger than 32,000ish characters. Keep it for reference purposes.
# qr/\"((?:\\.|[^\"])*)\"/
my $re_capture_double_quoted = qr/\"([^\\"]*(?:\\.[^\\"]*)*)\"/;
my $re_capture_single_quoted = qr/\'([^\']*(?:\'\'[^\']*)*)\'/;
# unquoted re gets trailing space that needs to be stripped
my $re_capture_unquoted_key  = qr/([^:]+(?::+\S(?:[^:]*|.*?(?=:)))*)(?=\s*\:(?:\s+|$))/;
my $re_trailing_comment      = qr/(?:\s+\#.*)?/;
my $re_key_value_separator   = qr/\s*:(?:\s+(?:\#.*)?|$)/;


#####################################################################
# CPAN::Meta::YAML Implementation.
#
# These are the private methods that do all the work. They may change
# at any time.


###
# Loader functions:

# Create an object from a file
sub _load_file {
    my $class = ref $_[0] ? ref shift : shift;

    # Check the file
    my $file = shift or $class->_error( 'You did not specify a file name' );
    $class->_error( "File '$file' does not exist" )
        unless -e $file;
    $class->_error( "'$file' is a directory, not a file" )
        unless -f _;
    $class->_error( "Insufficient permissions to read '$file'" )
        unless -r _;

    # Open unbuffered with strict UTF-8 decoding and no translation layers
    open( my $fh, "<:unix:encoding(UTF-8)", $file );
    unless ( $fh ) {
        $class->_error("Failed to open file '$file': $!");
    }

    # flock if available (or warn if not possible for OS-specific reasons)
    if ( _can_flock() ) {
        flock( $fh, Fcntl::LOCK_SH() )
            or warn "Couldn't lock '$file' for reading: $!";
    }

    # slurp the contents
    my $contents = eval {
        use warnings FATAL => 'utf8';
        local $/;
        <$fh>
    };
    if ( my $err = $@ ) {
        $class->_error("Error reading from file '$file': $err");
    }

    # close the file (release the lock)
    unless ( close $fh ) {
        $class->_error("Failed to close file '$file': $!");
    }

    $class->_load_string( $contents );
}

# Create an object from a string
sub _load_string {
    my $class  = ref $_[0] ? ref shift : shift;
    my $self   = bless [], $class;
    my $string = $_[0];
    eval {
        unless ( defined $string ) {
            die \"Did not provide a string to load";
        }

        # Check if Perl has it marked as characters, but it's internally
        # inconsistent.  E.g. maybe latin1 got read on a :utf8 layer
        if ( utf8::is_utf8($string) && ! utf8::valid($string) ) {
            die \<<'...';
Read an invalid UTF-8 string (maybe mixed UTF-8 and 8-bit character set).
Did you decode with lax ":utf8" instead of strict ":encoding(UTF-8)"?
...
        }

        # Ensure Unicode character semantics, even for 0x80-0xff
        utf8::upgrade($string);

        # Check for and strip any leading UTF-8 BOM
        $string =~ s/^\x{FEFF}//;

        # Check for some special cases
        return $self unless length $string;

        # Split the file into lines
        my @lines = grep { ! /^\s*(?:\#.*)?\z/ }
                split /(?:\015{1,2}\012|\015|\012)/, $string;

        # Strip the initial YAML header
        @lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines;

        # A nibbling parser
        my $in_document = 0;
        while ( @lines ) {
            # Do we have a document header?
            if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) {
                # Handle scalar documents
                shift @lines;
                if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) {
                    push @$self,
                        $self->_load_scalar( "$1", [ undef ], \@lines );
                    next;
                }
                $in_document = 1;
            }

            if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) {
                # A naked document
                push @$self, undef;
                while ( @lines and $lines[0] !~ /^---/ ) {
                    shift @lines;
                }
                $in_document = 0;

            # XXX The final '-+$' is to look for -- which ends up being an
            # error later.
            } elsif ( ! $in_document && @$self ) {
                # only the first document can be explicit
                die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'";
            } elsif ( $lines[0] =~ /^\s*\-(?:\s|$|-+$)/ ) {
                # An array at the root
                my $document = [ ];
                push @$self, $document;
                $self->_load_array( $document, [ 0 ], \@lines );

            } elsif ( $lines[0] =~ /^(\s*)\S/ ) {
                # A hash at the root
                my $document = { };
                push @$self, $document;
                $self->_load_hash( $document, [ length($1) ], \@lines );

            } else {
                # Shouldn't get here.  @lines have whitespace-only lines
                # stripped, and previous match is a line with any
                # non-whitespace.  So this clause should only be reachable via
                # a perlbug where \s is not symmetric with \S

                # uncoverable statement
                die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'";
            }
        }
    };
    my $err = $@;
    if ( ref $err eq 'SCALAR' ) {
        $self->_error(${$err});
    } elsif ( $err ) {
        $self->_error($err);
    }

    return $self;
}

sub _unquote_single {
    my ($self, $string) = @_;
    return '' unless length $string;
    $string =~ s/\'\'/\'/g;
    return $string;
}

sub _unquote_double {
    my ($self, $string) = @_;
    return '' unless length $string;
    $string =~ s/\\"/"/g;
    $string =~
        s{\\([Nnever\\fartz0b]|x([0-9a-fA-F]{2}))}
         {(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}}gex;
    return $string;
}

# Load a YAML scalar string to the actual Perl scalar
sub _load_scalar {
    my ($self, $string, $indent, $lines) = @_;

    # Trim trailing whitespace
    $string =~ s/\s*\z//;

    # Explitic null/undef
    return undef if $string eq '~';

    # Single quote
    if ( $string =~ /^$re_capture_single_quoted$re_trailing_comment\z/ ) {
        return $self->_unquote_single($1);
    }

    # Double quote.
    if ( $string =~ /^$re_capture_double_quoted$re_trailing_comment\z/ ) {
        return $self->_unquote_double($1);
    }

    # Special cases
    if ( $string =~ /^[\'\"!&]/ ) {
        die \"CPAN::Meta::YAML does not support a feature in line '$string'";
    }
    return {} if $string =~ /^{}(?:\s+\#.*)?\z/;
    return [] if $string =~ /^\[\](?:\s+\#.*)?\z/;

    # Regular unquoted string
    if ( $string !~ /^[>|]/ ) {
        die \"CPAN::Meta::YAML found illegal characters in plain scalar: '$string'"
            if $string =~ /^(?:-(?:\s|$)|[\@\%\`])/ or
                $string =~ /:(?:\s|$)/;
        $string =~ s/\s+#.*\z//;
        return $string;
    }

    # Error
    die \"CPAN::Meta::YAML failed to find multi-line scalar content" unless @$lines;

    # Check the indent depth
    $lines->[0]   =~ /^(\s*)/;
    $indent->[-1] = length("$1");
    if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) {
        die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
    }

    # Pull the lines
    my @multiline = ();
    while ( @$lines ) {
        $lines->[0] =~ /^(\s*)/;
        last unless length($1) >= $indent->[-1];
        push @multiline, substr(shift(@$lines), length($1));
    }

    my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n";
    my $t = (substr($string, 1, 1) eq '-') ? ''  : "\n";
    return join( $j, @multiline ) . $t;
}

# Load an array
sub _load_array {
    my ($self, $array, $indent, $lines) = @_;

    while ( @$lines ) {
        # Check for a new document
        if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
            while ( @$lines and $lines->[0] !~ /^---/ ) {
                shift @$lines;
            }
            return 1;
        }

        # Check the indent level
        $lines->[0] =~ /^(\s*)/;
        if ( length($1) < $indent->[-1] ) {
            return 1;
        } elsif ( length($1) > $indent->[-1] ) {
            die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
        }

        if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) {
            # Inline nested hash
            my $indent2 = length("$1");
            $lines->[0] =~ s/-/ /;
            push @$array, { };
            $self->_load_hash( $array->[-1], [ @$indent, $indent2 ], $lines );

        } elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) {
            shift @$lines;
            unless ( @$lines ) {
                push @$array, undef;
                return 1;
            }
            if ( $lines->[0] =~ /^(\s*)\-/ ) {
                my $indent2 = length("$1");
                if ( $indent->[-1] == $indent2 ) {
                    # Null array entry
                    push @$array, undef;
                } else {
                    # Naked indenter
                    push @$array, [ ];
                    $self->_load_array(
                        $array->[-1], [ @$indent, $indent2 ], $lines
                    );
                }

            } elsif ( $lines->[0] =~ /^(\s*)\S/ ) {
                push @$array, { };
                $self->_load_hash(
                    $array->[-1], [ @$indent, length("$1") ], $lines
                );

            } else {
                die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
            }

        } elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) {
            # Array entry with a value
            shift @$lines;
            push @$array, $self->_load_scalar(
                "$2", [ @$indent, undef ], $lines
            );

        } elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) {
            # This is probably a structure like the following...
            # ---
            # foo:
            # - list
            # bar: value
            #
            # ... so lets return and let the hash parser handle it
            return 1;

        } else {
            die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
        }
    }

    return 1;
}

# Load a hash
sub _load_hash {
    my ($self, $hash, $indent, $lines) = @_;

    while ( @$lines ) {
        # Check for a new document
        if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
            while ( @$lines and $lines->[0] !~ /^---/ ) {
                shift @$lines;
            }
            return 1;
        }

        # Check the indent level
        $lines->[0] =~ /^(\s*)/;
        if ( length($1) < $indent->[-1] ) {
            return 1;
        } elsif ( length($1) > $indent->[-1] ) {
            die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
        }

        # Find the key
        my $key;

        # Quoted keys
        if ( $lines->[0] =~
            s/^\s*$re_capture_single_quoted$re_key_value_separator//
        ) {
            $key = $self->_unquote_single($1);
        }
        elsif ( $lines->[0] =~
            s/^\s*$re_capture_double_quoted$re_key_value_separator//
        ) {
            $key = $self->_unquote_double($1);
        }
        elsif ( $lines->[0] =~
            s/^\s*$re_capture_unquoted_key$re_key_value_separator//
        ) {
            $key = $1;
            $key =~ s/\s+$//;
        }
        elsif ( $lines->[0] =~ /^\s*\?/ ) {
            die \"CPAN::Meta::YAML does not support a feature in line '$lines->[0]'";
        }
        else {
            die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
        }

        if ( exists $hash->{$key} ) {
            warn "CPAN::Meta::YAML found a duplicate key '$key' in line '$lines->[0]'";
        }

        # Do we have a value?
        if ( length $lines->[0] ) {
            # Yes
            $hash->{$key} = $self->_load_scalar(
                shift(@$lines), [ @$indent, undef ], $lines
            );
        } else {
            # An indent
            shift @$lines;
            unless ( @$lines ) {
                $hash->{$key} = undef;
                return 1;
            }
            if ( $lines->[0] =~ /^(\s*)-/ ) {
                $hash->{$key} = [];
                $self->_load_array(
                    $hash->{$key}, [ @$indent, length($1) ], $lines
                );
            } elsif ( $lines->[0] =~ /^(\s*)./ ) {
                my $indent2 = length("$1");
                if ( $indent->[-1] >= $indent2 ) {
                    # Null hash entry
                    $hash->{$key} = undef;
                } else {
                    $hash->{$key} = {};
                    $self->_load_hash(
                        $hash->{$key}, [ @$indent, length($1) ], $lines
                    );
                }
            }
        }
    }

    return 1;
}


###
# Dumper functions:

# Save an object to a file
sub _dump_file {
    my $self = shift;

    require Fcntl;

    # Check the file
    my $file = shift or $self->_error( 'You did not specify a file name' );

    my $fh;
    # flock if available (or warn if not possible for OS-specific reasons)
    if ( _can_flock() ) {
        # Open without truncation (truncate comes after lock)
        my $flags = Fcntl::O_WRONLY()|Fcntl::O_CREAT();
        sysopen( $fh, $file, $flags );
        unless ( $fh ) {
            $self->_error("Failed to open file '$file' for writing: $!");
        }

        # Use no translation and strict UTF-8
        binmode( $fh, ":raw:encoding(UTF-8)");

        flock( $fh, Fcntl::LOCK_EX() )
            or warn "Couldn't lock '$file' for reading: $!";

        # truncate and spew contents
        truncate $fh, 0;
        seek $fh, 0, 0;
    }
    else {
        open $fh, ">:unix:encoding(UTF-8)", $file;
    }

    # serialize and spew to the handle
    print {$fh} $self->_dump_string;

    # close the file (release the lock)
    unless ( close $fh ) {
        $self->_error("Failed to close file '$file': $!");
    }

    return 1;
}

# Save an object to a string
sub _dump_string {
    my $self = shift;
    return '' unless ref $self && @$self;

    # Iterate over the documents
    my $indent = 0;
    my @lines  = ();

    eval {
        foreach my $cursor ( @$self ) {
            push @lines, '---';

            # An empty document
            if ( ! defined $cursor ) {
                # Do nothing

            # A scalar document
            } elsif ( ! ref $cursor ) {
                $lines[-1] .= ' ' . $self->_dump_scalar( $cursor );

            # A list at the root
            } elsif ( ref $cursor eq 'ARRAY' ) {
                unless ( @$cursor ) {
                    $lines[-1] .= ' []';
                    next;
                }
                push @lines, $self->_dump_array( $cursor, $indent, {} );

            # A hash at the root
            } elsif ( ref $cursor eq 'HASH' ) {
                unless ( %$cursor ) {
                    $lines[-1] .= ' {}';
                    next;
                }
                push @lines, $self->_dump_hash( $cursor, $indent, {} );

            } else {
                die \("Cannot serialize " . ref($cursor));
            }
        }
    };
    if ( ref $@ eq 'SCALAR' ) {
        $self->_error(${$@});
    } elsif ( $@ ) {
        $self->_error($@);
    }

    join '', map { "$_\n" } @lines;
}

sub _has_internal_string_value {
    my $value = shift;
    my $b_obj = B::svref_2object(\$value);  # for round trip problem
    return $b_obj->FLAGS & B::SVf_POK();
}

sub _dump_scalar {
    my $string = $_[1];
    my $is_key = $_[2];
    # Check this before checking length or it winds up looking like a string!
    my $has_string_flag = _has_internal_string_value($string);
    return '~'  unless defined $string;
    return "''" unless length  $string;
    if (Scalar::Util::looks_like_number($string)) {
        # keys and values that have been used as strings get quoted
        if ( $is_key || $has_string_flag ) {
            return qq['$string'];
        }
        else {
            return $string;
        }
    }
    if ( $string =~ /[\x00-\x09\x0b-\x0d\x0e-\x1f\x7f-\x9f\'\n]/ ) {
        $string =~ s/\\/\\\\/g;
        $string =~ s/"/\\"/g;
        $string =~ s/\n/\\n/g;
        $string =~ s/[\x85]/\\N/g;
        $string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g;
        $string =~ s/([\x7f-\x9f])/'\x' . sprintf("%X",ord($1))/ge;
        return qq|"$string"|;
    }
    if ( $string =~ /(?:^[~!@#%&*|>?:,'"`{}\[\]]|^-+$|\s|:\z)/ or
        $QUOTE{$string}
    ) {
        return "'$string'";
    }
    return $string;
}

sub _dump_array {
    my ($self, $array, $indent, $seen) = @_;
    if ( $seen->{refaddr($array)}++ ) {
        die \"CPAN::Meta::YAML does not support circular references";
    }
    my @lines  = ();
    foreach my $el ( @$array ) {
        my $line = ('  ' x $indent) . '-';
        my $type = ref $el;
        if ( ! $type ) {
            $line .= ' ' . $self->_dump_scalar( $el );
            push @lines, $line;

        } elsif ( $type eq 'ARRAY' ) {
            if ( @$el ) {
                push @lines, $line;
                push @lines, $self->_dump_array( $el, $indent + 1, $seen );
            } else {
                $line .= ' []';
                push @lines, $line;
            }

        } elsif ( $type eq 'HASH' ) {
            if ( keys %$el ) {
                push @lines, $line;
                push @lines, $self->_dump_hash( $el, $indent + 1, $seen );
            } else {
                $line .= ' {}';
                push @lines, $line;
            }

        } else {
            die \"CPAN::Meta::YAML does not support $type references";
        }
    }

    @lines;
}

sub _dump_hash {
    my ($self, $hash, $indent, $seen) = @_;
    if ( $seen->{refaddr($hash)}++ ) {
        die \"CPAN::Meta::YAML does not support circular references";
    }
    my @lines  = ();
    foreach my $name ( sort keys %$hash ) {
        my $el   = $hash->{$name};
        my $line = ('  ' x $indent) . $self->_dump_scalar($name, 1) . ":";
        my $type = ref $el;
        if ( ! $type ) {
            $line .= ' ' . $self->_dump_scalar( $el );
            push @lines, $line;

        } elsif ( $type eq 'ARRAY' ) {
            if ( @$el ) {
                push @lines, $line;
                push @lines, $self->_dump_array( $el, $indent + 1, $seen );
            } else {
                $line .= ' []';
                push @lines, $line;
            }

        } elsif ( $type eq 'HASH' ) {
            if ( keys %$el ) {
                push @lines, $line;
                push @lines, $self->_dump_hash( $el, $indent + 1, $seen );
            } else {
                $line .= ' {}';
                push @lines, $line;
            }

        } else {
            die \"CPAN::Meta::YAML does not support $type references";
        }
    }

    @lines;
}


#####################################################################
# DEPRECATED API methods:

# Error storage (DEPRECATED as of 1.57)
our $errstr    = '';

# Set error
sub _error {
    require Carp;
    $errstr = $_[1];
    $errstr =~ s/ at \S+ line \d+.*//;
    Carp::croak( $errstr );
}

# Retrieve error
my $errstr_warned;
sub errstr {
    require Carp;
    Carp::carp( "CPAN::Meta::YAML->errstr and \$CPAN::Meta::YAML::errstr is deprecated" )
        unless $errstr_warned++;
    $errstr;
}


#####################################################################
# Helper functions. Possibly not needed.


# Use to detect nv or iv
use B;

# XXX-INGY Is flock CPAN::Meta::YAML's responsibility?
# Some platforms can't flock :-(
# XXX-XDG I think it is.  When reading and writing files, we ought
# to be locking whenever possible.  People (foolishly) use YAML
# files for things like session storage, which has race issues.
my $HAS_FLOCK;
sub _can_flock {
    if ( defined $HAS_FLOCK ) {
        return $HAS_FLOCK;
    }
    else {
        require Config;
        my $c = \%Config::Config;
        $HAS_FLOCK = grep { $c->{$_} } qw/d_flock d_fcntl_can_lock d_lockf/;
        require Fcntl if $HAS_FLOCK;
        return $HAS_FLOCK;
    }
}


# XXX-INGY Is this core in 5.8.1? Can we remove this?
# XXX-XDG Scalar::Util 1.18 didn't land until 5.8.8, so we need this
#####################################################################
# Use Scalar::Util if possible, otherwise emulate it

use Scalar::Util ();
BEGIN {
    local $@;
    if ( eval { Scalar::Util->VERSION(1.18); } ) {
        *refaddr = *Scalar::Util::refaddr;
    }
    else {
        eval <<'END_PERL';
# Scalar::Util failed to load or too old
sub refaddr {
    my $pkg = ref($_[0]) or return undef;
    if ( !! UNIVERSAL::can($_[0], 'can') ) {
        bless $_[0], 'Scalar::Util::Fake';
    } else {
        $pkg = undef;
    }
    "$_[0]" =~ /0x(\w+)/;
    my $i = do { no warnings 'portable'; hex $1 };
    bless $_[0], $pkg if defined $pkg;
    $i;
}
END_PERL
    }
}

delete $CPAN::Meta::YAML::{refaddr};

1;

# XXX-INGY Doc notes I'm putting up here. Changing the doc when it's wrong
# but leaving grey area stuff up here.
#
# I would like to change Read/Write to Load/Dump below without
# changing the actual API names.
#
# It might be better to put Load/Dump API in the SYNOPSIS instead of the
# dubious OO API.
#
# null and bool explanations may be outdated.

=pod

=encoding UTF-8

=head1 NAME

CPAN::Meta::YAML - Read and write a subset of YAML for CPAN Meta files

=head1 VERSION

version 0.018

=head1 SYNOPSIS

    use CPAN::Meta::YAML;

    # reading a META file
    open $fh, "<:utf8", "META.yml";
    $yaml_text = do { local $/; <$fh> };
    $yaml = CPAN::Meta::YAML->read_string($yaml_text)
      or die CPAN::Meta::YAML->errstr;

    # finding the metadata
    $meta = $yaml->[0];

    # writing a META file
    $yaml_text = $yaml->write_string
      or die CPAN::Meta::YAML->errstr;
    open $fh, ">:utf8", "META.yml";
    print $fh $yaml_text;

=head1 DESCRIPTION

This module implements a subset of the YAML specification for use in reading
and writing CPAN metadata files like F<META.yml> and F<MYMETA.yml>.  It should
not be used for any other general YAML parsing or generation task.

NOTE: F<META.yml> (and F<MYMETA.yml>) files should be UTF-8 encoded.  Users are
responsible for proper encoding and decoding.  In particular, the C<read> and
C<write> methods do B<not> support UTF-8 and should not be used.

=head1 SUPPORT

This module is currently derived from L<YAML::Tiny> by Adam Kennedy.  If
there are bugs in how it parses a particular META.yml file, please file
a bug report in the YAML::Tiny bugtracker:
L<https://github.com/Perl-Toolchain-Gang/YAML-Tiny/issues>

=head1 SEE ALSO

L<YAML::Tiny>, L<YAML>, L<YAML::XS>

=head1 AUTHORS

=over 4

=item *

Adam Kennedy <adamk@cpan.org>

=item *

David Golden <dagolden@cpan.org>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2010 by Adam Kennedy.

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

=cut

__END__


# ABSTRACT: Read and write a subset of YAML for CPAN Meta files


PK       ! ��cm�  �    perl5/CPAN/Meta/Merge.pmnu ��6�$        use strict;
use warnings;

package CPAN::Meta::Merge;
# VERSION
$CPAN::Meta::Merge::VERSION = '2.143240';
use Carp qw/croak/;
use Scalar::Util qw/blessed/;
use CPAN::Meta::Converter;

sub _identical {
  my ($left, $right, $path) = @_;
  croak sprintf "Can't merge attribute %s: '%s' does not equal '%s'", join('.', @{$path}), $left, $right unless $left eq $right;
  return $left;
}

sub _merge {
  my ($current, $next, $mergers, $path) = @_;
  for my $key (keys %{$next}) {
    if (not exists $current->{$key}) {
      $current->{$key} = $next->{$key};
    }
    elsif (my $merger = $mergers->{$key}) {
      $current->{$key} = $merger->($current->{$key}, $next->{$key}, [ @{$path}, $key ]);
    }
    elsif ($merger = $mergers->{':default'}) {
      $current->{$key} = $merger->($current->{$key}, $next->{$key}, [ @{$path}, $key ]);
    }
    else {
      croak sprintf "Can't merge unknown attribute '%s'", join '.', @{$path}, $key;
    }
  }
  return $current;
}

sub _uniq {
  my %seen = ();
  return grep { not $seen{$_}++ } @_;
}

sub _set_addition {
  my ($left, $right) = @_;
  return [ +_uniq(@{$left}, @{$right}) ];
}

sub _uniq_map {
  my ($left, $right, $path) = @_;
  for my $key (keys %{$right}) {
    if (not exists $left->{$key}) {
      $left->{$key} = $right->{$key};
    }
    else {
      croak 'Duplication of element ' . join '.', @{$path}, $key;
    }
  }
  return $left;
}

sub _improvize {
  my ($left, $right, $path) = @_;
  my ($name) = reverse @{$path};
  if ($name =~ /^x_/) {
    if (ref($left) eq 'ARRAY') {
      return _set_addition($left, $right, $path);
    }
    elsif (ref($left) eq 'HASH') {
      return _uniq_map($left, $right, $path);
    }
    else {
      return _identical($left, $right, $path);
    }
  }
  croak sprintf "Can't merge '%s'", join '.', @{$path};
}

sub _optional_features {
  my ($left, $right, $path) = @_;

  for my $key (keys %{$right}) {
    if (not exists $left->{$key}) {
      $left->{$key} = $right->{$key};
    }
    else {
      for my $subkey (keys %{ $right->{$key} }) {
        next if $subkey eq 'prereqs';
        if (not exists $left->{$key}{$subkey}) {
          $left->{$key}{$subkey} = $right->{$key}{$subkey};
        }
        else {
          Carp::croak "Cannot merge two optional_features named '$key' with different '$subkey' values"
            if do { no warnings 'uninitialized'; $left->{$key}{$subkey} ne $right->{$key}{$subkey} };
        }
      }

      require CPAN::Meta::Prereqs;
      $left->{$key}{prereqs} =
        CPAN::Meta::Prereqs->new($left->{$key}{prereqs})
          ->with_merged_prereqs(CPAN::Meta::Prereqs->new($right->{$key}{prereqs}))
          ->as_string_hash;
    }
  }
  return $left;
}


my %default = (
  abstract       => \&_identical,
  author         => \&_set_addition,
  dynamic_config => sub {
    my ($left, $right) = @_;
    return $left || $right;
  },
  generated_by => sub {
    my ($left, $right) = @_;
    return join ', ', _uniq(split(/, /, $left), split(/, /, $right));
  },
  license     => \&_set_addition,
  'meta-spec' => {
    version => \&_identical,
    url     => \&_identical
  },
  name              => \&_identical,
  release_status    => \&_identical,
  version           => \&_identical,
  description       => \&_identical,
  keywords          => \&_set_addition,
  no_index          => { map { ($_ => \&_set_addition) } qw/file directory package namespace/ },
  optional_features => \&_optional_features,
  prereqs           => sub {
    require CPAN::Meta::Prereqs;
    my ($left, $right) = map { CPAN::Meta::Prereqs->new($_) } @_[0,1];
    return $left->with_merged_prereqs($right)->as_string_hash;
  },
  provides  => \&_uniq_map,
  resources => {
    license    => \&_set_addition,
    homepage   => \&_identical,
    bugtracker => \&_uniq_map,
    repository => \&_uniq_map,
    ':default' => \&_improvize,
  },
  ':default' => \&_improvize,
);

sub new {
  my ($class, %arguments) = @_;
  croak 'default version required' if not exists $arguments{default_version};
  my %mapping = %default;
  my %extra = %{ $arguments{extra_mappings} || {} };
  for my $key (keys %extra) {
    if (ref($mapping{$key}) eq 'HASH') {
      $mapping{$key} = { %{ $mapping{$key} }, %{ $extra{$key} } };
    }
    else {
      $mapping{$key} = $extra{$key};
    }
  }
  return bless {
    default_version => $arguments{default_version},
    mapping => _coerce_mapping(\%mapping, []),
  }, $class;
}

my %coderef_for = (
  set_addition => \&_set_addition,
  uniq_map     => \&_uniq_map,
  identical    => \&_identical,
  improvize    => \&_improvize,
);

sub _coerce_mapping {
  my ($orig, $map_path) = @_;
  my %ret;
  for my $key (keys %{$orig}) {
    my $value = $orig->{$key};
    if (ref($orig->{$key}) eq 'CODE') {
      $ret{$key} = $value;
    }
    elsif (ref($value) eq 'HASH') {
      my $mapping = _coerce_mapping($value, [ @{$map_path}, $key ]);
      $ret{$key} = sub {
        my ($left, $right, $path) = @_;
        return _merge($left, $right, $mapping, [ @{$path} ]);
      };
    }
    elsif ($coderef_for{$value}) {
      $ret{$key} = $coderef_for{$value};
    }
    else {
      croak "Don't know what to do with " . join '.', @{$map_path}, $key;
    }
  }
  return \%ret;
}

sub merge {
  my ($self, @items) = @_;
  my $current = {};
  for my $next (@items) {
    if ( blessed($next) && $next->isa('CPAN::Meta') ) {
      $next = $next->as_struct;
    }
    elsif ( ref($next) eq 'HASH' ) {
      my $cmc = CPAN::Meta::Converter->new(
        $next, default_version => $self->{default_version}
      );
      $next = $cmc->upgrade_fragment;
    }
    else {
      croak "Don't know how to merge '$next'";
    }
    $current = _merge($current, $next, $self->{mapping}, []);
  }
  return $current;
}

1;

# ABSTRACT: Merging CPAN Meta fragments

__END__

=pod

=encoding UTF-8

=head1 NAME

CPAN::Meta::Merge - Merging CPAN Meta fragments

=head1 VERSION

version 2.143240

=head1 SYNOPSIS

 my $merger = CPAN::Meta::Merge->new(default_version => "2");
 my $meta = $merger->merge($base, @additional);

=head1 DESCRIPTION

=head1 METHODS

=head2 new

This creates a CPAN::Meta::Merge object. It takes one mandatory named
argument, C<version>, declaring the version of the meta-spec that must be
used for the merge. It can optionally take an C<extra_mappings> argument
that allows one to add additional merging functions for specific elements.

=head2 merge(@fragments)

Merge all C<@fragments> together. It will accept both CPAN::Meta objects and
(possibly incomplete) hashrefs of metadata.

=head1 AUTHORS

=over 4

=item *

David Golden <dagolden@cpan.org>

=item *

Ricardo Signes <rjbs@cpan.org>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2010 by David Golden and Ricardo Signes.

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

=cut
PK       ! �somFU  FU    perl5/CPAN/Meta/Requirements.pmnu ��6�$        use v5.10;
use strict;
use warnings;
package CPAN::Meta::Requirements;
# ABSTRACT: a set of version requirements for a CPAN dist

our $VERSION = '2.143';

use CPAN::Meta::Requirements::Range;

#pod =head1 SYNOPSIS
#pod
#pod   use CPAN::Meta::Requirements;
#pod
#pod   my $build_requires = CPAN::Meta::Requirements->new;
#pod
#pod   $build_requires->add_minimum('Library::Foo' => 1.208);
#pod
#pod   $build_requires->add_minimum('Library::Foo' => 2.602);
#pod
#pod   $build_requires->add_minimum('Module::Bar'  => 'v1.2.3');
#pod
#pod   $METAyml->{build_requires} = $build_requires->as_string_hash;
#pod
#pod =head1 DESCRIPTION
#pod
#pod A CPAN::Meta::Requirements object models a set of version constraints like
#pod those specified in the F<META.yml> or F<META.json> files in CPAN distributions,
#pod and as defined by L<CPAN::Meta::Spec>.
#pod It can be built up by adding more and more constraints, and it will reduce them
#pod to the simplest representation.
#pod
#pod Logically impossible constraints will be identified immediately by thrown
#pod exceptions.
#pod
#pod =cut

use Carp ();

#pod =method new
#pod
#pod   my $req = CPAN::Meta::Requirements->new;
#pod
#pod This returns a new CPAN::Meta::Requirements object.  It takes an optional
#pod hash reference argument.  Currently, only one key is supported:
#pod
#pod =for :list
#pod * C<bad_version_hook> -- if provided, when a version cannot be parsed into
#pod   a version object, this code reference will be called with the invalid
#pod   version string as first argument, and the module name as second
#pod   argument.  It must return a valid version object.
#pod
#pod All other keys are ignored.
#pod
#pod =cut

my @valid_options = qw( bad_version_hook );

sub new {
  my ($class, $options) = @_;
  $options ||= {};
  Carp::croak "Argument to $class\->new() must be a hash reference"
    unless ref $options eq 'HASH';
  my %self = map {; $_ => $options->{$_}} @valid_options;

  return bless \%self => $class;
}

#pod =method add_minimum
#pod
#pod   $req->add_minimum( $module => $version );
#pod
#pod This adds a new minimum version requirement.  If the new requirement is
#pod redundant to the existing specification, this has no effect.
#pod
#pod Minimum requirements are inclusive.  C<$version> is required, along with any
#pod greater version number.
#pod
#pod This method returns the requirements object.
#pod
#pod =method add_maximum
#pod
#pod   $req->add_maximum( $module => $version );
#pod
#pod This adds a new maximum version requirement.  If the new requirement is
#pod redundant to the existing specification, this has no effect.
#pod
#pod Maximum requirements are inclusive.  No version strictly greater than the given
#pod version is allowed.
#pod
#pod This method returns the requirements object.
#pod
#pod =method add_exclusion
#pod
#pod   $req->add_exclusion( $module => $version );
#pod
#pod This adds a new excluded version.  For example, you might use these three
#pod method calls:
#pod
#pod   $req->add_minimum( $module => '1.00' );
#pod   $req->add_maximum( $module => '1.82' );
#pod
#pod   $req->add_exclusion( $module => '1.75' );
#pod
#pod Any version between 1.00 and 1.82 inclusive would be acceptable, except for
#pod 1.75.
#pod
#pod This method returns the requirements object.
#pod
#pod =method exact_version
#pod
#pod   $req->exact_version( $module => $version );
#pod
#pod This sets the version required for the given module to I<exactly> the given
#pod version.  No other version would be considered acceptable.
#pod
#pod This method returns the requirements object.
#pod
#pod =cut

BEGIN {
  for my $type (qw(maximum exclusion exact_version)) {
    my $method = "with_$type";
    my $to_add = $type eq 'exact_version' ? $type : "add_$type";

    my $code = sub {
      my ($self, $name, $version) = @_;

      $self->__modify_entry_for($name, $method, $version);

      return $self;
    };

    no strict 'refs';
    *$to_add = $code;
  }
}

# add_minimum is optimized compared to generated subs above because
# it is called frequently and with "0" or equivalent input
sub add_minimum {
  my ($self, $name, $version) = @_;

  # stringify $version so that version->new("0.00")->stringify ne "0"
  # which preserves the user's choice of "0.00" as the requirement
  if (not defined $version or "$version" eq '0') {
    return $self if $self->__entry_for($name);
    Carp::croak("can't add new requirements to finalized requirements")
      if $self->is_finalized;

    $self->{requirements}{ $name } =
      CPAN::Meta::Requirements::Range->with_minimum('0', $name);
  }
  else {
    $self->__modify_entry_for($name, 'with_minimum', $version);
  }
  return $self;
}

#pod =method version_range_for_module
#pod
#pod   $req->version_range_for_module( $another_req_object );
#pod
#pod =cut

sub version_range_for_module {
  my ($self, $module) = @_;
  return $self->{requirements}{$module};
}

#pod =method add_requirements
#pod
#pod   $req->add_requirements( $another_req_object );
#pod
#pod This method adds all the requirements in the given CPAN::Meta::Requirements
#pod object to the requirements object on which it was called.  If there are any
#pod conflicts, an exception is thrown.
#pod
#pod This method returns the requirements object.
#pod
#pod =cut

sub add_requirements {
  my ($self, $req) = @_;

  for my $module ($req->required_modules) {
    my $new_range = $req->version_range_for_module($module);
    $self->__modify_entry_for($module, 'with_range', $new_range);
  }

  return $self;
}

#pod =method accepts_module
#pod
#pod   my $bool = $req->accepts_module($module => $version);
#pod
#pod Given an module and version, this method returns true if the version
#pod specification for the module accepts the provided version.  In other words,
#pod given:
#pod
#pod   Module => '>= 1.00, < 2.00'
#pod
#pod We will accept 1.00 and 1.75 but not 0.50 or 2.00.
#pod
#pod For modules that do not appear in the requirements, this method will return
#pod true.
#pod
#pod =cut

sub accepts_module {
  my ($self, $module, $version) = @_;

  return 1 unless my $range = $self->__entry_for($module);
  return $range->accepts($version);
}

#pod =method clear_requirement
#pod
#pod   $req->clear_requirement( $module );
#pod
#pod This removes the requirement for a given module from the object.
#pod
#pod This method returns the requirements object.
#pod
#pod =cut

sub clear_requirement {
  my ($self, $module) = @_;

  return $self unless $self->__entry_for($module);

  Carp::croak("can't clear requirements on finalized requirements")
    if $self->is_finalized;

  delete $self->{requirements}{ $module };

  return $self;
}

#pod =method requirements_for_module
#pod
#pod   $req->requirements_for_module( $module );
#pod
#pod This returns a string containing the version requirements for a given module in
#pod the format described in L<CPAN::Meta::Spec> or undef if the given module has no
#pod requirements. This should only be used for informational purposes such as error
#pod messages and should not be interpreted or used for comparison (see
#pod L</accepts_module> instead).
#pod
#pod =cut

sub requirements_for_module {
  my ($self, $module) = @_;
  my $entry = $self->__entry_for($module);
  return unless $entry;
  return $entry->as_string;
}

#pod =method structured_requirements_for_module
#pod
#pod   $req->structured_requirements_for_module( $module );
#pod
#pod This returns a data structure containing the version requirements for a given
#pod module or undef if the given module has no requirements.  This should
#pod not be used for version checks (see L</accepts_module> instead).
#pod
#pod Added in version 2.134.
#pod
#pod =cut

sub structured_requirements_for_module {
  my ($self, $module) = @_;
  my $entry = $self->__entry_for($module);
  return unless $entry;
  return $entry->as_struct;
}

#pod =method required_modules
#pod
#pod This method returns a list of all the modules for which requirements have been
#pod specified.
#pod
#pod =cut

sub required_modules { keys %{ $_[0]{requirements} } }

#pod =method clone
#pod
#pod   $req->clone;
#pod
#pod This method returns a clone of the invocant.  The clone and the original object
#pod can then be changed independent of one another.
#pod
#pod =cut

sub clone {
  my ($self) = @_;
  my $new = (ref $self)->new;

  return $new->add_requirements($self);
}

sub __entry_for     { $_[0]{requirements}{ $_[1] } }

sub __modify_entry_for {
  my ($self, $name, $method, $version) = @_;

  my $fin = $self->is_finalized;
  my $old = $self->__entry_for($name);

  Carp::croak("can't add new requirements to finalized requirements")
    if $fin and not $old;

  my $new = ($old || 'CPAN::Meta::Requirements::Range')
          ->$method($version, $name, $self->{bad_version_hook});

  Carp::croak("can't modify finalized requirements")
    if $fin and $old->as_string ne $new->as_string;

  $self->{requirements}{ $name } = $new;
}

#pod =method is_simple
#pod
#pod This method returns true if and only if all requirements are inclusive minimums
#pod -- that is, if their string expression is just the version number.
#pod
#pod =cut

sub is_simple {
  my ($self) = @_;
  for my $module ($self->required_modules) {
    # XXX: This is a complete hack, but also entirely correct.
    return if not $self->__entry_for($module)->is_simple;
  }

  return 1;
}

#pod =method is_finalized
#pod
#pod This method returns true if the requirements have been finalized by having the
#pod C<finalize> method called on them.
#pod
#pod =cut

sub is_finalized { $_[0]{finalized} }

#pod =method finalize
#pod
#pod This method marks the requirements finalized.  Subsequent attempts to change
#pod the requirements will be fatal, I<if> they would result in a change.  If they
#pod would not alter the requirements, they have no effect.
#pod
#pod If a finalized set of requirements is cloned, the cloned requirements are not
#pod also finalized.
#pod
#pod =cut

sub finalize { $_[0]{finalized} = 1 }

#pod =method as_string_hash
#pod
#pod This returns a reference to a hash describing the requirements using the
#pod strings in the L<CPAN::Meta::Spec> specification.
#pod
#pod For example after the following program:
#pod
#pod   my $req = CPAN::Meta::Requirements->new;
#pod
#pod   $req->add_minimum('CPAN::Meta::Requirements' => 0.102);
#pod
#pod   $req->add_minimum('Library::Foo' => 1.208);
#pod
#pod   $req->add_maximum('Library::Foo' => 2.602);
#pod
#pod   $req->add_minimum('Module::Bar'  => 'v1.2.3');
#pod
#pod   $req->add_exclusion('Module::Bar'  => 'v1.2.8');
#pod
#pod   $req->exact_version('Xyzzy'  => '6.01');
#pod
#pod   my $hashref = $req->as_string_hash;
#pod
#pod C<$hashref> would contain:
#pod
#pod   {
#pod     'CPAN::Meta::Requirements' => '0.102',
#pod     'Library::Foo' => '>= 1.208, <= 2.206',
#pod     'Module::Bar'  => '>= v1.2.3, != v1.2.8',
#pod     'Xyzzy'        => '== 6.01',
#pod   }
#pod
#pod =cut

sub as_string_hash {
  my ($self) = @_;

  my %hash = map {; $_ => $self->{requirements}{$_}->as_string }
             $self->required_modules;

  return \%hash;
}

#pod =method add_string_requirement
#pod
#pod   $req->add_string_requirement('Library::Foo' => '>= 1.208, <= 2.206');
#pod   $req->add_string_requirement('Library::Foo' => v1.208);
#pod
#pod This method parses the passed in string and adds the appropriate requirement
#pod for the given module.  A version can be a Perl "v-string".  It understands
#pod version ranges as described in the L<CPAN::Meta::Spec/Version Ranges>. For
#pod example:
#pod
#pod =over 4
#pod
#pod =item 1.3
#pod
#pod =item >= 1.3
#pod
#pod =item <= 1.3
#pod
#pod =item == 1.3
#pod
#pod =item != 1.3
#pod
#pod =item > 1.3
#pod
#pod =item < 1.3
#pod
#pod =item >= 1.3, != 1.5, <= 2.0
#pod
#pod A version number without an operator is equivalent to specifying a minimum
#pod (C<E<gt>=>).  Extra whitespace is allowed.
#pod
#pod =back
#pod
#pod =cut

sub add_string_requirement {
  my ($self, $module, $req) = @_;

  $self->__modify_entry_for($module, 'with_string_requirement', $req);
}

#pod =method from_string_hash
#pod
#pod   my $req = CPAN::Meta::Requirements->from_string_hash( \%hash );
#pod   my $req = CPAN::Meta::Requirements->from_string_hash( \%hash, \%opts );
#pod
#pod This is an alternate constructor for a CPAN::Meta::Requirements
#pod object. It takes a hash of module names and version requirement
#pod strings and returns a new CPAN::Meta::Requirements object. As with
#pod add_string_requirement, a version can be a Perl "v-string". Optionally,
#pod you can supply a hash-reference of options, exactly as with the L</new>
#pod method.
#pod
#pod =cut

sub from_string_hash {
  my ($class, $hash, $options) = @_;

  my $self = $class->new($options);

  for my $module (keys %$hash) {
    my $req = $hash->{$module};
    $self->add_string_requirement($module, $req);
  }

  return $self;
}

1;
# vim: ts=2 sts=2 sw=2 et:

__END__

=pod

=encoding UTF-8

=head1 NAME

CPAN::Meta::Requirements - a set of version requirements for a CPAN dist

=head1 VERSION

version 2.143

=head1 SYNOPSIS

  use CPAN::Meta::Requirements;

  my $build_requires = CPAN::Meta::Requirements->new;

  $build_requires->add_minimum('Library::Foo' => 1.208);

  $build_requires->add_minimum('Library::Foo' => 2.602);

  $build_requires->add_minimum('Module::Bar'  => 'v1.2.3');

  $METAyml->{build_requires} = $build_requires->as_string_hash;

=head1 DESCRIPTION

A CPAN::Meta::Requirements object models a set of version constraints like
those specified in the F<META.yml> or F<META.json> files in CPAN distributions,
and as defined by L<CPAN::Meta::Spec>.
It can be built up by adding more and more constraints, and it will reduce them
to the simplest representation.

Logically impossible constraints will be identified immediately by thrown
exceptions.

=head1 METHODS

=head2 new

  my $req = CPAN::Meta::Requirements->new;

This returns a new CPAN::Meta::Requirements object.  It takes an optional
hash reference argument.  Currently, only one key is supported:

=over 4

=item *

C<bad_version_hook> -- if provided, when a version cannot be parsed into a version object, this code reference will be called with the invalid version string as first argument, and the module name as second argument.  It must return a valid version object.

=back

All other keys are ignored.

=head2 add_minimum

  $req->add_minimum( $module => $version );

This adds a new minimum version requirement.  If the new requirement is
redundant to the existing specification, this has no effect.

Minimum requirements are inclusive.  C<$version> is required, along with any
greater version number.

This method returns the requirements object.

=head2 add_maximum

  $req->add_maximum( $module => $version );

This adds a new maximum version requirement.  If the new requirement is
redundant to the existing specification, this has no effect.

Maximum requirements are inclusive.  No version strictly greater than the given
version is allowed.

This method returns the requirements object.

=head2 add_exclusion

  $req->add_exclusion( $module => $version );

This adds a new excluded version.  For example, you might use these three
method calls:

  $req->add_minimum( $module => '1.00' );
  $req->add_maximum( $module => '1.82' );

  $req->add_exclusion( $module => '1.75' );

Any version between 1.00 and 1.82 inclusive would be acceptable, except for
1.75.

This method returns the requirements object.

=head2 exact_version

  $req->exact_version( $module => $version );

This sets the version required for the given module to I<exactly> the given
version.  No other version would be considered acceptable.

This method returns the requirements object.

=head2 version_range_for_module

  $req->version_range_for_module( $another_req_object );

=head2 add_requirements

  $req->add_requirements( $another_req_object );

This method adds all the requirements in the given CPAN::Meta::Requirements
object to the requirements object on which it was called.  If there are any
conflicts, an exception is thrown.

This method returns the requirements object.

=head2 accepts_module

  my $bool = $req->accepts_module($module => $version);

Given an module and version, this method returns true if the version
specification for the module accepts the provided version.  In other words,
given:

  Module => '>= 1.00, < 2.00'

We will accept 1.00 and 1.75 but not 0.50 or 2.00.

For modules that do not appear in the requirements, this method will return
true.

=head2 clear_requirement

  $req->clear_requirement( $module );

This removes the requirement for a given module from the object.

This method returns the requirements object.

=head2 requirements_for_module

  $req->requirements_for_module( $module );

This returns a string containing the version requirements for a given module in
the format described in L<CPAN::Meta::Spec> or undef if the given module has no
requirements. This should only be used for informational purposes such as error
messages and should not be interpreted or used for comparison (see
L</accepts_module> instead).

=head2 structured_requirements_for_module

  $req->structured_requirements_for_module( $module );

This returns a data structure containing the version requirements for a given
module or undef if the given module has no requirements.  This should
not be used for version checks (see L</accepts_module> instead).

Added in version 2.134.

=head2 required_modules

This method returns a list of all the modules for which requirements have been
specified.

=head2 clone

  $req->clone;

This method returns a clone of the invocant.  The clone and the original object
can then be changed independent of one another.

=head2 is_simple

This method returns true if and only if all requirements are inclusive minimums
-- that is, if their string expression is just the version number.

=head2 is_finalized

This method returns true if the requirements have been finalized by having the
C<finalize> method called on them.

=head2 finalize

This method marks the requirements finalized.  Subsequent attempts to change
the requirements will be fatal, I<if> they would result in a change.  If they
would not alter the requirements, they have no effect.

If a finalized set of requirements is cloned, the cloned requirements are not
also finalized.

=head2 as_string_hash

This returns a reference to a hash describing the requirements using the
strings in the L<CPAN::Meta::Spec> specification.

For example after the following program:

  my $req = CPAN::Meta::Requirements->new;

  $req->add_minimum('CPAN::Meta::Requirements' => 0.102);

  $req->add_minimum('Library::Foo' => 1.208);

  $req->add_maximum('Library::Foo' => 2.602);

  $req->add_minimum('Module::Bar'  => 'v1.2.3');

  $req->add_exclusion('Module::Bar'  => 'v1.2.8');

  $req->exact_version('Xyzzy'  => '6.01');

  my $hashref = $req->as_string_hash;

C<$hashref> would contain:

  {
    'CPAN::Meta::Requirements' => '0.102',
    'Library::Foo' => '>= 1.208, <= 2.206',
    'Module::Bar'  => '>= v1.2.3, != v1.2.8',
    'Xyzzy'        => '== 6.01',
  }

=head2 add_string_requirement

  $req->add_string_requirement('Library::Foo' => '>= 1.208, <= 2.206');
  $req->add_string_requirement('Library::Foo' => v1.208);

This method parses the passed in string and adds the appropriate requirement
for the given module.  A version can be a Perl "v-string".  It understands
version ranges as described in the L<CPAN::Meta::Spec/Version Ranges>. For
example:

=over 4

=item 1.3

=item >= 1.3

=item <= 1.3

=item == 1.3

=item != 1.3

=item > 1.3

=item < 1.3

=item >= 1.3, != 1.5, <= 2.0

A version number without an operator is equivalent to specifying a minimum
(C<E<gt>=>).  Extra whitespace is allowed.

=back

=head2 from_string_hash

  my $req = CPAN::Meta::Requirements->from_string_hash( \%hash );
  my $req = CPAN::Meta::Requirements->from_string_hash( \%hash, \%opts );

This is an alternate constructor for a CPAN::Meta::Requirements
object. It takes a hash of module names and version requirement
strings and returns a new CPAN::Meta::Requirements object. As with
add_string_requirement, a version can be a Perl "v-string". Optionally,
you can supply a hash-reference of options, exactly as with the L</new>
method.

=for :stopwords cpan testmatrix url bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan

=head1 SUPPORT

=head2 Bugs / Feature Requests

Please report any bugs or feature requests through the issue tracker
at L<https://github.com/Perl-Toolchain-Gang/CPAN-Meta-Requirements/issues>.
You will be notified automatically of any progress on your issue.

=head2 Source Code

This is open source software.  The code repository is available for
public review and contribution under the terms of the license.

L<https://github.com/Perl-Toolchain-Gang/CPAN-Meta-Requirements>

  git clone https://github.com/Perl-Toolchain-Gang/CPAN-Meta-Requirements.git

=head1 AUTHORS

=over 4

=item *

David Golden <dagolden@cpan.org>

=item *

Ricardo Signes <rjbs@cpan.org>

=back

=head1 CONTRIBUTORS

=for stopwords Ed J Graham Knop Karen Etheridge Leon Timmermans Paul Howarth Ricardo Signes robario Tatsuhiko Miyagawa

=over 4

=item *

Ed J <mohawk2@users.noreply.github.com>

=item *

Graham Knop <haarg@haarg.org>

=item *

Karen Etheridge <ether@cpan.org>

=item *

Leon Timmermans <fawaka@gmail.com>

=item *

Paul Howarth <paul@city-fan.org>

=item *

Ricardo Signes <rjbs@semiotic.systems>

=item *

robario <webmaster@robario.com>

=item *

Tatsuhiko Miyagawa <miyagawa@bulknews.net>

=item *

Tatsuhiko Miyagawa <miyagawa@gmail.com>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2010 by David Golden and Ricardo Signes.

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

=cut
PK       ! �E'�      perl5/CPAN/Meta/Feature.pmnu ��6�$        use 5.006;
use strict;
use warnings;
package CPAN::Meta::Feature;
# VERSION
$CPAN::Meta::Feature::VERSION = '2.143240';
use CPAN::Meta::Prereqs;

#pod =head1 DESCRIPTION
#pod
#pod A CPAN::Meta::Feature object describes an optional feature offered by a CPAN
#pod distribution and specified in the distribution's F<META.json> (or F<META.yml>)
#pod file.
#pod
#pod For the most part, this class will only be used when operating on the result of
#pod the C<feature> or C<features> methods on a L<CPAN::Meta> object.
#pod
#pod =method new
#pod
#pod   my $feature = CPAN::Meta::Feature->new( $identifier => \%spec );
#pod
#pod This returns a new Feature object.  The C<%spec> argument to the constructor
#pod should be the same as the value of the C<optional_feature> entry in the
#pod distmeta.  It must contain entries for C<description> and C<prereqs>.
#pod
#pod =cut

sub new {
  my ($class, $identifier, $spec) = @_;

  my %guts = (
    identifier  => $identifier,
    description => $spec->{description},
    prereqs     => CPAN::Meta::Prereqs->new($spec->{prereqs}),
  );

  bless \%guts => $class;
}

#pod =method identifier
#pod
#pod This method returns the feature's identifier.
#pod
#pod =cut

sub identifier  { $_[0]{identifier}  }

#pod =method description
#pod
#pod This method returns the feature's long description.
#pod
#pod =cut

sub description { $_[0]{description} }

#pod =method prereqs
#pod
#pod This method returns the feature's prerequisites as a L<CPAN::Meta::Prereqs>
#pod object.
#pod
#pod =cut

sub prereqs     { $_[0]{prereqs} }

1;

# ABSTRACT: an optional feature provided by a CPAN distribution

__END__

=pod

=encoding UTF-8

=head1 NAME

CPAN::Meta::Feature - an optional feature provided by a CPAN distribution

=head1 VERSION

version 2.143240

=head1 DESCRIPTION

A CPAN::Meta::Feature object describes an optional feature offered by a CPAN
distribution and specified in the distribution's F<META.json> (or F<META.yml>)
file.

For the most part, this class will only be used when operating on the result of
the C<feature> or C<features> methods on a L<CPAN::Meta> object.

=head1 METHODS

=head2 new

  my $feature = CPAN::Meta::Feature->new( $identifier => \%spec );

This returns a new Feature object.  The C<%spec> argument to the constructor
should be the same as the value of the C<optional_feature> entry in the
distmeta.  It must contain entries for C<description> and C<prereqs>.

=head2 identifier

This method returns the feature's identifier.

=head2 description

This method returns the feature's long description.

=head2 prereqs

This method returns the feature's prerequisites as a L<CPAN::Meta::Prereqs>
object.

=head1 BUGS

Please report any bugs or feature using the CPAN Request Tracker.
Bugs can be submitted through the web interface at
L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>

When submitting a bug or request, please include a test-file or a patch to an
existing test-file that illustrates the bug or desired feature.

=head1 AUTHORS

=over 4

=item *

David Golden <dagolden@cpan.org>

=item *

Ricardo Signes <rjbs@cpan.org>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2010 by David Golden and Ricardo Signes.

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

=cut
PK       ! B$s�  �    perl5/CPAN/Meta/Spec.pmnu ��6�$        # XXX RULES FOR PATCHING THIS FILE XXX
# Patches that fix typos or formatting are acceptable.  Patches
# that change semantics are not acceptable without prior approval
# by David Golden or Ricardo Signes.

use 5.006;
use strict;
use warnings;
package CPAN::Meta::Spec;
# VERSION
$CPAN::Meta::Spec::VERSION = '2.143240';
1;

# ABSTRACT: specification for CPAN distribution metadata


# vi:tw=72

__END__

=pod

=encoding UTF-8

=head1 NAME

CPAN::Meta::Spec - specification for CPAN distribution metadata

=head1 VERSION

version 2.143240

=head1 SYNOPSIS

  my $distmeta = {
    name => 'Module-Build',
    abstract => 'Build and install Perl modules',
    description =>  "Module::Build is a system for "
      . "building, testing, and installing Perl modules. "
      . "It is meant to ... blah blah blah ...",
    version  => '0.36',
    release_status => 'stable',
    author   => [
      'Ken Williams <kwilliams@cpan.org>',
      'Module-Build List <module-build@perl.org>', # additional contact
    ],
    license  => [ 'perl_5' ],
    prereqs => {
      runtime => {
        requires => {
          'perl'   => '5.006',
          'ExtUtils::Install' => '0',
          'File::Basename' => '0',
          'File::Compare'  => '0',
          'IO::File'   => '0',
        },
        recommends => {
          'Archive::Tar' => '1.00',
          'ExtUtils::Install' => '0.3',
          'ExtUtils::ParseXS' => '2.02',
        },
      },
      build => {
        requires => {
          'Test::More' => '0',
        },
      }
    },
    resources => {
      license => ['http://dev.perl.org/licenses/'],
    },
    optional_features => {
      domination => {
        description => 'Take over the world',
        prereqs     => {
          develop => { requires => { 'Genius::Evil'     => '1.234' } },
          runtime => { requires => { 'Machine::Weather' => '2.0'   } },
        },
      },
    },
    dynamic_config => 1,
    keywords => [ qw/ toolchain cpan dual-life / ],
    'meta-spec' => {
      version => '2',
      url     => 'https://metacpan.org/pod/CPAN::Meta::Spec',
    },
    generated_by => 'Module::Build version 0.36',
  };

=head1 DESCRIPTION

This document describes version 2 of the CPAN distribution metadata
specification, also known as the "CPAN Meta Spec".

Revisions of this specification for typo corrections and prose
clarifications may be issued as CPAN::Meta::Spec 2.I<x>.  These
revisions will never change semantics or add or remove specified
behavior.

Distribution metadata describe important properties of Perl
distributions. Distribution building tools like Module::Build,
Module::Install, ExtUtils::MakeMaker or Dist::Zilla should create a
metadata file in accordance with this specification and include it with
the distribution for use by automated tools that index, examine, package
or install Perl distributions.

=head1 TERMINOLOGY

=over 4

=item distribution

This is the primary object described by the metadata. In the context of
this document it usually refers to a collection of modules, scripts,
and/or documents that are distributed together for other developers to
use.  Examples of distributions are C<Class-Container>, C<libwww-perl>,
or C<DBI>.

=item module

This refers to a reusable library of code contained in a single file.
Modules usually contain one or more packages and are often referred
to by the name of a primary package that can be mapped to the file
name. For example, one might refer to C<File::Spec> instead of
F<File/Spec.pm>

=item package

This refers to a namespace declared with the Perl C<package> statement.
In Perl, packages often have a version number property given by the
C<$VERSION> variable in the namespace.

=item consumer

This refers to code that reads a metadata file, deserializes it into a
data structure in memory, or interprets a data structure of metadata
elements.

=item producer

This refers to code that constructs a metadata data structure,
serializes into a bytestream and/or writes it to disk.

=item must, should, may, etc.

These terms are interpreted as described in IETF RFC 2119.

=back

=head1 DATA TYPES

Fields in the L</STRUCTURE> section describe data elements, each of
which has an associated data type as described herein.  There are four
primitive types: Boolean, String, List and Map.  Other types are
subtypes of primitives and define compound data structures or define
constraints on the values of a data element.

=head2 Boolean

A I<Boolean> is used to provide a true or false value.  It B<must> be
represented as a defined value.

=head2 String

A I<String> is data element containing a non-zero length sequence of
Unicode characters, such as an ordinary Perl scalar that is not a
reference.

=head2 List

A I<List> is an ordered collection of zero or more data elements.
Elements of a List may be of mixed types.

Producers B<must> represent List elements using a data structure which
unambiguously indicates that multiple values are possible, such as a
reference to a Perl array (an "arrayref").

Consumers expecting a List B<must> consider a String as equivalent to a
List of length 1.

=head2 Map

A I<Map> is an unordered collection of zero or more data elements
("values"), indexed by associated String elements ("keys").  The Map's
value elements may be of mixed types.

=head2 License String

A I<License String> is a subtype of String with a restricted set of
values.  Valid values are described in detail in the description of
the L</license> field.

=head2 URL

I<URL> is a subtype of String containing a Uniform Resource Locator or
Identifier.  [ This type is called URL and not URI for historical reasons. ]

=head2 Version

A I<Version> is a subtype of String containing a value that describes
the version number of packages or distributions.  Restrictions on format
are described in detail in the L</Version Formats> section.

=head2 Version Range

The I<Version Range> type is a subtype of String.  It describes a range
of Versions that may be present or installed to fulfill prerequisites.
It is specified in detail in the L</Version Ranges> section.

=head1 STRUCTURE

The metadata structure is a data element of type Map.  This section
describes valid keys within the Map.

Any keys not described in this specification document (whether top-level
or within compound data structures described herein) are considered
I<custom keys> and B<must> begin with an "x" or "X" and be followed by an
underscore; i.e. they must match the pattern: C<< qr{\Ax_}i >>.  If a
custom key refers to a compound data structure, subkeys within it do not
need an "x_" or "X_" prefix.

Consumers of metadata may ignore any or all custom keys.  All other keys
not described herein are invalid and should be ignored by consumers.
Producers must not generate or output invalid keys.

For each key, an example is provided followed by a description.  The
description begins with the version of spec in which the key was added
or in which the definition was modified, whether the key is I<required>
or I<optional> and the data type of the corresponding data element.
These items are in parentheses, brackets and braces, respectively.

If a data type is a Map or Map subtype, valid subkeys will be described
as well.

Some fields are marked I<Deprecated>.  These are shown for historical
context and must not be produced in or consumed from any metadata structure
of version 2 or higher.

=head2 REQUIRED FIELDS

=head3 abstract

Example:

  abstract => 'Build and install Perl modules'

(Spec 1.2) [required] {String}

This is a short description of the purpose of the distribution.

=head3 author

Example:

  author => [ 'Ken Williams <kwilliams@cpan.org>' ]

(Spec 1.2) [required] {List of one or more Strings}

This List indicates the person(s) to contact concerning the
distribution. The preferred form of the contact string is:

  contact-name <email-address>

This field provides a general contact list independent of other
structured fields provided within the L</resources> field, such as
C<bugtracker>.  The addressee(s) can be contacted for any purpose
including but not limited to (security) problems with the distribution,
questions about the distribution or bugs in the distribution.

A distribution's original author is usually the contact listed within
this field.  Co-maintainers, successor maintainers or mailing lists
devoted to the distribution may also be listed in addition to or instead
of the original author.

=head3 dynamic_config

Example:

  dynamic_config => 1

(Spec 2) [required] {Boolean}

A boolean flag indicating whether a F<Build.PL> or F<Makefile.PL> (or
similar) must be executed to determine prerequisites.

This field should be set to a true value if the distribution performs
some dynamic configuration (asking questions, sensing the environment,
etc.) as part of its configuration.  This field should be set to a false
value to indicate that prerequisites included in metadata may be
considered final and valid for static analysis.

Note: when this field is true, post-configuration prerequisites are not
guaranteed to bear any relation whatsoever to those stated in the metadata,
and relying on them doing so is an error. See also
L</Prerequisites for dynamically configured distributions> in the implementors'
notes.

This field explicitly B<does not> indicate whether installation may be
safely performed without using a Makefile or Build file, as there may be
special files to install or custom installation targets (e.g. for
dual-life modules that exist on CPAN as well as in the Perl core).  This
field only defines whether or not prerequisites are exactly as given in the
metadata.

=head3 generated_by

Example:

  generated_by => 'Module::Build version 0.36'

(Spec 1.0) [required] {String}

This field indicates the tool that was used to create this metadata.
There are no defined semantics for this field, but it is traditional to
use a string in the form "Generating::Package version 1.23" or the
author's name, if the file was generated by hand.

=head3 license

Example:

  license => [ 'perl_5' ]

  license => [ 'apache_2_0', 'mozilla_1_0' ]

(Spec 2) [required] {List of one or more License Strings}

One or more licenses that apply to some or all of the files in the
distribution.  If multiple licenses are listed, the distribution
documentation should be consulted to clarify the interpretation of
multiple licenses.

The following list of license strings are valid:

 string          description
 -------------   -----------------------------------------------
 agpl_3          GNU Affero General Public License, Version 3
 apache_1_1      Apache Software License, Version 1.1
 apache_2_0      Apache License, Version 2.0
 artistic_1      Artistic License, (Version 1)
 artistic_2      Artistic License, Version 2.0
 bsd             BSD License (three-clause)
 freebsd         FreeBSD License (two-clause)
 gfdl_1_2        GNU Free Documentation License, Version 1.2
 gfdl_1_3        GNU Free Documentation License, Version 1.3
 gpl_1           GNU General Public License, Version 1
 gpl_2           GNU General Public License, Version 2
 gpl_3           GNU General Public License, Version 3
 lgpl_2_1        GNU Lesser General Public License, Version 2.1
 lgpl_3_0        GNU Lesser General Public License, Version 3.0
 mit             MIT (aka X11) License
 mozilla_1_0     Mozilla Public License, Version 1.0
 mozilla_1_1     Mozilla Public License, Version 1.1
 openssl         OpenSSL License
 perl_5          The Perl 5 License (Artistic 1 & GPL 1 or later)
 qpl_1_0         Q Public License, Version 1.0
 ssleay          Original SSLeay License
 sun             Sun Internet Standards Source License (SISSL)
 zlib            zlib License

The following license strings are also valid and indicate other
licensing not described above:

 string          description
 -------------   -----------------------------------------------
 open_source     Other Open Source Initiative (OSI) approved license
 restricted      Requires special permission from copyright holder
 unrestricted    Not an OSI approved license, but not restricted
 unknown         License not provided in metadata

All other strings are invalid in the license field.

=head3 meta-spec

Example:

  'meta-spec' => {
    version => '2',
    url     => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec',
  }

(Spec 1.2) [required] {Map}

This field indicates the version of the CPAN Meta Spec that should be
used to interpret the metadata.  Consumers must check this key as soon
as possible and abort further metadata processing if the meta-spec
version is not supported by the consumer.

The following keys are valid, but only C<version> is required.

=over

=item version

This subkey gives the integer I<Version> of the CPAN Meta Spec against
which the document was generated.

=item url

This is a I<URL> of the metadata specification document corresponding to
the given version.  This is strictly for human-consumption and should
not impact the interpretation of the document.

For the version 2 spec, either of these are recommended:

=over 4

=item *

C<https://metacpan.org/pod/CPAN::Meta::Spec>

=item *

C<http://search.cpan.org/perldoc?CPAN::Meta::Spec>

=back

=back

=head3 name

Example:

  name => 'Module-Build'

(Spec 1.0) [required] {String}

This field is the name of the distribution.  This is often created by
taking the "main package" in the distribution and changing C<::> to
C<->, but the name may be completely unrelated to the packages within
the distribution.  For example, L<LWP::UserAgent> is distributed as part
of the distribution name "libwww-perl".

=head3 release_status

Example:

  release_status => 'stable'

(Spec 2) [required] {String}

This field provides the  release status of this distribution.  If the
C<version> field contains an underscore character, then
C<release_status> B<must not> be "stable."

The C<release_status> field B<must> have one of the following values:

=over

=item stable

This indicates an ordinary, "final" release that should be indexed by PAUSE
or other indexers.

=item testing

This indicates a "beta" release that is substantially complete, but has an
elevated risk of bugs and requires additional testing.  The distribution
should not be installed over a stable release without an explicit request
or other confirmation from a user.  This release status may also be used
for "release candidate" versions of a distribution.

=item unstable

This indicates an "alpha" release that is under active development, but has
been released for early feedback or testing and may be missing features or
may have serious bugs.  The distribution should not be installed over a
stable release without an explicit request or other confirmation from a
user.

=back

Consumers B<may> use this field to determine how to index the
distribution for CPAN or other repositories in addition to or in
replacement of heuristics based on version number or file name.

=head3 version

Example:

  version => '0.36'

(Spec 1.0) [required] {Version}

This field gives the version of the distribution to which the metadata
structure refers.

=head2 OPTIONAL FIELDS

=head3 description

Example:

    description =>  "Module::Build is a system for "
      . "building, testing, and installing Perl modules. "
      . "It is meant to ... blah blah blah ...",

(Spec 2) [optional] {String}

A longer, more complete description of the purpose or intended use of
the distribution than the one provided by the C<abstract> key.

=head3 keywords

Example:

  keywords => [ qw/ toolchain cpan dual-life / ]

(Spec 1.1) [optional] {List of zero or more Strings}

A List of keywords that describe this distribution.  Keywords
B<must not> include whitespace.

=head3 no_index

Example:

  no_index => {
    file      => [ 'My/Module.pm' ],
    directory => [ 'My/Private' ],
    package   => [ 'My::Module::Secret' ],
    namespace => [ 'My::Module::Sample' ],
  }

(Spec 1.2) [optional] {Map}

This Map describes any files, directories, packages, and namespaces that
are private to the packaging or implementation of the distribution and
should be ignored by indexing or search tools. Note that this is a list of
exclusions, and the spec does not define what to I<include> - see
L</Indexing distributions a la PAUSE> in the implementors notes for more
information.

Valid subkeys are as follows:

=over

=item file

A I<List> of relative paths to files.  Paths B<must be> specified with
unix conventions.

=item directory

A I<List> of relative paths to directories.  Paths B<must be> specified
with unix conventions.

[ Note: previous editions of the spec had C<dir> instead of C<directory> ]

=item package

A I<List> of package names.

=item namespace

A I<List> of package namespaces, where anything below the namespace
must be ignored, but I<not> the namespace itself.

In the example above for C<no_index>, C<My::Module::Sample::Foo> would
be ignored, but C<My::Module::Sample> would not.

=back

=head3 optional_features

Example:

  optional_features => {
    sqlite => {
      description => 'Provides SQLite support',
      prereqs => {
        runtime => {
          requires => {
            'DBD::SQLite' => '1.25'
          }
        }
      }
    }
  }

(Spec 2) [optional] {Map}

This Map describes optional features with incremental prerequisites.
Each key of the C<optional_features> Map is a String used to identify
the feature and each value is a Map with additional information about
the feature.  Valid subkeys include:

=over

=item description

This is a String describing the feature.  Every optional feature
should provide a description

=item prereqs

This entry is required and has the same structure as that of the
C<L</prereqs>> key.  It provides a list of package requirements
that must be satisfied for the feature to be supported or enabled.

There is one crucial restriction:  the prereqs of an optional feature
B<must not> include C<configure> phase prereqs.

=back

Consumers B<must not> include optional features as prerequisites without
explicit instruction from users (whether via interactive prompting,
a function parameter or a configuration value, etc. ).

If an optional feature is used by a consumer to add additional
prerequisites, the consumer should merge the optional feature
prerequisites into those given by the C<prereqs> key using the same
semantics.  See L</Merging and Resolving Prerequisites> for details on
merging prerequisites.

I<Suggestion for disuse:> Because there is currently no way for a
distribution to specify a dependency on an optional feature of another
dependency, the use of C<optional_feature> is discouraged.  Instead,
create a separate, installable distribution that ensures the desired
feature is available.  For example, if C<Foo::Bar> has a C<Baz> feature,
release a separate C<Foo-Bar-Baz> distribution that satisfies
requirements for the feature.

=head3 prereqs

Example:

  prereqs => {
    runtime => {
      requires => {
        'perl'          => '5.006',
        'File::Spec'    => '0.86',
        'JSON'          => '2.16',
      },
      recommends => {
        'JSON::XS'      => '2.26',
      },
      suggests => {
        'Archive::Tar'  => '0',
      },
    },
    build => {
      requires => {
        'Alien::SDL'    => '1.00',
      },
    },
    test => {
      recommends => {
        'Test::Deep'    => '0.10',
      },
    }
  }

(Spec 2) [optional] {Map}

This is a Map that describes all the prerequisites of the distribution.
The keys are phases of activity, such as C<configure>, C<build>, C<test>
or C<runtime>.  Values are Maps in which the keys name the type of
prerequisite relationship such as C<requires>, C<recommends>, or
C<suggests> and the value provides a set of prerequisite relations.  The
set of relations B<must> be specified as a Map of package names to
version ranges.

The full definition for this field is given in the L</Prereq Spec>
section.

=head3 provides

Example:

  provides => {
    'Foo::Bar' => {
      file    => 'lib/Foo/Bar.pm',
      version => '0.27_02',
    },
    'Foo::Bar::Blah' => {
      file    => 'lib/Foo/Bar/Blah.pm',
    },
    'Foo::Bar::Baz' => {
      file    => 'lib/Foo/Bar/Baz.pm',
      version => '0.3',
    },
  }

(Spec 1.2) [optional] {Map}

This describes all packages provided by this distribution.  This
information is used by distribution and automation mechanisms like
PAUSE, CPAN, metacpan.org and search.cpan.org to build indexes saying in
which distribution various packages can be found.

The keys of C<provides> are package names that can be found within
the distribution.  If a package name key is provided, it must
have a Map with the following valid subkeys:

=over

=item file

This field is required.  It must contain a Unix-style relative file path
from the root of the distribution directory to a file that contains or
generates the package.  It may be given as C<META.yml> or C<META.json>
to claim a package for indexing without needing a C<*.pm>.

=item version

If it exists, this field must contains a I<Version> String for the
package.  If the package does not have a C<$VERSION>, this field must
be omitted.

=back

=head3 resources

Example:

  resources => {
    license     => [ 'http://dev.perl.org/licenses/' ],
    homepage    => 'http://sourceforge.net/projects/module-build',
    bugtracker  => {
      web    => 'http://rt.cpan.org/Public/Dist/Display.html?Name=CPAN-Meta',
      mailto => 'meta-bugs@example.com',
    },
    repository  => {
      url  => 'git://github.com/dagolden/cpan-meta.git',
      web  => 'http://github.com/dagolden/cpan-meta',
      type => 'git',
    },
    x_twitter   => 'http://twitter.com/cpan_linked/',
  }

(Spec 2) [optional] {Map}

This field describes resources related to this distribution.

Valid subkeys include:

=over

=item homepage

The official home of this project on the web.

=item license

A List of I<URL>'s that relate to this distribution's license.  As with the
top-level C<license> field, distribution documentation should be consulted
to clarify the interpretation of multiple licenses provided here.

=item bugtracker

This entry describes the bug tracking system for this distribution.  It
is a Map with the following valid keys:

  web    - a URL pointing to a web front-end for the bug tracker
  mailto - an email address to which bugs can be sent

=item repository

This entry describes the source control repository for this distribution.  It
is a Map with the following valid keys:

  url  - a URL pointing to the repository itself
  web  - a URL pointing to a web front-end for the repository
  type - a lowercase string indicating the VCS used

Because a url like C<http://myrepo.example.com/> is ambiguous as to
type, producers should provide a C<type> whenever a C<url> key is given.
The C<type> field should be the name of the most common program used
to work with the repository, e.g. C<git>, C<svn>, C<cvs>, C<darcs>,
C<bzr> or C<hg>.

=back

=head2 DEPRECATED FIELDS

=head3 build_requires

I<(Deprecated in Spec 2)> [optional] {String}

Replaced by C<prereqs>

=head3 configure_requires

I<(Deprecated in Spec 2)> [optional] {String}

Replaced by C<prereqs>

=head3 conflicts

I<(Deprecated in Spec 2)> [optional] {String}

Replaced by C<prereqs>

=head3 distribution_type

I<(Deprecated in Spec 2)> [optional] {String}

This field indicated 'module' or 'script' but was considered
meaningless, since many distributions are hybrids of several kinds of
things.

=head3 license_uri

I<(Deprecated in Spec 1.2)> [optional] {URL}

Replaced by C<license> in C<resources>

=head3 private

I<(Deprecated in Spec 1.2)> [optional] {Map}

This field has been renamed to L</"no_index">.

=head3 recommends

I<(Deprecated in Spec 2)> [optional] {String}

Replaced by C<prereqs>

=head3 requires

I<(Deprecated in Spec 2)> [optional] {String}

Replaced by C<prereqs>

=head1 VERSION NUMBERS

=head2 Version Formats

This section defines the Version type, used by several fields in the
CPAN Meta Spec.

Version numbers must be treated as strings, not numbers.  For
example, C<1.200> B<must not> be serialized as C<1.2>.  Version
comparison should be delegated to the Perl L<version> module, version
0.80 or newer.

Unless otherwise specified, version numbers B<must> appear in one of two
formats:

=over

=item Decimal versions

Decimal versions are regular "decimal numbers", with some limitations.
They B<must> be non-negative and B<must> begin and end with a digit.  A
single underscore B<may> be included, but B<must> be between two digits.
They B<must not> use exponential notation ("1.23e-2").

   version => '1.234'       # OK
   version => '1.23_04'     # OK

   version => '1.23_04_05'  # Illegal
   version => '1.'          # Illegal
   version => '.1'          # Illegal

=item Dotted-integer versions

Dotted-integer (also known as dotted-decimal) versions consist of
positive integers separated by full stop characters (i.e. "dots",
"periods" or "decimal points").  This are equivalent in format to Perl
"v-strings", with some additional restrictions on form.  They must be
given in "normal" form, which has a leading "v" character and at least
three integer components.  To retain a one-to-one mapping with decimal
versions, all components after the first B<should> be restricted to the
range 0 to 999.  The final component B<may> be separated by an
underscore character instead of a period.

   version => 'v1.2.3'      # OK
   version => 'v1.2_3'      # OK
   version => 'v1.2.3.4'    # OK
   version => 'v1.2.3_4'    # OK
   version => 'v2009.10.31' # OK

   version => 'v1.2'          # Illegal
   version => '1.2.3'         # Illegal
   version => 'v1.2_3_4'      # Illegal
   version => 'v1.2009.10.31' # Not recommended

=back

=head2 Version Ranges

Some fields (prereq, optional_features) indicate the particular
version(s) of some other module that may be required as a prerequisite.
This section details the Version Range type used to provide this
information.

The simplest format for a Version Range is just the version
number itself, e.g. C<2.4>.  This means that B<at least> version 2.4
must be present.  To indicate that B<any> version of a prerequisite is
okay, even if the prerequisite doesn't define a version at all, use
the version C<0>.

Alternatively, a version range B<may> use the operators E<lt> (less than),
E<lt>= (less than or equal), E<gt> (greater than), E<gt>= (greater than
or equal), == (equal), and != (not equal).  For example, the
specification C<E<lt> 2.0> means that any version of the prerequisite
less than 2.0 is suitable.

For more complicated situations, version specifications B<may> be AND-ed
together using commas.  The specification C<E<gt>= 1.2, != 1.5, E<lt>
2.0> indicates a version that must be B<at least> 1.2, B<less than> 2.0,
and B<not equal to> 1.5.

=head1 PREREQUISITES

=head2 Prereq Spec

The C<prereqs> key in the top-level metadata and within
C<optional_features> define the relationship between a distribution and
other packages.  The prereq spec structure is a hierarchical data
structure which divides prerequisites into I<Phases> of activity in the
installation process and I<Relationships> that indicate how
prerequisites should be resolved.

For example, to specify that C<Data::Dumper> is C<required> during the
C<test> phase, this entry would appear in the distribution metadata:

  prereqs => {
    test => {
      requires => {
        'Data::Dumper' => '2.00'
      }
    }
  }

=head3 Phases

Requirements for regular use must be listed in the C<runtime> phase.
Other requirements should be listed in the earliest stage in which they
are required and consumers must accumulate and satisfy requirements
across phases before executing the activity. For example, C<build>
requirements must also be available during the C<test> phase.

  before action       requirements that must be met
  ----------------    --------------------------------
  perl Build.PL       configure
  perl Makefile.PL

  make                configure, runtime, build
  Build

  make test           configure, runtime, build, test
  Build test

Consumers that install the distribution must ensure that
I<runtime> requirements are also installed and may install
dependencies from other phases.

  after action        requirements that must be met
  ----------------    --------------------------------
  make install        runtime
  Build install

=over

=item configure

The configure phase occurs before any dynamic configuration has been
attempted.  Libraries required by the configure phase B<must> be
available for use before the distribution building tool has been
executed.

=item build

The build phase is when the distribution's source code is compiled (if
necessary) and otherwise made ready for installation.

=item test

The test phase is when the distribution's automated test suite is run.
Any library that is needed only for testing and not for subsequent use
should be listed here.

=item runtime

The runtime phase refers not only to when the distribution's contents
are installed, but also to its continued use.  Any library that is a
prerequisite for regular use of this distribution should be indicated
here.

=item develop

The develop phase's prereqs are libraries needed to work on the
distribution's source code as its author does.  These tools might be
needed to build a release tarball, to run author-only tests, or to
perform other tasks related to developing new versions of the
distribution.

=back

=head3 Relationships

=over

=item requires

These dependencies B<must> be installed for proper completion of the
phase.

=item recommends

Recommended dependencies are I<strongly> encouraged and should be
satisfied except in resource constrained environments.

=item suggests

These dependencies are optional, but are suggested for enhanced operation
of the described distribution.

=item conflicts

These libraries cannot be installed when the phase is in operation.
This is a very rare situation, and the C<conflicts> relationship should
be used with great caution, or not at all.

=back

=head2 Merging and Resolving Prerequisites

Whenever metadata consumers merge prerequisites, either from different
phases or from C<optional_features>, they should merged in a way which
preserves the intended semantics of the prerequisite structure.  Generally,
this means concatenating the version specifications using commas, as
described in the L<Version Ranges> section.

Another subtle error that can occur in resolving prerequisites comes from
the way that modules in prerequisites are indexed to distribution files on
CPAN.  When a module is deleted from a distribution, prerequisites calling
for that module could indicate an older distribution should be installed,
potentially overwriting files from a newer distribution.

For example, as of Oct 31, 2009, the CPAN index file contained these
module-distribution mappings:

  Class::MOP                   0.94  D/DR/DROLSKY/Class-MOP-0.94.tar.gz
  Class::MOP::Class            0.94  D/DR/DROLSKY/Class-MOP-0.94.tar.gz
  Class::MOP::Class::Immutable 0.04  S/ST/STEVAN/Class-MOP-0.36.tar.gz

Consider the case where "Class::MOP" 0.94 is installed.  If a
distribution specified "Class::MOP::Class::Immutable" as a prerequisite,
it could result in Class-MOP-0.36.tar.gz being installed, overwriting
any files from Class-MOP-0.94.tar.gz.

Consumers of metadata B<should> test whether prerequisites would result
in installed module files being "downgraded" to an older version and
B<may> warn users or ignore the prerequisite that would cause such a
result.

=head1 SERIALIZATION

Distribution metadata should be serialized (as a hashref) as
JSON-encoded data and packaged with distributions as the file
F<META.json>.

In the past, the distribution metadata structure had been packed with
distributions as F<META.yml>, a file in the YAML Tiny format (for which,
see L<YAML::Tiny>).  Tools that consume distribution metadata from disk
should be capable of loading F<META.yml>, but should prefer F<META.json>
if both are found.

=head1 NOTES FOR IMPLEMENTORS

=head2 Extracting Version Numbers from Perl Modules

To get the version number from a Perl module, consumers should use the
C<< MM->parse_version($file) >> method provided by
L<ExtUtils::MakeMaker> or L<Module::Metadata>.  For example, for the
module given by C<$mod>, the version may be retrieved in one of the
following ways:

  # via ExtUtils::MakeMaker
  my $file = MM->_installed_file_for_module($mod);
  my $version = MM->parse_version($file)

The private C<_installed_file_for_module> method may be replaced with
other methods for locating a module in C<@INC>.

  # via Module::Metadata
  my $info = Module::Metadata->new_from_module($mod);
  my $version = $info->version;

If only a filename is available, the following approach may be used:

  # via Module::Build
  my $info = Module::Metadata->new_from_file($file);
  my $version = $info->version;

=head2 Comparing Version Numbers

The L<version> module provides the most reliable way to compare version
numbers in all the various ways they might be provided or might exist
within modules.  Given two strings containing version numbers, C<$v1> and
C<$v2>, they should be converted to C<version> objects before using
ordinary comparison operators.  For example:

  use version;
  if ( version->new($v1) <=> version->new($v2) ) {
    print "Versions are not equal\n";
  }

If the only comparison needed is whether an installed module is of a
sufficiently high version, a direct test may be done using the string
form of C<eval> and the C<use> function.  For example, for module C<$mod>
and version prerequisite C<$prereq>:

  if ( eval "use $mod $prereq (); 1" ) {
    print "Module $mod version is OK.\n";
  }

If the values of C<$mod> and C<$prereq> have not been scrubbed, however,
this presents security implications.

=head2 Prerequisites for dynamically configured distributions

When C<dynamic_config> is true, it is an error to presume that the
prerequisites given in distribution metadata will have any relationship
whatsoever to the actual prerequisites of the distribution.

In practice, however, one can generally expect such prerequisites to be
one of two things:

=over 4

=item *

The minimum prerequisites for the distribution, to which dynamic configuration will only add items

=item *

Whatever the distribution configured with on the releaser's machine at release time

=back

The second case often turns out to have identical results to the first case,
albeit only by accident.

As such, consumers may use this data for informational analysis, but
presenting it to the user as canonical or relying on it as such is
invariably the height of folly.

=head2 Indexing distributions a la PAUSE

While no_index tells you what must be ignored when indexing, this spec holds
no opinion on how you should get your initial candidate list of things to
possibly index. For "normal" distributions you might consider simply indexing
the contents of lib/, but there are many fascinating oddities on CPAN and
many dists from the days when it was normal to put the main .pm file in the
root of the distribution archive - so PAUSE currently indexes all .pm and .PL
files that are not either (a) specifically excluded by no_index (b) in
C<inc>, C<xt>, or C<t> directories, or common 'mistake' directories such as
C<perl5>.

Or: If you're trying to be PAUSE-like, make sure you skip C<inc>, C<xt> and
C<t> as well as anything marked as no_index.

Also remember: If the META file contains a provides field, you shouldn't be
indexing anything in the first place - just use that.

=head1 SEE ALSO

=over 4

=item *

CPAN, L<http://www.cpan.org/>

=item *

JSON, L<http://json.org/>

=item *

YAML, L<http://www.yaml.org/>

=item *

L<CPAN>

=item *

L<CPANPLUS>

=item *

L<ExtUtils::MakeMaker>

=item *

L<Module::Build>

=item *

L<Module::Install>

=back

=head1 HISTORY

Ken Williams wrote the original CPAN Meta Spec (also known as the
"META.yml spec") in 2003 and maintained it through several revisions
with input from various members of the community.  In 2005, Randy
Sims redrafted it from HTML to POD for the version 1.2 release.  Ken
continued to maintain the spec through version 1.4.

In late 2009, David Golden organized the version 2 proposal review
process.  David and Ricardo Signes drafted the final version 2 spec
in April 2010 based on the version 1.4 spec and patches contributed
during the proposal process.

=head1 AUTHORS

=over 4

=item *

David Golden <dagolden@cpan.org>

=item *

Ricardo Signes <rjbs@cpan.org>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2010 by David Golden and Ricardo Signes.

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

=cut
PK       ! ��+n�  n�    perl5/CPAN/Meta/Validator.pmnu ��6�$        use 5.006;
use strict;
use warnings;
package CPAN::Meta::Validator;
# VERSION
$CPAN::Meta::Validator::VERSION = '2.143240';
#pod =head1 SYNOPSIS
#pod
#pod   my $struct = decode_json_file('META.json');
#pod
#pod   my $cmv = CPAN::Meta::Validator->new( $struct );
#pod
#pod   unless ( $cmv->is_valid ) {
#pod     my $msg = "Invalid META structure.  Errors found:\n";
#pod     $msg .= join( "\n", $cmv->errors );
#pod     die $msg;
#pod   }
#pod
#pod =head1 DESCRIPTION
#pod
#pod This module validates a CPAN Meta structure against the version of the
#pod the specification claimed in the C<meta-spec> field of the structure.
#pod
#pod =cut

#--------------------------------------------------------------------------#
# This code copied and adapted from Test::CPAN::Meta
# by Barbie, <barbie@cpan.org> for Miss Barbell Productions,
# L<http://www.missbarbell.co.uk>
#--------------------------------------------------------------------------#

#--------------------------------------------------------------------------#
# Specification Definitions
#--------------------------------------------------------------------------#

my %known_specs = (
    '1.4' => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
    '1.3' => 'http://module-build.sourceforge.net/META-spec-v1.3.html',
    '1.2' => 'http://module-build.sourceforge.net/META-spec-v1.2.html',
    '1.1' => 'http://module-build.sourceforge.net/META-spec-v1.1.html',
    '1.0' => 'http://module-build.sourceforge.net/META-spec-v1.0.html'
);
my %known_urls = map {$known_specs{$_} => $_} keys %known_specs;

my $module_map1 = { 'map' => { ':key' => { name => \&module, value => \&exversion } } };

my $module_map2 = { 'map' => { ':key' => { name => \&module, value => \&version   } } };

my $no_index_2 = {
    'map'       => { file       => { list => { value => \&string } },
                     directory  => { list => { value => \&string } },
                     'package'  => { list => { value => \&string } },
                     namespace  => { list => { value => \&string } },
                    ':key'      => { name => \&custom_2, value => \&anything },
    }
};

my $no_index_1_3 = {
    'map'       => { file       => { list => { value => \&string } },
                     directory  => { list => { value => \&string } },
                     'package'  => { list => { value => \&string } },
                     namespace  => { list => { value => \&string } },
                     ':key'     => { name => \&string, value => \&anything },
    }
};

my $no_index_1_2 = {
    'map'       => { file       => { list => { value => \&string } },
                     dir        => { list => { value => \&string } },
                     'package'  => { list => { value => \&string } },
                     namespace  => { list => { value => \&string } },
                     ':key'     => { name => \&string, value => \&anything },
    }
};

my $no_index_1_1 = {
    'map'       => { ':key'     => { name => \&string, list => { value => \&string } },
    }
};

my $prereq_map = {
  map => {
    ':key' => {
      name => \&phase,
      'map' => {
        ':key'  => {
          name => \&relation,
          %$module_map1,
        },
      },
    }
  },
};

my %definitions = (
  '2' => {
    # REQUIRED
    'abstract'            => { mandatory => 1, value => \&string  },
    'author'              => { mandatory => 1, list => { value => \&string } },
    'dynamic_config'      => { mandatory => 1, value => \&boolean },
    'generated_by'        => { mandatory => 1, value => \&string  },
    'license'             => { mandatory => 1, list => { value => \&license } },
    'meta-spec' => {
      mandatory => 1,
      'map' => {
        version => { mandatory => 1, value => \&version},
        url     => { value => \&url },
        ':key' => { name => \&custom_2, value => \&anything },
      }
    },
    'name'                => { mandatory => 1, value => \&string  },
    'release_status'      => { mandatory => 1, value => \&release_status },
    'version'             => { mandatory => 1, value => \&version },

    # OPTIONAL
    'description' => { value => \&string },
    'keywords'    => { list => { value => \&string } },
    'no_index'    => $no_index_2,
    'optional_features'   => {
      'map'       => {
        ':key'  => {
          name => \&string,
          'map'   => {
            description        => { value => \&string },
            prereqs => $prereq_map,
            ':key' => { name => \&custom_2, value => \&anything },
          }
        }
      }
    },
    'prereqs' => $prereq_map,
    'provides'    => {
      'map'       => {
        ':key' => {
          name  => \&module,
          'map' => {
            file    => { mandatory => 1, value => \&file },
            version => { value => \&version },
            ':key' => { name => \&custom_2, value => \&anything },
          }
        }
      }
    },
    'resources'   => {
      'map'       => {
        license    => { list => { value => \&url } },
        homepage   => { value => \&url },
        bugtracker => {
          'map' => {
            web => { value => \&url },
            mailto => { value => \&string},
            ':key' => { name => \&custom_2, value => \&anything },
          }
        },
        repository => {
          'map' => {
            web => { value => \&url },
            url => { value => \&url },
            type => { value => \&string },
            ':key' => { name => \&custom_2, value => \&anything },
          }
        },
        ':key'     => { value => \&string, name => \&custom_2 },
      }
    },

    # CUSTOM -- additional user defined key/value pairs
    # note we can only validate the key name, as the structure is user defined
    ':key'        => { name => \&custom_2, value => \&anything },
  },

'1.4' => {
  'meta-spec'           => {
    mandatory => 1,
    'map' => {
      version => { mandatory => 1, value => \&version},
      url     => { mandatory => 1, value => \&urlspec },
      ':key'  => { name => \&string, value => \&anything },
    },
  },

  'name'                => { mandatory => 1, value => \&string  },
  'version'             => { mandatory => 1, value => \&version },
  'abstract'            => { mandatory => 1, value => \&string  },
  'author'              => { mandatory => 1, list  => { value => \&string } },
  'license'             => { mandatory => 1, value => \&license },
  'generated_by'        => { mandatory => 1, value => \&string  },

  'distribution_type'   => { value => \&string  },
  'dynamic_config'      => { value => \&boolean },

  'requires'            => $module_map1,
  'recommends'          => $module_map1,
  'build_requires'      => $module_map1,
  'configure_requires'  => $module_map1,
  'conflicts'           => $module_map2,

  'optional_features'   => {
    'map'       => {
        ':key'  => { name => \&string,
            'map'   => { description        => { value => \&string },
                         requires           => $module_map1,
                         recommends         => $module_map1,
                         build_requires     => $module_map1,
                         conflicts          => $module_map2,
                         ':key'  => { name => \&string, value => \&anything },
            }
        }
     }
  },

  'provides'    => {
    'map'       => {
      ':key' => { name  => \&module,
        'map' => {
          file    => { mandatory => 1, value => \&file },
          version => { value => \&version },
          ':key'  => { name => \&string, value => \&anything },
        }
      }
    }
  },

  'no_index'    => $no_index_1_3,
  'private'     => $no_index_1_3,

  'keywords'    => { list => { value => \&string } },

  'resources'   => {
    'map'       => { license    => { value => \&url },
                     homepage   => { value => \&url },
                     bugtracker => { value => \&url },
                     repository => { value => \&url },
                     ':key'     => { value => \&string, name => \&custom_1 },
    }
  },

  # additional user defined key/value pairs
  # note we can only validate the key name, as the structure is user defined
  ':key'        => { name => \&string, value => \&anything },
},

'1.3' => {
  'meta-spec'           => {
    mandatory => 1,
    'map' => {
      version => { mandatory => 1, value => \&version},
      url     => { mandatory => 1, value => \&urlspec },
      ':key'  => { name => \&string, value => \&anything },
    },
  },

  'name'                => { mandatory => 1, value => \&string  },
  'version'             => { mandatory => 1, value => \&version },
  'abstract'            => { mandatory => 1, value => \&string  },
  'author'              => { mandatory => 1, list  => { value => \&string } },
  'license'             => { mandatory => 1, value => \&license },
  'generated_by'        => { mandatory => 1, value => \&string  },

  'distribution_type'   => { value => \&string  },
  'dynamic_config'      => { value => \&boolean },

  'requires'            => $module_map1,
  'recommends'          => $module_map1,
  'build_requires'      => $module_map1,
  'conflicts'           => $module_map2,

  'optional_features'   => {
    'map'       => {
        ':key'  => { name => \&string,
            'map'   => { description        => { value => \&string },
                         requires           => $module_map1,
                         recommends         => $module_map1,
                         build_requires     => $module_map1,
                         conflicts          => $module_map2,
                         ':key'  => { name => \&string, value => \&anything },
            }
        }
     }
  },

  'provides'    => {
    'map'       => {
      ':key' => { name  => \&module,
        'map' => {
          file    => { mandatory => 1, value => \&file },
          version => { value => \&version },
          ':key'  => { name => \&string, value => \&anything },
        }
      }
    }
  },


  'no_index'    => $no_index_1_3,
  'private'     => $no_index_1_3,

  'keywords'    => { list => { value => \&string } },

  'resources'   => {
    'map'       => { license    => { value => \&url },
                     homepage   => { value => \&url },
                     bugtracker => { value => \&url },
                     repository => { value => \&url },
                     ':key'     => { value => \&string, name => \&custom_1 },
    }
  },

  # additional user defined key/value pairs
  # note we can only validate the key name, as the structure is user defined
  ':key'        => { name => \&string, value => \&anything },
},

# v1.2 is misleading, it seems to assume that a number of fields where created
# within v1.1, when they were created within v1.2. This may have been an
# original mistake, and that a v1.1 was retro fitted into the timeline, when
# v1.2 was originally slated as v1.1. But I could be wrong ;)
'1.2' => {
  'meta-spec'           => {
    mandatory => 1,
    'map' => {
      version => { mandatory => 1, value => \&version},
      url     => { mandatory => 1, value => \&urlspec },
      ':key'  => { name => \&string, value => \&anything },
    },
  },


  'name'                => { mandatory => 1, value => \&string  },
  'version'             => { mandatory => 1, value => \&version },
  'license'             => { mandatory => 1, value => \&license },
  'generated_by'        => { mandatory => 1, value => \&string  },
  'author'              => { mandatory => 1, list => { value => \&string } },
  'abstract'            => { mandatory => 1, value => \&string  },

  'distribution_type'   => { value => \&string  },
  'dynamic_config'      => { value => \&boolean },

  'keywords'            => { list => { value => \&string } },

  'private'             => $no_index_1_2,
  '$no_index'           => $no_index_1_2,

  'requires'            => $module_map1,
  'recommends'          => $module_map1,
  'build_requires'      => $module_map1,
  'conflicts'           => $module_map2,

  'optional_features'   => {
    'map'       => {
        ':key'  => { name => \&string,
            'map'   => { description        => { value => \&string },
                         requires           => $module_map1,
                         recommends         => $module_map1,
                         build_requires     => $module_map1,
                         conflicts          => $module_map2,
                         ':key'  => { name => \&string, value => \&anything },
            }
        }
     }
  },

  'provides'    => {
    'map'       => {
      ':key' => { name  => \&module,
        'map' => {
          file    => { mandatory => 1, value => \&file },
          version => { value => \&version },
          ':key'  => { name => \&string, value => \&anything },
        }
      }
    }
  },

  'resources'   => {
    'map'       => { license    => { value => \&url },
                     homepage   => { value => \&url },
                     bugtracker => { value => \&url },
                     repository => { value => \&url },
                     ':key'     => { value => \&string, name => \&custom_1 },
    }
  },

  # additional user defined key/value pairs
  # note we can only validate the key name, as the structure is user defined
  ':key'        => { name => \&string, value => \&anything },
},

# note that the 1.1 spec only specifies 'version' as mandatory
'1.1' => {
  'name'                => { value => \&string  },
  'version'             => { mandatory => 1, value => \&version },
  'license'             => { value => \&license },
  'generated_by'        => { value => \&string  },

  'license_uri'         => { value => \&url },
  'distribution_type'   => { value => \&string  },
  'dynamic_config'      => { value => \&boolean },

  'private'             => $no_index_1_1,

  'requires'            => $module_map1,
  'recommends'          => $module_map1,
  'build_requires'      => $module_map1,
  'conflicts'           => $module_map2,

  # additional user defined key/value pairs
  # note we can only validate the key name, as the structure is user defined
  ':key'        => { name => \&string, value => \&anything },
},

# note that the 1.0 spec doesn't specify optional or mandatory fields
# but we will treat version as mandatory since otherwise META 1.0 is
# completely arbitrary and pointless
'1.0' => {
  'name'                => { value => \&string  },
  'version'             => { mandatory => 1, value => \&version },
  'license'             => { value => \&license },
  'generated_by'        => { value => \&string  },

  'license_uri'         => { value => \&url },
  'distribution_type'   => { value => \&string  },
  'dynamic_config'      => { value => \&boolean },

  'requires'            => $module_map1,
  'recommends'          => $module_map1,
  'build_requires'      => $module_map1,
  'conflicts'           => $module_map2,

  # additional user defined key/value pairs
  # note we can only validate the key name, as the structure is user defined
  ':key'        => { name => \&string, value => \&anything },
},
);

#--------------------------------------------------------------------------#
# Code
#--------------------------------------------------------------------------#

#pod =method new
#pod
#pod   my $cmv = CPAN::Meta::Validator->new( $struct )
#pod
#pod The constructor must be passed a metadata structure.
#pod
#pod =cut

sub new {
  my ($class,$data) = @_;

  # create an attributes hash
  my $self = {
    'data'    => $data,
    'spec'    => eval { $data->{'meta-spec'}{'version'} } || "1.0",
    'errors'  => undef,
  };

  # create the object
  return bless $self, $class;
}

#pod =method is_valid
#pod
#pod   if ( $cmv->is_valid ) {
#pod     ...
#pod   }
#pod
#pod Returns a boolean value indicating whether the metadata provided
#pod is valid.
#pod
#pod =cut

sub is_valid {
    my $self = shift;
    my $data = $self->{data};
    my $spec_version = $self->{spec};
    $self->check_map($definitions{$spec_version},$data);
    return ! $self->errors;
}

#pod =method errors
#pod
#pod   warn( join "\n", $cmv->errors );
#pod
#pod Returns a list of errors seen during validation.
#pod
#pod =cut

sub errors {
    my $self = shift;
    return ()   unless(defined $self->{errors});
    return @{$self->{errors}};
}

#pod =begin :internals
#pod
#pod =head2 Check Methods
#pod
#pod =over
#pod
#pod =item *
#pod
#pod check_map($spec,$data)
#pod
#pod Checks whether a map (or hash) part of the data structure conforms to the
#pod appropriate specification definition.
#pod
#pod =item *
#pod
#pod check_list($spec,$data)
#pod
#pod Checks whether a list (or array) part of the data structure conforms to
#pod the appropriate specification definition.
#pod
#pod =item *
#pod
#pod =back
#pod
#pod =cut

my $spec_error = "Missing validation action in specification. "
  . "Must be one of 'map', 'list', or 'value'";

sub check_map {
    my ($self,$spec,$data) = @_;

    if(ref($spec) ne 'HASH') {
        $self->_error( "Unknown META specification, cannot validate." );
        return;
    }

    if(ref($data) ne 'HASH') {
        $self->_error( "Expected a map structure from string or file." );
        return;
    }

    for my $key (keys %$spec) {
        next    unless($spec->{$key}->{mandatory});
        next    if(defined $data->{$key});
        push @{$self->{stack}}, $key;
        $self->_error( "Missing mandatory field, '$key'" );
        pop @{$self->{stack}};
    }

    for my $key (keys %$data) {
        push @{$self->{stack}}, $key;
        if($spec->{$key}) {
            if($spec->{$key}{value}) {
                $spec->{$key}{value}->($self,$key,$data->{$key});
            } elsif($spec->{$key}{'map'}) {
                $self->check_map($spec->{$key}{'map'},$data->{$key});
            } elsif($spec->{$key}{'list'}) {
                $self->check_list($spec->{$key}{'list'},$data->{$key});
            } else {
                $self->_error( "$spec_error for '$key'" );
            }

        } elsif ($spec->{':key'}) {
            $spec->{':key'}{name}->($self,$key,$key);
            if($spec->{':key'}{value}) {
                $spec->{':key'}{value}->($self,$key,$data->{$key});
            } elsif($spec->{':key'}{'map'}) {
                $self->check_map($spec->{':key'}{'map'},$data->{$key});
            } elsif($spec->{':key'}{'list'}) {
                $self->check_list($spec->{':key'}{'list'},$data->{$key});
            } else {
                $self->_error( "$spec_error for ':key'" );
            }


        } else {
            $self->_error( "Unknown key, '$key', found in map structure" );
        }
        pop @{$self->{stack}};
    }
}

sub check_list {
    my ($self,$spec,$data) = @_;

    if(ref($data) ne 'ARRAY') {
        $self->_error( "Expected a list structure" );
        return;
    }

    if(defined $spec->{mandatory}) {
        if(!defined $data->[0]) {
            $self->_error( "Missing entries from mandatory list" );
        }
    }

    for my $value (@$data) {
        push @{$self->{stack}}, $value || "<undef>";
        if(defined $spec->{value}) {
            $spec->{value}->($self,'list',$value);
        } elsif(defined $spec->{'map'}) {
            $self->check_map($spec->{'map'},$value);
        } elsif(defined $spec->{'list'}) {
            $self->check_list($spec->{'list'},$value);
        } elsif ($spec->{':key'}) {
            $self->check_map($spec,$value);
        } else {
          $self->_error( "$spec_error associated with '$self->{stack}[-2]'" );
        }
        pop @{$self->{stack}};
    }
}

#pod =head2 Validator Methods
#pod
#pod =over
#pod
#pod =item *
#pod
#pod header($self,$key,$value)
#pod
#pod Validates that the header is valid.
#pod
#pod Note: No longer used as we now read the data structure, not the file.
#pod
#pod =item *
#pod
#pod url($self,$key,$value)
#pod
#pod Validates that a given value is in an acceptable URL format
#pod
#pod =item *
#pod
#pod urlspec($self,$key,$value)
#pod
#pod Validates that the URL to a META specification is a known one.
#pod
#pod =item *
#pod
#pod string_or_undef($self,$key,$value)
#pod
#pod Validates that the value is either a string or an undef value. Bit of a
#pod catchall function for parts of the data structure that are completely user
#pod defined.
#pod
#pod =item *
#pod
#pod string($self,$key,$value)
#pod
#pod Validates that a string exists for the given key.
#pod
#pod =item *
#pod
#pod file($self,$key,$value)
#pod
#pod Validate that a file is passed for the given key. This may be made more
#pod thorough in the future. For now it acts like \&string.
#pod
#pod =item *
#pod
#pod exversion($self,$key,$value)
#pod
#pod Validates a list of versions, e.g. '<= 5, >=2, ==3, !=4, >1, <6, 0'.
#pod
#pod =item *
#pod
#pod version($self,$key,$value)
#pod
#pod Validates a single version string. Versions of the type '5.8.8' and '0.00_00'
#pod are both valid. A leading 'v' like 'v1.2.3' is also valid.
#pod
#pod =item *
#pod
#pod boolean($self,$key,$value)
#pod
#pod Validates for a boolean value. Currently these values are '1', '0', 'true',
#pod 'false', however the latter 2 may be removed.
#pod
#pod =item *
#pod
#pod license($self,$key,$value)
#pod
#pod Validates that a value is given for the license. Returns 1 if an known license
#pod type, or 2 if a value is given but the license type is not a recommended one.
#pod
#pod =item *
#pod
#pod custom_1($self,$key,$value)
#pod
#pod Validates that the given key is in CamelCase, to indicate a user defined
#pod keyword and only has characters in the class [-_a-zA-Z].  In version 1.X
#pod of the spec, this was only explicitly stated for 'resources'.
#pod
#pod =item *
#pod
#pod custom_2($self,$key,$value)
#pod
#pod Validates that the given key begins with 'x_' or 'X_', to indicate a user
#pod defined keyword and only has characters in the class [-_a-zA-Z]
#pod
#pod =item *
#pod
#pod identifier($self,$key,$value)
#pod
#pod Validates that key is in an acceptable format for the META specification,
#pod for an identifier, i.e. any that matches the regular expression
#pod qr/[a-z][a-z_]/i.
#pod
#pod =item *
#pod
#pod module($self,$key,$value)
#pod
#pod Validates that a given key is in an acceptable module name format, e.g.
#pod 'Test::CPAN::Meta::Version'.
#pod
#pod =back
#pod
#pod =end :internals
#pod
#pod =cut

sub header {
    my ($self,$key,$value) = @_;
    if(defined $value) {
        return 1    if($value && $value =~ /^--- #YAML:1.0/);
    }
    $self->_error( "file does not have a valid YAML header." );
    return 0;
}

sub release_status {
  my ($self,$key,$value) = @_;
  if(defined $value) {
    my $version = $self->{data}{version} || '';
    if ( $version =~ /_/ ) {
      return 1 if ( $value =~ /\A(?:testing|unstable)\z/ );
      $self->_error( "'$value' for '$key' is invalid for version '$version'" );
    }
    else {
      return 1 if ( $value =~ /\A(?:stable|testing|unstable)\z/ );
      $self->_error( "'$value' for '$key' is invalid" );
    }
  }
  else {
    $self->_error( "'$key' is not defined" );
  }
  return 0;
}

# _uri_split taken from URI::Split by Gisle Aas, Copyright 2003
sub _uri_split {
     return $_[0] =~ m,(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?,;
}

sub url {
    my ($self,$key,$value) = @_;
    if(defined $value) {
      my ($scheme, $auth, $path, $query, $frag) = _uri_split($value);
      unless ( defined $scheme && length $scheme ) {
        $self->_error( "'$value' for '$key' does not have a URL scheme" );
        return 0;
      }
      unless ( defined $auth && length $auth ) {
        $self->_error( "'$value' for '$key' does not have a URL authority" );
        return 0;
      }
      return 1;
    }
    $value ||= '';
    $self->_error( "'$value' for '$key' is not a valid URL." );
    return 0;
}

sub urlspec {
    my ($self,$key,$value) = @_;
    if(defined $value) {
        return 1    if($value && $known_specs{$self->{spec}} eq $value);
        if($value && $known_urls{$value}) {
            $self->_error( 'META specification URL does not match version' );
            return 0;
        }
    }
    $self->_error( 'Unknown META specification' );
    return 0;
}

sub anything { return 1 }

sub string {
    my ($self,$key,$value) = @_;
    if(defined $value) {
        return 1    if($value || $value =~ /^0$/);
    }
    $self->_error( "value is an undefined string" );
    return 0;
}

sub string_or_undef {
    my ($self,$key,$value) = @_;
    return 1    unless(defined $value);
    return 1    if($value || $value =~ /^0$/);
    $self->_error( "No string defined for '$key'" );
    return 0;
}

sub file {
    my ($self,$key,$value) = @_;
    return 1    if(defined $value);
    $self->_error( "No file defined for '$key'" );
    return 0;
}

sub exversion {
    my ($self,$key,$value) = @_;
    if(defined $value && ($value || $value =~ /0/)) {
        my $pass = 1;
        for(split(",",$value)) { $self->version($key,$_) or ($pass = 0); }
        return $pass;
    }
    $value = '<undef>'  unless(defined $value);
    $self->_error( "'$value' for '$key' is not a valid version." );
    return 0;
}

sub version {
    my ($self,$key,$value) = @_;
    if(defined $value) {
        return 0    unless($value || $value =~ /0/);
        return 1    if($value =~ /^\s*((<|<=|>=|>|!=|==)\s*)?v?\d+((\.\d+((_|\.)\d+)?)?)/);
    } else {
        $value = '<undef>';
    }
    $self->_error( "'$value' for '$key' is not a valid version." );
    return 0;
}

sub boolean {
    my ($self,$key,$value) = @_;
    if(defined $value) {
        return 1    if($value =~ /^(0|1|true|false)$/);
    } else {
        $value = '<undef>';
    }
    $self->_error( "'$value' for '$key' is not a boolean value." );
    return 0;
}

my %v1_licenses = (
    'perl'         => 'http://dev.perl.org/licenses/',
    'gpl'          => 'http://www.opensource.org/licenses/gpl-license.php',
    'apache'       => 'http://apache.org/licenses/LICENSE-2.0',
    'artistic'     => 'http://opensource.org/licenses/artistic-license.php',
    'artistic_2'   => 'http://opensource.org/licenses/artistic-license-2.0.php',
    'lgpl'         => 'http://www.opensource.org/licenses/lgpl-license.php',
    'bsd'          => 'http://www.opensource.org/licenses/bsd-license.php',
    'gpl'          => 'http://www.opensource.org/licenses/gpl-license.php',
    'mit'          => 'http://opensource.org/licenses/mit-license.php',
    'mozilla'      => 'http://opensource.org/licenses/mozilla1.1.php',
    'open_source'  => undef,
    'unrestricted' => undef,
    'restrictive'  => undef,
    'unknown'      => undef,
);

my %v2_licenses = map { $_ => 1 } qw(
  agpl_3
  apache_1_1
  apache_2_0
  artistic_1
  artistic_2
  bsd
  freebsd
  gfdl_1_2
  gfdl_1_3
  gpl_1
  gpl_2
  gpl_3
  lgpl_2_1
  lgpl_3_0
  mit
  mozilla_1_0
  mozilla_1_1
  openssl
  perl_5
  qpl_1_0
  ssleay
  sun
  zlib
  open_source
  restricted
  unrestricted
  unknown
);

sub license {
    my ($self,$key,$value) = @_;
    my $licenses = $self->{spec} < 2 ? \%v1_licenses : \%v2_licenses;
    if(defined $value) {
        return 1    if($value && exists $licenses->{$value});
    } else {
        $value = '<undef>';
    }
    $self->_error( "License '$value' is invalid" );
    return 0;
}

sub custom_1 {
    my ($self,$key) = @_;
    if(defined $key) {
        # a valid user defined key should be alphabetic
        # and contain at least one capital case letter.
        return 1    if($key && $key =~ /^[_a-z]+$/i && $key =~ /[A-Z]/);
    } else {
        $key = '<undef>';
    }
    $self->_error( "Custom resource '$key' must be in CamelCase." );
    return 0;
}

sub custom_2 {
    my ($self,$key) = @_;
    if(defined $key) {
        return 1    if($key && $key =~ /^x_/i);  # user defined
    } else {
        $key = '<undef>';
    }
    $self->_error( "Custom key '$key' must begin with 'x_' or 'X_'." );
    return 0;
}

sub identifier {
    my ($self,$key) = @_;
    if(defined $key) {
        return 1    if($key && $key =~ /^([a-z][_a-z]+)$/i);    # spec 2.0 defined
    } else {
        $key = '<undef>';
    }
    $self->_error( "Key '$key' is not a legal identifier." );
    return 0;
}

sub module {
    my ($self,$key) = @_;
    if(defined $key) {
        return 1    if($key && $key =~ /^[A-Za-z0-9_]+(::[A-Za-z0-9_]+)*$/);
    } else {
        $key = '<undef>';
    }
    $self->_error( "Key '$key' is not a legal module name." );
    return 0;
}

my @valid_phases = qw/ configure build test runtime develop /;
sub phase {
    my ($self,$key) = @_;
    if(defined $key) {
        return 1 if( length $key && grep { $key eq $_ } @valid_phases );
        return 1 if $key =~ /x_/i;
    } else {
        $key = '<undef>';
    }
    $self->_error( "Key '$key' is not a legal phase." );
    return 0;
}

my @valid_relations = qw/ requires recommends suggests conflicts /;
sub relation {
    my ($self,$key) = @_;
    if(defined $key) {
        return 1 if( length $key && grep { $key eq $_ } @valid_relations );
        return 1 if $key =~ /x_/i;
    } else {
        $key = '<undef>';
    }
    $self->_error( "Key '$key' is not a legal prereq relationship." );
    return 0;
}

sub _error {
    my $self = shift;
    my $mess = shift;

    $mess .= ' ('.join(' -> ',@{$self->{stack}}).')'  if($self->{stack});
    $mess .= " [Validation: $self->{spec}]";

    push @{$self->{errors}}, $mess;
}

1;

# ABSTRACT: validate CPAN distribution metadata structures

__END__

=pod

=encoding UTF-8

=head1 NAME

CPAN::Meta::Validator - validate CPAN distribution metadata structures

=head1 VERSION

version 2.143240

=head1 SYNOPSIS

  my $struct = decode_json_file('META.json');

  my $cmv = CPAN::Meta::Validator->new( $struct );

  unless ( $cmv->is_valid ) {
    my $msg = "Invalid META structure.  Errors found:\n";
    $msg .= join( "\n", $cmv->errors );
    die $msg;
  }

=head1 DESCRIPTION

This module validates a CPAN Meta structure against the version of the
the specification claimed in the C<meta-spec> field of the structure.

=head1 METHODS

=head2 new

  my $cmv = CPAN::Meta::Validator->new( $struct )

The constructor must be passed a metadata structure.

=head2 is_valid

  if ( $cmv->is_valid ) {
    ...
  }

Returns a boolean value indicating whether the metadata provided
is valid.

=head2 errors

  warn( join "\n", $cmv->errors );

Returns a list of errors seen during validation.

=begin :internals

=head2 Check Methods

=over

=item *

check_map($spec,$data)

Checks whether a map (or hash) part of the data structure conforms to the
appropriate specification definition.

=item *

check_list($spec,$data)

Checks whether a list (or array) part of the data structure conforms to
the appropriate specification definition.

=item *

=back

=head2 Validator Methods

=over

=item *

header($self,$key,$value)

Validates that the header is valid.

Note: No longer used as we now read the data structure, not the file.

=item *

url($self,$key,$value)

Validates that a given value is in an acceptable URL format

=item *

urlspec($self,$key,$value)

Validates that the URL to a META specification is a known one.

=item *

string_or_undef($self,$key,$value)

Validates that the value is either a string or an undef value. Bit of a
catchall function for parts of the data structure that are completely user
defined.

=item *

string($self,$key,$value)

Validates that a string exists for the given key.

=item *

file($self,$key,$value)

Validate that a file is passed for the given key. This may be made more
thorough in the future. For now it acts like \&string.

=item *

exversion($self,$key,$value)

Validates a list of versions, e.g. '<= 5, >=2, ==3, !=4, >1, <6, 0'.

=item *

version($self,$key,$value)

Validates a single version string. Versions of the type '5.8.8' and '0.00_00'
are both valid. A leading 'v' like 'v1.2.3' is also valid.

=item *

boolean($self,$key,$value)

Validates for a boolean value. Currently these values are '1', '0', 'true',
'false', however the latter 2 may be removed.

=item *

license($self,$key,$value)

Validates that a value is given for the license. Returns 1 if an known license
type, or 2 if a value is given but the license type is not a recommended one.

=item *

custom_1($self,$key,$value)

Validates that the given key is in CamelCase, to indicate a user defined
keyword and only has characters in the class [-_a-zA-Z].  In version 1.X
of the spec, this was only explicitly stated for 'resources'.

=item *

custom_2($self,$key,$value)

Validates that the given key begins with 'x_' or 'X_', to indicate a user
defined keyword and only has characters in the class [-_a-zA-Z]

=item *

identifier($self,$key,$value)

Validates that key is in an acceptable format for the META specification,
for an identifier, i.e. any that matches the regular expression
qr/[a-z][a-z_]/i.

=item *

module($self,$key,$value)

Validates that a given key is in an acceptable module name format, e.g.
'Test::CPAN::Meta::Version'.

=back

=end :internals

=for Pod::Coverage anything boolean check_list custom_1 custom_2 exversion file
identifier license module phase relation release_status string string_or_undef
url urlspec version header check_map

=head1 BUGS

Please report any bugs or feature using the CPAN Request Tracker.
Bugs can be submitted through the web interface at
L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>

When submitting a bug or request, please include a test-file or a patch to an
existing test-file that illustrates the bug or desired feature.

=head1 AUTHORS

=over 4

=item *

David Golden <dagolden@cpan.org>

=item *

Ricardo Signes <rjbs@cpan.org>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2010 by David Golden and Ricardo Signes.

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

=cut
PK       ! 4T�	�  �    perl5/CPAN/Meta/History.pmnu ��6�$        # vi:tw=72
use 5.006;
use strict;
use warnings;
package CPAN::Meta::History;
# VERSION
$CPAN::Meta::History::VERSION = '2.143240';
1;

# ABSTRACT: history of CPAN Meta Spec changes

__END__

=pod

=encoding UTF-8

=head1 NAME

CPAN::Meta::History - history of CPAN Meta Spec changes

=head1 VERSION

version 2.143240

=head1 DESCRIPTION

The CPAN Meta Spec has gone through several iterations.  It was
originally written in HTML and later revised into POD (though published
in HTML generated from the POD).  Fields were added, removed or changed,
sometimes by design and sometimes to reflect real-world usage after the
fact.

This document reconstructs the history of the CPAN Meta Spec based on
change logs, repository commit messages and the published HTML files.
In some cases, particularly prior to version 1.2, the exact version
when certain fields were introduced or changed is inconsistent between
sources.  When in doubt, the published HTML files for versions 1.0 to
1.4 as they existed when version 2 was developed are used as the
definitive source.

Starting with version 2, the specification document is part of the
CPAN-Meta distribution and will be published on CPAN as
L<CPAN::Meta::Spec>.

Going forward, specification version numbers will be integers and
decimal portions will correspond to a release date for the CPAN::Meta
library.

=head1 HISTORY

=head2 Version 2

April 2010

=over

=item *

Revised spec examples as perl data structures rather than YAML

=item *

Switched to JSON serialization from YAML

=item *

Specified allowed version number formats

=item *

Replaced 'requires', 'build_requires', 'configure_requires',
'recommends' and 'conflicts' with new 'prereqs' data structure divided
by I<phase> (configure, build, test, runtime, etc.) and I<relationship>
(requires, recommends, suggests, conflicts)

=item *

Added support for 'develop' phase for requirements for maintaining
a list of authoring tools

=item *

Changed 'license' to a list and revised the set of valid licenses

=item *

Made 'dynamic_config' mandatory to reduce confusion

=item *

Changed 'resources' subkey 'repository' to a hash that clarifies
repository type, url for browsing and url for checkout

=item *

Changed 'resources' subkey 'bugtracker' to a hash for either web
or mailto resource

=item *

Changed specification of 'optional_features':

=over

=item *

Added formal specification and usage guide instead of just example

=item *

Changed to use new prereqs data structure instead of individual keys

=back

=item *

Clarified intended use of 'author' as generalized contact list

=item *

Added 'release_status' field to indicate stable, testing or unstable
status to provide hints to indexers

=item *

Added 'description' field for a longer description of the distribution

=item *

Formalized use of "x_" or "X_" for all custom keys not listed in the
official spec

=back

=head2 Version 1.4

June 2008

=over

=item *

Noted explicit support for 'perl' in prerequisites

=item *

Added 'configure_requires' prerequisite type

=item *

Changed 'optional_features'

=over

=item *

Example corrected to show map of maps instead of list of maps
(though descriptive text said 'map' even in v1.3)

=item *

Removed 'requires_packages', 'requires_os' and 'excluded_os'
as valid subkeys

=back

=back

=head2 Version 1.3

November 2006

=over

=item *

Added 'no_index' subkey 'directory' and removed 'dir' to match actual
usage in the wild

=item *

Added a 'repository' subkey to 'resources'

=back

=head2 Version 1.2

August 2005

=over

=item *

Re-wrote and restructured spec in POD syntax

=item *

Changed 'name' to be mandatory

=item *

Changed 'generated_by' to be mandatory

=item *

Changed 'license' to be mandatory

=item *

Added version range specifications for prerequisites

=item *

Added required 'abstract' field

=item *

Added required 'author' field

=item *

Added required 'meta-spec' field to define 'version' (and 'url') of the
CPAN Meta Spec used for metadata

=item *

Added 'provides' field

=item *

Added 'no_index' field and deprecated 'private' field.  'no_index'
subkeys include 'file', 'dir', 'package' and 'namespace'

=item *

Added 'keywords' field

=item *

Added 'resources' field with subkeys 'homepage', 'license', and
'bugtracker'

=item *

Added 'optional_features' field as an alternate under 'recommends'.
Includes 'description', 'requires', 'build_requires', 'conflicts',
'requires_packages', 'requires_os' and 'excluded_os' as valid subkeys

=item *

Removed 'license_uri' field

=back

=head2 Version 1.1

May 2003

=over

=item *

Changed 'version' to be mandatory

=item *

Added 'private' field

=item *

Added 'license_uri' field

=back

=head2 Version 1.0

March 2003

=over

=item *

Original release (in HTML format only)

=item *

Included 'name', 'version', 'license', 'distribution_type', 'requires',
'recommends', 'build_requires', 'conflicts', 'dynamic_config',
'generated_by'

=back

=head1 AUTHORS

=over 4

=item *

David Golden <dagolden@cpan.org>

=item *

Ricardo Signes <rjbs@cpan.org>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2010 by David Golden and Ricardo Signes.

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

=cut
PK       ! �A�Ɵ�  ��    perl5/CPAN/Meta/Converter.pmnu ��6�$        use 5.006;
use strict;
use warnings;
package CPAN::Meta::Converter;
# VERSION
$CPAN::Meta::Converter::VERSION = '2.143240';
#pod =head1 SYNOPSIS
#pod
#pod   my $struct = decode_json_file('META.json');
#pod
#pod   my $cmc = CPAN::Meta::Converter->new( $struct );
#pod
#pod   my $new_struct = $cmc->convert( version => "2" );
#pod
#pod =head1 DESCRIPTION
#pod
#pod This module converts CPAN Meta structures from one form to another.  The
#pod primary use is to convert older structures to the most modern version of
#pod the specification, but other transformations may be implemented in the
#pod future as needed.  (E.g. stripping all custom fields or stripping all
#pod optional fields.)
#pod
#pod =cut

use CPAN::Meta::Validator;
use CPAN::Meta::Requirements;
use Parse::CPAN::Meta 1.4400 ();

# To help ExtUtils::MakeMaker bootstrap CPAN::Meta::Requirements on perls
# before 5.10, we fall back to the EUMM bundled compatibility version module if
# that's the only thing available.  This shouldn't ever happen in a normal CPAN
# install of CPAN::Meta::Requirements, as version.pm will be picked up from
# prereqs and be available at runtime.

BEGIN {
  eval "use version ()"; ## no critic
  if ( my $err = $@ ) {
    eval "use ExtUtils::MakeMaker::version" or die $err; ## no critic
  }
}

# Perl 5.10.0 didn't have "is_qv" in version.pm
*_is_qv = version->can('is_qv') ? sub { $_[0]->is_qv } : sub { exists $_[0]->{qv} };

sub _dclone {
  my $ref = shift;

  # if an object is in the data structure and doesn't specify how to
  # turn itself into JSON, we just stringify the object.  That does the
  # right thing for typical things that might be there, like version objects,
  # Path::Class objects, etc.
  no warnings 'once';
  no warnings 'redefine';
  local *UNIVERSAL::TO_JSON = sub { "$_[0]" };

  my $json = Parse::CPAN::Meta->json_backend()->new
      ->utf8
      ->allow_blessed
      ->convert_blessed;
  $json->decode($json->encode($ref))
}

my %known_specs = (
    '2'   => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec',
    '1.4' => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
    '1.3' => 'http://module-build.sourceforge.net/META-spec-v1.3.html',
    '1.2' => 'http://module-build.sourceforge.net/META-spec-v1.2.html',
    '1.1' => 'http://module-build.sourceforge.net/META-spec-v1.1.html',
    '1.0' => 'http://module-build.sourceforge.net/META-spec-v1.0.html'
);

my @spec_list = sort { $a <=> $b } keys %known_specs;
my ($LOWEST, $HIGHEST) = @spec_list[0,-1];

#--------------------------------------------------------------------------#
# converters
#
# called as $converter->($element, $field_name, $full_meta, $to_version)
#
# defined return value used for field
# undef return value means field is skipped
#--------------------------------------------------------------------------#

sub _keep { $_[0] }

sub _keep_or_one { defined($_[0]) ? $_[0] : 1 }

sub _keep_or_zero { defined($_[0]) ? $_[0] : 0 }

sub _keep_or_unknown { defined($_[0]) && length($_[0]) ? $_[0] : "unknown" }

sub _generated_by {
  my $gen = shift;
  my $sig = __PACKAGE__ . " version " . (__PACKAGE__->VERSION || "<dev>");

  return $sig unless defined $gen and length $gen;
  return $gen if $gen =~ /\Q$sig/;
  return "$gen, $sig";
}

sub _listify { ! defined $_[0] ? undef : ref $_[0] eq 'ARRAY' ? $_[0] : [$_[0]] }

sub _prefix_custom {
  my $key = shift;
  $key =~ s/^(?!x_)   # Unless it already starts with x_
             (?:x-?)? # Remove leading x- or x (if present)
           /x_/ix;    # and prepend x_
  return $key;
}

sub _ucfirst_custom {
  my $key = shift;
  $key = ucfirst $key unless $key =~ /[A-Z]/;
  return $key;
}

sub _no_prefix_ucfirst_custom {
  my $key = shift;
  $key =~ s/^x_//;
  return _ucfirst_custom($key);
}

sub _change_meta_spec {
  my ($element, undef, undef, $version) = @_;
  return {
    version => $version,
    url => $known_specs{$version},
  };
}

my @open_source = (
  'perl',
  'gpl',
  'apache',
  'artistic',
  'artistic_2',
  'lgpl',
  'bsd',
  'gpl',
  'mit',
  'mozilla',
  'open_source',
);

my %is_open_source = map {; $_ => 1 } @open_source;

my @valid_licenses_1 = (
  @open_source,
  'unrestricted',
  'restrictive',
  'unknown',
);

my %license_map_1 = (
  ( map { $_ => $_ } @valid_licenses_1 ),
  artistic2 => 'artistic_2',
);

sub _license_1 {
  my ($element) = @_;
  return 'unknown' unless defined $element;
  if ( $license_map_1{lc $element} ) {
    return $license_map_1{lc $element};
  }
  else {
    return 'unknown';
  }
}

my @valid_licenses_2 = qw(
  agpl_3
  apache_1_1
  apache_2_0
  artistic_1
  artistic_2
  bsd
  freebsd
  gfdl_1_2
  gfdl_1_3
  gpl_1
  gpl_2
  gpl_3
  lgpl_2_1
  lgpl_3_0
  mit
  mozilla_1_0
  mozilla_1_1
  openssl
  perl_5
  qpl_1_0
  ssleay
  sun
  zlib
  open_source
  restricted
  unrestricted
  unknown
);

# The "old" values were defined by Module::Build, and were often vague.  I have
# made the decisions below based on reading Module::Build::API and how clearly
# it specifies the version of the license.
my %license_map_2 = (
  (map { $_ => $_ } @valid_licenses_2),
  apache      => 'apache_2_0',  # clearly stated as 2.0
  artistic    => 'artistic_1',  # clearly stated as 1
  artistic2   => 'artistic_2',  # clearly stated as 2
  gpl         => 'open_source', # we don't know which GPL; punt
  lgpl        => 'open_source', # we don't know which LGPL; punt
  mozilla     => 'open_source', # we don't know which MPL; punt
  perl        => 'perl_5',      # clearly Perl 5
  restrictive => 'restricted',
);

sub _license_2 {
  my ($element) = @_;
  return [ 'unknown' ] unless defined $element;
  $element = [ $element ] unless ref $element eq 'ARRAY';
  my @new_list;
  for my $lic ( @$element ) {
    next unless defined $lic;
    if ( my $new = $license_map_2{lc $lic} ) {
      push @new_list, $new;
    }
  }
  return @new_list ? \@new_list : [ 'unknown' ];
}

my %license_downgrade_map = qw(
  agpl_3            open_source
  apache_1_1        apache
  apache_2_0        apache
  artistic_1        artistic
  artistic_2        artistic_2
  bsd               bsd
  freebsd           open_source
  gfdl_1_2          open_source
  gfdl_1_3          open_source
  gpl_1             gpl
  gpl_2             gpl
  gpl_3             gpl
  lgpl_2_1          lgpl
  lgpl_3_0          lgpl
  mit               mit
  mozilla_1_0       mozilla
  mozilla_1_1       mozilla
  openssl           open_source
  perl_5            perl
  qpl_1_0           open_source
  ssleay            open_source
  sun               open_source
  zlib              open_source
  open_source       open_source
  restricted        restrictive
  unrestricted      unrestricted
  unknown           unknown
);

sub _downgrade_license {
  my ($element) = @_;
  if ( ! defined $element ) {
    return "unknown";
  }
  elsif( ref $element eq 'ARRAY' ) {
    if ( @$element > 1) {
      if (grep { !$is_open_source{ $license_downgrade_map{lc $_} || 'unknown' } } @$element) {
        return 'unknown';
      }
      else {
        return 'open_source';
      }
    }
    elsif ( @$element == 1 ) {
      return $license_downgrade_map{lc $element->[0]} || "unknown";
    }
  }
  elsif ( ! ref $element ) {
    return $license_downgrade_map{lc $element} || "unknown";
  }
  return "unknown";
}

my $no_index_spec_1_2 = {
  'file' => \&_listify,
  'dir' => \&_listify,
  'package' => \&_listify,
  'namespace' => \&_listify,
};

my $no_index_spec_1_3 = {
  'file' => \&_listify,
  'directory' => \&_listify,
  'package' => \&_listify,
  'namespace' => \&_listify,
};

my $no_index_spec_2 = {
  'file' => \&_listify,
  'directory' => \&_listify,
  'package' => \&_listify,
  'namespace' => \&_listify,
  ':custom'  => \&_prefix_custom,
};

sub _no_index_1_2 {
  my (undef, undef, $meta) = @_;
  my $no_index = $meta->{no_index} || $meta->{private};
  return unless $no_index;

  # cleanup wrong format
  if ( ! ref $no_index ) {
    my $item = $no_index;
    $no_index = { dir => [ $item ], file => [ $item ] };
  }
  elsif ( ref $no_index eq 'ARRAY' ) {
    my $list = $no_index;
    $no_index = { dir => [ @$list ], file => [ @$list ] };
  }

  # common mistake: files -> file
  if ( exists $no_index->{files} ) {
    $no_index->{file} = delete $no_index->{file};
  }
  # common mistake: modules -> module
  if ( exists $no_index->{modules} ) {
    $no_index->{module} = delete $no_index->{module};
  }
  return _convert($no_index, $no_index_spec_1_2);
}

sub _no_index_directory {
  my ($element, $key, $meta, $version) = @_;
  return unless $element;

  # cleanup wrong format
  if ( ! ref $element ) {
    my $item = $element;
    $element = { directory => [ $item ], file => [ $item ] };
  }
  elsif ( ref $element eq 'ARRAY' ) {
    my $list = $element;
    $element = { directory => [ @$list ], file => [ @$list ] };
  }

  if ( exists $element->{dir} ) {
    $element->{directory} = delete $element->{dir};
  }
  # common mistake: files -> file
  if ( exists $element->{files} ) {
    $element->{file} = delete $element->{file};
  }
  # common mistake: modules -> module
  if ( exists $element->{modules} ) {
    $element->{module} = delete $element->{module};
  }
  my $spec = $version == 2 ? $no_index_spec_2 : $no_index_spec_1_3;
  return _convert($element, $spec);
}

sub _is_module_name {
  my $mod = shift;
  return unless defined $mod && length $mod;
  return $mod =~ m{^[A-Za-z][A-Za-z0-9_]*(?:::[A-Za-z0-9_]+)*$};
}

sub _clean_version {
  my ($element) = @_;
  return 0 if ! defined $element;

  $element =~ s{^\s*}{};
  $element =~ s{\s*$}{};
  $element =~ s{^\.}{0.};

  return 0 if ! length $element;
  return 0 if ( $element eq 'undef' || $element eq '<undef>' );

  my $v = eval { version->new($element) };
  # XXX check defined $v and not just $v because version objects leak memory
  # in boolean context -- dagolden, 2012-02-03
  if ( defined $v ) {
    return _is_qv($v) ? $v->normal : $element;
  }
  else {
    return 0;
  }
}

sub _bad_version_hook {
  my ($v) = @_;
  $v =~ s{[a-z]+$}{}; # strip trailing alphabetics
  my $vobj = eval { version->new($v) };
  return defined($vobj) ? $vobj : version->new(0); # or give up
}

sub _version_map {
  my ($element) = @_;
  return unless defined $element;
  if ( ref $element eq 'HASH' ) {
    # XXX turn this into CPAN::Meta::Requirements with bad version hook
    # and then turn it back into a hash
    my $new_map = CPAN::Meta::Requirements->new(
      { bad_version_hook => \&_bad_version_hook } # punt
    );
    while ( my ($k,$v) = each %$element ) {
      next unless _is_module_name($k);
      if ( !defined($v) || !length($v) || $v eq 'undef' || $v eq '<undef>'  ) {
        $v = 0;
      }
      # some weird, old META have bad yml with module => module
      # so check if value is like a module name and not like a version
      if ( _is_module_name($v) && ! version::is_lax($v) ) {
        $new_map->add_minimum($k => 0);
        $new_map->add_minimum($v => 0);
      }
      $new_map->add_string_requirement($k => $v);
    }
    return $new_map->as_string_hash;
  }
  elsif ( ref $element eq 'ARRAY' ) {
    my $hashref = { map { $_ => 0 } @$element };
    return _version_map($hashref); # cleanup any weird stuff
  }
  elsif ( ref $element eq '' && length $element ) {
    return { $element => 0 }
  }
  return;
}

sub _prereqs_from_1 {
  my (undef, undef, $meta) = @_;
  my $prereqs = {};
  for my $phase ( qw/build configure/ ) {
    my $key = "${phase}_requires";
    $prereqs->{$phase}{requires} = _version_map($meta->{$key})
      if $meta->{$key};
  }
  for my $rel ( qw/requires recommends conflicts/ ) {
    $prereqs->{runtime}{$rel} = _version_map($meta->{$rel})
      if $meta->{$rel};
  }
  return $prereqs;
}

my $prereqs_spec = {
  configure => \&_prereqs_rel,
  build     => \&_prereqs_rel,
  test      => \&_prereqs_rel,
  runtime   => \&_prereqs_rel,
  develop   => \&_prereqs_rel,
  ':custom'  => \&_prefix_custom,
};

my $relation_spec = {
  requires   => \&_version_map,
  recommends => \&_version_map,
  suggests   => \&_version_map,
  conflicts  => \&_version_map,
  ':custom'  => \&_prefix_custom,
};

sub _cleanup_prereqs {
  my ($prereqs, $key, $meta, $to_version) = @_;
  return unless $prereqs && ref $prereqs eq 'HASH';
  return _convert( $prereqs, $prereqs_spec, $to_version );
}

sub _prereqs_rel {
  my ($relation, $key, $meta, $to_version) = @_;
  return unless $relation && ref $relation eq 'HASH';
  return _convert( $relation, $relation_spec, $to_version );
}


BEGIN {
  my @old_prereqs = qw(
    requires
    configure_requires
    recommends
    conflicts
  );

  for ( @old_prereqs ) {
    my $sub = "_get_$_";
    my ($phase,$type) = split qr/_/, $_;
    if ( ! defined $type ) {
      $type = $phase;
      $phase = 'runtime';
    }
    no strict 'refs';
    *{$sub} = sub { _extract_prereqs($_[2]->{prereqs},$phase,$type) };
  }
}

sub _get_build_requires {
  my ($data, $key, $meta) = @_;

  my $test_h  = _extract_prereqs($_[2]->{prereqs}, qw(test  requires)) || {};
  my $build_h = _extract_prereqs($_[2]->{prereqs}, qw(build requires)) || {};

  my $test_req  = CPAN::Meta::Requirements->from_string_hash($test_h);
  my $build_req = CPAN::Meta::Requirements->from_string_hash($build_h);

  $test_req->add_requirements($build_req)->as_string_hash;
}

sub _extract_prereqs {
  my ($prereqs, $phase, $type) = @_;
  return unless ref $prereqs eq 'HASH';
  return scalar _version_map($prereqs->{$phase}{$type});
}

sub _downgrade_optional_features {
  my (undef, undef, $meta) = @_;
  return unless exists $meta->{optional_features};
  my $origin = $meta->{optional_features};
  my $features = {};
  for my $name ( keys %$origin ) {
    $features->{$name} = {
      description => $origin->{$name}{description},
      requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','requires'),
      configure_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','configure_requires'),
      build_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','build_requires'),
      recommends => _extract_prereqs($origin->{$name}{prereqs},'runtime','recommends'),
      conflicts => _extract_prereqs($origin->{$name}{prereqs},'runtime','conflicts'),
    };
    for my $k (keys %{$features->{$name}} ) {
      delete $features->{$name}{$k} unless defined $features->{$name}{$k};
    }
  }
  return $features;
}

sub _upgrade_optional_features {
  my (undef, undef, $meta) = @_;
  return unless exists $meta->{optional_features};
  my $origin = $meta->{optional_features};
  my $features = {};
  for my $name ( keys %$origin ) {
    $features->{$name} = {
      description => $origin->{$name}{description},
      prereqs => _prereqs_from_1(undef, undef, $origin->{$name}),
    };
    delete $features->{$name}{prereqs}{configure};
  }
  return $features;
}

my $optional_features_2_spec = {
  description => \&_keep,
  prereqs => \&_cleanup_prereqs,
  ':custom'  => \&_prefix_custom,
};

sub _feature_2 {
  my ($element, $key, $meta, $to_version) = @_;
  return unless $element && ref $element eq 'HASH';
  _convert( $element, $optional_features_2_spec, $to_version );
}

sub _cleanup_optional_features_2 {
  my ($element, $key, $meta, $to_version) = @_;
  return unless $element && ref $element eq 'HASH';
  my $new_data = {};
  for my $k ( keys %$element ) {
    $new_data->{$k} = _feature_2( $element->{$k}, $k, $meta, $to_version );
  }
  return unless keys %$new_data;
  return $new_data;
}

sub _optional_features_1_4 {
  my ($element) = @_;
  return unless $element;
  $element = _optional_features_as_map($element);
  for my $name ( keys %$element ) {
    for my $drop ( qw/requires_packages requires_os excluded_os/ ) {
      delete $element->{$name}{$drop};
    }
  }
  return $element;
}

sub _optional_features_as_map {
  my ($element) = @_;
  return unless $element;
  if ( ref $element eq 'ARRAY' ) {
    my %map;
    for my $feature ( @$element ) {
      my (@parts) = %$feature;
      $map{$parts[0]} = $parts[1];
    }
    $element = \%map;
  }
  return $element;
}

sub _is_urlish { defined $_[0] && $_[0] =~ m{\A[-+.a-z0-9]+:.+}i }

sub _url_or_drop {
  my ($element) = @_;
  return $element if _is_urlish($element);
  return;
}

sub _url_list {
  my ($element) = @_;
  return unless $element;
  $element = _listify( $element );
  $element = [ grep { _is_urlish($_) } @$element ];
  return unless @$element;
  return $element;
}

sub _author_list {
  my ($element) = @_;
  return [ 'unknown' ] unless $element;
  $element = _listify( $element );
  $element = [ map { defined $_ && length $_ ? $_ : 'unknown' } @$element ];
  return [ 'unknown' ] unless @$element;
  return $element;
}

my $resource2_upgrade = {
  license    => sub { return _is_urlish($_[0]) ? _listify( $_[0] ) : undef },
  homepage   => \&_url_or_drop,
  bugtracker => sub {
    my ($item) = @_;
    return unless $item;
    if ( $item =~ m{^mailto:(.*)$} ) { return { mailto => $1 } }
    elsif( _is_urlish($item) ) { return { web => $item } }
    else { return }
  },
  repository => sub { return _is_urlish($_[0]) ? { url => $_[0] } : undef },
  ':custom'  => \&_prefix_custom,
};

sub _upgrade_resources_2 {
  my (undef, undef, $meta, $version) = @_;
  return unless exists $meta->{resources};
  return _convert($meta->{resources}, $resource2_upgrade);
}

my $bugtracker2_spec = {
  web => \&_url_or_drop,
  mailto => \&_keep,
  ':custom'  => \&_prefix_custom,
};

sub _repo_type {
  my ($element, $key, $meta, $to_version) = @_;
  return $element if defined $element;
  return unless exists $meta->{url};
  my $repo_url = $meta->{url};
  for my $type ( qw/git svn/ ) {
    return $type if $repo_url =~ m{\A$type};
  }
  return;
}

my $repository2_spec = {
  web => \&_url_or_drop,
  url => \&_url_or_drop,
  type => \&_repo_type,
  ':custom'  => \&_prefix_custom,
};

my $resources2_cleanup = {
  license    => \&_url_list,
  homepage   => \&_url_or_drop,
  bugtracker => sub { ref $_[0] ? _convert( $_[0], $bugtracker2_spec ) : undef },
  repository => sub { my $data = shift; ref $data ? _convert( $data, $repository2_spec ) : undef },
  ':custom'  => \&_prefix_custom,
};

sub _cleanup_resources_2 {
  my ($resources, $key, $meta, $to_version) = @_;
  return unless $resources && ref $resources eq 'HASH';
  return _convert($resources, $resources2_cleanup, $to_version);
}

my $resource1_spec = {
  license    => \&_url_or_drop,
  homepage   => \&_url_or_drop,
  bugtracker => \&_url_or_drop,
  repository => \&_url_or_drop,
  ':custom'  => \&_keep,
};

sub _resources_1_3 {
  my (undef, undef, $meta, $version) = @_;
  return unless exists $meta->{resources};
  return _convert($meta->{resources}, $resource1_spec);
}

*_resources_1_4 = *_resources_1_3;

sub _resources_1_2 {
  my (undef, undef, $meta) = @_;
  my $resources = $meta->{resources} || {};
  if ( $meta->{license_url} && ! $resources->{license} ) {
    $resources->{license} = $meta->{license_url}
      if _is_urlish($meta->{license_url});
  }
  return unless keys %$resources;
  return _convert($resources, $resource1_spec);
}

my $resource_downgrade_spec = {
  license    => sub { return ref $_[0] ? $_[0]->[0] : $_[0] },
  homepage   => \&_url_or_drop,
  bugtracker => sub { return $_[0]->{web} },
  repository => sub { return $_[0]->{url} || $_[0]->{web} },
  ':custom'  => \&_no_prefix_ucfirst_custom,
};

sub _downgrade_resources {
  my (undef, undef, $meta, $version) = @_;
  return unless exists $meta->{resources};
  return _convert($meta->{resources}, $resource_downgrade_spec);
}

sub _release_status {
  my ($element, undef, $meta) = @_;
  return $element if $element && $element =~ m{\A(?:stable|testing|unstable)\z};
  return _release_status_from_version(undef, undef, $meta);
}

sub _release_status_from_version {
  my (undef, undef, $meta) = @_;
  my $version = $meta->{version} || '';
  return ( $version =~ /_/ ) ? 'testing' : 'stable';
}

my $provides_spec = {
  file => \&_keep,
  version => \&_keep,
};

my $provides_spec_2 = {
  file => \&_keep,
  version => \&_keep,
  ':custom'  => \&_prefix_custom,
};

sub _provides {
  my ($element, $key, $meta, $to_version) = @_;
  return unless defined $element && ref $element eq 'HASH';
  my $spec = $to_version == 2 ? $provides_spec_2 : $provides_spec;
  my $new_data = {};
  for my $k ( keys %$element ) {
    $new_data->{$k} = _convert($element->{$k}, $spec, $to_version);
    $new_data->{$k}{version} = _clean_version($element->{$k}{version})
      if exists $element->{$k}{version};
  }
  return $new_data;
}

sub _convert {
  my ($data, $spec, $to_version, $is_fragment) = @_;

  my $new_data = {};
  for my $key ( keys %$spec ) {
    next if $key eq ':custom' || $key eq ':drop';
    next unless my $fcn = $spec->{$key};
    if ( $is_fragment && $key eq 'generated_by' ) {
      $fcn = \&_keep;
    }
    die "spec for '$key' is not a coderef"
      unless ref $fcn && ref $fcn eq 'CODE';
    my $new_value = $fcn->($data->{$key}, $key, $data, $to_version);
    $new_data->{$key} = $new_value if defined $new_value;
  }

  my $drop_list   = $spec->{':drop'};
  my $customizer  = $spec->{':custom'} || \&_keep;

  for my $key ( keys %$data ) {
    next if $drop_list && grep { $key eq $_ } @$drop_list;
    next if exists $spec->{$key}; # we handled it
    $new_data->{ $customizer->($key) } = $data->{$key};
  }

  return $new_data;
}

#--------------------------------------------------------------------------#
# define converters for each conversion
#--------------------------------------------------------------------------#

# each converts from prior version
# special ":custom" field is used for keys not recognized in spec
my %up_convert = (
  '2-from-1.4' => {
    # PRIOR MANDATORY
    'abstract'            => \&_keep_or_unknown,
    'author'              => \&_author_list,
    'generated_by'        => \&_generated_by,
    'license'             => \&_license_2,
    'meta-spec'           => \&_change_meta_spec,
    'name'                => \&_keep,
    'version'             => \&_keep,
    # CHANGED TO MANDATORY
    'dynamic_config'      => \&_keep_or_one,
    # ADDED MANDATORY
    'release_status'      => \&_release_status_from_version,
    # PRIOR OPTIONAL
    'keywords'            => \&_keep,
    'no_index'            => \&_no_index_directory,
    'optional_features'   => \&_upgrade_optional_features,
    'provides'            => \&_provides,
    'resources'           => \&_upgrade_resources_2,
    # ADDED OPTIONAL
    'description'         => \&_keep,
    'prereqs'             => \&_prereqs_from_1,

    # drop these deprecated fields, but only after we convert
    ':drop' => [ qw(
        build_requires
        configure_requires
        conflicts
        distribution_type
        license_url
        private
        recommends
        requires
    ) ],

    # other random keys need x_ prefixing
    ':custom'              => \&_prefix_custom,
  },
  '1.4-from-1.3' => {
    # PRIOR MANDATORY
    'abstract'            => \&_keep_or_unknown,
    'author'              => \&_author_list,
    'generated_by'        => \&_generated_by,
    'license'             => \&_license_1,
    'meta-spec'           => \&_change_meta_spec,
    'name'                => \&_keep,
    'version'             => \&_keep,
    # PRIOR OPTIONAL
    'build_requires'      => \&_version_map,
    'conflicts'           => \&_version_map,
    'distribution_type'   => \&_keep,
    'dynamic_config'      => \&_keep_or_one,
    'keywords'            => \&_keep,
    'no_index'            => \&_no_index_directory,
    'optional_features'   => \&_optional_features_1_4,
    'provides'            => \&_provides,
    'recommends'          => \&_version_map,
    'requires'            => \&_version_map,
    'resources'           => \&_resources_1_4,
    # ADDED OPTIONAL
    'configure_requires'  => \&_keep,

    # drop these deprecated fields, but only after we convert
    ':drop' => [ qw(
      license_url
      private
    )],

    # other random keys are OK if already valid
    ':custom'              => \&_keep
  },
  '1.3-from-1.2' => {
    # PRIOR MANDATORY
    'abstract'            => \&_keep_or_unknown,
    'author'              => \&_author_list,
    'generated_by'        => \&_generated_by,
    'license'             => \&_license_1,
    'meta-spec'           => \&_change_meta_spec,
    'name'                => \&_keep,
    'version'             => \&_keep,
    # PRIOR OPTIONAL
    'build_requires'      => \&_version_map,
    'conflicts'           => \&_version_map,
    'distribution_type'   => \&_keep,
    'dynamic_config'      => \&_keep_or_one,
    'keywords'            => \&_keep,
    'no_index'            => \&_no_index_directory,
    'optional_features'   => \&_optional_features_as_map,
    'provides'            => \&_provides,
    'recommends'          => \&_version_map,
    'requires'            => \&_version_map,
    'resources'           => \&_resources_1_3,

    # drop these deprecated fields, but only after we convert
    ':drop' => [ qw(
      license_url
      private
    )],

    # other random keys are OK if already valid
    ':custom'              => \&_keep
  },
  '1.2-from-1.1' => {
    # PRIOR MANDATORY
    'version'             => \&_keep,
    # CHANGED TO MANDATORY
    'license'             => \&_license_1,
    'name'                => \&_keep,
    'generated_by'        => \&_generated_by,
    # ADDED MANDATORY
    'abstract'            => \&_keep_or_unknown,
    'author'              => \&_author_list,
    'meta-spec'           => \&_change_meta_spec,
    # PRIOR OPTIONAL
    'build_requires'      => \&_version_map,
    'conflicts'           => \&_version_map,
    'distribution_type'   => \&_keep,
    'dynamic_config'      => \&_keep_or_one,
    'recommends'          => \&_version_map,
    'requires'            => \&_version_map,
    # ADDED OPTIONAL
    'keywords'            => \&_keep,
    'no_index'            => \&_no_index_1_2,
    'optional_features'   => \&_optional_features_as_map,
    'provides'            => \&_provides,
    'resources'           => \&_resources_1_2,

    # drop these deprecated fields, but only after we convert
    ':drop' => [ qw(
      license_url
      private
    )],

    # other random keys are OK if already valid
    ':custom'              => \&_keep
  },
  '1.1-from-1.0' => {
    # CHANGED TO MANDATORY
    'version'             => \&_keep,
    # IMPLIED MANDATORY
    'name'                => \&_keep,
    # PRIOR OPTIONAL
    'build_requires'      => \&_version_map,
    'conflicts'           => \&_version_map,
    'distribution_type'   => \&_keep,
    'dynamic_config'      => \&_keep_or_one,
    'generated_by'        => \&_generated_by,
    'license'             => \&_license_1,
    'recommends'          => \&_version_map,
    'requires'            => \&_version_map,
    # ADDED OPTIONAL
    'license_url'         => \&_url_or_drop,
    'private'             => \&_keep,

    # other random keys are OK if already valid
    ':custom'              => \&_keep
  },
);

my %down_convert = (
  '1.4-from-2' => {
    # MANDATORY
    'abstract'            => \&_keep_or_unknown,
    'author'              => \&_author_list,
    'generated_by'        => \&_generated_by,
    'license'             => \&_downgrade_license,
    'meta-spec'           => \&_change_meta_spec,
    'name'                => \&_keep,
    'version'             => \&_keep,
    # OPTIONAL
    'build_requires'      => \&_get_build_requires,
    'configure_requires'  => \&_get_configure_requires,
    'conflicts'           => \&_get_conflicts,
    'distribution_type'   => \&_keep,
    'dynamic_config'      => \&_keep_or_one,
    'keywords'            => \&_keep,
    'no_index'            => \&_no_index_directory,
    'optional_features'   => \&_downgrade_optional_features,
    'provides'            => \&_provides,
    'recommends'          => \&_get_recommends,
    'requires'            => \&_get_requires,
    'resources'           => \&_downgrade_resources,

    # drop these unsupported fields (after conversion)
    ':drop' => [ qw(
      description
      prereqs
      release_status
    )],

    # custom keys will be left unchanged
    ':custom'              => \&_keep
  },
  '1.3-from-1.4' => {
    # MANDATORY
    'abstract'            => \&_keep_or_unknown,
    'author'              => \&_author_list,
    'generated_by'        => \&_generated_by,
    'license'             => \&_license_1,
    'meta-spec'           => \&_change_meta_spec,
    'name'                => \&_keep,
    'version'             => \&_keep,
    # OPTIONAL
    'build_requires'      => \&_version_map,
    'conflicts'           => \&_version_map,
    'distribution_type'   => \&_keep,
    'dynamic_config'      => \&_keep_or_one,
    'keywords'            => \&_keep,
    'no_index'            => \&_no_index_directory,
    'optional_features'   => \&_optional_features_as_map,
    'provides'            => \&_provides,
    'recommends'          => \&_version_map,
    'requires'            => \&_version_map,
    'resources'           => \&_resources_1_3,

    # drop these unsupported fields, but only after we convert
    ':drop' => [ qw(
      configure_requires
    )],

    # other random keys are OK if already valid
    ':custom'              => \&_keep,
  },
  '1.2-from-1.3' => {
    # MANDATORY
    'abstract'            => \&_keep_or_unknown,
    'author'              => \&_author_list,
    'generated_by'        => \&_generated_by,
    'license'             => \&_license_1,
    'meta-spec'           => \&_change_meta_spec,
    'name'                => \&_keep,
    'version'             => \&_keep,
    # OPTIONAL
    'build_requires'      => \&_version_map,
    'conflicts'           => \&_version_map,
    'distribution_type'   => \&_keep,
    'dynamic_config'      => \&_keep_or_one,
    'keywords'            => \&_keep,
    'no_index'            => \&_no_index_1_2,
    'optional_features'   => \&_optional_features_as_map,
    'provides'            => \&_provides,
    'recommends'          => \&_version_map,
    'requires'            => \&_version_map,
    'resources'           => \&_resources_1_3,

    # other random keys are OK if already valid
    ':custom'              => \&_keep,
  },
  '1.1-from-1.2' => {
    # MANDATORY
    'version'             => \&_keep,
    # IMPLIED MANDATORY
    'name'                => \&_keep,
    'meta-spec'           => \&_change_meta_spec,
    # OPTIONAL
    'build_requires'      => \&_version_map,
    'conflicts'           => \&_version_map,
    'distribution_type'   => \&_keep,
    'dynamic_config'      => \&_keep_or_one,
    'generated_by'        => \&_generated_by,
    'license'             => \&_license_1,
    'private'             => \&_keep,
    'recommends'          => \&_version_map,
    'requires'            => \&_version_map,

    # drop unsupported fields
    ':drop' => [ qw(
      abstract
      author
      provides
      no_index
      keywords
      resources
    )],

    # other random keys are OK if already valid
    ':custom'              => \&_keep,
  },
  '1.0-from-1.1' => {
    # IMPLIED MANDATORY
    'name'                => \&_keep,
    'meta-spec'           => \&_change_meta_spec,
    'version'             => \&_keep,
    # PRIOR OPTIONAL
    'build_requires'      => \&_version_map,
    'conflicts'           => \&_version_map,
    'distribution_type'   => \&_keep,
    'dynamic_config'      => \&_keep_or_one,
    'generated_by'        => \&_generated_by,
    'license'             => \&_license_1,
    'recommends'          => \&_version_map,
    'requires'            => \&_version_map,

    # other random keys are OK if already valid
    ':custom'              => \&_keep,
  },
);

my %cleanup = (
  '2' => {
    # PRIOR MANDATORY
    'abstract'            => \&_keep_or_unknown,
    'author'              => \&_author_list,
    'generated_by'        => \&_generated_by,
    'license'             => \&_license_2,
    'meta-spec'           => \&_change_meta_spec,
    'name'                => \&_keep,
    'version'             => \&_keep,
    # CHANGED TO MANDATORY
    'dynamic_config'      => \&_keep_or_one,
    # ADDED MANDATORY
    'release_status'      => \&_release_status,
    # PRIOR OPTIONAL
    'keywords'            => \&_keep,
    'no_index'            => \&_no_index_directory,
    'optional_features'   => \&_cleanup_optional_features_2,
    'provides'            => \&_provides,
    'resources'           => \&_cleanup_resources_2,
    # ADDED OPTIONAL
    'description'         => \&_keep,
    'prereqs'             => \&_cleanup_prereqs,

    # drop these deprecated fields, but only after we convert
    ':drop' => [ qw(
        build_requires
        configure_requires
        conflicts
        distribution_type
        license_url
        private
        recommends
        requires
    ) ],

    # other random keys need x_ prefixing
    ':custom'              => \&_prefix_custom,
  },
  '1.4' => {
    # PRIOR MANDATORY
    'abstract'            => \&_keep_or_unknown,
    'author'              => \&_author_list,
    'generated_by'        => \&_generated_by,
    'license'             => \&_license_1,
    'meta-spec'           => \&_change_meta_spec,
    'name'                => \&_keep,
    'version'             => \&_keep,
    # PRIOR OPTIONAL
    'build_requires'      => \&_version_map,
    'conflicts'           => \&_version_map,
    'distribution_type'   => \&_keep,
    'dynamic_config'      => \&_keep_or_one,
    'keywords'            => \&_keep,
    'no_index'            => \&_no_index_directory,
    'optional_features'   => \&_optional_features_1_4,
    'provides'            => \&_provides,
    'recommends'          => \&_version_map,
    'requires'            => \&_version_map,
    'resources'           => \&_resources_1_4,
    # ADDED OPTIONAL
    'configure_requires'  => \&_keep,

    # other random keys are OK if already valid
    ':custom'             => \&_keep
  },
  '1.3' => {
    # PRIOR MANDATORY
    'abstract'            => \&_keep_or_unknown,
    'author'              => \&_author_list,
    'generated_by'        => \&_generated_by,
    'license'             => \&_license_1,
    'meta-spec'           => \&_change_meta_spec,
    'name'                => \&_keep,
    'version'             => \&_keep,
    # PRIOR OPTIONAL
    'build_requires'      => \&_version_map,
    'conflicts'           => \&_version_map,
    'distribution_type'   => \&_keep,
    'dynamic_config'      => \&_keep_or_one,
    'keywords'            => \&_keep,
    'no_index'            => \&_no_index_directory,
    'optional_features'   => \&_optional_features_as_map,
    'provides'            => \&_provides,
    'recommends'          => \&_version_map,
    'requires'            => \&_version_map,
    'resources'           => \&_resources_1_3,

    # other random keys are OK if already valid
    ':custom'             => \&_keep
  },
  '1.2' => {
    # PRIOR MANDATORY
    'version'             => \&_keep,
    # CHANGED TO MANDATORY
    'license'             => \&_license_1,
    'name'                => \&_keep,
    'generated_by'        => \&_generated_by,
    # ADDED MANDATORY
    'abstract'            => \&_keep_or_unknown,
    'author'              => \&_author_list,
    'meta-spec'           => \&_change_meta_spec,
    # PRIOR OPTIONAL
    'build_requires'      => \&_version_map,
    'conflicts'           => \&_version_map,
    'distribution_type'   => \&_keep,
    'dynamic_config'      => \&_keep_or_one,
    'recommends'          => \&_version_map,
    'requires'            => \&_version_map,
    # ADDED OPTIONAL
    'keywords'            => \&_keep,
    'no_index'            => \&_no_index_1_2,
    'optional_features'   => \&_optional_features_as_map,
    'provides'            => \&_provides,
    'resources'           => \&_resources_1_2,

    # other random keys are OK if already valid
    ':custom'             => \&_keep
  },
  '1.1' => {
    # CHANGED TO MANDATORY
    'version'             => \&_keep,
    # IMPLIED MANDATORY
    'name'                => \&_keep,
    'meta-spec'           => \&_change_meta_spec,
    # PRIOR OPTIONAL
    'build_requires'      => \&_version_map,
    'conflicts'           => \&_version_map,
    'distribution_type'   => \&_keep,
    'dynamic_config'      => \&_keep_or_one,
    'generated_by'        => \&_generated_by,
    'license'             => \&_license_1,
    'recommends'          => \&_version_map,
    'requires'            => \&_version_map,
    # ADDED OPTIONAL
    'license_url'         => \&_url_or_drop,
    'private'             => \&_keep,

    # other random keys are OK if already valid
    ':custom'             => \&_keep
  },
  '1.0' => {
    # IMPLIED MANDATORY
    'name'                => \&_keep,
    'meta-spec'           => \&_change_meta_spec,
    'version'             => \&_keep,
    # IMPLIED OPTIONAL
    'build_requires'      => \&_version_map,
    'conflicts'           => \&_version_map,
    'distribution_type'   => \&_keep,
    'dynamic_config'      => \&_keep_or_one,
    'generated_by'        => \&_generated_by,
    'license'             => \&_license_1,
    'recommends'          => \&_version_map,
    'requires'            => \&_version_map,

    # other random keys are OK if already valid
    ':custom'             => \&_keep,
  },
);

# for a given field in a spec version, what fields will it feed
# into in the *latest* spec (i.e. v2); meta-spec omitted because
# we always expect a meta-spec to be generated
my %fragments_generate = (
  '2' => {
    'abstract'            =>   'abstract',
    'author'              =>   'author',
    'generated_by'        =>   'generated_by',
    'license'             =>   'license',
    'name'                =>   'name',
    'version'             =>   'version',
    'dynamic_config'      =>   'dynamic_config',
    'release_status'      =>   'release_status',
    'keywords'            =>   'keywords',
    'no_index'            =>   'no_index',
    'optional_features'   =>   'optional_features',
    'provides'            =>   'provides',
    'resources'           =>   'resources',
    'description'         =>   'description',
    'prereqs'             =>   'prereqs',
  },
  '1.4' => {
    'abstract'            => 'abstract',
    'author'              => 'author',
    'generated_by'        => 'generated_by',
    'license'             => 'license',
    'name'                => 'name',
    'version'             => 'version',
    'build_requires'      => 'prereqs',
    'conflicts'           => 'prereqs',
    'distribution_type'   => 'distribution_type',
    'dynamic_config'      => 'dynamic_config',
    'keywords'            => 'keywords',
    'no_index'            => 'no_index',
    'optional_features'   => 'optional_features',
    'provides'            => 'provides',
    'recommends'          => 'prereqs',
    'requires'            => 'prereqs',
    'resources'           => 'resources',
    'configure_requires'  => 'prereqs',
  },
);
# this is not quite true but will work well enough
# as 1.4 is a superset of earlier ones
$fragments_generate{$_} = $fragments_generate{'1.4'} for qw/1.3 1.2 1.1 1.0/;

#--------------------------------------------------------------------------#
# Code
#--------------------------------------------------------------------------#

#pod =method new
#pod
#pod   my $cmc = CPAN::Meta::Converter->new( $struct );
#pod
#pod The constructor should be passed a valid metadata structure but invalid
#pod structures are accepted.  If no meta-spec version is provided, version 1.0 will
#pod be assumed.
#pod
#pod Optionally, you can provide a C<default_version> argument after C<$struct>:
#pod
#pod   my $cmc = CPAN::Meta::Converter->new( $struct, default_version => "1.4" );
#pod
#pod This is only needed when converting a metadata fragment that does not include a
#pod C<meta-spec> field.
#pod
#pod =cut

sub new {
  my ($class,$data,%args) = @_;

  # create an attributes hash
  my $self = {
    'data'    => $data,
    'spec'    => _extract_spec_version($data, $args{default_version}),
  };

  # create the object
  return bless $self, $class;
}

sub _extract_spec_version {
    my ($data, $default) = @_;
    my $spec = $data->{'meta-spec'};

    # is meta-spec there and valid?
    return( $default || "1.0" ) unless defined $spec && ref $spec eq 'HASH'; # before meta-spec?

    # does the version key look like a valid version?
    my $v = $spec->{version};
    if ( defined $v && $v =~ /^\d+(?:\.\d+)?$/ ) {
        return $v if defined $v && grep { $v eq $_ } keys %known_specs; # known spec
        return $v+0 if defined $v && grep { $v == $_ } keys %known_specs; # 2.0 => 2
    }

    # otherwise, use heuristics: look for 1.x vs 2.0 fields
    return "2" if exists $data->{prereqs};
    return "1.4" if exists $data->{configure_requires};
    return( $default || "1.2" ); # when meta-spec was first defined
}

#pod =method convert
#pod
#pod   my $new_struct = $cmc->convert( version => "2" );
#pod
#pod Returns a new hash reference with the metadata converted to a different form.
#pod C<convert> will die if any conversion/standardization still results in an
#pod invalid structure.
#pod
#pod Valid parameters include:
#pod
#pod =over
#pod
#pod =item *
#pod
#pod C<version> -- Indicates the desired specification version (e.g. "1.0", "1.1" ... "1.4", "2").
#pod Defaults to the latest version of the CPAN Meta Spec.
#pod
#pod =back
#pod
#pod Conversion proceeds through each version in turn.  For example, a version 1.2
#pod structure might be converted to 1.3 then 1.4 then finally to version 2. The
#pod conversion process attempts to clean-up simple errors and standardize data.
#pod For example, if C<author> is given as a scalar, it will converted to an array
#pod reference containing the item. (Converting a structure to its own version will
#pod also clean-up and standardize.)
#pod
#pod When data are cleaned and standardized, missing or invalid fields will be
#pod replaced with sensible defaults when possible.  This may be lossy or imprecise.
#pod For example, some badly structured META.yml files on CPAN have prerequisite
#pod modules listed as both keys and values:
#pod
#pod   requires => { 'Foo::Bar' => 'Bam::Baz' }
#pod
#pod These would be split and each converted to a prerequisite with a minimum
#pod version of zero.
#pod
#pod When some mandatory fields are missing or invalid, the conversion will attempt
#pod to provide a sensible default or will fill them with a value of 'unknown'.  For
#pod example a missing or unrecognized C<license> field will result in a C<license>
#pod field of 'unknown'.  Fields that may get an 'unknown' include:
#pod
#pod =for :list
#pod * abstract
#pod * author
#pod * license
#pod
#pod =cut

sub convert {
  my ($self, %args) = @_;
  my $args = { %args };

  my $new_version = $args->{version} || $HIGHEST;
  my $is_fragment = $args->{is_fragment};

  my ($old_version) = $self->{spec};
  my $converted = _dclone($self->{data});

  if ( $old_version == $new_version ) {
    $converted = _convert( $converted, $cleanup{$old_version}, $old_version, $is_fragment );
    unless ( $args->{is_fragment} ) {
      my $cmv = CPAN::Meta::Validator->new( $converted );
      unless ( $cmv->is_valid ) {
        my $errs = join("\n", $cmv->errors);
        die "Failed to clean-up $old_version metadata. Errors:\n$errs\n";
      }
    }
    return $converted;
  }
  elsif ( $old_version > $new_version )  {
    my @vers = sort { $b <=> $a } keys %known_specs;
    for my $i ( 0 .. $#vers-1 ) {
      next if $vers[$i] > $old_version;
      last if $vers[$i+1] < $new_version;
      my $spec_string = "$vers[$i+1]-from-$vers[$i]";
      $converted = _convert( $converted, $down_convert{$spec_string}, $vers[$i+1], $is_fragment );
      unless ( $args->{is_fragment} ) {
        my $cmv = CPAN::Meta::Validator->new( $converted );
        unless ( $cmv->is_valid ) {
          my $errs = join("\n", $cmv->errors);
          die "Failed to downconvert metadata to $vers[$i+1]. Errors:\n$errs\n";
        }
      }
    }
    return $converted;
  }
  else {
    my @vers = sort { $a <=> $b } keys %known_specs;
    for my $i ( 0 .. $#vers-1 ) {
      next if $vers[$i] < $old_version;
      last if $vers[$i+1] > $new_version;
      my $spec_string = "$vers[$i+1]-from-$vers[$i]";
      $converted = _convert( $converted, $up_convert{$spec_string}, $vers[$i+1], $is_fragment );
      unless ( $args->{is_fragment} ) {
        my $cmv = CPAN::Meta::Validator->new( $converted );
        unless ( $cmv->is_valid ) {
          my $errs = join("\n", $cmv->errors);
          die "Failed to upconvert metadata to $vers[$i+1]. Errors:\n$errs\n";
        }
      }
    }
    return $converted;
  }
}

#pod =method upgrade_fragment
#pod
#pod   my $new_struct = $cmc->upgrade_fragment;
#pod
#pod Returns a new hash reference with the metadata converted to the latest version
#pod of the CPAN Meta Spec.  No validation is done on the result -- you must
#pod validate after merging fragments into a complete metadata document.
#pod
#pod =cut

sub upgrade_fragment {
  my ($self) = @_;
  my ($old_version) = $self->{spec};
  my %expected =
    map {; $_ => 1 }
    grep { defined }
    map { $fragments_generate{$old_version}{$_} }
    keys %{ $self->{data} };
  my $converted = $self->convert( version => $HIGHEST, is_fragment => 1 );
  for my $key ( keys %$converted ) {
    next if $key =~ /^x_/i || $key eq 'meta-spec';
    delete $converted->{$key} unless $expected{$key};
  }
  return $converted;
}

1;

# ABSTRACT: Convert CPAN distribution metadata structures

=pod

=encoding UTF-8

=head1 NAME

CPAN::Meta::Converter - Convert CPAN distribution metadata structures

=head1 VERSION

version 2.143240

=head1 SYNOPSIS

  my $struct = decode_json_file('META.json');

  my $cmc = CPAN::Meta::Converter->new( $struct );

  my $new_struct = $cmc->convert( version => "2" );

=head1 DESCRIPTION

This module converts CPAN Meta structures from one form to another.  The
primary use is to convert older structures to the most modern version of
the specification, but other transformations may be implemented in the
future as needed.  (E.g. stripping all custom fields or stripping all
optional fields.)

=head1 METHODS

=head2 new

  my $cmc = CPAN::Meta::Converter->new( $struct );

The constructor should be passed a valid metadata structure but invalid
structures are accepted.  If no meta-spec version is provided, version 1.0 will
be assumed.

Optionally, you can provide a C<default_version> argument after C<$struct>:

  my $cmc = CPAN::Meta::Converter->new( $struct, default_version => "1.4" );

This is only needed when converting a metadata fragment that does not include a
C<meta-spec> field.

=head2 convert

  my $new_struct = $cmc->convert( version => "2" );

Returns a new hash reference with the metadata converted to a different form.
C<convert> will die if any conversion/standardization still results in an
invalid structure.

Valid parameters include:

=over

=item *

C<version> -- Indicates the desired specification version (e.g. "1.0", "1.1" ... "1.4", "2").
Defaults to the latest version of the CPAN Meta Spec.

=back

Conversion proceeds through each version in turn.  For example, a version 1.2
structure might be converted to 1.3 then 1.4 then finally to version 2. The
conversion process attempts to clean-up simple errors and standardize data.
For example, if C<author> is given as a scalar, it will converted to an array
reference containing the item. (Converting a structure to its own version will
also clean-up and standardize.)

When data are cleaned and standardized, missing or invalid fields will be
replaced with sensible defaults when possible.  This may be lossy or imprecise.
For example, some badly structured META.yml files on CPAN have prerequisite
modules listed as both keys and values:

  requires => { 'Foo::Bar' => 'Bam::Baz' }

These would be split and each converted to a prerequisite with a minimum
version of zero.

When some mandatory fields are missing or invalid, the conversion will attempt
to provide a sensible default or will fill them with a value of 'unknown'.  For
example a missing or unrecognized C<license> field will result in a C<license>
field of 'unknown'.  Fields that may get an 'unknown' include:

=over 4

=item *

abstract

=item *

author

=item *

license

=back

=head2 upgrade_fragment

  my $new_struct = $cmc->upgrade_fragment;

Returns a new hash reference with the metadata converted to the latest version
of the CPAN Meta Spec.  No validation is done on the result -- you must
validate after merging fragments into a complete metadata document.

=head1 BUGS

Please report any bugs or feature using the CPAN Request Tracker.
Bugs can be submitted through the web interface at
L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>

When submitting a bug or request, please include a test-file or a patch to an
existing test-file that illustrates the bug or desired feature.

=head1 AUTHORS

=over 4

=item *

David Golden <dagolden@cpan.org>

=item *

Ricardo Signes <rjbs@cpan.org>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2010 by David Golden and Ricardo Signes.

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

=cut

__END__


# vim: ts=2 sts=2 sw=2 et:
PK       ! < $l:M  :M  %  perl5/CPAN/Meta/Requirements/Range.pmnu ��6�$        use v5.10;
use strict;
use warnings;
package CPAN::Meta::Requirements::Range;
# ABSTRACT: a set of version requirements for a CPAN dist

our $VERSION = '2.143';

use Carp ();

#pod =head1 SYNOPSIS
#pod
#pod   use CPAN::Meta::Requirements::Range;
#pod
#pod   my $range = CPAN::Meta::Requirements::Range->with_minimum(1);
#pod
#pod   $range = $range->with_maximum('v2.2');
#pod
#pod   my $stringified = $range->as_string;
#pod
#pod =head1 DESCRIPTION
#pod
#pod A CPAN::Meta::Requirements::Range object models a set of version constraints like
#pod those specified in the F<META.yml> or F<META.json> files in CPAN distributions,
#pod and as defined by L<CPAN::Meta::Spec>;
#pod It can be built up by adding more and more constraints, and it will reduce them
#pod to the simplest representation.
#pod
#pod Logically impossible constraints will be identified immediately by thrown
#pod exceptions.
#pod
#pod =cut

use Carp ();

package
  CPAN::Meta::Requirements::Range::_Base;

# To help ExtUtils::MakeMaker bootstrap CPAN::Meta::Requirements on perls
# before 5.10, we fall back to the EUMM bundled compatibility version module if
# that's the only thing available.  This shouldn't ever happen in a normal CPAN
# install of CPAN::Meta::Requirements, as version.pm will be picked up from
# prereqs and be available at runtime.

BEGIN {
  eval "use version ()"; ## no critic
  if ( my $err = $@ ) {
    eval "use ExtUtils::MakeMaker::version" or die $err; ## no critic
  }
}

# from version::vpp
sub _find_magic_vstring {
  my $value = shift;
  my $tvalue = '';
  require B;
  my $sv = B::svref_2object(\$value);
  my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef;
  while ( $magic ) {
    if ( $magic->TYPE eq 'V' ) {
      $tvalue = $magic->PTR;
      $tvalue =~ s/^v?(.+)$/v$1/;
      last;
    }
    else {
      $magic = $magic->MOREMAGIC;
    }
  }
  return $tvalue;
}

# Perl 5.10.0 didn't have "is_qv" in version.pm
*_is_qv = version->can('is_qv') ? sub { $_[0]->is_qv } : sub { exists $_[0]->{qv} };

# construct once, reuse many times
my $V0 = version->new(0);

# safe if given an unblessed reference
sub _isa_version {
  UNIVERSAL::isa( $_[0], 'UNIVERSAL' ) && $_[0]->isa('version')
}

sub _version_object {
  my ($self, $version, $module, $bad_version_hook) = @_;

  my ($vobj, $err);

  if (not defined $version or (!ref($version) && $version eq '0')) {
    return $V0;
  }
  elsif ( ref($version) eq 'version' || ( ref($version) && _isa_version($version) ) ) {
    $vobj = $version;
  }
  else {
    # hack around version::vpp not handling <3 character vstring literals
    if ( $INC{'version/vpp.pm'} || $INC{'ExtUtils/MakeMaker/version/vpp.pm'} ) {
      my $magic = _find_magic_vstring( $version );
      $version = $magic if length $magic;
    }
    # pad to 3 characters if before 5.8.1 and appears to be a v-string
    if ( $] < 5.008001 && $version !~ /\A[0-9]/ && substr($version,0,1) ne 'v' && length($version) < 3 ) {
      $version .= "\0" x (3 - length($version));
    }
    eval {
      local $SIG{__WARN__} = sub { die "Invalid version: $_[0]" };
      # avoid specific segfault on some older version.pm versions
      die "Invalid version: $version" if $version eq 'version';
      $vobj = version->new($version);
    };
    if ( my $err = $@ ) {
      $vobj = eval { $bad_version_hook->($version, $module) }
        if ref $bad_version_hook eq 'CODE';
      unless (eval { $vobj->isa("version") }) {
        $err =~ s{ at .* line \d+.*$}{};
        die "Can't convert '$version': $err";
      }
    }
  }

  # ensure no leading '.'
  if ( $vobj =~ m{\A\.} ) {
    $vobj = version->new("0$vobj");
  }

  # ensure normal v-string form
  if ( _is_qv($vobj) ) {
    $vobj = version->new($vobj->normal);
  }

  return $vobj;
}

#pod =method with_string_requirement
#pod
#pod   $req->with_string_requirement('>= 1.208, <= 2.206');
#pod   $req->with_string_requirement(v1.208);
#pod
#pod This method parses the passed in string and adds the appropriate requirement.
#pod A version can be a Perl "v-string".  It understands version ranges as described
#pod in the L<CPAN::Meta::Spec/Version Ranges>. For example:
#pod
#pod =over 4
#pod
#pod =item 1.3
#pod
#pod =item >= 1.3
#pod
#pod =item <= 1.3
#pod
#pod =item == 1.3
#pod
#pod =item != 1.3
#pod
#pod =item > 1.3
#pod
#pod =item < 1.3
#pod
#pod =item >= 1.3, != 1.5, <= 2.0
#pod
#pod A version number without an operator is equivalent to specifying a minimum
#pod (C<E<gt>=>).  Extra whitespace is allowed.
#pod
#pod =back
#pod
#pod =cut

my %methods_for_op = (
  '==' => [ qw(with_exact_version) ],
  '!=' => [ qw(with_exclusion) ],
  '>=' => [ qw(with_minimum)   ],
  '<=' => [ qw(with_maximum)   ],
  '>'  => [ qw(with_minimum with_exclusion) ],
  '<'  => [ qw(with_maximum with_exclusion) ],
);

sub with_string_requirement {
  my ($self, $req, $module, $bad_version_hook) = @_;
  $module //= 'module';

  unless ( defined $req && length $req ) {
    $req = 0;
    Carp::carp("Undefined requirement for $module treated as '0'");
  }

  my $magic = _find_magic_vstring( $req );
  if (length $magic) {
    return $self->with_minimum($magic, $module, $bad_version_hook);
  }

  my @parts = split qr{\s*,\s*}, $req;

  for my $part (@parts) {
    my ($op, $ver) = $part =~ m{\A\s*(==|>=|>|<=|<|!=)\s*(.*)\z};

    if (! defined $op) {
      $self = $self->with_minimum($part, $module, $bad_version_hook);
    } else {
      Carp::croak("illegal requirement string: $req")
        unless my $methods = $methods_for_op{ $op };

      $self = $self->$_($ver, $module, $bad_version_hook) for @$methods;
    }
  }

  return $self;
}

#pod =method with_range
#pod
#pod  $range->with_range($other_range)
#pod
#pod This creates a new range object that is a merge two others.
#pod
#pod =cut

sub with_range {
  my ($self, $other, $module, $bad_version_hook) = @_;
  for my $modifier($other->_as_modifiers) {
    my ($method, $arg) = @$modifier;
    $self = $self->$method($arg, $module, $bad_version_hook);
  }
  return $self;
}

package CPAN::Meta::Requirements::Range;

our @ISA = 'CPAN::Meta::Requirements::Range::_Base';

sub _clone {
  return (bless { } => $_[0]) unless ref $_[0];

  my ($s) = @_;
  my %guts = (
    (exists $s->{minimum} ? (minimum => version->new($s->{minimum})) : ()),
    (exists $s->{maximum} ? (maximum => version->new($s->{maximum})) : ()),

    (exists $s->{exclusions}
      ? (exclusions => [ map { version->new($_) } @{ $s->{exclusions} } ])
      : ()),
  );

  bless \%guts => ref($s);
}

#pod =method with_exact_version
#pod
#pod   $range->with_exact_version( $version );
#pod
#pod This sets the version required to I<exactly> the given
#pod version.  No other version would be considered acceptable.
#pod
#pod This method returns the version range object.
#pod
#pod =cut

sub with_exact_version {
  my ($self, $version, $module, $bad_version_hook) = @_;
  $module //= 'module';
  $self = $self->_clone;
  $version = $self->_version_object($version, $module, $bad_version_hook);

  unless ($self->accepts($version)) {
    $self->_reject_requirements(
      $module,
      "exact specification $version outside of range " . $self->as_string
    );
  }

  return CPAN::Meta::Requirements::Range::_Exact->_new($version);
}

sub _simplify {
  my ($self, $module) = @_;

  if (defined $self->{minimum} and defined $self->{maximum}) {
    if ($self->{minimum} == $self->{maximum}) {
      if (grep { $_ == $self->{minimum} } @{ $self->{exclusions} || [] }) {
        $self->_reject_requirements(
          $module,
          "minimum and maximum are both $self->{minimum}, which is excluded",
        );
      }

      return CPAN::Meta::Requirements::Range::_Exact->_new($self->{minimum});
    }

    if ($self->{minimum} > $self->{maximum}) {
      $self->_reject_requirements(
        $module,
        "minimum $self->{minimum} exceeds maximum $self->{maximum}",
      );
    }
  }

  # eliminate irrelevant exclusions
  if ($self->{exclusions}) {
    my %seen;
    @{ $self->{exclusions} } = grep {
      (! defined $self->{minimum} or $_ >= $self->{minimum})
      and
      (! defined $self->{maximum} or $_ <= $self->{maximum})
      and
      ! $seen{$_}++
    } @{ $self->{exclusions} };
  }

  return $self;
}

#pod =method with_minimum
#pod
#pod   $range->with_minimum( $version );
#pod
#pod This adds a new minimum version requirement.  If the new requirement is
#pod redundant to the existing specification, this has no effect.
#pod
#pod Minimum requirements are inclusive.  C<$version> is required, along with any
#pod greater version number.
#pod
#pod This method returns the version range object.
#pod
#pod =cut

sub with_minimum {
  my ($self, $minimum, $module, $bad_version_hook) = @_;
  $module //= 'module';
  $self = $self->_clone;
  $minimum = $self->_version_object( $minimum, $module, $bad_version_hook );

  if (defined (my $old_min = $self->{minimum})) {
    $self->{minimum} = (sort { $b cmp $a } ($minimum, $old_min))[0];
  } else {
    $self->{minimum} = $minimum;
  }

  return $self->_simplify($module);
}

#pod =method with_maximum
#pod
#pod   $range->with_maximum( $version );
#pod
#pod This adds a new maximum version requirement.  If the new requirement is
#pod redundant to the existing specification, this has no effect.
#pod
#pod Maximum requirements are inclusive.  No version strictly greater than the given
#pod version is allowed.
#pod
#pod This method returns the version range object.
#pod
#pod =cut

sub with_maximum {
  my ($self, $maximum, $module, $bad_version_hook) = @_;
  $module //= 'module';
  $self = $self->_clone;
  $maximum = $self->_version_object( $maximum, $module, $bad_version_hook );

  if (defined (my $old_max = $self->{maximum})) {
    $self->{maximum} = (sort { $a cmp $b } ($maximum, $old_max))[0];
  } else {
    $self->{maximum} = $maximum;
  }

  return $self->_simplify($module);
}

#pod =method with_exclusion
#pod
#pod   $range->with_exclusion( $version );
#pod
#pod This adds a new excluded version.  For example, you might use these three
#pod method calls:
#pod
#pod   $range->with_minimum( '1.00' );
#pod   $range->with_maximum( '1.82' );
#pod
#pod   $range->with_exclusion( '1.75' );
#pod
#pod Any version between 1.00 and 1.82 inclusive would be acceptable, except for
#pod 1.75.
#pod
#pod This method returns the requirements object.
#pod
#pod =cut

sub with_exclusion {
  my ($self, $exclusion, $module, $bad_version_hook) = @_;
  $module //= 'module';
  $self = $self->_clone;
  $exclusion = $self->_version_object( $exclusion, $module, $bad_version_hook );

  push @{ $self->{exclusions} ||= [] }, $exclusion;

  return $self->_simplify($module);
}

sub _as_modifiers {
  my ($self) = @_;
  my @mods;
  push @mods, [ with_minimum => $self->{minimum} ] if exists $self->{minimum};
  push @mods, [ with_maximum => $self->{maximum} ] if exists $self->{maximum};
  push @mods, map {; [ with_exclusion => $_ ] } @{$self->{exclusions} || []};
  return @mods;
}

#pod =method as_struct
#pod
#pod   $range->as_struct( $module );
#pod
#pod This returns a data structure containing the version requirements. This should
#pod not be used for version checks (see L</accepts_module> instead).
#pod
#pod =cut

sub as_struct {
  my ($self) = @_;

  return 0 if ! keys %$self;

  my @exclusions = @{ $self->{exclusions} || [] };

  my @parts;

  for my $tuple (
    [ qw( >= > minimum ) ],
    [ qw( <= < maximum ) ],
  ) {
    my ($op, $e_op, $k) = @$tuple;
    if (exists $self->{$k}) {
      my @new_exclusions = grep { $_ != $self->{ $k } } @exclusions;
      if (@new_exclusions == @exclusions) {
        push @parts, [ $op, "$self->{ $k }" ];
      } else {
        push @parts, [ $e_op, "$self->{ $k }" ];
        @exclusions = @new_exclusions;
      }
    }
  }

  push @parts, map {; [ "!=", "$_" ] } @exclusions;

  return \@parts;
}

#pod =method as_string
#pod
#pod   $range->as_string;
#pod
#pod This returns a string containing the version requirements in the format
#pod described in L<CPAN::Meta::Spec>. This should only be used for informational
#pod purposes such as error messages and should not be interpreted or used for
#pod comparison (see L</accepts> instead).
#pod
#pod =cut

sub as_string {
  my ($self) = @_;

  my @parts = @{ $self->as_struct };

  return $parts[0][1] if @parts == 1 and $parts[0][0] eq '>=';

  return join q{, }, map {; join q{ }, @$_ } @parts;
}

sub _reject_requirements {
  my ($self, $module, $error) = @_;
  Carp::croak("illegal requirements for $module: $error")
}

#pod =method accepts
#pod
#pod   my $bool = $range->accepts($version);
#pod
#pod Given a version, this method returns true if the version specification
#pod accepts the provided version.  In other words, given:
#pod
#pod   '>= 1.00, < 2.00'
#pod
#pod We will accept 1.00 and 1.75 but not 0.50 or 2.00.
#pod
#pod =cut

sub accepts {
  my ($self, $version) = @_;

  return if defined $self->{minimum} and $version < $self->{minimum};
  return if defined $self->{maximum} and $version > $self->{maximum};
  return if defined $self->{exclusions}
        and grep { $version == $_ } @{ $self->{exclusions} };

  return 1;
}

#pod =method is_simple
#pod
#pod This method returns true if and only if the range is an inclusive minimum
#pod -- that is, if their string expression is just the version number.
#pod
#pod =cut

sub is_simple {
  my ($self) = @_;
  # XXX: This is a complete hack, but also entirely correct.
  return if $self->as_string =~ /\s/;

  return 1;
}

package
  CPAN::Meta::Requirements::Range::_Exact;

our @ISA = 'CPAN::Meta::Requirements::Range::_Base';

our $VERSION = '2.141';

BEGIN {
  eval "use version ()"; ## no critic
  if ( my $err = $@ ) {
    eval "use ExtUtils::MakeMaker::version" or die $err; ## no critic
  }
}

sub _new      { bless { version => $_[1] } => $_[0] }

sub accepts { return $_[0]{version} == $_[1] }

sub _reject_requirements {
  my ($self, $module, $error) = @_;
  Carp::croak("illegal requirements for $module: $error")
}

sub _clone {
  (ref $_[0])->_new( version->new( $_[0]{version} ) )
}

sub with_exact_version {
  my ($self, $version, $module, $bad_version_hook) = @_;
  $module //= 'module';
  $version = $self->_version_object($version, $module, $bad_version_hook);

  return $self->_clone if $self->accepts($version);

  $self->_reject_requirements(
    $module,
    "can't be exactly $version when exact requirement is already $self->{version}",
  );
}

sub with_minimum {
  my ($self, $minimum, $module, $bad_version_hook) = @_;
  $module //= 'module';
  $minimum = $self->_version_object( $minimum, $module, $bad_version_hook );

  return $self->_clone if $self->{version} >= $minimum;
  $self->_reject_requirements(
    $module,
    "minimum $minimum exceeds exact specification $self->{version}",
  );
}

sub with_maximum {
  my ($self, $maximum, $module, $bad_version_hook) = @_;
  $module //= 'module';
  $maximum = $self->_version_object( $maximum, $module, $bad_version_hook );

  return $self->_clone if $self->{version} <= $maximum;
  $self->_reject_requirements(
    $module,
    "maximum $maximum below exact specification $self->{version}",
  );
}

sub with_exclusion {
  my ($self, $exclusion, $module, $bad_version_hook) = @_;
  $module //= 'module';
  $exclusion = $self->_version_object( $exclusion, $module, $bad_version_hook );

  return $self->_clone unless $exclusion == $self->{version};
  $self->_reject_requirements(
    $module,
    "tried to exclude $exclusion, which is already exactly specified",
  );
}

sub as_string { return "== $_[0]{version}" }

sub as_struct { return [ [ '==', "$_[0]{version}" ] ] }

sub _as_modifiers { return [ with_exact_version => $_[0]{version} ] }


1;

# vim: ts=2 sts=2 sw=2 et:

__END__

=pod

=encoding UTF-8

=head1 NAME

CPAN::Meta::Requirements::Range - a set of version requirements for a CPAN dist

=head1 VERSION

version 2.143

=head1 SYNOPSIS

  use CPAN::Meta::Requirements::Range;

  my $range = CPAN::Meta::Requirements::Range->with_minimum(1);

  $range = $range->with_maximum('v2.2');

  my $stringified = $range->as_string;

=head1 DESCRIPTION

A CPAN::Meta::Requirements::Range object models a set of version constraints like
those specified in the F<META.yml> or F<META.json> files in CPAN distributions,
and as defined by L<CPAN::Meta::Spec>;
It can be built up by adding more and more constraints, and it will reduce them
to the simplest representation.

Logically impossible constraints will be identified immediately by thrown
exceptions.

=head1 METHODS

=head2 with_string_requirement

  $req->with_string_requirement('>= 1.208, <= 2.206');
  $req->with_string_requirement(v1.208);

This method parses the passed in string and adds the appropriate requirement.
A version can be a Perl "v-string".  It understands version ranges as described
in the L<CPAN::Meta::Spec/Version Ranges>. For example:

=over 4

=item 1.3

=item >= 1.3

=item <= 1.3

=item == 1.3

=item != 1.3

=item > 1.3

=item < 1.3

=item >= 1.3, != 1.5, <= 2.0

A version number without an operator is equivalent to specifying a minimum
(C<E<gt>=>).  Extra whitespace is allowed.

=back

=head2 with_range

 $range->with_range($other_range)

This creates a new range object that is a merge two others.

=head2 with_exact_version

  $range->with_exact_version( $version );

This sets the version required to I<exactly> the given
version.  No other version would be considered acceptable.

This method returns the version range object.

=head2 with_minimum

  $range->with_minimum( $version );

This adds a new minimum version requirement.  If the new requirement is
redundant to the existing specification, this has no effect.

Minimum requirements are inclusive.  C<$version> is required, along with any
greater version number.

This method returns the version range object.

=head2 with_maximum

  $range->with_maximum( $version );

This adds a new maximum version requirement.  If the new requirement is
redundant to the existing specification, this has no effect.

Maximum requirements are inclusive.  No version strictly greater than the given
version is allowed.

This method returns the version range object.

=head2 with_exclusion

  $range->with_exclusion( $version );

This adds a new excluded version.  For example, you might use these three
method calls:

  $range->with_minimum( '1.00' );
  $range->with_maximum( '1.82' );

  $range->with_exclusion( '1.75' );

Any version between 1.00 and 1.82 inclusive would be acceptable, except for
1.75.

This method returns the requirements object.

=head2 as_struct

  $range->as_struct( $module );

This returns a data structure containing the version requirements. This should
not be used for version checks (see L</accepts_module> instead).

=head2 as_string

  $range->as_string;

This returns a string containing the version requirements in the format
described in L<CPAN::Meta::Spec>. This should only be used for informational
purposes such as error messages and should not be interpreted or used for
comparison (see L</accepts> instead).

=head2 accepts

  my $bool = $range->accepts($version);

Given a version, this method returns true if the version specification
accepts the provided version.  In other words, given:

  '>= 1.00, < 2.00'

We will accept 1.00 and 1.75 but not 0.50 or 2.00.

=head2 is_simple

This method returns true if and only if the range is an inclusive minimum
-- that is, if their string expression is just the version number.

=head1 AUTHORS

=over 4

=item *

David Golden <dagolden@cpan.org>

=item *

Ricardo Signes <rjbs@cpan.org>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2010 by David Golden and Ricardo Signes.

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

=cut
PK       ! ���h}.  }.    perl5/CPAN/Meta/Prereqs.pmnu ��6�$        use 5.006;
use strict;
use warnings;
package CPAN::Meta::Prereqs;
# VERSION
$CPAN::Meta::Prereqs::VERSION = '2.143240';
#pod =head1 DESCRIPTION
#pod
#pod A CPAN::Meta::Prereqs object represents the prerequisites for a CPAN
#pod distribution or one of its optional features.  Each set of prereqs is
#pod organized by phase and type, as described in L<CPAN::Meta::Prereqs>.
#pod
#pod =cut

use Carp qw(confess);
use Scalar::Util qw(blessed);
use CPAN::Meta::Requirements 2.121;

#pod =method new
#pod
#pod   my $prereq = CPAN::Meta::Prereqs->new( \%prereq_spec );
#pod
#pod This method returns a new set of Prereqs.  The input should look like the
#pod contents of the C<prereqs> field described in L<CPAN::Meta::Spec>, meaning
#pod something more or less like this:
#pod
#pod   my $prereq = CPAN::Meta::Prereqs->new({
#pod     runtime => {
#pod       requires => {
#pod         'Some::Module' => '1.234',
#pod         ...,
#pod       },
#pod       ...,
#pod     },
#pod     ...,
#pod   });
#pod
#pod You can also construct an empty set of prereqs with:
#pod
#pod   my $prereqs = CPAN::Meta::Prereqs->new;
#pod
#pod This empty set of prereqs is useful for accumulating new prereqs before finally
#pod dumping the whole set into a structure or string.
#pod
#pod =cut

sub __legal_phases { qw(configure build test runtime develop)   }
sub __legal_types  { qw(requires recommends suggests conflicts) }

# expect a prereq spec from META.json -- rjbs, 2010-04-11
sub new {
  my ($class, $prereq_spec) = @_;
  $prereq_spec ||= {};

  my %is_legal_phase = map {; $_ => 1 } $class->__legal_phases;
  my %is_legal_type  = map {; $_ => 1 } $class->__legal_types;

  my %guts;
  PHASE: for my $phase (keys %$prereq_spec) {
    next PHASE unless $phase =~ /\Ax_/i or $is_legal_phase{$phase};

    my $phase_spec = $prereq_spec->{ $phase };
    next PHASE unless keys %$phase_spec;

    TYPE: for my $type (keys %$phase_spec) {
      next TYPE unless $type =~ /\Ax_/i or $is_legal_type{$type};

      my $spec = $phase_spec->{ $type };

      next TYPE unless keys %$spec;

      $guts{prereqs}{$phase}{$type} = CPAN::Meta::Requirements->from_string_hash(
        $spec
      );
    }
  }

  return bless \%guts => $class;
}

#pod =method requirements_for
#pod
#pod   my $requirements = $prereqs->requirements_for( $phase, $type );
#pod
#pod This method returns a L<CPAN::Meta::Requirements> object for the given
#pod phase/type combination.  If no prerequisites are registered for that
#pod combination, a new CPAN::Meta::Requirements object will be returned, and it may
#pod be added to as needed.
#pod
#pod If C<$phase> or C<$type> are undefined or otherwise invalid, an exception will
#pod be raised.
#pod
#pod =cut

sub requirements_for {
  my ($self, $phase, $type) = @_;

  confess "requirements_for called without phase" unless defined $phase;
  confess "requirements_for called without type"  unless defined $type;

  unless ($phase =~ /\Ax_/i or grep { $phase eq $_ } $self->__legal_phases) {
    confess "requested requirements for unknown phase: $phase";
  }

  unless ($type =~ /\Ax_/i or grep { $type eq $_ } $self->__legal_types) {
    confess "requested requirements for unknown type: $type";
  }

  my $req = ($self->{prereqs}{$phase}{$type} ||= CPAN::Meta::Requirements->new);

  $req->finalize if $self->is_finalized;

  return $req;
}

#pod =method with_merged_prereqs
#pod
#pod   my $new_prereqs = $prereqs->with_merged_prereqs( $other_prereqs );
#pod
#pod   my $new_prereqs = $prereqs->with_merged_prereqs( \@other_prereqs );
#pod
#pod This method returns a new CPAN::Meta::Prereqs objects in which all the
#pod other prerequisites given are merged into the current set.  This is primarily
#pod provided for combining a distribution's core prereqs with the prereqs of one of
#pod its optional features.
#pod
#pod The new prereqs object has no ties to the originals, and altering it further
#pod will not alter them.
#pod
#pod =cut

sub with_merged_prereqs {
  my ($self, $other) = @_;

  my @other = blessed($other) ? $other : @$other;

  my @prereq_objs = ($self, @other);

  my %new_arg;

  for my $phase ($self->__legal_phases) {
    for my $type ($self->__legal_types) {
      my $req = CPAN::Meta::Requirements->new;

      for my $prereq (@prereq_objs) {
        my $this_req = $prereq->requirements_for($phase, $type);
        next unless $this_req->required_modules;

        $req->add_requirements($this_req);
      }

      next unless $req->required_modules;

      $new_arg{ $phase }{ $type } = $req->as_string_hash;
    }
  }

  return (ref $self)->new(\%new_arg);
}

#pod =method merged_requirements
#pod
#pod     my $new_reqs = $prereqs->merged_requirements( \@phases, \@types );
#pod     my $new_reqs = $prereqs->merged_requirements( \@phases );
#pod     my $new_reqs = $preerqs->merged_requirements();
#pod
#pod This method joins together all requirements across a number of phases
#pod and types into a new L<CPAN::Meta::Requirements> object.  If arguments
#pod are omitted, it defaults to "runtime", "build" and "test" for phases
#pod and "requires" and "recommends" for types.
#pod
#pod =cut

sub merged_requirements {
  my ($self, $phases, $types) = @_;
  $phases = [qw/runtime build test/] unless defined $phases;
  $types = [qw/requires recommends/] unless defined $types;

  confess "merged_requirements phases argument must be an arrayref"
    unless ref $phases eq 'ARRAY';
  confess "merged_requirements types argument must be an arrayref"
    unless ref $types eq 'ARRAY';

  my $req = CPAN::Meta::Requirements->new;

  for my $phase ( @$phases ) {
    unless ($phase =~ /\Ax_/i or grep { $phase eq $_ } $self->__legal_phases) {
        confess "requested requirements for unknown phase: $phase";
    }
    for my $type ( @$types ) {
      unless ($type =~ /\Ax_/i or grep { $type eq $_ } $self->__legal_types) {
          confess "requested requirements for unknown type: $type";
      }
      $req->add_requirements( $self->requirements_for($phase, $type) );
    }
  }

  $req->finalize if $self->is_finalized;

  return $req;
}


#pod =method as_string_hash
#pod
#pod This method returns a hashref containing structures suitable for dumping into a
#pod distmeta data structure.  It is made up of hashes and strings, only; there will
#pod be no Prereqs, CPAN::Meta::Requirements, or C<version> objects inside it.
#pod
#pod =cut

sub as_string_hash {
  my ($self) = @_;

  my %hash;

  for my $phase ($self->__legal_phases) {
    for my $type ($self->__legal_types) {
      my $req = $self->requirements_for($phase, $type);
      next unless $req->required_modules;

      $hash{ $phase }{ $type } = $req->as_string_hash;
    }
  }

  return \%hash;
}

#pod =method is_finalized
#pod
#pod This method returns true if the set of prereqs has been marked "finalized," and
#pod cannot be altered.
#pod
#pod =cut

sub is_finalized { $_[0]{finalized} }

#pod =method finalize
#pod
#pod Calling C<finalize> on a Prereqs object will close it for further modification.
#pod Attempting to make any changes that would actually alter the prereqs will
#pod result in an exception being thrown.
#pod
#pod =cut

sub finalize {
  my ($self) = @_;

  $self->{finalized} = 1;

  for my $phase (keys %{ $self->{prereqs} }) {
    $_->finalize for values %{ $self->{prereqs}{$phase} };
  }
}

#pod =method clone
#pod
#pod   my $cloned_prereqs = $prereqs->clone;
#pod
#pod This method returns a Prereqs object that is identical to the original object,
#pod but can be altered without affecting the original object.  Finalization does
#pod not survive cloning, meaning that you may clone a finalized set of prereqs and
#pod then modify the clone.
#pod
#pod =cut

sub clone {
  my ($self) = @_;

  my $clone = (ref $self)->new( $self->as_string_hash );
}

1;

# ABSTRACT: a set of distribution prerequisites by phase and type

__END__

=pod

=encoding UTF-8

=head1 NAME

CPAN::Meta::Prereqs - a set of distribution prerequisites by phase and type

=head1 VERSION

version 2.143240

=head1 DESCRIPTION

A CPAN::Meta::Prereqs object represents the prerequisites for a CPAN
distribution or one of its optional features.  Each set of prereqs is
organized by phase and type, as described in L<CPAN::Meta::Prereqs>.

=head1 METHODS

=head2 new

  my $prereq = CPAN::Meta::Prereqs->new( \%prereq_spec );

This method returns a new set of Prereqs.  The input should look like the
contents of the C<prereqs> field described in L<CPAN::Meta::Spec>, meaning
something more or less like this:

  my $prereq = CPAN::Meta::Prereqs->new({
    runtime => {
      requires => {
        'Some::Module' => '1.234',
        ...,
      },
      ...,
    },
    ...,
  });

You can also construct an empty set of prereqs with:

  my $prereqs = CPAN::Meta::Prereqs->new;

This empty set of prereqs is useful for accumulating new prereqs before finally
dumping the whole set into a structure or string.

=head2 requirements_for

  my $requirements = $prereqs->requirements_for( $phase, $type );

This method returns a L<CPAN::Meta::Requirements> object for the given
phase/type combination.  If no prerequisites are registered for that
combination, a new CPAN::Meta::Requirements object will be returned, and it may
be added to as needed.

If C<$phase> or C<$type> are undefined or otherwise invalid, an exception will
be raised.

=head2 with_merged_prereqs

  my $new_prereqs = $prereqs->with_merged_prereqs( $other_prereqs );

  my $new_prereqs = $prereqs->with_merged_prereqs( \@other_prereqs );

This method returns a new CPAN::Meta::Prereqs objects in which all the
other prerequisites given are merged into the current set.  This is primarily
provided for combining a distribution's core prereqs with the prereqs of one of
its optional features.

The new prereqs object has no ties to the originals, and altering it further
will not alter them.

=head2 merged_requirements

    my $new_reqs = $prereqs->merged_requirements( \@phases, \@types );
    my $new_reqs = $prereqs->merged_requirements( \@phases );
    my $new_reqs = $preerqs->merged_requirements();

This method joins together all requirements across a number of phases
and types into a new L<CPAN::Meta::Requirements> object.  If arguments
are omitted, it defaults to "runtime", "build" and "test" for phases
and "requires" and "recommends" for types.

=head2 as_string_hash

This method returns a hashref containing structures suitable for dumping into a
distmeta data structure.  It is made up of hashes and strings, only; there will
be no Prereqs, CPAN::Meta::Requirements, or C<version> objects inside it.

=head2 is_finalized

This method returns true if the set of prereqs has been marked "finalized," and
cannot be altered.

=head2 finalize

Calling C<finalize> on a Prereqs object will close it for further modification.
Attempting to make any changes that would actually alter the prereqs will
result in an exception being thrown.

=head2 clone

  my $cloned_prereqs = $prereqs->clone;

This method returns a Prereqs object that is identical to the original object,
but can be altered without affecting the original object.  Finalization does
not survive cloning, meaning that you may clone a finalized set of prereqs and
then modify the clone.

=head1 BUGS

Please report any bugs or feature using the CPAN Request Tracker.
Bugs can be submitted through the web interface at
L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>

When submitting a bug or request, please include a test-file or a patch to an
existing test-file that illustrates the bug or desired feature.

=head1 AUTHORS

=over 4

=item *

David Golden <dagolden@cpan.org>

=item *

Ricardo Signes <rjbs@cpan.org>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2010 by David Golden and Ricardo Signes.

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

=cut
PK       ! �oO�q  �q    perl5/CPAN/Meta.pmnu ��6�$        use 5.006;
use strict;
use warnings;
package CPAN::Meta;
# VERSION
$CPAN::Meta::VERSION = '2.143240';
#pod =head1 SYNOPSIS
#pod
#pod     use v5.10;
#pod     use strict;
#pod     use warnings;
#pod     use CPAN::Meta;
#pod     use Module::Load;
#pod
#pod     my $meta = CPAN::Meta->load_file('META.json');
#pod
#pod     printf "testing requirements for %s version %s\n",
#pod     $meta->name,
#pod     $meta->version;
#pod
#pod     my $prereqs = $meta->effective_prereqs;
#pod
#pod     for my $phase ( qw/configure runtime build test/ ) {
#pod         say "Requirements for $phase:";
#pod         my $reqs = $prereqs->requirements_for($phase, "requires");
#pod         for my $module ( sort $reqs->required_modules ) {
#pod             my $status;
#pod             if ( eval { load $module unless $module eq 'perl'; 1 } ) {
#pod                 my $version = $module eq 'perl' ? $] : $module->VERSION;
#pod                 $status = $reqs->accepts_module($module, $version)
#pod                         ? "$version ok" : "$version not ok";
#pod             } else {
#pod                 $status = "missing"
#pod             };
#pod             say "  $module ($status)";
#pod         }
#pod     }
#pod
#pod =head1 DESCRIPTION
#pod
#pod Software distributions released to the CPAN include a F<META.json> or, for
#pod older distributions, F<META.yml>, which describes the distribution, its
#pod contents, and the requirements for building and installing the distribution.
#pod The data structure stored in the F<META.json> file is described in
#pod L<CPAN::Meta::Spec>.
#pod
#pod CPAN::Meta provides a simple class to represent this distribution metadata (or
#pod I<distmeta>), along with some helpful methods for interrogating that data.
#pod
#pod The documentation below is only for the methods of the CPAN::Meta object.  For
#pod information on the meaning of individual fields, consult the spec.
#pod
#pod =cut

use Carp qw(carp croak);
use CPAN::Meta::Feature;
use CPAN::Meta::Prereqs;
use CPAN::Meta::Converter;
use CPAN::Meta::Validator;
use Parse::CPAN::Meta 1.4414 ();

BEGIN { *_dclone = \&CPAN::Meta::Converter::_dclone }

#pod =head1 STRING DATA
#pod
#pod The following methods return a single value, which is the value for the
#pod corresponding entry in the distmeta structure.  Values should be either undef
#pod or strings.
#pod
#pod =for :list
#pod * abstract
#pod * description
#pod * dynamic_config
#pod * generated_by
#pod * name
#pod * release_status
#pod * version
#pod
#pod =cut

BEGIN {
  my @STRING_READERS = qw(
    abstract
    description
    dynamic_config
    generated_by
    name
    release_status
    version
  );

  no strict 'refs';
  for my $attr (@STRING_READERS) {
    *$attr = sub { $_[0]{ $attr } };
  }
}

#pod =head1 LIST DATA
#pod
#pod These methods return lists of string values, which might be represented in the
#pod distmeta structure as arrayrefs or scalars:
#pod
#pod =for :list
#pod * authors
#pod * keywords
#pod * licenses
#pod
#pod The C<authors> and C<licenses> methods may also be called as C<author> and
#pod C<license>, respectively, to match the field name in the distmeta structure.
#pod
#pod =cut

BEGIN {
  my @LIST_READERS = qw(
    author
    keywords
    license
  );

  no strict 'refs';
  for my $attr (@LIST_READERS) {
    *$attr = sub {
      my $value = $_[0]{ $attr };
      croak "$attr must be called in list context"
        unless wantarray;
      return @{ _dclone($value) } if ref $value;
      return $value;
    };
  }
}

sub authors  { $_[0]->author }
sub licenses { $_[0]->license }

#pod =head1 MAP DATA
#pod
#pod These readers return hashrefs of arbitrary unblessed data structures, each
#pod described more fully in the specification:
#pod
#pod =for :list
#pod * meta_spec
#pod * resources
#pod * provides
#pod * no_index
#pod * prereqs
#pod * optional_features
#pod
#pod =cut

BEGIN {
  my @MAP_READERS = qw(
    meta-spec
    resources
    provides
    no_index

    prereqs
    optional_features
  );

  no strict 'refs';
  for my $attr (@MAP_READERS) {
    (my $subname = $attr) =~ s/-/_/;
    *$subname = sub {
      my $value = $_[0]{ $attr };
      return _dclone($value) if $value;
      return {};
    };
  }
}

#pod =head1 CUSTOM DATA
#pod
#pod A list of custom keys are available from the C<custom_keys> method and
#pod particular keys may be retrieved with the C<custom> method.
#pod
#pod   say $meta->custom($_) for $meta->custom_keys;
#pod
#pod If a custom key refers to a data structure, a deep clone is returned.
#pod
#pod =cut

sub custom_keys {
  return grep { /^x_/i } keys %{$_[0]};
}

sub custom {
  my ($self, $attr) = @_;
  my $value = $self->{$attr};
  return _dclone($value) if ref $value;
  return $value;
}

#pod =method new
#pod
#pod   my $meta = CPAN::Meta->new($distmeta_struct, \%options);
#pod
#pod Returns a valid CPAN::Meta object or dies if the supplied metadata hash
#pod reference fails to validate.  Older-format metadata will be up-converted to
#pod version 2 if they validate against the original stated specification.
#pod
#pod It takes an optional hashref of options. Valid options include:
#pod
#pod =over
#pod
#pod =item *
#pod
#pod lazy_validation -- if true, new will attempt to convert the given metadata
#pod to version 2 before attempting to validate it.  This means than any
#pod fixable errors will be handled by CPAN::Meta::Converter before validation.
#pod (Note that this might result in invalid optional data being silently
#pod dropped.)  The default is false.
#pod
#pod =back
#pod
#pod =cut

sub _new {
  my ($class, $struct, $options) = @_;
  my $self;

  if ( $options->{lazy_validation} ) {
    # try to convert to a valid structure; if succeeds, then return it
    my $cmc = CPAN::Meta::Converter->new( $struct );
    $self = $cmc->convert( version => 2 ); # valid or dies
    return bless $self, $class;
  }
  else {
    # validate original struct
    my $cmv = CPAN::Meta::Validator->new( $struct );
    unless ( $cmv->is_valid) {
      die "Invalid metadata structure. Errors: "
        . join(", ", $cmv->errors) . "\n";
    }
  }

  # up-convert older spec versions
  my $version = $struct->{'meta-spec'}{version} || '1.0';
  if ( $version == 2 ) {
    $self = $struct;
  }
  else {
    my $cmc = CPAN::Meta::Converter->new( $struct );
    $self = $cmc->convert( version => 2 );
  }

  return bless $self, $class;
}

sub new {
  my ($class, $struct, $options) = @_;
  my $self = eval { $class->_new($struct, $options) };
  croak($@) if $@;
  return $self;
}

#pod =method create
#pod
#pod   my $meta = CPAN::Meta->create($distmeta_struct, \%options);
#pod
#pod This is same as C<new()>, except that C<generated_by> and C<meta-spec> fields
#pod will be generated if not provided.  This means the metadata structure is
#pod assumed to otherwise follow the latest L<CPAN::Meta::Spec>.
#pod
#pod =cut

sub create {
  my ($class, $struct, $options) = @_;
  my $version = __PACKAGE__->VERSION || 2;
  $struct->{generated_by} ||= __PACKAGE__ . " version $version" ;
  $struct->{'meta-spec'}{version} ||= int($version);
  my $self = eval { $class->_new($struct, $options) };
  croak ($@) if $@;
  return $self;
}

#pod =method load_file
#pod
#pod   my $meta = CPAN::Meta->load_file($distmeta_file, \%options);
#pod
#pod Given a pathname to a file containing metadata, this deserializes the file
#pod according to its file suffix and constructs a new C<CPAN::Meta> object, just
#pod like C<new()>.  It will die if the deserialized version fails to validate
#pod against its stated specification version.
#pod
#pod It takes the same options as C<new()> but C<lazy_validation> defaults to
#pod true.
#pod
#pod =cut

sub load_file {
  my ($class, $file, $options) = @_;
  $options->{lazy_validation} = 1 unless exists $options->{lazy_validation};

  croak "load_file() requires a valid, readable filename"
    unless -r $file;

  my $self;
  eval {
    my $struct = Parse::CPAN::Meta->load_file( $file );
    $self = $class->_new($struct, $options);
  };
  croak($@) if $@;
  return $self;
}

#pod =method load_yaml_string
#pod
#pod   my $meta = CPAN::Meta->load_yaml_string($yaml, \%options);
#pod
#pod This method returns a new CPAN::Meta object using the first document in the
#pod given YAML string.  In other respects it is identical to C<load_file()>.
#pod
#pod =cut

sub load_yaml_string {
  my ($class, $yaml, $options) = @_;
  $options->{lazy_validation} = 1 unless exists $options->{lazy_validation};

  my $self;
  eval {
    my ($struct) = Parse::CPAN::Meta->load_yaml_string( $yaml );
    $self = $class->_new($struct, $options);
  };
  croak($@) if $@;
  return $self;
}

#pod =method load_json_string
#pod
#pod   my $meta = CPAN::Meta->load_json_string($json, \%options);
#pod
#pod This method returns a new CPAN::Meta object using the structure represented by
#pod the given JSON string.  In other respects it is identical to C<load_file()>.
#pod
#pod =cut

sub load_json_string {
  my ($class, $json, $options) = @_;
  $options->{lazy_validation} = 1 unless exists $options->{lazy_validation};

  my $self;
  eval {
    my $struct = Parse::CPAN::Meta->load_json_string( $json );
    $self = $class->_new($struct, $options);
  };
  croak($@) if $@;
  return $self;
}

#pod =method load_string
#pod
#pod   my $meta = CPAN::Meta->load_string($string, \%options);
#pod
#pod If you don't know if a string contains YAML or JSON, this method will use
#pod L<Parse::CPAN::Meta> to guess.  In other respects it is identical to
#pod C<load_file()>.
#pod
#pod =cut

sub load_string {
  my ($class, $string, $options) = @_;
  $options->{lazy_validation} = 1 unless exists $options->{lazy_validation};

  my $self;
  eval {
    my $struct = Parse::CPAN::Meta->load_string( $string );
    $self = $class->_new($struct, $options);
  };
  croak($@) if $@;
  return $self;
}

#pod =method save
#pod
#pod   $meta->save($distmeta_file, \%options);
#pod
#pod Serializes the object as JSON and writes it to the given file.  The only valid
#pod option is C<version>, which defaults to '2'. On Perl 5.8.1 or later, the file
#pod is saved with UTF-8 encoding.
#pod
#pod For C<version> 2 (or higher), the filename should end in '.json'.  L<JSON::PP>
#pod is the default JSON backend. Using another JSON backend requires L<JSON> 2.5 or
#pod later and you must set the C<$ENV{PERL_JSON_BACKEND}> to a supported alternate
#pod backend like L<JSON::XS>.
#pod
#pod For C<version> less than 2, the filename should end in '.yml'.
#pod L<CPAN::Meta::Converter> is used to generate an older metadata structure, which
#pod is serialized to YAML.  CPAN::Meta::YAML is the default YAML backend.  You may
#pod set the C<$ENV{PERL_YAML_BACKEND}> to a supported alternative backend, though
#pod this is not recommended due to subtle incompatibilities between YAML parsers on
#pod CPAN.
#pod
#pod =cut

sub save {
  my ($self, $file, $options) = @_;

  my $version = $options->{version} || '2';
  my $layer = $] ge '5.008001' ? ':utf8' : '';

  if ( $version ge '2' ) {
    carp "'$file' should end in '.json'"
      unless $file =~ m{\.json$};
  }
  else {
    carp "'$file' should end in '.yml'"
      unless $file =~ m{\.yml$};
  }

  my $data = $self->as_string( $options );
  open my $fh, ">$layer", $file
    or die "Error opening '$file' for writing: $!\n";

  print {$fh} $data;
  close $fh
    or die "Error closing '$file': $!\n";

  return 1;
}

#pod =method meta_spec_version
#pod
#pod This method returns the version part of the C<meta_spec> entry in the distmeta
#pod structure.  It is equivalent to:
#pod
#pod   $meta->meta_spec->{version};
#pod
#pod =cut

sub meta_spec_version {
  my ($self) = @_;
  return $self->meta_spec->{version};
}

#pod =method effective_prereqs
#pod
#pod   my $prereqs = $meta->effective_prereqs;
#pod
#pod   my $prereqs = $meta->effective_prereqs( \@feature_identifiers );
#pod
#pod This method returns a L<CPAN::Meta::Prereqs> object describing all the
#pod prereqs for the distribution.  If an arrayref of feature identifiers is given,
#pod the prereqs for the identified features are merged together with the
#pod distribution's core prereqs before the CPAN::Meta::Prereqs object is returned.
#pod
#pod =cut

sub effective_prereqs {
  my ($self, $features) = @_;
  $features ||= [];

  my $prereq = CPAN::Meta::Prereqs->new($self->prereqs);

  return $prereq unless @$features;

  my @other = map {; $self->feature($_)->prereqs } @$features;

  return $prereq->with_merged_prereqs(\@other);
}

#pod =method should_index_file
#pod
#pod   ... if $meta->should_index_file( $filename );
#pod
#pod This method returns true if the given file should be indexed.  It decides this
#pod by checking the C<file> and C<directory> keys in the C<no_index> property of
#pod the distmeta structure. Note that neither the version format nor
#pod C<release_status> are considered.
#pod
#pod C<$filename> should be given in unix format.
#pod
#pod =cut

sub should_index_file {
  my ($self, $filename) = @_;

  for my $no_index_file (@{ $self->no_index->{file} || [] }) {
    return if $filename eq $no_index_file;
  }

  for my $no_index_dir (@{ $self->no_index->{directory} }) {
    $no_index_dir =~ s{$}{/} unless $no_index_dir =~ m{/\z};
    return if index($filename, $no_index_dir) == 0;
  }

  return 1;
}

#pod =method should_index_package
#pod
#pod   ... if $meta->should_index_package( $package );
#pod
#pod This method returns true if the given package should be indexed.  It decides
#pod this by checking the C<package> and C<namespace> keys in the C<no_index>
#pod property of the distmeta structure. Note that neither the version format nor
#pod C<release_status> are considered.
#pod
#pod =cut

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

  for my $no_index_pkg (@{ $self->no_index->{package} || [] }) {
    return if $package eq $no_index_pkg;
  }

  for my $no_index_ns (@{ $self->no_index->{namespace} }) {
    return if index($package, "${no_index_ns}::") == 0;
  }

  return 1;
}

#pod =method features
#pod
#pod   my @feature_objects = $meta->features;
#pod
#pod This method returns a list of L<CPAN::Meta::Feature> objects, one for each
#pod optional feature described by the distribution's metadata.
#pod
#pod =cut

sub features {
  my ($self) = @_;

  my $opt_f = $self->optional_features;
  my @features = map {; CPAN::Meta::Feature->new($_ => $opt_f->{ $_ }) }
                 keys %$opt_f;

  return @features;
}

#pod =method feature
#pod
#pod   my $feature_object = $meta->feature( $identifier );
#pod
#pod This method returns a L<CPAN::Meta::Feature> object for the optional feature
#pod with the given identifier.  If no feature with that identifier exists, an
#pod exception will be raised.
#pod
#pod =cut

sub feature {
  my ($self, $ident) = @_;

  croak "no feature named $ident"
    unless my $f = $self->optional_features->{ $ident };

  return CPAN::Meta::Feature->new($ident, $f);
}

#pod =method as_struct
#pod
#pod   my $copy = $meta->as_struct( \%options );
#pod
#pod This method returns a deep copy of the object's metadata as an unblessed hash
#pod reference.  It takes an optional hashref of options.  If the hashref contains
#pod a C<version> argument, the copied metadata will be converted to the version
#pod of the specification and returned.  For example:
#pod
#pod   my $old_spec = $meta->as_struct( {version => "1.4"} );
#pod
#pod =cut

sub as_struct {
  my ($self, $options) = @_;
  my $struct = _dclone($self);
  if ( $options->{version} ) {
    my $cmc = CPAN::Meta::Converter->new( $struct );
    $struct = $cmc->convert( version => $options->{version} );
  }
  return $struct;
}

#pod =method as_string
#pod
#pod   my $string = $meta->as_string( \%options );
#pod
#pod This method returns a serialized copy of the object's metadata as a character
#pod string.  (The strings are B<not> UTF-8 encoded.)  It takes an optional hashref
#pod of options.  If the hashref contains a C<version> argument, the copied metadata
#pod will be converted to the version of the specification and returned.  For
#pod example:
#pod
#pod   my $string = $meta->as_string( {version => "1.4"} );
#pod
#pod For C<version> greater than or equal to 2, the string will be serialized as
#pod JSON.  For C<version> less than 2, the string will be serialized as YAML.  In
#pod both cases, the same rules are followed as in the C<save()> method for choosing
#pod a serialization backend.
#pod
#pod =cut

sub as_string {
  my ($self, $options) = @_;

  my $version = $options->{version} || '2';

  my $struct;
  if ( $self->meta_spec_version ne $version ) {
    my $cmc = CPAN::Meta::Converter->new( $self->as_struct );
    $struct = $cmc->convert( version => $version );
  }
  else {
    $struct = $self->as_struct;
  }

  my ($data, $backend);
  if ( $version ge '2' ) {
    $backend = Parse::CPAN::Meta->json_backend();
    $data = $backend->new->pretty->canonical->encode($struct);
  }
  else {
    $backend = Parse::CPAN::Meta->yaml_backend();
    $data = eval { no strict 'refs'; &{"$backend\::Dump"}($struct) };
    if ( $@ ) {
      croak $backend->can('errstr') ? $backend->errstr : $@
    }
  }

  return $data;
}

# Used by JSON::PP, etc. for "convert_blessed"
sub TO_JSON {
  return { %{ $_[0] } };
}

1;

# ABSTRACT: the distribution metadata for a CPAN dist

__END__

=pod

=encoding UTF-8

=head1 NAME

CPAN::Meta - the distribution metadata for a CPAN dist

=head1 VERSION

version 2.143240

=head1 SYNOPSIS

    use v5.10;
    use strict;
    use warnings;
    use CPAN::Meta;
    use Module::Load;

    my $meta = CPAN::Meta->load_file('META.json');

    printf "testing requirements for %s version %s\n",
    $meta->name,
    $meta->version;

    my $prereqs = $meta->effective_prereqs;

    for my $phase ( qw/configure runtime build test/ ) {
        say "Requirements for $phase:";
        my $reqs = $prereqs->requirements_for($phase, "requires");
        for my $module ( sort $reqs->required_modules ) {
            my $status;
            if ( eval { load $module unless $module eq 'perl'; 1 } ) {
                my $version = $module eq 'perl' ? $] : $module->VERSION;
                $status = $reqs->accepts_module($module, $version)
                        ? "$version ok" : "$version not ok";
            } else {
                $status = "missing"
            };
            say "  $module ($status)";
        }
    }

=head1 DESCRIPTION

Software distributions released to the CPAN include a F<META.json> or, for
older distributions, F<META.yml>, which describes the distribution, its
contents, and the requirements for building and installing the distribution.
The data structure stored in the F<META.json> file is described in
L<CPAN::Meta::Spec>.

CPAN::Meta provides a simple class to represent this distribution metadata (or
I<distmeta>), along with some helpful methods for interrogating that data.

The documentation below is only for the methods of the CPAN::Meta object.  For
information on the meaning of individual fields, consult the spec.

=head1 METHODS

=head2 new

  my $meta = CPAN::Meta->new($distmeta_struct, \%options);

Returns a valid CPAN::Meta object or dies if the supplied metadata hash
reference fails to validate.  Older-format metadata will be up-converted to
version 2 if they validate against the original stated specification.

It takes an optional hashref of options. Valid options include:

=over

=item *

lazy_validation -- if true, new will attempt to convert the given metadata
to version 2 before attempting to validate it.  This means than any
fixable errors will be handled by CPAN::Meta::Converter before validation.
(Note that this might result in invalid optional data being silently
dropped.)  The default is false.

=back

=head2 create

  my $meta = CPAN::Meta->create($distmeta_struct, \%options);

This is same as C<new()>, except that C<generated_by> and C<meta-spec> fields
will be generated if not provided.  This means the metadata structure is
assumed to otherwise follow the latest L<CPAN::Meta::Spec>.

=head2 load_file

  my $meta = CPAN::Meta->load_file($distmeta_file, \%options);

Given a pathname to a file containing metadata, this deserializes the file
according to its file suffix and constructs a new C<CPAN::Meta> object, just
like C<new()>.  It will die if the deserialized version fails to validate
against its stated specification version.

It takes the same options as C<new()> but C<lazy_validation> defaults to
true.

=head2 load_yaml_string

  my $meta = CPAN::Meta->load_yaml_string($yaml, \%options);

This method returns a new CPAN::Meta object using the first document in the
given YAML string.  In other respects it is identical to C<load_file()>.

=head2 load_json_string

  my $meta = CPAN::Meta->load_json_string($json, \%options);

This method returns a new CPAN::Meta object using the structure represented by
the given JSON string.  In other respects it is identical to C<load_file()>.

=head2 load_string

  my $meta = CPAN::Meta->load_string($string, \%options);

If you don't know if a string contains YAML or JSON, this method will use
L<Parse::CPAN::Meta> to guess.  In other respects it is identical to
C<load_file()>.

=head2 save

  $meta->save($distmeta_file, \%options);

Serializes the object as JSON and writes it to the given file.  The only valid
option is C<version>, which defaults to '2'. On Perl 5.8.1 or later, the file
is saved with UTF-8 encoding.

For C<version> 2 (or higher), the filename should end in '.json'.  L<JSON::PP>
is the default JSON backend. Using another JSON backend requires L<JSON> 2.5 or
later and you must set the C<$ENV{PERL_JSON_BACKEND}> to a supported alternate
backend like L<JSON::XS>.

For C<version> less than 2, the filename should end in '.yml'.
L<CPAN::Meta::Converter> is used to generate an older metadata structure, which
is serialized to YAML.  CPAN::Meta::YAML is the default YAML backend.  You may
set the C<$ENV{PERL_YAML_BACKEND}> to a supported alternative backend, though
this is not recommended due to subtle incompatibilities between YAML parsers on
CPAN.

=head2 meta_spec_version

This method returns the version part of the C<meta_spec> entry in the distmeta
structure.  It is equivalent to:

  $meta->meta_spec->{version};

=head2 effective_prereqs

  my $prereqs = $meta->effective_prereqs;

  my $prereqs = $meta->effective_prereqs( \@feature_identifiers );

This method returns a L<CPAN::Meta::Prereqs> object describing all the
prereqs for the distribution.  If an arrayref of feature identifiers is given,
the prereqs for the identified features are merged together with the
distribution's core prereqs before the CPAN::Meta::Prereqs object is returned.

=head2 should_index_file

  ... if $meta->should_index_file( $filename );

This method returns true if the given file should be indexed.  It decides this
by checking the C<file> and C<directory> keys in the C<no_index> property of
the distmeta structure. Note that neither the version format nor
C<release_status> are considered.

C<$filename> should be given in unix format.

=head2 should_index_package

  ... if $meta->should_index_package( $package );

This method returns true if the given package should be indexed.  It decides
this by checking the C<package> and C<namespace> keys in the C<no_index>
property of the distmeta structure. Note that neither the version format nor
C<release_status> are considered.

=head2 features

  my @feature_objects = $meta->features;

This method returns a list of L<CPAN::Meta::Feature> objects, one for each
optional feature described by the distribution's metadata.

=head2 feature

  my $feature_object = $meta->feature( $identifier );

This method returns a L<CPAN::Meta::Feature> object for the optional feature
with the given identifier.  If no feature with that identifier exists, an
exception will be raised.

=head2 as_struct

  my $copy = $meta->as_struct( \%options );

This method returns a deep copy of the object's metadata as an unblessed hash
reference.  It takes an optional hashref of options.  If the hashref contains
a C<version> argument, the copied metadata will be converted to the version
of the specification and returned.  For example:

  my $old_spec = $meta->as_struct( {version => "1.4"} );

=head2 as_string

  my $string = $meta->as_string( \%options );

This method returns a serialized copy of the object's metadata as a character
string.  (The strings are B<not> UTF-8 encoded.)  It takes an optional hashref
of options.  If the hashref contains a C<version> argument, the copied metadata
will be converted to the version of the specification and returned.  For
example:

  my $string = $meta->as_string( {version => "1.4"} );

For C<version> greater than or equal to 2, the string will be serialized as
JSON.  For C<version> less than 2, the string will be serialized as YAML.  In
both cases, the same rules are followed as in the C<save()> method for choosing
a serialization backend.

=head1 STRING DATA

The following methods return a single value, which is the value for the
corresponding entry in the distmeta structure.  Values should be either undef
or strings.

=over 4

=item *

abstract

=item *

description

=item *

dynamic_config

=item *

generated_by

=item *

name

=item *

release_status

=item *

version

=back

=head1 LIST DATA

These methods return lists of string values, which might be represented in the
distmeta structure as arrayrefs or scalars:

=over 4

=item *

authors

=item *

keywords

=item *

licenses

=back

The C<authors> and C<licenses> methods may also be called as C<author> and
C<license>, respectively, to match the field name in the distmeta structure.

=head1 MAP DATA

These readers return hashrefs of arbitrary unblessed data structures, each
described more fully in the specification:

=over 4

=item *

meta_spec

=item *

resources

=item *

provides

=item *

no_index

=item *

prereqs

=item *

optional_features

=back

=head1 CUSTOM DATA

A list of custom keys are available from the C<custom_keys> method and
particular keys may be retrieved with the C<custom> method.

  say $meta->custom($_) for $meta->custom_keys;

If a custom key refers to a data structure, a deep clone is returned.

=for Pod::Coverage TO_JSON abstract author authors custom custom_keys description dynamic_config
generated_by keywords license licenses meta_spec name no_index
optional_features prereqs provides release_status resources version

=head1 BUGS

Please report any bugs or feature using the CPAN Request Tracker.
Bugs can be submitted through the web interface at
L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>

When submitting a bug or request, please include a test-file or a patch to an
existing test-file that illustrates the bug or desired feature.

=head1 SEE ALSO

=over 4

=item *

L<CPAN::Meta::Converter>

=item *

L<CPAN::Meta::Validator>

=back

=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan

=head1 SUPPORT

=head2 Bugs / Feature Requests

Please report any bugs or feature requests through the issue tracker
at L<https://github.com/Perl-Toolchain-Gang/CPAN-Meta/issues>.
You will be notified automatically of any progress on your issue.

=head2 Source Code

This is open source software.  The code repository is available for
public review and contribution under the terms of the license.

L<https://github.com/Perl-Toolchain-Gang/CPAN-Meta>

  git clone https://github.com/Perl-Toolchain-Gang/CPAN-Meta.git

=head1 AUTHORS

=over 4

=item *

David Golden <dagolden@cpan.org>

=item *

Ricardo Signes <rjbs@cpan.org>

=back

=head1 CONTRIBUTORS

=for stopwords Ansgar Burchardt Avar Arnfjord Bjarmason Christopher J. Madsen Chuck Adams Cory G Watson Damyan Ivanov Eric Wilhelm Graham Knop Gregor Hermann Karen Etheridge Kenichi Ishigaki Ken Williams Lars Dieckow Leon Timmermans majensen Mark Fowler Matt S Trout Michael G. Schwern moznion Olaf Alders Olivier Mengue Randy Sims

=over 4

=item *

Ansgar Burchardt <ansgar@cpan.org>

=item *

Avar Arnfjord Bjarmason <avar@cpan.org>

=item *

Christopher J. Madsen <cjm@cpan.org>

=item *

Chuck Adams <cja987@gmail.com>

=item *

Cory G Watson <gphat@cpan.org>

=item *

Damyan Ivanov <dam@cpan.org>

=item *

Eric Wilhelm <ewilhelm@cpan.org>

=item *

Graham Knop <haarg@haarg.org>

=item *

Gregor Hermann <gregoa@debian.org>

=item *

Karen Etheridge <ether@cpan.org>

=item *

Kenichi Ishigaki <ishigaki@cpan.org>

=item *

Ken Williams <kwilliams@cpan.org>

=item *

Lars Dieckow <daxim@cpan.org>

=item *

Leon Timmermans <leont@cpan.org>

=item *

majensen <maj@fortinbras.us>

=item *

Mark Fowler <markf@cpan.org>

=item *

Matt S Trout <mst@shadowcat.co.uk>

=item *

Michael G. Schwern <mschwern@cpan.org>

=item *

moznion <moznion@gmail.com>

=item *

Olaf Alders <olaf@wundersolutions.com>

=item *

Olivier Mengue <dolmen@cpan.org>

=item *

Randy Sims <randys@thepierianspring.org>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2010 by David Golden and Ricardo Signes.

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

=cut
PK       ! CP��>  �>    perl5/POD2/PT_BR/local/lib.podnu ��6�$        =encoding utf8

=head1 NAME

local::lib~[pt_br] - crie e use um diretório lib/ local para módulos perl com PERL5LIB

=head1 SINOPSE

No código -

  use local::lib; # configura um lib local em ~/perl5

  use local::lib '~/foo'; # idem, mas ~/foo

  # Ou...
  use FindBin;
  use local::lib "$FindBin::Bin/../suporte";  # bibliotecas de suporte locais à aplicação

Pela linha de comando (shell) -

  # Instala o LWP e suas dependências não encontradas no diretório '~/perl5'
  perl -MCPAN -Mlocal::lib -e 'CPAN::install(LWP)'

  # Apenas exibe alguns comandos úteis para a shell
  $ perl -Mlocal::lib
  export PERL_MB_OPT='--install_base /home/username/perl5'
  export PERL_MM_OPT='INSTALL_BASE=/home/username/perl5'
  export PERL5LIB='/home/username/perl5/lib/perl5/i386-linux:/home/username/perl5/lib/perl5'
  export PATH="/home/username/perl5/bin:$PATH"

=head2 A técnica de 'bootstrapping'

Uma forma comum de instalar o local::lib é usando o que é conhecido como
técnica de "bootstrapping". É uma boa abordagem caso seu administrador de
sistemas não tenha instalado o local::lib. Nesse caso, você precisará
instalar o local::lib em seu diretório de usuário.

Caso você tenha privilégios de administrador, ainda assim deverá
configurar suas variáveis de ambiente, como discutido no passo 4, abaixo.
Sem elas, você ainda instalará módulos no CPAN do sistema e seus scripts
Perl não utilizarão o caminho para o lib/ que você definiu com o local::lib.

Por padrão, o local::lib instala os módulos do CPAN e a si próprio em ~/perl5.

Usuários do Windows devem ler L</Diferenças ao usar esse módulo em Win32>.

1. Baixe e descompacte o local::lib do CPAN (procure por "Download" na página
do CPAN sobre o local::lib). Faça isso como um usuário comum, não como root
ou administrador. Descompacte o arquivo em seu diretório de usuário ou em
qualquer outro local conveniente.

2. Execute isso:

  perl Makefile.PL --bootstrap

Caso o sistema pergunte se deve configurar tudo que puder automaticamente,
você provavelmente deve responder que sim (yes).

Para instalar o local::lib em um diretório que não o padrão, você precisará
especificá-lo ao chamar o bootstrap, da seguinte forma:

  perl Makefile.PL --bootstrap=~/foo

3. Execute isso: (local::lib assume que você possui o comando 'make'
instalado em seu sistema)

  make test && make install

4. Agora precisamos configurar as variáveis de ambiente apropriadas para
que o Perl use nosso recém-criado diretório lib/. Caso esteja usando bash
ou outra shell Bourne, você pode fazer isso adicionando a seguinte linha
em seu script de inicialização da shell:

  echo 'eval $(perl -I$HOME/perl5/lib/perl5 -Mlocal::lib)' >>~/.bashrc

Caso esteja usando a shell C, pode fazer da seguinte forma:

  /bin/csh
  echo $SHELL
  /bin/csh
  perl -I$HOME/perl5/lib/perl5 -Mlocal::lib >> ~/.cshrc

Caso tenha passado para o bootstrap um diretório que não o padrão, você
precisará indicá-lo na chamada ao local::lib, dessa forma:

  echo 'eval $(perl -I$HOME/foo/lib/perl5 -Mlocal::lib=$HOME/foo)' >>~/.bashrc

Após atualizar seu arquivo de configuração da shell, certifique-se de
processá-lo novamente para obter as modificações em sua shell atual.
Shells Bourne usam C<. ~/.bashrc> para isso, enquanto shells C
usam C<source ~/.cshrc>.

Se estiver em uma máquina lenta ou operando com grandes limitações de
espaço em disco, você pode desativar a geração automática de manpages a
partir do POD ao instalar módulos. Para isso, basta passar o argumento
C<--no-manpages> durante o bootstrap:

  perl Makefile.PL --bootstrap --no-manpages

Para evitar ter que fazer vários bootstraps para vários ambientes de
módulos Perl na mesma conta de usuário - por exemplo se você usa o
local::lib para desenvolver diferentes aplicativos independentes -
você pode utilizar uma única instalação bootstrap do local::lib para
instalar módulos em diretórios diferentes da seguinte forma:

  cd ~/meudir1
  perl -Mlocal::lib=./
  eval $(perl -Mlocal::lib=./)  ### Para configurar o ambiente apenas nessa shell
  printenv                      ### Veja que o ~/meudir1 está na PERL5LIB
  perl -MCPAN -e install ...    ### Os módulos que quiser
  cd ../meudir2
  ... REPITA ...

Para múltiplos ambientes destinados a múltiplos aplicativos, você pode
precisar incluir uma versão modificada das instruções de C<< use FindBin >>
no exemplo "No código" acima. Caso tenha feito algo como o que foi descrito
acima, terá um conjunto de módulos Perl em C<< ~/meudir1/lib >>. Caso
tenha um script em C<< ~/meudir1/scripts/meuscript.pl >>, você precisará
indicar a ele onde encontrar os módulos que instalou para ele
em C<< ~/meudir1/lib >>.

Em C<< ~/meudir1/scripts/meuscript.pl >>:

  use strict;
  use warnings;
  use local::lib "$FindBin::Bin/..";  ### aponta para ~/meudir1 e o local::lib acha o lib/
  use lib "$FindBin::Bin/../lib";     ### aponta para ~/meudir1/lib

Coloque isso antes de qualquer bloco BEGIN { ... } que precise dos módulos instalados.

=head2 Diferenças ao usar esse módulo em Win32

Para configurar as variáveis de ambiente apropriadas para sua sessão atual
do C<CMD.exe>, você pode fazer assim:

  C:\>perl -Mlocal::lib
  set PERL_MB_OPT=--install_base C:\DOCUME~1\ADMINI~1\perl5
  set PERL_MM_OPT=INSTALL_BASE=C:\DOCUME~1\ADMINI~1\perl5
  set PERL5LIB=C:\DOCUME~1\ADMINI~1\perl5\lib\perl5;C:\DOCUME~1\ADMINI~1\perl5\lib\perl5\MSWin32-x86-multi-thread
  set PATH=C:\DOCUME~1\ADMINI~1\perl5\bin;%PATH%

  ### Para configurar o ambiente apenas dessa shell
  C:\>perl -Mlocal::lib > %TEMP%\tmp.bat && %TEMP%\tmp.bat && del %TEMP%\temp.bat
  ### em vez de $(perl -Mlocal::lib=./)

Caso queira que as configurações do ambiente persistam, você precisará
adicioná-las em Painel de Controle -> Sistema, ou usar o L<App::local::lib::Win32Helper>.

O "~" é transformado no diretório do perfil do usuário (o diretório com o
nome do usuário dentro de "Documents and Settings" (Windows XP ou anterior)
ou "Usuários" (Windows Vista e mais recentes)) a menos que $ENV{HOME} exista.
Após isso, o nome do diretório é encurtado e os subdiretórios são criados
(o que significa que o diretório deve existir).

=head1 MOTIVAÇÃO

A versão de um pacote Perl na sua máquina nem sempre é a que você precisa.
Obviamente, a melhor coisa a fazer seria atualizá-la para a versão desejada.
No entanto, você pode estar em uma situação que o impede de fazer isso.
Talvez você não tenha privilégios de administrador do sistema; ou talvez
esteja usando um sistema de gerenciamento de pacotes como o do Debian,
e ainda não exista um pacote disponível na versão desejada.

local::lib resolve esse problema possibilitando a criação de seu próprio
diretório de pacotes Perl obtidos do CPAN (em sistemas multi-usuário, isso
normalmente fica dentro do diretório de seu usuário). A instalação do Perl
no sistema permanece inalterada; você simplesmente chama o Perl com opções
especiais para que ele use os pacotes em seu diretório local em vez dos
pacotes do sistema. O local::lib organiza as coisas para que versões dos
pacotes Perl instalados localmente tenham precedência sobre as do sistema.

Caso esteja usando um sistema de gerenciamento de pacote (como em sistemas
Debian), não precisará se preocupar com conflitos entre o Debian e o CPAN.
Sua versão local dos pacotes será instalada em um diretório completamente
diferente das versões instaladas pelo gerenciador de pacotes do sistema.

=head1 DESCRIÇÃO

Este módulo oferece uma forma rápida e conveniente para criar um repositório
de módulos locais ao usuário, dentro do diretório do mesmo. Ele também monta
e exibe para o usuário uma lista de variáveis de ambiente utilizando a
sintaxe da shell atual do usuário (conforme especificado pela variável
de ambiente C<SHELL>), pronta para ser adicionada diretamente no arquivo
de configuração da shell.

Generalizando, o local::lib permite a criação e uso de um diretório contendo
módulos Perl fora do C<@INC> do Perl. Isso facilita a produção de aplicações
com uma versão específica de determinado módulo, ou coleção de módulos.
Também é útil quando o mantenedor de um módulo não aplicou determinado patch
que você precisa para seu aplicativo.

Durante o C<import>, o local::lib define valores apropriados para as
seguintes variáveis de ambiente:

=over 4

=item PERL_MB_OPT

=item PERL_MM_OPT

=item PERL5LIB

=item PATH

valores serão anexados ao PATH, em vez de substituí-lo.

=back

Esses valores são então disponibilizados para referência por qualquer
outro código após o C<import>.

=head1 CRIANDO UM CONJUNTO AUTO-CONTIDO DE MÓDULOS

Veja L<lib::core::only|lib::core::only> para uma maneira de fazer isso - mas
note que há uma série de ressalvas na abordagem, e a melhor forma é sempre
fazer o 'build' contra uma versão limpa do perl (i.e. com 'site' e 'vendor'
o mais vazios possível).

=head1 MÉTODOS

=head2 ensure_dir_structure_for

=over 4

=item Argumentos: $caminho_do_diretorio

=item Valor de Retorno: Nenhum

=back

Tenta criar o caminho fornecido, e todos os diretórios superiores necessários. Gera uma exceção em caso de falha.

=head2 print_environment_vars_for

=over 4

=item Argumentos: $caminho_do_diretorio

=item Valor de Retorno: Nenhum

=back

Exibe na saída padrão as variáveis listadas acima, devidamente ajustadas
para utilizar o caminho fornecido como diretório base.

=head2 build_environment_vars_for

=over 4

=item Argumentos: $caminho_do_diretorio, $interpolar

=item Valor de Retorno: %variaveis_de_ambiente

=back

Retorna hash contendo as variáveis de ambiente listadas acima, devidamente
ajustadas para utilizar o caminho fornecido como diretório base.

=head2 setup_env_hash_for

=over 4

=item Argumentos: $caminho_do_diretorio

=item Valor de Retorno: Nenhum

=back

Constrói as chaves no C<%ENV> para o caminho fornecido, chamando
C<build_environment_vars_for>.

=head2 install_base_perl_path

=over 4

=item Argumentos: $caminho_do_diretorio

=item Valor de Retorno: $caminho_base_de_instalacao

=back

Retorna um caminho de diretório indicando onde instalar os módulos Perl
para essa instalação local de bibliotecas. Adiciona os diretórios C<lib>
e C<perl5> ao final do caminho fornecido.

=head2 install_base_arch_path

=over 4

=item Argumentos: $caminho_do_diretorio

=item Valor de Retorno: $caminho_base_de_instalacao_arch

=back

Retorna um caminho de diretório indicando onde instalar os módulos Perl
de arquiteturas específicas para essa instalação local de bibliotecas.
Baseia-se no valor de retorno do método L</install_base_perl_path>,
adicionando o valor de C<$Config{archname}>.

=head2 install_base_bin_path

=over 4

=item Argumentos: $caminho_do_diretorio

=item Valor de Retorno: $caminho_base_de_instalacao_bin

=back

Retorna um caminho de diretório indicando onde instalar programas executáveis
para essa instalação local de bibliotecas. Baseia-se no valor de retorno do
método L</install_base_perl_path>, adicionando o diretório C<bin>.

=head2 resolve_empty_path

=over 4

=item Argumentos: $caminho_do_diretorio

=item Valor de Retorno: $caminho_base_de_instalacao

=back

Cria e retorna o caminho de diretório raiz em que a instalação local de
módulos deve ser feita. O padrão é C<~/perl5>.

=head2 resolve_home_path

=over 4

=item Argumentos: $caminho_do_diretorio

=item Valor de Retorno: $caminho_para_home

=back

Procura pelo diretório padrão (home) do usuário.
Gera uma exceção caso não encontre
resultado definitivo.

=head2 resolve_relative_path

=over 4

=item Argumentos: $caminho_do_diretorio

=item Valor de Retorno: $caminho_absoluto

=back

Transforma o caminho fornecido em um caminho absoluto.

=head2 resolve_path

=over 4

=item Argumentos: $caminho_do_diretorio

=item Valor de Retorno: $caminho_absoluto

=back

Invoca os seguintes métodos em sequência, passando o resultado do método
anterior para o seguinte, na tentativa de descobrir onde configurar o
ambiente para a instalação local de bibliotecas: L</resolve_empty_path>,
L</resolve_home_path>, L</resolve_relative_path>. Passa o caminho de
diretório fornecido para L</resolve_empty_path> que retorna um resultado
que é passado para L</resolve_home_path>, que então tem seu resultado
passado para L</resolve_relative_path>. O resultado dessa chamada final
é então retornado pelo L</resolve_path>.

=head1 UM AVISO SOBRE UNINST=1

Tenha cuidado ao usar o local::lib em conjunto com "make install UNINST=1".
A idéia dessa opção é desinstalar a versão anterior de um módulo antes de
instalar a mais recente. No entanto ela não possui uma verificação de
segurança de que a versão antiga e a nova referem-se ao mesmo diretório.
Usada em combinação com o local::lib, você pode potencialmente apagar uma
versão globalmente acessível de um módulo e instalar a versão mais nova
no diretório local. Apenas utilize "make install UNINST=1" junto com o
local::lib se você entende essas possíveis consequências.

=head1 LIMITAÇÕES

As ferramentas auxiliares do perl não conseguem lidar com nomes de
diretórios contendo espaços, então não é possível fazer seu bootstrap
do local::lib em um diretório com espaços. O que você pode fazer é mover
seu local::lib para um diretório com espaços B<após> ter instalado todos
os módulos dentro dele. Mas esteja ciente que você não poderá atualizar
ou instalar outros módulos do CPAN nesse diretório local após a mudança.

A detecção da shell é relativamente básica. Neste momento, qualquer coisa
com csh no nome será tratada como a C shell ou compatível, e todo o resto
será tratado como Bourne, exceto em sistemas Win32. Caso a variável de
ambiente C<SHELL> não esteja disponível, assumiremos tratar-se de uma
shell compatível com a Bourne.

A técnica de bootstrap é um hack e usará o CPAN.pm para o ExtUtils::MakeMaker
mesmo que você tenha o CPANPLUS instalado.

Destrói qualquer valor pré-existente nas variáveis de ambiente PERL5LIB,
PERL_MM_OPT e PERL_MB_OPT.

Provavelmente deveria auto-configurar o CPAN caso isso ainda não tenha
sido feito.

Correções (patches) são muito bem-vindos para quaisquer dos itens acima.

Em sistemas Win32, não há uma forma de escrever no registro as variáveis
de ambiente criadas, para que elas persistam a uma reinicialização.

=head1 SOLUÇÃO DE PROBLEMAS

Se você configurou o local::lib para instalar módulos do CPAN em algum lugar
do seu 'home', e mais tarde tentou instalar um módulo fazendo C<cpan -i
Foo::Bar>, mas ele falhou com um erro como: C<Warning: You do not have
permissions to install into /usr/lib64/perl5/site_perl/5.8.8/x86_64-linux at
/usr/lib64/perl5/5.8.8/Foo/Bar.pm> e em algum lugar no seu log de instalação
houver um erro dizendo C<'INSTALL_BASE' is not a known MakeMaker parameter
name>, então você de alguma forma perdeu seu ExtUtils::MakeMaker atualizado.

Para remediar a situação, execute novamente o procedimento de bootstrap
descrito acima.

Então, execute C<rm -r ~/.cpan/build/Foo-Bar*>

Finalmente, execute novamente o C<cpan -i Foo::Bar> e ele deve instalar
sem problemas.

=head1 AMBIENTE

=over 4

=item SHELL

=item COMSPEC

O local::lib procura pela variável de ambiente C<SHELL> do usuário ao
processar e exibir os comandos a serem adicionados no arquivo de
configuração da shell.

Em sistemas Win32, C<COMSPEC> também será examinado.

=back

=head1 SUPORTE

IRC:

    Acesse #local-lib em irc.perl.org.

=head1 AUTOR DA TRADUÇÃO

Breno G. de Oliveira, C<< <garu at cpan.org> >>, após ter perdido uma aposta
para o L<Getty|http://search.cpan.org/~getty/> durante a Copa de 2010.


=head1 COPYRIGHT

Copyright (c) 2007 - 2010 L<local::lib/"AUTHOR">
e L<local::lib/"CONTRIBUTORS"> do local::lib como listados em L<local::lib>.

=head1 LICENÇA

Esta biblioteca é software livre e pode ser distribuída sob os mesmo termos
do perl.

PK       ! ��(	�@  �@    perl5/POD2/DE/local/lib.podnu ��6�$        =encoding utf8

=head1 NAME

local::lib~[de] - Erschaffen und benutzen von Perl Modulen in einem lokalen lib/ Verzeichnis mit PERL5LIB

=head1 SYNOPSIS

Im Code -

  use local::lib; # Benutzt das Verzeichnis ~/perl5 zum anlegen des lokalen lib/ Verzeichnisses

  use local::lib '~/foo'; # das selbe, aber mit ~/foo

  # Oder...
  use FindBin;
  use local::lib "$FindBin::Bin/../support";  # Applikationsspezifische Sammlung von Modulen

Von der Shell -

  # Installiert LWP und alle notwendigen Abhängigkeiten in das '~/perl5' Verzeichnis
  perl -MCPAN -Mlocal::lib -e 'CPAN::install(LWP)'

  # Gibt die Shell Kommandos aus um die Umgebung vorzubereiten
  $ perl -Mlocal::lib
  export PERL_MB_OPT='--install_base /home/username/perl5'
  export PERL_MM_OPT='INSTALL_BASE=/home/username/perl5'
  export PERL5LIB='/home/username/perl5/lib/perl5/i386-linux:/home/username/perl5/lib/perl5'
  export PATH="/home/username/perl5/bin:$PATH"

=head2 Die Bootstrapping Methode

Ein typischer Weg um local::lib zu benutzen ist die sogenannte "Bootstrapping" Methode.
Diese Methode wird benutzt wenn noch kein local::lib auf dem System installiert ist.
In diesem Fall kannst du einfach local::lib direkt in deinem Home-Verzeichnis installieren.

Selbst wenn du administrative Rechte hast, ist es wichtig das die Umgebungsvariablen von
Schritt 4 in deinem Shell Startup Skript gesetzt werden. Ohne diesen Schritt werden die
Module von CPAN weiterhin im System installiert und auch Perl Skripte die du startest
würden das von local::lib erstellte lib/ Verzeichnis nicht nutzen.

Standardmäßig installiert sich local::lib in ~/perl5.

Windows Benutzern müssen ausserdem dies hier lesen:
L</Unterschiede bei Benutzung dieses Module mit Win32>.

1. Lade das Tar-Archiv von CPAN runter (Suche nach "Download" auf der CPAN Seite von
local::lib) und entpacke es in einem beliebigem Verzeichnis. Um das obige Problem zu
vermeiden, sollte man dies als normaler User tun und nicht als root oder Administrator.

2. Starte in dem entstandenen Verzeichnis folgenden Befehl:

  perl Makefile.PL --bootstrap

Wenn das System dir vorschlägt gewisse Dinge eigenständig zu konfigurieren ist es in
fast allen Fällen vollkommen in Ordnung einfach "yes" zu antworten.

Falls du local::lib nicht in das Standard Verzeichnis installieren willst, musst du
dieses Verzeichnis als Parameter angeben:

  perl Makefile.PL --bootstrap=~/foo

3. Danach folgenden Befehl starten: (local::lib erwartet make auf dem System)

  make test && make install

4. Nun müssen wir die benötigten Umgebungsvariablen, damit Perl unser neu generiertes
lib/ Verzeichnis benutzt. Wenn du bash oder eine andere Bourne Shell benutzt, kannst
du es über diesen Weg zu deinem Shell Startup Skript hinzufügen:

  echo 'eval $(perl -I$HOME/perl5/lib/perl5 -Mlocal::lib)' >>~/.bashrc

Wenn du C Shell benutzt, du kannst das gleiche hiermit erreichen:

  /bin/csh
  echo $SHELL
  /bin/csh
  perl -I$HOME/perl5/lib/perl5 -Mlocal::lib >> ~/.cshrc

Wenn du beim bootstrappen ein anderes Verzeichnis benutzt als das Standardverzeichnis,
dann musst du dieses Verzeichnis als Parameter beim Laden des Modules local::lib angeben:

  echo 'eval $(perl -I$HOME/foo/lib/perl5 -Mlocal::lib=$HOME/foo)' >>~/.bashrc

Nachdem diese Änderungen in deinem Shell Startup Skript gemacht wurden, ist es nun wichtig
das diese Umgebungsvariablen auch gesetzt sind in deiner aktuellen Umgebung. In Bourne
Shells macht man dies z.B. mit C<. ~/.bashrc>, und in C Shell würde man es mit:
C<source ~/.cshrc> mit.

Wenn du eine sehr langsames System hast, oder du unter drakonischen Regulierungen des
Plattenplatz leben musst, kann man die automatische Generierung der manpages vom POD
bei der Installation des Moduls deaktivieren beim bootstrapping mit dem C<--no-manpages>
Parameter:

  perl Makefile.PL --bootstrap --no-manpages

Um zu vermeiden das man mehrere bootstraps macht um z.B. für verschiedene Applikationen
eigene local::lib Installationen zu nutzen, kann man eine dieser Umgebungen benutzen
um einfach in beliebigen anderen Verzeichnis Module zu installieren und somit weitere
eigenständige lib/ Umgebungen zu bekommen:

  cd ~/mydir1
  perl -Mlocal::lib=./
  eval $(perl -Mlocal::lib=./)  ### Um die Umgebungsvariablen für die
                                ### aktuelle Shell zusetzen

  printenv                      ### Hier kannst du sehen das ~/mydir1
                                ### in der PERL5LIB Umgebungsvariable
                                ### steht

  perl -MCPAN -e install ...    ### welche Module auch immer ...
  cd ../mydir2

  ... WIEDERHOLEN ...

Für mehrere Umgebungen in dieser Form brauch man eine Modifikation in der
Benutzung von C<< use FindBin >> in dem "Im Code" Beispiel oben.
Wenn du sowas machst, und du hast damit z.B. Perl Module nach C<<
~/mydir1/lib >> installiert und du hast ein Script in C<<
~/mydir1/scripts/myscript.pl >>, du musst dort angeben das die Module
die es braucht im Verzeichnis C<< ~/mydir1/lib >> liegen.

In C<< ~/mydir1/scripts/myscript.pl >> steht dann:

  use strict;
  use warnings;
  use local::lib "$FindBin::Bin/..";  ### zeigt auf ~/mydir1 und local::lib
                                      ### findet dort lib
  use lib "$FindBin::Bin/../lib";     ### zeigt auf ~/mydir1/lib

Setze das vor jeden BEGIN { ... } Block der die Module braucht die du
installiert hast.

=head2 Unterschiede bei Benutzung dieses Module mit Win32

Um die nötigen Umgebungsvariablen für diese Variablen in der derzeitigen
Sitzung mit C<CMD.EXE> zu setzen, kann man folgendes kommando nutzen:

  C:\>perl -Mlocal::lib
  set PERL_MB_OPT=--install_base C:\DOCUME~1\ADMINI~1\perl5
  set PERL_MM_OPT=INSTALL_BASE=C:\DOCUME~1\ADMINI~1\perl5
  set PERL5LIB=C:\DOCUME~1\ADMINI~1\perl5\lib\perl5;C:\DOCUME~1\ADMINI~1\perl5\lib\perl5\MSWin32-x86-multi-thread
  set PATH=C:\DOCUME~1\ADMINI~1\perl5\bin;%PATH%

  ### Um die Umgebungsvariablen für diese Shell alleine zu setzen
  C:\>perl -Mlocal::lib > %TEMP%\tmp.bat && %TEMP%\tmp.bat && del %TEMP%\temp.bat
  ### anstelle von $(perl -Mlocal::lib=./) in bash.

Wenn du willst das die Umgebungsvariablen dauerhaft gesetzt sind, musst du diese
in Systemsteuerung / System dauerhaft selber eintragen oder
L<App::local::lib::Win32Helper> benutzen.

Die "~" wird übersetzt zu dem Benutzer Profil Verzeichnis (das Verzeichnis was
beim User als "Dokumente und Einstellungen" bekannt ist unter Windows XP und
vorher oder das "Benutzer" Verzeichnis bei Windows Vista und später), solange
$ENV{HOME} nicht gesetzt ist. Das Verzeichnis wird hierbei zu dem korrekten
Kurznamen umgewandelt, und muss daher definitiv existieren, und wird um die
nötigen Unterverzeichnise erweitert.

=head1 GRUNDPRINZIP

Die Version von den Perl Paketen die man benötigt für spezifische Aufgaben sind
sehr häufig nicht die richtigen oder korrekten Versionen auf dem System
vorinstalliert. Ein Updaten von diesen Modulen ist in vielen Fällen einfach
nicht möglich weil die nötigen Rechte fehlen. Ausserdem ist es generell nicht
gut eigenständig die Versionen der Module auf dem System auszutauschen, weil
natürlich der Rest des Systems genau die Version erwartet die von der
Systemverwaltung auch installiert wurde.

local::lib löst dieses Problem, es erlaubt dir dein komplett eigenes Verzeichnis
für deine CPAN Module zu haben und bist so nicht genötigt die Module vom
System zu nutzen oder andersrum andere User nicht mit individuellen
Modulwünschen zu Überarbeitung ihres Codes zu zwingen, weil bestimmte Module
zentral für alle auf neuere Version upgedatet werden. Die Installation findet
hierbei dann z.B. im Home Verzeichnis statt. Es werden nur Umgebungsvariablen
gesetzt die das installierte Perl dazu bewegen die im Homeverzeichnis
installierten Module zu benutzen, zusätzlich und vorgezogen zu denen auf dem
System.

Daher muss man sich wenn man ein Paket System benutzt, wie z.b. Debian, garnicht
mehr Sorgen machen, irgendwas auf dem System zu verletzten nur durch die
Installation von Perl Modulen.

=head1 BESCHREIBUNG

Dieses Modul bietet eine schnelle und legitime Art und Weise ein sogenanntes
bootstrapping zu machen um in einem User Homeverzeichnis eine Sammlung von
Modulen zu installieren. Es erstellt auch die nötigen Umgebungsvariablen
die benötigt werden um diese Module zu nutzen, passend zu der Shell die der
User in der Umgebungsvariable C<SHELL> angegeben hat, um dann direkt passend
in die entsprechenden Konfigurationsdateien der Shell einfügt zu werden.

Weitergehend ist local::lib in der Lage Module zu nutzen die nicht im
standardmäßigen C<@INC> Pfad von Perl enthalten sind. Das macht es einfacher
für bestimmte Applikationen ein bestimmtes Set von Modulen zu installieren
ohne die anderen Module auf dem System in irgendeiner Art anzufassen.
Damit es z.B. auch sicherer Module zu installieren die vom Maintainer noch
nicht als Release verfügbar sind.

Beim Import setzt local::lib die folgenden Umgebungsvariablen zu den
nötigen Werten:

=over 4

=item PERL_MB_OPT

=item PERL_MM_OPT

=item PERL5LIB

=item PATH

Am PATH wird natürlich angehangen, und nicht ersetzt.

=back

Diese Werte sind dann verfügbar für jeden Code der danach importiert wurde.

=head1 ERSTELLEN EINES EIGENSTÄNDIGE SAMMLUNG VON MODULEN

Mit L<lib::core::only> besteht eine Möglichkeit dieses zutun, aber beachte das
hier eine Menge von Fallstricken und Problemen existieren, und man sollte
immer darauf achten das man auf einem Perl aufbaut was sowenig wie möglich
verändert wurde (d.h. site und vendor Verzeichnis so leer wie möglich).

=head1 METHODEN

=head2 ensure_dir_structure_for

=over 4

=item Parameter: $path

=item Rückgabewert: Keiner

=back

Versucht den angegebenen Pfad anzulegen, mit allen nötigen drüberliegenden
Verzeichnissen. Im Fehlerfall wird eine Exception geworfen.

=head2 print_environment_vars_for

=over 4

=item Parameter: $pfad

=item Rückgabewert: Keiner

=back

Gibt die Umgebungsvariablen aus, die benötigt werden um den angegebenen Pfad
als Basis Verzeichnis zu nutzen.

=head2 build_environment_vars_for

=over 4

=item Parameter: $pfad, $interpolate

=item Rückgabewert: \%umgebungs_variablen

=back

Gibt ein Hash zurück mit den Variablen die nötig sind in den Umgebungsvariablen
um eine Installation in dem gegebenen Pfad zu benutzen.

=head2 setup_env_hash_for

=over 4

=item Parameter: $pfad

=item Rückgabewert: Keiner

=back

Setzt die C<%ENV> Einträge basierend auf dem Aufruf von
L</build_environment_vars_for>.

=head2 install_base_perl_path

=over 4

=item Parameter: $pfad

=item Rückgabewert: $module_installations_pfad

=back

Gibt den Pfad zurück der benutzt wird um Perl Module zu installieren bei
dem gegebenen Pfad als Basis. Prinzipiell wird nur C<lib> und C<perl5> als
Pfadelemente angehangen.

=head2 install_base_arch_path

=over 4

=item Parameter: $pfad

=item Rückgabewert: $architektur_module_installations_pfad

=back

Gibt den Pfad zurück der benutzt wird um die Architektur-abhängigen Perl
Module zu installieren basirend auf dem angegebenen Pfad als Basis. Basierend
auf dem was L</install_base_perl_path> zurückgibt, and appends the value of
C<$Config{archname}>.asis.

=head2 install_base_bin_path

=over 4

=item Parameter: $pfad

=item Rückgabewert: $ausfuehrbare_programme_installations_pfad

=back

Gibt den Pfad zurück, wo ausführbare Programme installiert werden, basierend
auf der Basis des angegebenen Pfad. Basierend auf L</install_base_perl_path>
Rückgabewert, hängt diese Methode noch C<bin> an.

=head2 resolve_empty_path

=over 4

=item Parameter: $pfad

=item Rückgabewert: $basis_pfad

=back

Erstellt und gibt zurück den Pfad der benutzt wird als Basis zur Installation
der Module. Standardmäßig dies ist C<~/perl5>.

=head2 resolve_home_path( $path )

=over 4

=item Parameter: $pfad

=item Rückgabewert: $home

=back

Versucht das Home Verzeichnis vom aktullen User zu finden.
Es wird eine Exception geworfen, wenn
kein Home Verzeichnis ermittelt werden konnte.

=head2 resolve_relative_path

=over 4

=item Parameter: $pfad

=item Rückgabewert: $absoluter_pfad

=back

Macht aus dem angegebenen Pfad einen absoluten Pfad.

=head2 resolve_path

=over 4

=item Parameter: $pfad

=item Rückgabewert: $absoluter_pfad

=back

Hierbei wird der Pfad durch die folgende Methoden gegeben, wobei der Rückgabewert
der ersten an die nächste weitergeben wird, um die Umgebung zu konfigurieren
für die lokale Bibliotheks Installation: L</resolve_empty_path>,
L</resolve_home_path>, L</resolve_relative_path>.
Der daraus resultierende Pfad wird zu L</resolve_empty_path> übergeben, dessen
Resultat dann weitergegeben wird an L</resolve_home_path>, wessen Resultat dann
weitergegeben wird an L</resolve_relative_path>. Dieses Resultat wird dann final
an L</resolve_path> übergeben, welches dann den Rückgabewert stellt.

=head1 EINE WARNUNG VOR UNINST=1

Wenn man local::lib in Kombination mit "make install UNINST=1" benutzt, muss
man vorsichtig sein über die Tatsache das der Prozess über die Neuinstallation
eine nicht ausreichende Sicherheit hat bezüglich wo er nun installieren muss.
Hierdurch mann es passieren das beim deinstallieren eines Modul u.U. das
globale Modul deinstalliert wird (wenn die Rechte vorhanden sind) aber die
neue Version nur in der lokalen Version installiert ist. Es ist hier also sehr
wichtig das man "make install UNINST=1" und local::lib nur gleichzeitig
benutzt wenn man sehr sicher darüber ist welche Konsequenzen einem
entgegenkommen.

=head1 EINSCHRÄNKUNGEN

Die Werkzeuge von perl, die benutzt werden um die Pakete zu installieren
(die sogenannte toolchain), sind leider nicht in der Lage sauber mit
Verzeichnissen umzugehen die Leerzeichen enthalten und können daher local::lib
nicht direkt in ein solches Verzeichnis installieren. Was du machen kannst
ist B<nach> der Installation von local::lib und der Module die du in deiner
local::lib haben willst, das gesamte Verzeichnis dahin zu bewegen. local::lib
kann mit dem Verzeichnis mit Leerzeichen umgehen. Bitte aufpassen das natürlich
eine weitere Installation oder ein Erneuern von Paketen mit dem CPAN Programm
nicht mehr möglich ist.

Die Shell Erkennung ist sehr primitiv. Derzeit ist es so das alles was "csh"
im Namen hat auch als C Shell eingeordnet wird, und alles andere wird als
Bourne Shell betrachet, ausser auf Win32 Systemen. Wenn die C<SHELL> Variable
nicht gesetzt ist, eine Bourne Shell wird angenommen.

Bootstrap ist leider ein Hack, und wird auf jedenfall CPAN.pm benutzen für
ExtUtils::MakeMaker, auch wenn CPANPLUS installiert ist.

Es setzt definitiv PERL5LIB, PERL_MM_OPT und PERL_MB_OPT neu und vernichtet
jeden Wert der vorher gesetzt war.

Es sollte vielleicht eine automatische Korrektur der CPAN Config machen, wenn
das nicht schon gemacht wurde.

"Patches Welcome" - Patches sind immer willkommen beim Autor oder den anderen
Mitwirkenden.

Auf Win32 Systemen werden die Umgebungsvariablen nicht direkt in die Registrierung
geschrieben damit sie auch nach dem Neustarten erhalten bleiben.

=head1 FEHLERANALYSE

Wenn du local::lib konfiguriert hast CPAN Module in deinem Home Verzeichnis
zu installieren, und du danach versuchst mit C<cpan -i Foo::Bar> ein Modul
zu installieren, und dabei einen Fehler bekommst, wie: C<Warning: You do not
have permissions to install into /usr/lib64/perl5/site_perl/5.8.8/x86_64-linux at
/usr/lib64/perl5/5.8.8/Foo/Bar.pm> und in der installationsausgabe steht
irgendwo ein Fehler der sagt C<'INSTALL_BASE' is not a known MakeMaker parameter
name>, dann hast du aus irgendeinem Grund dein neue Version von ExtUtils::MakeMaker
verloren.

Um dies zu korrigieren, einfach nochmal die bootstrapping Methode laufen lassen,
wie oben beschrieben.

Dann starte C<rm -r ~/.cpan/build/Foo-Bar*>

Abschliessend dann nochmal mit C<cpan -i Foo::Bar> installieren und die Probleme
sollten verschwunden sein.

=head1 UMGEBUNGSVARIABLEN

=over 4

=item SHELL

=item COMSPEC

local::lib schaut in die C<SHELL> Umgebungsvariable um die korrekten Kommandos
zu der Shell Konfiguration hinzuzufügen.

Auf Win32 Systemen, C<COMSPEC> wird auch analysiert.

=back

=head1 SUPPORT

IRC:

    Wir sind im Channel #local-lib auf dem Server irc.perl.org.

=head1 AUTOR DER ÜBERSETZUNG

Torsten Raudssus <torsten@raudssus.de> http://www.raudssus.de/

=head1 URHEBERRECHT

Copyright (c) 2007 - 2010 von den local::lib L<local::lib/"AUTHOR">
und L<local::lib/"CONTRIBUTORS"> aufgelistet in L<local::lib|local::lib>.

=head1 LIZENZ

Diese Sammlung ist freie Software und kann unter der selben Lizenz verbreitet
werden wie Perl selber.

=cut

1;
PK       ! �ڮ /"  /"    perl5/Types/Serialiser.pmnu ��6�$        =head1 NAME

Types::Serialiser - simple data types for common serialisation formats

=encoding utf-8

=head1 SYNOPSIS

=head1 DESCRIPTION

This module provides some extra datatypes that are used by common
serialisation formats such as JSON or CBOR. The idea is to have a
repository of simple/small constants and containers that can be shared by
different implementations so they become interoperable between each other.

=cut

package Types::Serialiser;

use common::sense; # required to suppress annoying warnings

our $VERSION = '1.0';

=head1 SIMPLE SCALAR CONSTANTS

Simple scalar constants are values that are overloaded to act like simple
Perl values, but have (class) type to differentiate them from normal Perl
scalars. This is necessary because these have different representations in
the serialisation formats.

=head2 BOOLEANS (Types::Serialiser::Boolean class)

This type has only two instances, true and false. A natural representation
for these in Perl is C<1> and C<0>, but serialisation formats need to be
able to differentiate between them and mere numbers.

=over 4

=item $Types::Serialiser::true, Types::Serialiser::true

This value represents the "true" value. In most contexts is acts like
the number C<1>. It is up to you whether you use the variable form
(C<$Types::Serialiser::true>) or the constant form (C<Types::Serialiser::true>).

The constant is represented as a reference to a scalar containing C<1> -
implementations are allowed to directly test for this.

=item $Types::Serialiser::false, Types::Serialiser::false

This value represents the "false" value. In most contexts is acts like
the number C<0>. It is up to you whether you use the variable form
(C<$Types::Serialiser::false>) or the constant form (C<Types::Serialiser::false>).

The constant is represented as a reference to a scalar containing C<0> -
implementations are allowed to directly test for this.

=item $is_bool = Types::Serialiser::is_bool $value

Returns true iff the C<$value> is either C<$Types::Serialiser::true> or
C<$Types::Serialiser::false>.

For example, you could differentiate between a perl true value and a
C<Types::Serialiser::true> by using this:

   $value && Types::Serialiser::is_bool $value

=item $is_true = Types::Serialiser::is_true $value

Returns true iff C<$value> is C<$Types::Serialiser::true>.

=item $is_false = Types::Serialiser::is_false $value

Returns false iff C<$value> is C<$Types::Serialiser::false>.

=back

=head2 ERROR (Types::Serialiser::Error class)

This class has only a single instance, C<error>. It is used to signal
an encoding or decoding error. In CBOR for example, and object that
couldn't be encoded will be represented by a CBOR undefined value, which
is represented by the error value in Perl.

=over 4

=item $Types::Serialiser::error, Types::Serialiser::error

This value represents the "error" value. Accessing values of this type
will throw an exception.

The constant is represented as a reference to a scalar containing C<undef>
- implementations are allowed to directly test for this.

=item $is_error = Types::Serialiser::is_error $value

Returns false iff C<$value> is C<$Types::Serialiser::error>.

=back

=cut

BEGIN {
   # for historical reasons, and to avoid extra dependencies in JSON::PP,
   # we alias *Types::Serialiser::Boolean with JSON::PP::Boolean.
   package JSON::PP::Boolean;

   *Types::Serialiser::Boolean:: = *JSON::PP::Boolean::;
}

{
   # this must done before blessing to work around bugs
   # in perl < 5.18 (it seems to be fixed in 5.18).
   package Types::Serialiser::BooleanBase;

   use overload
      "0+"     => sub { ${$_[0]} },
      "++"     => sub { $_[0] = ${$_[0]} + 1 },
      "--"     => sub { $_[0] = ${$_[0]} - 1 },
      fallback => 1;

   @Types::Serialiser::Boolean::ISA = Types::Serialiser::BooleanBase::;
}

our $true  = do { bless \(my $dummy = 1), Types::Serialiser::Boolean:: };
our $false = do { bless \(my $dummy = 0), Types::Serialiser::Boolean:: };
our $error = do { bless \(my $dummy    ), Types::Serialiser::Error::   };

sub true  () { $true  }
sub false () { $false }
sub error () { $error }

sub is_bool  ($) {           UNIVERSAL::isa $_[0], Types::Serialiser::Boolean:: }
sub is_true  ($) {  $_[0] && UNIVERSAL::isa $_[0], Types::Serialiser::Boolean:: }
sub is_false ($) { !$_[0] && UNIVERSAL::isa $_[0], Types::Serialiser::Boolean:: }
sub is_error ($) {           UNIVERSAL::isa $_[0], Types::Serialiser::Error::   }

package Types::Serialiser::Error;

sub error {
   require Carp;
   Carp::croak ("caught attempt to use the Types::Serialiser::error value");
};

use overload
   "0+"     => \&error,
   "++"     => \&error,
   "--"     => \&error,
   fallback => 1;

=head1 NOTES FOR XS USERS

The recommended way to detect whether a scalar is one of these objects
is to check whether the stash is the C<Types::Serialiser::Boolean> or
C<Types::Serialiser::Error> stash, and then follow the scalar reference to
see if it's C<1> (true), C<0> (false) or C<undef> (error).

While it is possible to use an isa test, directly comparing stash pointers
is faster and guaranteed to work.

For historical reasons, the C<Types::Serialiser::Boolean> stash is
just an alias for C<JSON::PP::Boolean>. When printed, the classname
with usually be C<JSON::PP::Boolean>, but isa tests and stash pointer
comparison will normally work correctly (i.e. Types::Serialiser::true ISA
JSON::PP::Boolean, but also ISA Types::Serialiser::Boolean).

=head1 A GENERIC OBJECT SERIALIATION PROTOCOL

This section explains the object serialisation protocol used by
L<CBOR::XS>. It is meant to be generic enough to support any kind of
generic object serialiser.

This protocol is called "the Types::Serialiser object serialisation
protocol".

=head2 ENCODING

When the encoder encounters an object that it cannot otherwise encode (for
example, L<CBOR::XS> can encode a few special types itself, and will first
attempt to use the special C<TO_CBOR> serialisation protocol), it will
look up the C<FREEZE> method on the object.

Note that the C<FREEZE> method will normally be called I<during> encoding,
and I<MUST NOT> change the data structure that is being encoded in any
way, or it might cause memory corruption or worse.

If it exists, it will call it with two arguments: the object to serialise,
and a constant string that indicates the name of the data model. For
example L<CBOR::XS> uses C<CBOR>, and the L<JSON> and L<JSON::XS> modules
(or any other JSON serialiser), would use C<JSON> as second argument.

The C<FREEZE> method can then return zero or more values to identify the
object instance. The serialiser is then supposed to encode the class name
and all of these return values (which must be encodable in the format)
using the relevant form for Perl objects. In CBOR for example, there is a
registered tag number for encoded perl objects.

The values that C<FREEZE> returns must be serialisable with the serialiser
that calls it. Therefore, it is recommended to use simple types such as
strings and numbers, and maybe array references and hashes (basically, the
JSON data model). You can always use a more complex format for a specific
data model by checking the second argument, the data model.

The "data model" is not the same as the "data format" - the data model
indicates what types and kinds of return values can be returned from
C<FREEZE>. For example, in C<CBOR> it is permissible to return tagged CBOR
values, while JSON does not support these at all, so C<JSON> would be a
valid (but too limited) data model name for C<CBOR::XS>. similarly, a
serialising format that supports more or less the same data model as JSON
could use C<JSON> as data model without losing anything.

=head2 DECODING

When the decoder then encounters such an encoded perl object, it should
look up the C<THAW> method on the stored classname, and invoke it with the
classname, the constant string to identify the data model/data format, and
all the return values returned by C<FREEZE>.

=head2 EXAMPLES

See the C<OBJECT SERIALISATION> section in the L<CBOR::XS> manpage for
more details, an example implementation, and code examples.

Here is an example C<FREEZE>/C<THAW> method pair:

   sub My::Object::FREEZE {
      my ($self, $model) = @_;

      ($self->{type}, $self->{id}, $self->{variant})
   }

   sub My::Object::THAW {
      my ($class, $model, $type, $id, $variant) = @_;

      $class->new (type => $type, id => $id, variant => $variant)
   }

=head1 BUGS

The use of L<overload> makes this module much heavier than it should be
(on my system, this module: 4kB RSS, overload: 260kB RSS).

=head1 SEE ALSO

Currently, L<JSON::XS> and L<CBOR::XS> use these types.

=head1 AUTHOR

 Marc Lehmann <schmorp@schmorp.de>
 http://home.schmorp.de/

=cut

1

PK       ! �Wy��  �    perl5/Types/Serialiser/Error.pmnu ��6�$        =head1 NAME

Types::Serialiser::Error - dummy module for Types::Serialiser

=head1 SYNOPSIS

 # do not "use" yourself

=head1 DESCRIPTION

This module exists only to provide overload resolution for Storable and
similar modules that assume that class name equals module name. See
L<Types::Serialiser> for more info about this class.

=cut

use Types::Serialiser ();

=head1 AUTHOR

 Marc Lehmann <schmorp@schmorp.de>
 http://home.schmorp.de/

=cut

1

PK       ! ���y  y    perl5/HTML/Parse.pmnu ��6�$        package HTML::Parse;

use 5.008;

#ABSTRACT: Deprecated, a wrapper around HTML::TreeBuilder


use warnings;
use strict;

our $VERSION = '5.07'; # VERSION from OurPkgVersion

use vars qw(@ISA @EXPORT
    $IMPLICIT_TAGS $IGNORE_UNKNOWN $IGNORE_TEXT $WARN
);

require Exporter;
@ISA    = qw(Exporter);
@EXPORT = qw(parse_html parse_htmlfile);

# Backwards compatability
$IMPLICIT_TAGS  = 1;
$IGNORE_UNKNOWN = 1;
$IGNORE_TEXT    = 0;
$WARN           = 0;

require HTML::TreeBuilder;

sub parse_html {
    my $p = $_[1];
    $p = _new_tree_maker() unless $p;
    $p->parse( $_[0] );
}

sub parse_htmlfile {
    my ( $file, $p ) = @_;
    my ($HTML);
    open( $HTML, "<", $file ) or return;
    $p = _new_tree_maker() unless $p;
    $p->parse_file($HTML);
}

sub _new_tree_maker {
    my $p = HTML::TreeBuilder->new(
        implicit_tags  => $IMPLICIT_TAGS,
        ignore_unknown => $IGNORE_UNKNOWN,
        ignore_text    => $IGNORE_TEXT,
        'warn'         => $WARN,
    );
    $p->strict_comment(1);
    $p;
}

1;

__END__

=pod

=head1 NAME

HTML::Parse - Deprecated, a wrapper around HTML::TreeBuilder

=head1 VERSION

This document describes version 5.07 of
HTML::Parse, released August 31, 2017
as part of L<HTML-Tree|HTML::Tree>.

=head1 SYNOPSIS

  See the documentation for HTML::TreeBuilder

=head1 DESCRIPTION

Disclaimer: This module is provided only for backwards compatibility
with earlier versions of this library.  New code should I<not> use
this module, and should really use the HTML::Parser and
HTML::TreeBuilder modules directly, instead.

The C<HTML::Parse> module provides functions to parse HTML documents.
There are two functions exported by this module:

=over 4

=item parse_html($html) or parse_html($html, $obj)

This function is really just a synonym for $obj->parse($html) and $obj
is assumed to be a subclass of C<HTML::Parser>.  Refer to
L<HTML::Parser> for more documentation.

If $obj is not specified, the $obj will default to an internally
created new C<HTML::TreeBuilder> object configured with strict_comment()
turned on.  That class implements a parser that builds (and is) a HTML
syntax tree with HTML::Element objects as nodes.

The return value from parse_html() is $obj.

=item parse_htmlfile($file, [$obj])

Same as parse_html(), but pulls the HTML to parse, from the named file.

Returns C<undef> if the file could not be opened, or $obj otherwise.

=back

When a C<HTML::TreeBuilder> object is created, the following variables
control how parsing takes place:

=over 4

=item $HTML::Parse::IMPLICIT_TAGS

Setting this variable to true will instruct the parser to try to
deduce implicit elements and implicit end tags.  If this variable is
false you get a parse tree that just reflects the text as it stands.
Might be useful for quick & dirty parsing.  Default is true.

Implicit elements have the implicit() attribute set.

=item $HTML::Parse::IGNORE_UNKNOWN

This variable contols whether unknow tags should be represented as
elements in the parse tree.  Default is true.

=item $HTML::Parse::IGNORE_TEXT

Do not represent the text content of elements.  This saves space if
all you want is to examine the structure of the document.  Default is
false.

=item $HTML::Parse::WARN

Call warn() with an appropriate message for syntax errors.  Default is
false.

=back

=head1 REMEMBER!

HTML::TreeBuilder objects should be explicitly destroyed when you're
finished with them.  See L<HTML::TreeBuilder>.

=head1 SEE ALSO

L<HTML::Parser>, L<HTML::TreeBuilder>, L<HTML::Element>

=head1 AUTHOR

Current maintainers:

=over

=item * Christopher J. Madsen S<C<< <perl AT cjmweb.net> >>>

=item * Jeff Fearn S<C<< <jfearn AT cpan.org> >>>

=back

Original HTML-Tree author:

=over

=item * Gisle Aas

=back

Former maintainers:

=over

=item * Sean M. Burke

=item * Andy Lester

=item * Pete Krawczyk S<C<< <petek AT cpan.org> >>>

=back

You can follow or contribute to HTML-Tree's development at
L<< https://github.com/kentfredric/HTML-Tree >>.

=head1 COPYRIGHT AND LICENSE

Copyright 1995-1998 Gisle Aas, 1999-2004 Sean M. Burke,
2005 Andy Lester, 2006 Pete Krawczyk, 2010 Jeff Fearn,
2012 Christopher J. Madsen.

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

The programs in this library are distributed in the hope that they
will be useful, but without any warranty; without even the implied
warranty of merchantability or fitness for a particular purpose.

=cut
PK       ! �C�  �    perl5/HTML/Tree.pmnu ��6�$        package HTML::Tree;

# ABSTRACT: build and scan parse-trees of HTML

# HTML::Tree is basically just a happy alias to HTML::TreeBuilder.

use warnings;
use strict;

our $VERSION = '5.07'; # VERSION from OurPkgVersion

use HTML::TreeBuilder ();


sub new {
    shift;
    unshift @_, 'HTML::TreeBuilder';
    goto &HTML::TreeBuilder::new;
}

sub new_from_file {
    shift;
    unshift @_, 'HTML::TreeBuilder';
    goto &HTML::TreeBuilder::new_from_file;
}

sub new_from_content {
    shift;
    unshift @_, 'HTML::TreeBuilder';
    goto &HTML::TreeBuilder::new_from_content;
}

sub new_from_url {
    shift;
    unshift @_, 'HTML::TreeBuilder';
    goto &HTML::TreeBuilder::new_from_url;
}

1;

__END__

=pod

=head1 NAME

HTML::Tree - build and scan parse-trees of HTML

=head1 VERSION

This document describes version 5.07 of
HTML::Tree, released August 31, 2017
as part of L<HTML-Tree|HTML::Tree>.

=head1 SYNOPSIS

    use HTML::TreeBuilder;
    my $tree = HTML::TreeBuilder->new();
    $tree->parse_file($filename);

        # Then do something with the tree, using HTML::Element
        # methods -- for example:

    $tree->dump

        # Finally:

    $tree->delete;

=head1 DESCRIPTION

HTML-Tree is a suite of Perl modules for making parse trees out of
HTML source.  It consists of mainly two modules, whose documentation
you should refer to: L<HTML::TreeBuilder|HTML::TreeBuilder>
and L<HTML::Element|HTML::Element>.

HTML::TreeBuilder is the module that builds the parse trees.  (It uses
HTML::Parser to do the work of breaking the HTML up into tokens.)

The tree that TreeBuilder builds for you is made up of objects of the
class HTML::Element.

If you find that you do not properly understand the documentation
for HTML::TreeBuilder and HTML::Element, it may be because you are
unfamiliar with tree-shaped data structures, or with object-oriented
modules in general. Sean Burke has written some articles for
I<The Perl Journal> (C<www.tpj.com>) that seek to provide that background.
The full text of those articles is contained in this distribution, as:

=over 4

=item L<HTML::Tree::AboutObjects|HTML::Tree::AboutObjects>

"User's View of Object-Oriented Modules" from TPJ17.

=item L<HTML::Tree::AboutTrees|HTML::Tree::AboutTrees>

"Trees" from TPJ18

=item L<HTML::Tree::Scanning|HTML::Tree::Scanning>

"Scanning HTML" from TPJ19

=back

Readers already familiar with object-oriented modules and tree-shaped
data structures should read just the last article.  Readers without
that background should read the first, then the second, and then the
third.

=head1 METHODS

All these methods simply redirect to the corresponding method in
HTML::TreeBuilder.  It's more efficient to use HTML::TreeBuilder
directly, and skip loading HTML::Tree at all.

=head2 new

Redirects to L<HTML::TreeBuilder/new>.

=head2 new_from_file

Redirects to L<HTML::TreeBuilder/new_from_file>.

=head2 new_from_content

Redirects to L<HTML::TreeBuilder/new_from_content>.

=head2 new_from_url

Redirects to L<HTML::TreeBuilder/new_from_url>.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc HTML::Tree

    You can also look for information at:

=over 4

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/HTML-Tree>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/HTML-Tree>

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=HTML-Tree>

=item * Search CPAN

L<http://search.cpan.org/dist/HTML-Tree>

=item * Stack Overflow

L<http://stackoverflow.com/questions/tagged/html-tree>

If you have a question about how to use HTML-Tree, Stack Overflow is
the place to ask it.  Make sure you tag it both C<perl> and C<html-tree>.

=back

=head1 SEE ALSO

L<HTML::TreeBuilder>, L<HTML::Element>, L<HTML::Tagset>,
L<HTML::Parser>, L<HTML::DOMbo>

The book I<Perl & LWP> by Sean M. Burke published by
O'Reilly and Associates, 2002.  ISBN: 0-596-00178-9

It has several chapters to do with HTML processing in general,
and HTML-Tree specifically.  There's more info at:

    http://www.oreilly.com/catalog/perllwp/

    http://www.amazon.com/exec/obidos/ASIN/0596001789

=head1 SOURCE REPOSITORY

HTML-Tree is now maintained using Git.  The main public repository is
L<< https://github.com/kentfredric/HTML-Tree >>.

The best way to send a patch is to make a pull request there.

=head1 ACKNOWLEDGEMENTS

Thanks to Gisle Aas, Sean Burke and Andy Lester for their original work.

Thanks to Chicago Perl Mongers (http://chicago.pm.org) for their
patches submitted to HTML::Tree as part of the Phalanx project
(http://qa.perl.org/phalanx).

Thanks to the following people for additional patches and documentation:
Terrence Brannon, Gordon Lack, Chris Madsen and Ricardo Signes.

=head1 AUTHOR

Current maintainers:

=over

=item * Christopher J. Madsen S<C<< <perl AT cjmweb.net> >>>

=item * Jeff Fearn S<C<< <jfearn AT cpan.org> >>>

=back

Original HTML-Tree author:

=over

=item * Gisle Aas

=back

Former maintainers:

=over

=item * Sean M. Burke

=item * Andy Lester

=item * Pete Krawczyk S<C<< <petek AT cpan.org> >>>

=back

You can follow or contribute to HTML-Tree's development at
L<< https://github.com/kentfredric/HTML-Tree >>.

=head1 COPYRIGHT AND LICENSE

Copyright 1995-1998 Gisle Aas, 1999-2004 Sean M. Burke,
2005 Andy Lester, 2006 Pete Krawczyk, 2010 Jeff Fearn,
2012 Christopher J. Madsen.
(Except the articles contained in HTML::Tree::AboutObjects,
HTML::Tree::AboutTrees, and HTML::Tree::Scanning, which are all
copyright 2000 The Perl Journal.)

Except for those three TPJ articles, the whole HTML-Tree distribution,
of which this file is a part, is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.

Those three TPJ articles may be distributed under the same terms as
Perl itself.

The programs in this library are distributed in the hope that they
will be useful, but without any warranty; without even the implied
warranty of merchantability or fitness for a particular purpose.

=cut
PK       ! a@���'  �'    perl5/HTML/Element/traverse.pmnu ��6�$        
# This is a .pm just to (try to) make some CPAN document converters
#  convert it happily as part of the dist's documentation tree.
package HTML::Element::traverse;

# ABSTRACT: discussion of HTML::Element's traverse method

use warnings;
use strict;

our $VERSION = '5.07'; # VERSION from OurPkgVersion

use HTML::Element ();
1;

__END__

=pod

=head1 NAME

HTML::Element::traverse - discussion of HTML::Element's traverse method

=head1 VERSION

This document describes version 5.07 of
HTML::Element::traverse, released August 31, 2017
as part of L<HTML-Tree|HTML::Tree>.

=head1 SYNOPSIS

  # $element->traverse is unnecessary and obscure.
  #   Don't use it in new code.

=head1 DESCRIPTION

C<HTML::Element> provides a method C<traverse> that traverses the tree
and calls user-specified callbacks for each node, in pre- or
post-order.  However, use of the method is quite superfluous: if you
want to recursively visit every node in the tree, it's almost always
simpler to write a subroutine does just that, than it is to bundle up
the pre- and/or post-order code in callbacks for the C<traverse>
method.

=head1 EXAMPLES

Suppose you want to traverse at/under a node $tree and give elements
an 'id' attribute unless they already have one.

You can use the C<traverse> method:

  {
    my $counter = 'x0000';
    $start_node->traverse(
      [ # Callbacks;
        # pre-order callback:
        sub {
          my $x = $_[0];
          $x->attr('id', $counter++) unless defined $x->attr('id');
          return HTML::Element::OK; # keep traversing
        },
        # post-order callback:
        undef
      ],
      1, # don't call the callbacks for text nodes
    );
  }

or you can just be simple and clear (and not have to understand the
calling format for C<traverse>) by writing a sub that traverses the
tree by just calling itself:

  {
    my $counter = 'x0000';
    sub give_id {
      my $x = $_[0];
      $x->attr('id', $counter++) unless defined $x->attr('id');
      foreach my $c ($x->content_list) {
        give_id($c) if ref $c; # ignore text nodes
      }
    };
    give_id($start_node);
  }

See, isn't that nice and clear?

But, if you really need to know:

=head1 THE TRAVERSE METHOD

The C<traverse()> method is a general object-method for traversing a
tree or subtree and calling user-specified callbacks.  It accepts the
following syntaxes:

=over

=item $h->traverse(\&callback)

=item or $h->traverse(\&callback, $ignore_text)

=item or $h->traverse( [\&pre_callback,\&post_callback] , $ignore_text)

=back

These all mean to traverse the element and all of its children.  That
is, this method starts at node $h, "pre-order visits" $h, traverses its
children, and then will "post-order visit" $h.  "Visiting" means that
the callback routine is called, with these arguments:

    $_[0] : the node (element or text segment),
    $_[1] : a startflag, and
    $_[2] : the depth

If the $ignore_text parameter is given and true, then the pre-order
call I<will not> be happen for text content.

The startflag is 1 when we enter a node (i.e., in pre-order calls) and
0 when we leave the node (in post-order calls).

Note, however, that post-order calls don't happen for nodes that are
text segments or are elements that are prototypically empty (like "br",
"hr", etc.).

If we visit text nodes (i.e., unless $ignore_text is given and true),
then when text nodes are visited, we will also pass two extra
arguments to the callback:

    $_[3] : the element that's the parent
             of this text node
    $_[4] : the index of this text node
             in its parent's content list

Note that you can specify that the pre-order routine can
be a different routine from the post-order one:

    $h->traverse( [\&pre_callback,\&post_callback], ...);

You can also specify that no post-order calls are to be made,
by providing a false value as the post-order routine:

    $h->traverse([ \&pre_callback,0 ], ...);

And similarly for suppressing pre-order callbacks:

    $h->traverse([ 0,\&post_callback ], ...);

Note that these two syntaxes specify the same operation:

    $h->traverse([\&foo,\&foo], ...);
    $h->traverse( \&foo       , ...);

The return values from calls to your pre- or post-order
routines are significant, and are used to control recursion
into the tree.

These are the values you can return, listed in descending order
of my estimation of their usefulness:

=over

=item HTML::Element::OK, 1, or any other true value

...to keep on traversing.

Note that C<HTML::Element::OK> et
al are constants.  So if you're running under C<use strict>
(as I hope you are), and you say:
C<return HTML::Element::PRUEN>
the compiler will flag this as an error (an unallowable
bareword, specifically), whereas if you spell PRUNE correctly,
the compiler will not complain.

=item undef, 0, '0', '', or HTML::Element::PRUNE

...to block traversing under the current element's content.
(This is ignored if received from a post-order callback,
since by then the recursion has already happened.)
If this is returned by a pre-order callback, no
post-order callback for the current node will happen.
(Recall that if your callback exits with just C<return;>,
it is returning undef -- at least in scalar context, and
C<traverse> always calls your callbacks in scalar context.)

=item HTML::Element::ABORT

...to abort the whole traversal immediately.
This is often useful when you're looking for just the first
node in the tree that meets some criterion of yours.

=item HTML::Element::PRUNE_UP

...to abort continued traversal into this node and its parent
node.  No post-order callback for the current or parent
node will happen.

=item HTML::Element::PRUNE_SOFTLY

Like PRUNE, except that the post-order call for the current
node is not blocked.

=back

Almost every task to do with extracting information from a tree can be
expressed in terms of traverse operations (usually in only one pass,
and usually paying attention to only pre-order, or to only
post-order), or operations based on traversing. (In fact, many of the
other methods in this class are basically calls to traverse() with
particular arguments.)

The source code for HTML::Element and HTML::TreeBuilder contain
several examples of the use of the "traverse" method to gather
information about the content of trees and subtrees.

(Note: you should not change the structure of a tree I<while> you are
traversing it.)

[End of documentation for the C<traverse()> method]

=head2 Traversing with Recursive Anonymous Routines

Now, if you've been reading
I<Structure and Interpretation of Computer Programs> too much, maybe
you even want a recursive lambda.  Go ahead:

  {
    my $counter = 'x0000';
    my $give_id;
    $give_id = sub {
      my $x = $_[0];
      $x->attr('id', $counter++) unless defined $x->attr('id');
      foreach my $c ($x->content_list) {
        $give_id->($c) if ref $c; # ignore text nodes
      }
    };
    $give_id->($start_node);
    undef $give_id;
  }

It's a bit nutty, and it's I<still> more concise than a call to the
C<traverse> method!

It is left as an exercise to the reader to figure out how to do the
same thing without using a C<$give_id> symbol at all.

It is also left as an exercise to the reader to figure out why I
undefine C<$give_id>, above; and why I could achieved the same effect
with any of:

    $give_id = 'I like pie!';
   # or...
    $give_id = [];
   # or even;
    $give_id = sub { print "Mmmm pie!\n" };

But not:

    $give_id = sub { print "I'm $give_id and I like pie!\n" };
   # nor...
    $give_id = \$give_id;
   # nor...
    $give_id = { 'pie' => \$give_id, 'mode' => 'a la' };

=head2 Doing Recursive Things Iteratively

Note that you may at times see an iterative implementation of
pre-order traversal, like so:

   {
     my @to_do = ($tree); # start-node
     while(@to_do) {
       my $this = shift @to_do;

       # "Visit" the node:
       $this->attr('id', $counter++)
        unless defined $this->attr('id');

       unshift @to_do, grep ref $_, $this->content_list;
        # Put children on the stack -- they'll be visited next
     }
   }

This can I<under certain circumstances> be more efficient than just a
normal recursive routine, but at the cost of being rather obscure.  It
gains efficiency by avoiding the overhead of function-calling, but
since there are several method dispatches however you do it (to
C<attr> and C<content_list>), the overhead for a simple function call
is insignificant.

=head2 Pruning and Whatnot

The C<traverse> method does have the fairly neat features of
the C<ABORT>, C<PRUNE_UP> and C<PRUNE_SOFTLY> signals.  None of these
can be implemented I<totally> straightforwardly with recursive
routines, but it is quite possible.  C<ABORT>-like behavior can be
implemented either with using non-local returning with C<eval>/C<die>:

  my $died_on; # if you need to know where...
  sub thing {
    ... visits $_[0]...
    ... maybe set $died_on to $_[0] and die "ABORT_TRAV" ...
    ... else call thing($child) for each child...
    ...any post-order visiting $_[0]...
  }
  eval { thing($node) };
  if($@) {
    if($@ =~ m<^ABORT_TRAV>) {
      ...it died (aborted) on $died_on...
    } else {
      die $@; # some REAL error happened
    }
  }

or you can just do it with flags:

  my($abort_flag, $died_on);
  sub thing {
    ... visits $_[0]...
    ... maybe set $abort_flag = 1; $died_on = $_[0]; return;
    foreach my $c ($_[0]->content_list) {
      thing($c);
      return if $abort_flag;
    }
    ...any post-order visiting $_[0]...
    return;
  }

  $abort_flag = $died_on = undef;
  thing($node);
  ...if defined $abort_flag, it died on $died_on

=head1 SEE ALSO

L<HTML::Element>

=head1 AUTHOR

Current maintainers:

=over

=item * Christopher J. Madsen S<C<< <perl AT cjmweb.net> >>>

=item * Jeff Fearn S<C<< <jfearn AT cpan.org> >>>

=back

Original HTML-Tree author:

=over

=item * Gisle Aas

=back

Former maintainers:

=over

=item * Sean M. Burke

=item * Andy Lester

=item * Pete Krawczyk S<C<< <petek AT cpan.org> >>>

=back

You can follow or contribute to HTML-Tree's development at
L<< https://github.com/kentfredric/HTML-Tree >>.

=head1 COPYRIGHT

Copyright 2000,2001 Sean M. Burke

=cut
PK       ! ���H�F �F   perl5/HTML/TreeBuilder.pmnu ��6�$        package HTML::TreeBuilder;

# ABSTRACT: Parser that builds a HTML syntax tree

use warnings;
use strict;
use integer;    # vroom vroom!
use Carp ();

our $VERSION = '5.07'; # VERSION from OurPkgVersion

#---------------------------------------------------------------------------
# Make a 'DEBUG' constant...

our $DEBUG; # Must be set BEFORE loading this file
BEGIN {

    # We used to have things like
    #  print $indent, "lalala" if $Debug;
    # But there were an awful lot of having to evaluate $Debug's value.
    # If we make that depend on a constant, like so:
    #   sub DEBUG () { 1 } # or whatever value.
    #   ...
    #   print $indent, "lalala" if DEBUG;
    # Which at compile-time (thru the miracle of constant folding) turns into:
    #   print $indent, "lalala";
    # or, if DEBUG is a constant with a true value, then that print statement
    # is simply optimized away, and doesn't appear in the target code at all.
    # If you don't believe me, run:
    #    perl -MO=Deparse,-uHTML::TreeBuilder -e 'BEGIN { \
    #      $HTML::TreeBuilder::DEBUG = 4}  use HTML::TreeBuilder'
    # and see for yourself (substituting whatever value you want for $DEBUG
    # there).
## no critic
    if ( defined &DEBUG ) {

        # Already been defined!  Do nothing.
    }
    elsif ( $] < 5.00404 ) {

        # Grudgingly accomodate ancient (pre-constant) versions.
        eval 'sub DEBUG { $Debug } ';
    }
    elsif ( !$DEBUG ) {
        eval 'sub DEBUG () {0}';    # Make it a constant.
    }
    elsif ( $DEBUG =~ m<^\d+$>s ) {
        eval 'sub DEBUG () { ' . $DEBUG . ' }';    # Make THAT a constant.
    }
    else {                                         # WTF?
        warn "Non-numeric value \"$DEBUG\" in \$HTML::Element::DEBUG";
        eval 'sub DEBUG () { $DEBUG }';            # I guess.
    }
## use critic
}

#---------------------------------------------------------------------------

use HTML::Entities ();
use HTML::Tagset 3.02 ();

use HTML::Element ();
use HTML::Parser 3.46 ();
our @ISA = qw(HTML::Element HTML::Parser);

# This looks schizoid, I know.
# It's not that we ARE an element AND a parser.
# We ARE an element, but one that knows how to handle signals
#  (method calls) from Parser in order to elaborate its subtree.

# Legacy aliases:
*HTML::TreeBuilder::isKnown             = \%HTML::Tagset::isKnown;
*HTML::TreeBuilder::canTighten          = \%HTML::Tagset::canTighten;
*HTML::TreeBuilder::isHeadElement       = \%HTML::Tagset::isHeadElement;
*HTML::TreeBuilder::isBodyElement       = \%HTML::Tagset::isBodyElement;
*HTML::TreeBuilder::isPhraseMarkup      = \%HTML::Tagset::isPhraseMarkup;
*HTML::TreeBuilder::isHeadOrBodyElement = \%HTML::Tagset::isHeadOrBodyElement;
*HTML::TreeBuilder::isList              = \%HTML::Tagset::isList;
*HTML::TreeBuilder::isTableElement      = \%HTML::Tagset::isTableElement;
*HTML::TreeBuilder::isFormElement       = \%HTML::Tagset::isFormElement;
*HTML::TreeBuilder::p_closure_barriers  = \@HTML::Tagset::p_closure_barriers;

#==========================================================================
# Two little shortcut constructors:

sub new_from_file {    # or from a FH
    my $class = shift;
    Carp::croak("new_from_file takes only one argument")
        unless @_ == 1;
    Carp::croak("new_from_file is a class method only")
        if ref $class;
    my $new = $class->new();
    defined $new->parse_file( $_[0] )
        or Carp::croak("unable to parse file: $!");
    return $new;
}

sub new_from_content {    # from any number of scalars
    my $class = shift;
    Carp::croak("new_from_content is a class method only")
        if ref $class;
    my $new = $class->new();
    foreach my $whunk (@_) {
        if ( ref($whunk) eq 'SCALAR' ) {
            $new->parse($$whunk);
        }
        else {
            $new->parse($whunk);
        }
        last if $new->{'_stunted'};    # might as well check that.
    }
    $new->eof();
    return $new;
}

sub new_from_url {                     # should accept anything that LWP does.
    undef our $lwp_response;
    my $class = shift;
    Carp::croak("new_from_url takes only one argument")
        unless @_ == 1;
    Carp::croak("new_from_url is a class method only")
        if ref $class;
    my $url = shift;
    my $new = $class->new();

    require LWP::UserAgent;
    # RECOMMEND PREREQ: LWP::UserAgent 5.815
    LWP::UserAgent->VERSION( 5.815 ); # HTTP::Headers content_is_html method
    $lwp_response = LWP::UserAgent->new->get( $url );

    Carp::croak("GET failed on $url: " . $lwp_response->status_line)
          unless $lwp_response->is_success;
    Carp::croak("$url returned " . $lwp_response->content_type . " not HTML")
          unless $lwp_response->content_is_html;

    $new->parse( $lwp_response->decoded_content );
    $new->eof;
    undef $lwp_response;        # Processed successfully
    return $new;
}

# TODO: document more fully?
sub parse_content {    # from any number of scalars
    my $tree = shift;
    my $retval;
    foreach my $whunk (@_) {
        if ( ref($whunk) eq 'SCALAR' ) {
            $retval = $tree->parse($$whunk);
        }
        else {
            $retval = $tree->parse($whunk);
        }
        last if $tree->{'_stunted'};    # might as well check that.
    }
    $tree->eof();
    return $retval;
}

#---------------------------------------------------------------------------

sub new {                               # constructor!
    my $class = shift;
    $class = ref($class) || $class;

    # Initialize HTML::Element part
    my $self = $class->element_class->new('html');

    {

        # A hack for certain strange versions of Parser:
        my $other_self = HTML::Parser->new();
        %$self = ( %$self, %$other_self );    # copy fields
           # Yes, multiple inheritance is messy.  Kids, don't try this at home.
        bless $other_self, "HTML::TreeBuilder::_hideyhole";

        # whack it out of the HTML::Parser class, to avoid the destructor
    }

    # The root of the tree is special, as it has these funny attributes,
    # and gets reblessed into this class.

    # Initialize parser settings
    $self->{'_implicit_tags'}       = 1;
    $self->{'_implicit_body_p_tag'} = 0;

    # If true, trying to insert text, or any of %isPhraseMarkup right
    #  under 'body' will implicate a 'p'.  If false, will just go there.

    $self->{'_tighten'} = 1;

    # whether ignorable WS in this tree should be deleted

    $self->{'_implicit'} = 1; # to delete, once we find a real open-"html" tag

    $self->{'_ignore_unknown'}      = 1;
    $self->{'_ignore_text'}         = 0;
    $self->{'_warn'}                = 0;
    $self->{'_no_space_compacting'} = 0;
    $self->{'_store_comments'}      = 0;
    $self->{'_store_declarations'}  = 1;
    $self->{'_store_pis'}           = 0;
    $self->{'_p_strict'}            = 0;
    $self->{'_no_expand_entities'}  = 0;

    # Parse attributes passed in as arguments
    if (@_) {
        my %attr = @_;
        for ( keys %attr ) {
            $self->{"_$_"} = $attr{$_};
        }
    }

    $HTML::Element::encoded_content = $self->{'_no_expand_entities'};

    # rebless to our class
    bless $self, $class;

    $self->{'_element_count'} = 1;

    # undocumented, informal, and maybe not exactly correct

    $self->{'_head'} = $self->insert_element( 'head', 1 );
    $self->{'_pos'}  = undef;                                # pull it back up
    $self->{'_body'} = $self->insert_element( 'body', 1 );
    $self->{'_pos'} = undef;    # pull it back up again

    return $self;
}

#==========================================================================

sub _elem                       # universal accessor...
{
    my ( $self, $elem, $val ) = @_;
    my $old = $self->{$elem};
    $self->{$elem} = $val if defined $val;
    return $old;
}

# accessors....
sub implicit_tags       { shift->_elem( '_implicit_tags',       @_ ); }
sub implicit_body_p_tag { shift->_elem( '_implicit_body_p_tag', @_ ); }
sub p_strict            { shift->_elem( '_p_strict',            @_ ); }
sub no_space_compacting { shift->_elem( '_no_space_compacting', @_ ); }
sub ignore_unknown      { shift->_elem( '_ignore_unknown',      @_ ); }
sub ignore_text         { shift->_elem( '_ignore_text',         @_ ); }
sub ignore_ignorable_whitespace { shift->_elem( '_tighten',            @_ ); }
sub store_comments              { shift->_elem( '_store_comments',     @_ ); }
sub store_declarations          { shift->_elem( '_store_declarations', @_ ); }
sub store_pis                   { shift->_elem( '_store_pis',          @_ ); }
sub warn                        { shift->_elem( '_warn',               @_ ); }

sub no_expand_entities {
    shift->_elem( '_no_expand_entities', @_ );
    $HTML::Element::encoded_content = @_;
}

#==========================================================================

sub warning {
    my $self = shift;
    CORE::warn("HTML::Parse: $_[0]\n") if $self->{'_warn'};

    # should maybe say HTML::TreeBuilder instead
}

#==========================================================================

{

    # To avoid having to rebuild these lists constantly...
    my $_Closed_by_structurals = [qw(p h1 h2 h3 h4 h5 h6 pre textarea)];
    my $indent;

    sub start {
        return if $_[0]{'_stunted'};

        # Accept a signal from HTML::Parser for start-tags.
        my ( $self, $tag, $attr ) = @_;

        # Parser passes more, actually:
        #   $self->start($tag, $attr, $attrseq, $origtext)
        # But we can merrily ignore $attrseq and $origtext.

        if ( $tag eq 'x-html' ) {
            print "Ignoring open-x-html tag.\n" if DEBUG;

            # inserted by some lame code-generators.
            return;    # bypass tweaking.
        }

        $tag =~ s{/$}{}s;    # So <b/> turns into <b>.  Silently forgive.

        unless ( $tag =~ m/^[-_a-zA-Z0-9:%]+$/s ) {
            DEBUG and print "Start-tag name $tag is no good.  Skipping.\n";
            return;

            # This avoids having Element's new() throw an exception.
        }

        my $ptag = ( my $pos = $self->{'_pos'} || $self )->{'_tag'};
        my $already_inserted;

        #my($indent);
        if (DEBUG) {

       # optimization -- don't figure out indenting unless we're in debug mode
            my @lineage = $pos->lineage;
            $indent = '  ' x ( 1 + @lineage );
            print $indent, "Proposing a new \U$tag\E under ",
                join( '/', map $_->{'_tag'}, reverse( $pos, @lineage ) )
                || 'Root',
                ".\n";

            #} else {
            #  $indent = ' ';
        }

        #print $indent, "POS: $pos ($ptag)\n" if DEBUG > 2;
        # $attr = {%$attr};

        foreach my $k ( keys %$attr ) {

            # Make sure some stooge doesn't have "<span _content='pie'>".
            # That happens every few million Web pages.
            $attr->{ ' ' . $k } = delete $attr->{$k}
                if length $k and substr( $k, 0, 1 ) eq '_';

            # Looks bad, but is fine for round-tripping.
        }

        my $e = $self->element_class->new( $tag, %$attr );

        # Make a new element object.
        # (Only rarely do we end up just throwing it away later in this call.)

      # Some prep -- custom messiness for those damned tables, and strict P's.
        if ( $self->{'_implicit_tags'} ) {    # wallawallawalla!

            unless ( $HTML::TreeBuilder::isTableElement{$tag} ) {
                if ( $ptag eq 'table' ) {
                    print $indent,
                        " * Phrasal \U$tag\E right under TABLE makes implicit TR and TD\n"
                        if DEBUG > 1;
                    $self->insert_element( 'tr', 1 );
                    $pos = $self->insert_element( 'td', 1 )
                        ;                     # yes, needs updating
                }
                elsif ( $ptag eq 'tr' ) {
                    print $indent,
                        " * Phrasal \U$tag\E right under TR makes an implicit TD\n"
                        if DEBUG > 1;
                    $pos = $self->insert_element( 'td', 1 )
                        ;                     # yes, needs updating
                }
                $ptag = $pos->{'_tag'};       # yes, needs updating
            }

            # end of table-implication block.

            # Now maybe do a little dance to enforce P-strictness.
            # This seems like it should be integrated with the big
            # "ALL HOPE..." block, further below, but that doesn't
            # seem feasable.
            if (    $self->{'_p_strict'}
                and $HTML::TreeBuilder::isKnown{$tag}
                and not $HTML::Tagset::is_Possible_Strict_P_Content{$tag} )
            {
                my $here     = $pos;
                my $here_tag = $ptag;
                while (1) {
                    if ( $here_tag eq 'p' ) {
                        print $indent, " * Inserting $tag closes strict P.\n"
                            if DEBUG > 1;
                        $self->end( \q{p} );

                    # NB: same as \'q', but less confusing to emacs cperl-mode
                        last;
                    }

                    #print("Lasting from $here_tag\n"),
                    last
                        if $HTML::TreeBuilder::isKnown{$here_tag}
                            and
                            not $HTML::Tagset::is_Possible_Strict_P_Content{
                                $here_tag};

               # Don't keep looking up the tree if we see something that can't
               #  be strict-P content.

                    $here_tag
                        = ( $here = $here->{'_parent'} || last )->{'_tag'};
                }    # end while
                $ptag = ( $pos = $self->{'_pos'} || $self )
                    ->{'_tag'};    # better update!
            }

            # end of strict-p block.
        }

       # And now, get busy...
       #----------------------------------------------------------------------
        if ( !$self->{'_implicit_tags'} ) {    # bimskalabim
                                               # do nothing
            print $indent, " * _implicit_tags is off.  doing nothing\n"
                if DEBUG > 1;

       #----------------------------------------------------------------------
        }
        elsif ( $HTML::TreeBuilder::isHeadOrBodyElement{$tag} ) {
            if ( $pos->is_inside('body') ) {    # all is well
                print $indent,
                    " * ambilocal element \U$tag\E is fine under BODY.\n"
                    if DEBUG > 1;
            }
            elsif ( $pos->is_inside('head') ) {
                print $indent,
                    " * ambilocal element \U$tag\E is fine under HEAD.\n"
                    if DEBUG > 1;
            }
            else {

                # In neither head nor body!  mmmmm... put under head?

                if ( $ptag eq 'html' ) {    # expected case
                     # TODO?? : would there ever be a case where _head would be
                     #  absent from a tree that would ever be accessed at this
                     #  point?
                    die "Where'd my head go?" unless ref $self->{'_head'};
                    if ( $self->{'_head'}{'_implicit'} ) {
                        print $indent,
                            " * ambilocal element \U$tag\E makes an implicit HEAD.\n"
                            if DEBUG > 1;

                        # or rather, points us at it.
                        $self->{'_pos'}
                            = $self->{'_head'};    # to insert under...
                    }
                    else {
                        $self->warning(
                            "Ambilocal element <$tag> not under HEAD or BODY!?"
                        );

                        # Put it under HEAD by default, I guess
                        $self->{'_pos'}
                            = $self->{'_head'};    # to insert under...
                    }

                }
                else {

             # Neither under head nor body, nor right under html... pass thru?
                    $self->warning(
                        "Ambilocal element <$tag> neither under head nor body, nor right under html!?"
                    );
                }
            }

       #----------------------------------------------------------------------
        }
        elsif ( $HTML::TreeBuilder::isBodyElement{$tag} ) {

            # Ensure that we are within <body>
            if ( $ptag eq 'body' ) {

                # We're good.
            }
            elsif (
                $HTML::TreeBuilder::isBodyElement{$ptag}    # glarg
                and not $HTML::TreeBuilder::isHeadOrBodyElement{$ptag}
                )
            {

              # Special case: Save ourselves a call to is_inside further down.
              # If our $ptag is an isBodyElement element (but not an
              # isHeadOrBodyElement element), then we must be under body!
                print $indent, " * Inferring that $ptag is under BODY.\n",
                    if DEBUG > 3;

                # I think this and the test for 'body' trap everything
                # bodyworthy, except the case where the parent element is
                # under an unknown element that's a descendant of body.
            }
            elsif ( $pos->is_inside('head') ) {
                print $indent,
                    " * body-element \U$tag\E minimizes HEAD, makes implicit BODY.\n"
                    if DEBUG > 1;
                $ptag = (
                    $pos = $self->{'_pos'}
                        = $self->{'_body'}    # yes, needs updating
                        || die "Where'd my body go?"
                )->{'_tag'};                  # yes, needs updating
            }
            elsif ( !$pos->is_inside('body') ) {
                print $indent,
                    " * body-element \U$tag\E makes implicit BODY.\n"
                    if DEBUG > 1;
                $ptag = (
                    $pos = $self->{'_pos'}
                        = $self->{'_body'}    # yes, needs updating
                        || die "Where'd my body go?"
                )->{'_tag'};                  # yes, needs updating
            }

            # else we ARE under body, so okay.

            # Handle implicit endings and insert based on <tag> and position
            # ... ALL HOPE ABANDON ALL YE WHO ENTER HERE ...
            if (   $tag eq 'p'
                or $tag eq 'h1'
                or $tag eq 'h2'
                or $tag eq 'h3'
                or $tag eq 'h4'
                or $tag eq 'h5'
                or $tag eq 'h6'
                or $tag eq 'form'

                # Hm, should <form> really be here?!
                )
            {

                # Can't have <p>, <h#> or <form> inside these
                $self->end(
                    $_Closed_by_structurals,
                    @HTML::TreeBuilder::p_closure_barriers

                        # used to be just li!
                );

            }
            elsif ( $tag eq 'ol' or $tag eq 'ul' or $tag eq 'dl' ) {

                # Can't have lists inside <h#> -- in the unlikely
                #  event anyone tries to put them there!
                if (   $ptag eq 'h1'
                    or $ptag eq 'h2'
                    or $ptag eq 'h3'
                    or $ptag eq 'h4'
                    or $ptag eq 'h5'
                    or $ptag eq 'h6' )
                {
                    $self->end( \$ptag );
                }

                # TODO: Maybe keep closing up the tree until
                #  the ptag isn't any of the above?
                # But anyone that says <h1><h2><ul>...
                #  deserves what they get anyway.

            }
            elsif ( $tag eq 'li' ) {    # list item
                    # Get under a list tag, one way or another
                unless (
                    exists $HTML::TreeBuilder::isList{$ptag}
                    or $self->end( \q{*}, keys %HTML::TreeBuilder::isList ) #'
                    )
                {
                    print $indent,
                        " * inserting implicit UL for lack of containing ",
                        join( '|', keys %HTML::TreeBuilder::isList ), ".\n"
                        if DEBUG > 1;
                    $self->insert_element( 'ul', 1 );
                }

            }
            elsif ( $tag eq 'dt' or $tag eq 'dd' ) {

                # Get under a DL, one way or another
                unless ( $ptag eq 'dl' or $self->end( \q{*}, 'dl' ) ) {    #'
                    print $indent,
                        " * inserting implicit DL for lack of containing DL.\n"
                        if DEBUG > 1;
                    $self->insert_element( 'dl', 1 );
                }

            }
            elsif ( $HTML::TreeBuilder::isFormElement{$tag} ) {
                if ($self->{
                        '_ignore_formies_outside_form'}  # TODO: document this
                    and not $pos->is_inside('form')
                    )
                {
                    print $indent,
                        " * ignoring \U$tag\E because not in a FORM.\n"
                        if DEBUG > 1;
                    return;                              # bypass tweaking.
                }
                if ( $tag eq 'option' ) {

                    # return unless $ptag eq 'select';
                    $self->end( \q{option} );
                    $ptag = ( $self->{'_pos'} || $self )->{'_tag'};
                    unless ( $ptag eq 'select' or $ptag eq 'optgroup' ) {
                        print $indent,
                            " * \U$tag\E makes an implicit SELECT.\n"
                            if DEBUG > 1;
                        $pos = $self->insert_element( 'select', 1 );

                    # but not a very useful select -- has no 'name' attribute!
                    # is $pos's value used after this?
                    }
                }
            }
            elsif ( $HTML::TreeBuilder::isTableElement{$tag} ) {
                if ( !$pos->is_inside('table') ) {
                    print $indent, " * \U$tag\E makes an implicit TABLE\n"
                        if DEBUG > 1;
                    $self->insert_element( 'table', 1 );
                }

                if ( $tag eq 'td' or $tag eq 'th' ) {

                    # Get under a tr one way or another
                    unless (
                        $ptag eq 'tr'    # either under a tr
                        or $self->end( \q{*}, 'tr',
                            'table' )    #or we can get under one
                        )
                    {
                        print $indent,
                            " * \U$tag\E under \U$ptag\E makes an implicit TR\n"
                            if DEBUG > 1;
                        $self->insert_element( 'tr', 1 );

                        # presumably pos's value isn't used after this.
                    }
                }
                else {
                    $self->end( \$tag, 'table' );    #'
                }

                # Hmm, I guess this is right.  To work it out:
                #   tr closes any open tr (limited at a table)
                #   thead closes any open thead (limited at a table)
                #   tbody closes any open tbody (limited at a table)
                #   tfoot closes any open tfoot (limited at a table)
                #   colgroup closes any open colgroup (limited at a table)
                #   col can try, but will always fail, at the enclosing table,
                #     as col is empty, and therefore never open!
                # But!
                #   td closes any open td OR th (limited at a table)
                #   th closes any open th OR td (limited at a table)
                #   ...implementable as "close to a tr, or make a tr"

            }
            elsif ( $HTML::TreeBuilder::isPhraseMarkup{$tag} ) {
                if ( $ptag eq 'body' and $self->{'_implicit_body_p_tag'} ) {
                    print
                        " * Phrasal \U$tag\E right under BODY makes an implicit P\n"
                        if DEBUG > 1;
                    $pos = $self->insert_element( 'p', 1 );

                    # is $pos's value used after this?
                }
            }

            # End of implicit endings logic

       # End of "elsif ($HTML::TreeBuilder::isBodyElement{$tag}"
       #----------------------------------------------------------------------

        }
        elsif ( $HTML::TreeBuilder::isHeadElement{$tag} ) {
            if ( $pos->is_inside('body') ) {
                print $indent, " * head element \U$tag\E found inside BODY!\n"
                    if DEBUG;
                $self->warning("Header element <$tag> in body");    # [sic]
            }
            elsif ( !$pos->is_inside('head') ) {
                print $indent,
                    " * head element \U$tag\E makes an implicit HEAD.\n"
                    if DEBUG > 1;
            }
            else {
                print $indent,
                    " * head element \U$tag\E goes inside existing HEAD.\n"
                    if DEBUG > 1;
            }
            $self->{'_pos'} = $self->{'_head'} || die "Where'd my head go?";

       #----------------------------------------------------------------------
        }
        elsif ( $tag eq 'html' ) {
            if ( delete $self->{'_implicit'} ) {    # first time here
                print $indent, " * good! found the real HTML element!\n"
                    if DEBUG > 1;
            }
            else {
                print $indent, " * Found a second HTML element\n"
                    if DEBUG;
                $self->warning("Found a nested <html> element");
            }

            # in either case, migrate attributes to the real element
            for ( keys %$attr ) {
                $self->attr( $_, $attr->{$_} );
            }
            $self->{'_pos'} = undef;
            return $self;    # bypass tweaking.

       #----------------------------------------------------------------------
        }
        elsif ( $tag eq 'head' ) {
            my $head = $self->{'_head'} || die "Where'd my head go?";
            if ( delete $head->{'_implicit'} ) {    # first time here
                print $indent, " * good! found the real HEAD element!\n"
                    if DEBUG > 1;
            }
            else {                                  # been here before
                print $indent, " * Found a second HEAD element\n"
                    if DEBUG;
                $self->warning("Found a second <head> element");
            }

            # in either case, migrate attributes to the real element
            for ( keys %$attr ) {
                $head->attr( $_, $attr->{$_} );
            }
            return $self->{'_pos'} = $head;         # bypass tweaking.

       #----------------------------------------------------------------------
        }
        elsif ( $tag eq 'body' ) {
            my $body = $self->{'_body'} || die "Where'd my body go?";
            if ( delete $body->{'_implicit'} ) {    # first time here
                print $indent, " * good! found the real BODY element!\n"
                    if DEBUG > 1;
            }
            else {                                  # been here before
                print $indent, " * Found a second BODY element\n"
                    if DEBUG;
                $self->warning("Found a second <body> element");
            }

            # in either case, migrate attributes to the real element
            for ( keys %$attr ) {
                $body->attr( $_, $attr->{$_} );
            }
            return $self->{'_pos'} = $body;         # bypass tweaking.

       #----------------------------------------------------------------------
        }
        elsif ( $tag eq 'frameset' ) {
            if (!( $self->{'_frameset_seen'}++ )    # first frameset seen
                and !$self->{'_noframes_seen'}

                # otherwise it'll be under the noframes already
                and !$self->is_inside('body')
                )
            {

           # The following is a bit of a hack.  We don't use the normal
           #  insert_element because 1) we don't want it as _pos, but instead
           #  right under $self, and 2), more importantly, that we don't want
           #  this inserted at the /end/ of $self's content_list, but instead
           #  in the middle of it, specifically right before the body element.
           #
                my $c    = $self->{'_content'} || die "Contentless root?";
                my $body = $self->{'_body'}    || die "Where'd my BODY go?";
                for ( my $i = 0; $i < @$c; ++$i ) {
                    if ( $c->[$i] eq $body ) {
                        splice( @$c, $i, 0, $self->{'_pos'} = $pos = $e );
                        HTML::Element::_weaken($e->{'_parent'} = $self);
                        $already_inserted = 1;
                        print $indent,
                            " * inserting 'frameset' right before BODY.\n"
                            if DEBUG > 1;
                        last;
                    }
                }
                die "BODY not found in children of root?"
                    unless $already_inserted;
            }

        }
        elsif ( $tag eq 'frame' ) {

            # Okay, fine, pass thru.
            # Should probably enforce that these should be under a frameset.
            # But hey.  Ditto for enforcing that 'noframes' should be under
            # a 'frameset', as the DTDs say.

        }
        elsif ( $tag eq 'noframes' ) {

           # This basically assumes there'll be exactly one 'noframes' element
           #  per document.  At least, only the first one gets to have the
           #  body under it.  And if there are no noframes elements, then
           #  the body pretty much stays where it is.  Is that ever a problem?
            if ( $self->{'_noframes_seen'}++ ) {
                print $indent, " * ANOTHER noframes element?\n" if DEBUG;
            }
            else {
                if ( $pos->is_inside('body') ) {
                    print $indent, " * 'noframes' inside 'body'.  Odd!\n"
                        if DEBUG;

               # In that odd case, we /can't/ make body a child of 'noframes',
               # because it's an ancestor of the 'noframes'!
                }
                else {
                    $e->push_content( $self->{'_body'}
                            || die "Where'd my body go?" );
                    print $indent, " * Moving body to be under noframes.\n"
                        if DEBUG;
                }
            }

       #----------------------------------------------------------------------
        }
        else {

            # unknown tag
            if ( $self->{'_ignore_unknown'} ) {
                print $indent, " * Ignoring unknown tag \U$tag\E\n" if DEBUG;
                $self->warning("Skipping unknown tag $tag");
                return;
            }
            else {
                print $indent, " * Accepting unknown tag \U$tag\E\n"
                    if DEBUG;
            }
        }

       #----------------------------------------------------------------------
       # End of mumbo-jumbo

        print $indent, "(Attaching ", $e->{'_tag'}, " under ",
            ( $self->{'_pos'} || $self )->{'_tag'}, ")\n"

            # because if _pos isn't defined, it goes under self
            if DEBUG;

        # The following if-clause is to delete /some/ ignorable whitespace
        #  nodes, as we're making the tree.
        # This'd be a node we'd catch later anyway, but we might as well
        #  nip it in the bud now.
        # This doesn't catch /all/ deletable WS-nodes, so we do have to call
        #  the tightener later to catch the rest.

        if ( $self->{'_tighten'} and !$self->{'_ignore_text'} )
        {    # if tightenable
            my ( $sibs, $par );
            if (( $sibs = ( $par = $self->{'_pos'} || $self )->{'_content'} )
                and @$sibs            # parent already has content
                and !
                ref( $sibs->[-1] )    # and the last one there is a text node
                and $sibs->[-1] !~ m<[^\n\r\f\t ]>s  # and it's all whitespace

                and (    # one of these has to be eligible...
                    $HTML::TreeBuilder::canTighten{$tag}
                    or (( @$sibs == 1 )
                        ?    # WS is leftmost -- so parent matters
                        $HTML::TreeBuilder::canTighten{ $par->{'_tag'} }
                        :    # WS is after another node -- it matters
                        (   ref $sibs->[-2]
                                and
                                $HTML::TreeBuilder::canTighten{ $sibs->[-2]
                                    {'_tag'} }
                        )
                    )
                )

                and !$par->is_inside( 'pre', 'xmp', 'textarea', 'plaintext' )

                # we're clear
                )
            {
                pop @$sibs;
                print $indent, "Popping a preceding all-WS node\n" if DEBUG;
            }
        }

        $self->insert_element($e) unless $already_inserted;

        if (DEBUG) {
            if ( $self->{'_pos'} ) {
                print $indent, "(Current lineage of pos:  \U$tag\E under ",
                    join(
                    '/',
                    reverse(

                        # $self->{'_pos'}{'_tag'},  # don't list myself!
                        $self->{'_pos'}->lineage_tag_names
                    )
                    ),
                    ".)\n";
            }
            else {
                print $indent, "(Pos points nowhere!?)\n";
            }
        }

        unless ( ( $self->{'_pos'} || '' ) eq $e ) {

            # if it's an empty element -- i.e., if it didn't change the _pos
            &{         $self->{"_tweak_$tag"}
                    || $self->{'_tweak_*'}
                    || return $e }( map $_, $e, $tag, $self )
                ;    # make a list so the user can't clobber
        }

        return $e;
    }
}

#==========================================================================

{
    my $indent;

    sub end {
        return if $_[0]{'_stunted'};

       # Either: Acccept an end-tag signal from HTML::Parser
       # Or: Method for closing currently open elements in some fairly complex
       #  way, as used by other methods in this class.
        my ( $self, $tag, @stop ) = @_;
        if ( $tag eq 'x-html' ) {
            print "Ignoring close-x-html tag.\n" if DEBUG;

            # inserted by some lame code-generators.
            return;
        }

        unless ( ref($tag) or $tag =~ m/^[-_a-zA-Z0-9:%]+$/s ) {
            DEBUG and print "End-tag name $tag is no good.  Skipping.\n";
            return;

            # This avoids having Element's new() throw an exception.
        }

       # This method accepts two calling formats:
       #  1) from Parser:  $self->end('tag_name', 'origtext')
       #        in which case we shouldn't mistake origtext as a blocker tag
       #  2) from myself:  $self->end(\q{tagname1}, 'blk1', ... )
       #     from myself:  $self->end(['tagname1', 'tagname2'], 'blk1',  ... )

        # End the specified tag, but don't move above any of the blocker tags.
        # The tag can also be a reference to an array.  Terminate the first
        # tag found.

        my $ptag = ( my $p = $self->{'_pos'} || $self )->{'_tag'};

        # $p and $ptag are sort-of stratch

        if ( ref($tag) ) {

            # First param is a ref of one sort or another --
            #  THE CALL IS COMING FROM INSIDE THE HOUSE!
            $tag = $$tag if ref($tag) eq 'SCALAR';

            # otherwise it's an arrayref.
        }
        else {

            # the call came from Parser -- just ignore origtext
            # except in a table ignore unmatched table tags RT #59980
            @stop = $tag =~ /^t[hdr]\z/ ? 'table' : ();
        }

        #my($indent);
        if (DEBUG) {

           # optimization -- don't figure out depth unless we're in debug mode
            my @lineage_tags = $p->lineage_tag_names;
            $indent = '  ' x ( 1 + @lineage_tags );

            # now announce ourselves
            print $indent, "Ending ",
                ref($tag) ? ( '[', join( ' ', @$tag ), ']' ) : "\U$tag\E",
                scalar(@stop)
                ? ( " no higher than [", join( ' ', @stop ), "]" )
                : (), ".\n";

            print $indent, " (Current lineage: ", join( '/', @lineage_tags ),
                ".)\n"
                if DEBUG > 1;

            if ( DEBUG > 3 ) {

                #my(
                # $package, $filename, $line, $subroutine,
                # $hasargs, $wantarray, $evaltext, $is_require) = caller;
                print $indent,
                    " (Called from ", ( caller(1) )[3], ' line ',
                    ( caller(1) )[2],
                    ")\n";
            }

            #} else {
            #  $indent = ' ';
        }

        # End of if DEBUG

        # Now actually do it
        my @to_close;
        if ( $tag eq '*' ) {

        # Special -- close everything up to (but not including) the first
        #  limiting tag, or return if none found.  Somewhat of a special case.
        PARENT:
            while ( defined $p ) {
                $ptag = $p->{'_tag'};
                print $indent, " (Looking at $ptag.)\n" if DEBUG > 2;
                for (@stop) {
                    if ( $ptag eq $_ ) {
                        print $indent,
                            " (Hit a $_; closing everything up to here.)\n"
                            if DEBUG > 2;
                        last PARENT;
                    }
                }
                push @to_close, $p;
                $p = $p->{'_parent'};    # no match so far? keep moving up
                print $indent,
                    " (Moving on up to ", $p ? $p->{'_tag'} : 'nil', ")\n"
                    if DEBUG > 1;
            }
            unless ( defined $p ) { # We never found what we were looking for.
                print $indent, " (We never found a limit.)\n" if DEBUG > 1;
                return;
            }

            #print
            #   $indent,
            #   " (To close: ", join('/', map $_->tag, @to_close), ".)\n"
            #  if DEBUG > 4;

            # Otherwise update pos and fall thru.
            $self->{'_pos'} = $p;
        }
        elsif ( ref $tag ) {

           # Close the first of any of the matching tags, giving up if you hit
           #  any of the stop-tags.
        PARENT:
            while ( defined $p ) {
                $ptag = $p->{'_tag'};
                print $indent, " (Looking at $ptag.)\n" if DEBUG > 2;
                for (@$tag) {
                    if ( $ptag eq $_ ) {
                        print $indent, " (Closing $_.)\n" if DEBUG > 2;
                        last PARENT;
                    }
                }
                for (@stop) {
                    if ( $ptag eq $_ ) {
                        print $indent,
                            " (Hit a limiting $_ -- bailing out.)\n"
                            if DEBUG > 1;
                        return;    # so it was all for naught
                    }
                }
                push @to_close, $p;
                $p = $p->{'_parent'};
            }
            return unless defined $p;    # We went off the top of the tree.
               # Otherwise specified element was found; set pos to its parent.
            push @to_close, $p;
            $self->{'_pos'} = $p->{'_parent'};
        }
        else {

            # Close the first of the specified tag, giving up if you hit
            #  any of the stop-tags.
            while ( defined $p ) {
                $ptag = $p->{'_tag'};
                print $indent, " (Looking at $ptag.)\n" if DEBUG > 2;
                if ( $ptag eq $tag ) {
                    print $indent, " (Closing $tag.)\n" if DEBUG > 2;
                    last;
                }
                for (@stop) {
                    if ( $ptag eq $_ ) {
                        print $indent,
                            " (Hit a limiting $_ -- bailing out.)\n"
                            if DEBUG > 1;
                        return;    # so it was all for naught
                    }
                }
                push @to_close, $p;
                $p = $p->{'_parent'};
            }
            return unless defined $p;    # We went off the top of the tree.
               # Otherwise specified element was found; set pos to its parent.
            push @to_close, $p;
            $self->{'_pos'} = $p->{'_parent'};
        }

        $self->{'_pos'} = undef if $self eq ( $self->{'_pos'} || '' );
        print $indent, "(Pos now points to ",
            $self->{'_pos'} ? $self->{'_pos'}{'_tag'} : '???', ".)\n"
            if DEBUG > 1;

        ### EXPENSIVE, because has to check that it's not under a pre
        ### or a CDATA-parent.  That's one more method call per end()!
        ### Might as well just do this at the end of the tree-parse, I guess,
        ### at which point we'd be parsing top-down, and just not traversing
        ### under pre's or CDATA-parents.
        ##
        ## Take this opportunity to nix any terminal whitespace nodes.
        ## TODO: consider whether this (plus the logic in start(), above)
        ## would ever leave any WS nodes in the tree.
        ## If not, then there's no reason to have eof() call
        ## delete_ignorable_whitespace on the tree, is there?
        ##
    #if(@to_close and $self->{'_tighten'} and !$self->{'_ignore_text'} and
    #  ! $to_close[-1]->is_inside('pre', keys %HTML::Tagset::isCDATA_Parent)
    #) {  # if tightenable
    #  my($children, $e_tag);
    #  foreach my $e (reverse @to_close) { # going top-down
    #    last if 'pre' eq ($e_tag = $e->{'_tag'}) or
    #     $HTML::Tagset::isCDATA_Parent{$e_tag};
    #
    #    if(
    #      $children = $e->{'_content'}
    #      and @$children      # has children
    #      and !ref($children->[-1])
    #      and $children->[-1] =~ m<^\s+$>s # last node is all-WS
    #      and
    #        (
    #         # has a tightable parent:
    #         $HTML::TreeBuilder::canTighten{ $e_tag }
    #         or
    #          ( # has a tightenable left sibling:
    #            @$children > 1 and
    #            ref($children->[-2])
    #            and $HTML::TreeBuilder::canTighten{ $children->[-2]{'_tag'} }
    #          )
    #        )
    #    ) {
    #      pop @$children;
    #      #print $indent, "Popping a terminal WS node from ", $e->{'_tag'},
    #      #  " (", $e->address, ") while exiting.\n" if DEBUG;
    #    }
    #  }
    #}

        foreach my $e (@to_close) {

            # Call the applicable callback, if any
            $ptag = $e->{'_tag'};
            &{         $self->{"_tweak_$ptag"}
                    || $self->{'_tweak_*'}
                    || next }( map $_, $e, $ptag, $self );
            print $indent, "Back from tweaking.\n" if DEBUG;
            last
                if $self->{ '_stunted'
                    };    # in case one of the handlers called stunt
        }
        return @to_close;
    }
}

#==========================================================================
{
    my ( $indent, $nugget );

    sub text {
        return if $_[0]{'_stunted'};

        # Accept a "here's a text token" signal from HTML::Parser.
        my ( $self, $text, $is_cdata ) = @_;

        # the >3.0 versions of Parser may pass a cdata node.
        # Thanks to Gisle Aas for pointing this out.

        return unless length $text;    # I guess that's always right

        my $ignore_text         = $self->{'_ignore_text'};
        my $no_space_compacting = $self->{'_no_space_compacting'};
        my $no_expand_entities  = $self->{'_no_expand_entities'};
        my $pos                 = $self->{'_pos'} || $self;

        HTML::Entities::decode($text)
            unless $ignore_text
                || $is_cdata
                || $HTML::Tagset::isCDATA_Parent{ $pos->{'_tag'} }
                || $no_expand_entities;

        #my($indent, $nugget);
        if (DEBUG) {

           # optimization -- don't figure out depth unless we're in debug mode
            my @lineage_tags = $pos->lineage_tag_names;
            $indent = '  ' x ( 1 + @lineage_tags );

            $nugget
                = ( length($text) <= 25 )
                ? $text
                : ( substr( $text, 0, 25 ) . '...' );
            $nugget =~ s<([\x00-\x1F])>
                 <'\\x'.(unpack("H2",$1))>eg;
            print $indent, "Proposing a new text node ($nugget) under ",
                join( '/', reverse( $pos->{'_tag'}, @lineage_tags ) )
                || 'Root',
                ".\n";

            #} else {
            #  $indent = ' ';
        }

        my $ptag;
        if ($HTML::Tagset::isCDATA_Parent{ $ptag = $pos->{'_tag'} }

            #or $pos->is_inside('pre')
            or $pos->is_inside( 'pre', 'textarea' )
            )
        {
            return if $ignore_text;
            $pos->push_content($text);
        }
        else {

            # return unless $text =~ /\S/;  # This is sometimes wrong

            if ( !$self->{'_implicit_tags'} || $text !~ /[^\n\r\f\t ]/ ) {

                # don't change anything
            }
            elsif ( $ptag eq 'head' or $ptag eq 'noframes' ) {
                if ( $self->{'_implicit_body_p_tag'} ) {
                    print $indent,
                        " * Text node under \U$ptag\E closes \U$ptag\E, implicates BODY and P.\n"
                        if DEBUG > 1;
                    $self->end( \$ptag );
                    $pos = $self->{'_body'}
                        ? ( $self->{'_pos'}
                            = $self->{'_body'} )    # expected case
                        : $self->insert_element( 'body', 1 );
                    $pos = $self->insert_element( 'p', 1 );
                }
                else {
                    print $indent,
                        " * Text node under \U$ptag\E closes, implicates BODY.\n"
                        if DEBUG > 1;
                    $self->end( \$ptag );
                    $pos = $self->{'_body'}
                        ? ( $self->{'_pos'}
                            = $self->{'_body'} )    # expected case
                        : $self->insert_element( 'body', 1 );
                }
            }
            elsif ( $ptag eq 'html' ) {
                if ( $self->{'_implicit_body_p_tag'} ) {
                    print $indent,
                        " * Text node under HTML implicates BODY and P.\n"
                        if DEBUG > 1;
                    $pos = $self->{'_body'}
                        ? ( $self->{'_pos'}
                            = $self->{'_body'} )    # expected case
                        : $self->insert_element( 'body', 1 );
                    $pos = $self->insert_element( 'p', 1 );
                }
                else {
                    print $indent,
                        " * Text node under HTML implicates BODY.\n"
                        if DEBUG > 1;
                    $pos = $self->{'_body'}
                        ? ( $self->{'_pos'}
                            = $self->{'_body'} )    # expected case
                        : $self->insert_element( 'body', 1 );

                    #print "POS is $pos, ", $pos->{'_tag'}, "\n";
                }
            }
            elsif ( $ptag eq 'body' ) {
                if ( $self->{'_implicit_body_p_tag'} ) {
                    print $indent, " * Text node under BODY implicates P.\n"
                        if DEBUG > 1;
                    $pos = $self->insert_element( 'p', 1 );
                }
            }
            elsif ( $ptag eq 'table' ) {
                print $indent,
                    " * Text node under TABLE implicates TR and TD.\n"
                    if DEBUG > 1;
                $self->insert_element( 'tr', 1 );
                $pos = $self->insert_element( 'td', 1 );

                # double whammy!
            }
            elsif ( $ptag eq 'tr' ) {
                print $indent, " * Text node under TR implicates TD.\n"
                    if DEBUG > 1;
                $pos = $self->insert_element( 'td', 1 );
            }

            # elsif (
            #       # $ptag eq 'li'   ||
            #       # $ptag eq 'dd'   ||
            #         $ptag eq 'form') {
            #    $pos = $self->insert_element('p', 1);
            #}

            # Whatever we've done above should have had the side
            # effect of updating $self->{'_pos'}

            #print "POS is now $pos, ", $pos->{'_tag'}, "\n";

            return if $ignore_text;
            $text =~ s/[\n\r\f\t ]+/ /g    # canonical space
                unless $no_space_compacting;

            print $indent, " (Attaching text node ($nugget) under ",

           # was: $self->{'_pos'} ? $self->{'_pos'}{'_tag'} : $self->{'_tag'},
                $pos->{'_tag'}, ").\n"
                if DEBUG > 1;

            $pos->push_content($text);
        }

        &{ $self->{'_tweak_~text'} || return }( $text, $pos,
            $pos->{'_tag'} . '' );

        # Note that this is very exceptional -- it doesn't fall back to
        #  _tweak_*, and it gives its tweak different arguments.
        return;
    }
}

#==========================================================================

# TODO: test whether comment(), declaration(), and process(), do the right
#  thing as far as tightening and whatnot.
# Also, currently, doctypes and comments that appear before head or body
#  show up in the tree in the wrong place.  Something should be done about
#  this.  Tricky.  Maybe this whole business of pre-making the body and
#  whatnot is wrong.

sub comment {
    return if $_[0]{'_stunted'};

    # Accept a "here's a comment" signal from HTML::Parser.

    my ( $self, $text ) = @_;
    my $pos = $self->{'_pos'} || $self;
    return
        unless $self->{'_store_comments'}
            || $HTML::Tagset::isCDATA_Parent{ $pos->{'_tag'} };

    if (DEBUG) {
        my @lineage_tags = $pos->lineage_tag_names;
        my $indent = '  ' x ( 1 + @lineage_tags );

        my $nugget
            = ( length($text) <= 25 )
            ? $text
            : ( substr( $text, 0, 25 ) . '...' );
        $nugget =~ s<([\x00-\x1F])>
                 <'\\x'.(unpack("H2",$1))>eg;
        print $indent, "Proposing a Comment ($nugget) under ",
            join( '/', reverse( $pos->{'_tag'}, @lineage_tags ) ) || 'Root',
            ".\n";
    }

    ( my $e = $self->element_class->new('~comment') )->{'text'} = $text;
    $pos->push_content($e);
    ++( $self->{'_element_count'} );

    &{         $self->{'_tweak_~comment'}
            || $self->{'_tweak_*'}
            || return $e }( map $_, $e, '~comment', $self );

    return $e;
}

sub declaration {
    return if $_[0]{'_stunted'};

    # Accept a "here's a markup declaration" signal from HTML::Parser.

    my ( $self, $text ) = @_;
    my $pos = $self->{'_pos'} || $self;

    if (DEBUG) {
        my @lineage_tags = $pos->lineage_tag_names;
        my $indent = '  ' x ( 1 + @lineage_tags );

        my $nugget
            = ( length($text) <= 25 )
            ? $text
            : ( substr( $text, 0, 25 ) . '...' );
        $nugget =~ s<([\x00-\x1F])>
                 <'\\x'.(unpack("H2",$1))>eg;
        print $indent, "Proposing a Declaration ($nugget) under ",
            join( '/', reverse( $pos->{'_tag'}, @lineage_tags ) ) || 'Root',
            ".\n";
    }
    ( my $e = $self->element_class->new('~declaration') )->{'text'} = $text;

    $self->{_decl} = $e;
    return $e;
}

#==========================================================================

sub process {
    return if $_[0]{'_stunted'};

    # Accept a "here's a PI" signal from HTML::Parser.

    return unless $_[0]->{'_store_pis'};
    my ( $self, $text ) = @_;
    my $pos = $self->{'_pos'} || $self;

    if (DEBUG) {
        my @lineage_tags = $pos->lineage_tag_names;
        my $indent = '  ' x ( 1 + @lineage_tags );

        my $nugget
            = ( length($text) <= 25 )
            ? $text
            : ( substr( $text, 0, 25 ) . '...' );
        $nugget =~ s<([\x00-\x1F])>
                 <'\\x'.(unpack("H2",$1))>eg;
        print $indent, "Proposing a PI ($nugget) under ",
            join( '/', reverse( $pos->{'_tag'}, @lineage_tags ) ) || 'Root',
            ".\n";
    }
    ( my $e = $self->element_class->new('~pi') )->{'text'} = $text;
    $pos->push_content($e);
    ++( $self->{'_element_count'} );

    &{ $self->{'_tweak_~pi'} || $self->{'_tweak_*'} || return $e }( map $_,
        $e, '~pi', $self );

    return $e;
}

#==========================================================================

#When you call $tree->parse_file($filename), and the
#tree's ignore_ignorable_whitespace attribute is on (as it is
#by default), HTML::TreeBuilder's logic will manage to avoid
#creating some, but not all, nodes that represent ignorable
#whitespace.  However, at the end of its parse, it traverses the
#tree and deletes any that it missed.  (It does this with an
#around-method around HTML::Parser's eof method.)
#
#However, with $tree->parse($content), the cleanup-traversal step
#doesn't happen automatically -- so when you're done parsing all
#content for a document (regardless of whether $content is the only
#bit, or whether it's just another chunk of content you're parsing into
#the tree), call $tree->eof() to signal that you're at the end of the
#text you're inputting to the tree.  Besides properly cleaning any bits
#of ignorable whitespace from the tree, this will also ensure that
#HTML::Parser's internal buffer is flushed.

sub eof {

    # Accept an "end-of-file" signal from HTML::Parser, or thrown by the user.

    return if $_[0]->{'_done'};    # we've already been here

    return $_[0]->SUPER::eof() if $_[0]->{'_stunted'};

    my $x = $_[0];
    print "EOF received.\n" if DEBUG;
    my (@rv);
    if (wantarray) {

        # I don't think this makes any difference for this particular
        #  method, but let's be scrupulous, for once.
        @rv = $x->SUPER::eof();
    }
    else {
        $rv[0] = $x->SUPER::eof();
    }

    $x->end('html') unless $x eq ( $x->{'_pos'} || $x );

    # That SHOULD close everything, and will run the appropriate tweaks.
    # We /could/ be running under some insane mode such that there's more
    #  than one HTML element, but really, that's just insane to do anyhow.

    unless ( $x->{'_implicit_tags'} ) {

        # delete those silly implicit head and body in case we put
        # them there in implicit tags mode
        foreach my $node ( $x->{'_head'}, $x->{'_body'} ) {
            $node->replace_with_content
                if defined $node
                    and ref $node
                    and $node->{'_implicit'}
                    and $node->{'_parent'};

            # I think they should be empty anyhow, since the only
            # logic that'd insert under them can apply only, I think,
            # in the case where _implicit_tags is on
        }

        # this may still leave an implicit 'html' at the top, but there's
        # nothing we can do about that, is there?
    }

    $x->delete_ignorable_whitespace()

        # this's why we trap this -- an after-method
        if $x->{'_tighten'} and !$x->{'_ignore_text'};
    $x->{'_done'} = 1;

    return @rv if wantarray;
    return $rv[0];
}

#==========================================================================

# TODO: document

sub stunt {
    my $self = $_[0];
    print "Stunting the tree.\n" if DEBUG;
    $self->{'_done'} = 1;

    if ( $HTML::Parser::VERSION < 3 ) {

        #This is a MEAN MEAN HACK.  And it works most of the time!
        $self->{'_buf'} = '';
        my $fh = *HTML::Parser::F{IO};

        # the local'd FH used by parse_file loop
        if ( defined $fh ) {
            print "Closing Parser's filehandle $fh\n" if DEBUG;
            close($fh);
        }

      # But if they called $tree->parse_file($filehandle)
      #  or $tree->parse_file(*IO), then there will be no *HTML::Parser::F{IO}
      #  to close.  Ahwell.  Not a problem for most users these days.

    }
    else {
        $self->SUPER::eof();

        # Under 3+ versions, calling eof from inside a parse will abort the
        #  parse / parse_file
    }

    # In the off chance that the above didn't work, we'll throw
    #  this flag to make any future events be no-ops.
    $self->stunted(1);
    return;
}

# TODO: document
sub stunted { shift->_elem( '_stunted', @_ ); }
sub done    { shift->_elem( '_done',    @_ ); }

#==========================================================================

sub delete {

    # Override Element's delete method.
    # This does most, if not all, of what Element's delete does anyway.
    # Deletes content, including content in some special attributes.
    # But doesn't empty out the hash.

    $_[0]->{'_element_count'} = 1;    # never hurts to be scrupulously correct

    delete @{ $_[0] }{ '_body', '_head', '_pos' };
    for (
        @{ delete( $_[0]->{'_content'} ) || [] },    # all/any content

     #       delete @{$_[0]}{'_body', '_head', '_pos'}
     # ...and these, in case these elements don't appear in the
     #   content, which is possible.  If they did appear (as they
     #   usually do), then calling $_->delete on them again is harmless.
     #  I don't think that's such a hot idea now.  Thru creative reattachment,
     #  those could actually now point to elements in OTHER trees (which we do
     #  NOT want to delete!).
## Reasoned out:
  #  If these point to elements not in the content list of any element in this
  #   tree, but not in the content list of any element in any OTHER tree, then
  #   just deleting these will make their refcounts hit zero.
  #  If these point to elements in the content lists of elements in THIS tree,
  #   then we'll get to deleting them when we delete from the top.
  #  If these point to elements in the content lists of elements in SOME OTHER
  #   tree, then they're not to be deleted.
        )
    {
        $_->delete
            if defined $_ and ref $_    #  Make sure it's an object.
                and $_ ne $_[0];    #  And avoid hitting myself, just in case!
    }

    $_[0]->detach if $_[0]->{'_parent'} and $_[0]->{'_parent'}{'_content'};

    # An 'html' element having a parent is quite unlikely.

    return;
}

sub tighten_up {                    # legacy
    shift->delete_ignorable_whitespace(@_);
}

sub elementify {

    # Rebless this object down into the normal element class.
    my $self     = $_[0];
    my $to_class = $self->element_class;
    delete @{$self}{
        grep {
            ;
            length $_ and substr( $_, 0, 1 ) eq '_'

                # The private attributes that we'll retain:
                and $_ ne '_tag'
                and $_ ne '_parent'
                and $_ ne '_content'
                and $_ ne '_implicit'
                and $_ ne '_pos'
                and $_ ne '_element_class'
            } keys %$self
        };
    bless $self, $to_class;    # Returns the same object we were fed
}

sub element_class {
    return 'HTML::Element' if not ref $_[0];
    return $_[0]->{_element_class} || 'HTML::Element';
}

#--------------------------------------------------------------------------

sub guts {
    my @out;
    my @stack       = ( $_[0] );
    my $destructive = $_[1];
    my $this;
    while (@stack) {
        $this = shift @stack;
        if ( !ref $this ) {
            push @out, $this;    # yes, it can include text nodes
        }
        elsif ( !$this->{'_implicit'} ) {
            push @out, $this;
            delete $this->{'_parent'} if $destructive;
        }
        else {

            # it's an implicit node.  Delete it and recurse
            delete $this->{'_parent'} if $destructive;
            unshift @stack,
                @{
                (   $destructive
                    ? delete( $this->{'_content'} )
                    : $this->{'_content'}
                    )
                    || []
                };
        }
    }

    # Doesn't call a real $root->delete on the (when implicit) root,
    #  but I don't think it needs to.

    return @out if wantarray;    # one simple normal case.
    return unless @out;
    return $out[0] if @out == 1 and ref( $out[0] );
    my $x = HTML::Element->new( 'div', '_implicit' => 1 );
    $x->push_content(@out);
    return $x;
}

sub disembowel { $_[0]->guts(1) }

#--------------------------------------------------------------------------
1;

__END__

=pod

=head1 NAME

HTML::TreeBuilder - Parser that builds a HTML syntax tree

=head1 VERSION

This document describes version 5.07 of
HTML::TreeBuilder, released August 31, 2017
as part of L<HTML-Tree|HTML::Tree>.

=head1 SYNOPSIS

  use HTML::TreeBuilder 5 -weak; # Ensure weak references in use

  foreach my $file_name (@ARGV) {
    my $tree = HTML::TreeBuilder->new; # empty tree
    $tree->parse_file($file_name);
    print "Hey, here's a dump of the parse tree of $file_name:\n";
    $tree->dump; # a method we inherit from HTML::Element
    print "And here it is, bizarrely rerendered as HTML:\n",
      $tree->as_HTML, "\n";

    # Now that we're done with it, we must destroy it.
    # $tree = $tree->delete; # Not required with weak references
  }

=head1 DESCRIPTION

(This class is part of the L<HTML::Tree|HTML::Tree> dist.)

This class is for HTML syntax trees that get built out of HTML
source.  The way to use it is to:

1. start a new (empty) HTML::TreeBuilder object,

2. then use one of the methods from HTML::Parser (presumably with
C<< $tree->parse_file($filename) >> for files, or with
C<< $tree->parse($document_content) >> and C<< $tree->eof >> if you've got
the content in a string) to parse the HTML
document into the tree C<$tree>.

(You can combine steps 1 and 2 with the "new_from_file" or
"new_from_content" methods.)

2b. call C<< $root->elementify() >> if you want.

3. do whatever you need to do with the syntax tree, presumably
involving traversing it looking for some bit of information in it,

4. previous versions of HTML::TreeBuilder required you to call
C<< $tree->delete() >> to erase the contents of the tree from memory
when you're done with the tree.  This is not normally required anymore.
See L<HTML::Element/"Weak References"> for details.

=head1 ATTRIBUTES

Most of the following attributes native to HTML::TreeBuilder control how
parsing takes place; they should be set I<before> you try parsing into
the given object.  You can set the attributes by passing a TRUE or
FALSE value as argument.  E.g., C<< $root->implicit_tags >> returns
the current setting for the C<implicit_tags> option,
C<< $root->implicit_tags(1) >> turns that option on,
and C<< $root->implicit_tags(0) >> turns it off.

=head2 implicit_tags

Setting this attribute to true will instruct the parser to try to
deduce implicit elements and implicit end tags.  If it is false you
get a parse tree that just reflects the text as it stands, which is
unlikely to be useful for anything but quick and dirty parsing.
(In fact, I'd be curious to hear from anyone who finds it useful to
have C<implicit_tags> set to false.)
Default is true.

Implicit elements have the L<HTML::Element/implicit> attribute set.

=head2 implicit_body_p_tag

This controls an aspect of implicit element behavior, if C<implicit_tags>
is on:  If a text element (PCDATA) or a phrasal element (such as
C<< <em> >>) is to be inserted under C<< <body> >>, two things
can happen: if C<implicit_body_p_tag> is true, it's placed under a new,
implicit C<< <p> >> tag.  (Past DTDs suggested this was the only
correct behavior, and this is how past versions of this module
behaved.)  But if C<implicit_body_p_tag> is false, nothing is implicated
-- the PCDATA or phrasal element is simply placed under
C<< <body> >>.  Default is false.

=head2 no_expand_entities

This attribute controls whether entities are decoded during the initial
parse of the source. Enable this if you don't want entities decoded to
their character value. e.g. '&amp;' is decoded to '&' by default, but
will be unchanged if this is enabled.
Default is false (entities will be decoded.)

=head2 ignore_unknown

This attribute controls whether unknown tags should be represented as
elements in the parse tree, or whether they should be ignored.
Default is true (to ignore unknown tags.)

=head2 ignore_text

Do not represent the text content of elements.  This saves space if
all you want is to examine the structure of the document.  Default is
false.

=head2 ignore_ignorable_whitespace

If set to true, TreeBuilder will try to avoid
creating ignorable whitespace text nodes in the tree.  Default is
true.  (In fact, I'd be interested in hearing if there's ever a case
where you need this off, or where leaving it on leads to incorrect
behavior.)

=head2 no_space_compacting

This determines whether TreeBuilder compacts all whitespace strings
in the document (well, outside of PRE or TEXTAREA elements), or
leaves them alone.  Normally (default, value of 0), each string of
contiguous whitespace in the document is turned into a single space.
But that's not done if C<no_space_compacting> is set to 1.

Setting C<no_space_compacting> to 1 might be useful if you want
to read in a tree just to make some minor changes to it before
writing it back out.

This method is experimental.  If you use it, be sure to report
any problems you might have with it.

=head2 p_strict

If set to true (and it defaults to false), TreeBuilder will take a
narrower than normal view of what can be under a C<< <p> >> element; if it sees
a non-phrasal element about to be inserted under a C<< <p> >>, it will
close that C<< <p> >>.  Otherwise it will close C<< <p> >> elements only for
other C<< <p> >>'s, headings, and C<< <form> >> (although the latter may be
removed in future versions).

For example, when going thru this snippet of code,

  <p>stuff
  <ul>

TreeBuilder will normally (with C<p_strict> false) put the C<< <ul> >> element
under the C<< <p> >> element.  However, with C<p_strict> set to true, it will
close the C<< <p> >> first.

In theory, there should be strictness options like this for other/all
elements besides just C<< <p> >>; but I treat this as a special case simply
because of the fact that C<< <p> >> occurs so frequently and its end-tag is
omitted so often; and also because application of strictness rules
at parse-time across all elements often makes tiny errors in HTML
coding produce drastically bad parse-trees, in my experience.

If you find that you wish you had an option like this to enforce
content-models on all elements, then I suggest that what you want is
content-model checking as a stage after TreeBuilder has finished
parsing.

=head2 store_comments

This determines whether TreeBuilder will normally store comments found
while parsing content into C<$root>.  Currently, this is off by default.

=head2 store_declarations

This determines whether TreeBuilder will normally store markup
declarations found while parsing content into C<$root>.  This is on
by default.

=head2 store_pis

This determines whether TreeBuilder will normally store processing
instructions found while parsing content into C<$root> -- assuming a
recent version of HTML::Parser (old versions won't parse PIs
correctly).  Currently, this is off (false) by default.

It is somewhat of a known bug (to be fixed one of these days, if
anyone needs it?) that PIs in the preamble (before the C<< <html> >>
start-tag) end up actually I<under> the C<< <html> >> element.

=head2 warn

This determines whether syntax errors during parsing should generate
warnings, emitted via Perl's C<warn> function.

This is off (false) by default.

=head1 METHODS

Objects of this class inherit the methods of both HTML::Parser and
HTML::Element.  The methods inherited from HTML::Parser are used for
building the HTML tree, and the methods inherited from HTML::Element
are what you use to scrutinize the tree.  Besides this
(HTML::TreeBuilder) documentation, you must also carefully read the
HTML::Element documentation, and also skim the HTML::Parser
documentation -- probably only its parse and parse_file methods are of
interest.

=head2 new_from_file

  $root = HTML::TreeBuilder->new_from_file($filename_or_filehandle);

This "shortcut" constructor merely combines constructing a new object
(with the L</new> method, below), and calling C<< $new->parse_file(...) >> on
it.  Returns the new object.  Note that this provides no way of
setting any parse options like C<store_comments> (for that, call C<new>, and
then set options, before calling C<parse_file>).  See the notes (below)
on parameters to L</parse_file>.

If HTML::TreeBuilder is unable to read the file, then C<new_from_file>
dies.  The error can also be found in C<$!>.  (This behavior is new in
HTML-Tree 5. Previous versions returned a tree with only implicit elements.)

=head2 new_from_content

  $root = HTML::TreeBuilder->new_from_content(...);

This "shortcut" constructor merely combines constructing a new object
(with the L</new> method, below), and calling C<< for(...){$new->parse($_)} >>
and C<< $new->eof >> on it.  Returns the new object.  Note that this provides
no way of setting any parse options like C<store_comments> (for that,
call C<new>, and then set options, before calling C<parse>).  Example
usages: C<< HTML::TreeBuilder->new_from_content(@lines) >>, or
C<< HTML::TreeBuilder->new_from_content($content) >>.

=head2 new_from_url

  $root = HTML::TreeBuilder->new_from_url($url)

This "shortcut" constructor combines constructing a new object (with
the L</new> method, below), loading L<LWP::UserAgent>, fetching the
specified URL, and calling C<< $new->parse( $response->decoded_content) >>
and C<< $new->eof >> on it.
Returns the new object.  Note that this provides no way of setting any
parse options like C<store_comments>.

If LWP is unable to fetch the URL, or the response is not HTML (as
determined by L<HTTP::Headers/content_is_html>), then C<new_from_url>
dies, and the HTTP::Response object is found in
C<$HTML::TreeBuilder::lwp_response>.

You must have installed LWP::UserAgent for this method to work.  LWP
is not installed automatically, because it's a large set of modules
and you might not need it.

=head2 new

  $root = HTML::TreeBuilder->new();

This creates a new HTML::TreeBuilder object.  This method takes no
attributes.

=head2 parse_file

 $root->parse_file(...)

[An important method inherited from L<HTML::Parser|HTML::Parser>, which
see.  Current versions of HTML::Parser can take a filespec, or a
filehandle object, like *FOO, or some object from class IO::Handle,
IO::File, IO::Socket) or the like.
I think you should check that a given file exists I<before> calling
C<< $root->parse_file($filespec) >>.]

When you pass a filename to C<parse_file>, HTML::Parser opens it in
binary mode, which means it's interpreted as Latin-1 (ISO-8859-1).  If
the file is in another encoding, like UTF-8 or UTF-16, this will not
do the right thing.

One solution is to open the file yourself using the proper
C<:encoding> layer, and pass the filehandle to C<parse_file>.  You can
automate this process by using L<IO::HTML/html_file>, which will use
the HTML5 encoding sniffing algorithm to automatically determine the
proper C<:encoding> layer and apply it.

In the next major release of HTML-Tree, I plan to have it use IO::HTML
automatically.  If you really want your file opened in binary mode,
you should open it yourself and pass the filehandle to C<parse_file>.

The return value is C<undef> if there's an error opening the file.  In
that case, the error will be in C<$!>.

=head2 parse

  $root->parse(...)

[A important method inherited from L<HTML::Parser|HTML::Parser>, which
see.  See the note below for C<< $root->eof() >>.]

=head2 eof

  $root->eof();

This signals that you're finished parsing content into this tree; this
runs various kinds of crucial cleanup on the tree.  This is called
I<for you> when you call C<< $root->parse_file(...) >>, but not when
you call C<< $root->parse(...) >>.  So if you call
C<< $root->parse(...) >>, then you I<must> call C<< $root->eof() >>
once you've finished feeding all the chunks to C<parse(...)>, and
before you actually start doing anything else with the tree in C<$root>.

=head2 parse_content

  $root->parse_content(...);

Basically a handy alias for C<< $root->parse(...); $root->eof >>.
Takes the exact same arguments as C<< $root->parse() >>.

=head2 delete

  $root->delete();

[A previously important method inherited from L<HTML::Element|HTML::Element>,
which see.]

=head2 elementify

  $root->elementify();

This changes the class of the object in C<$root> from
HTML::TreeBuilder to the class used for all the rest of the elements
in that tree (generally HTML::Element).  Returns C<$root>.

For most purposes, this is unnecessary, but if you call this after
(after!!)
you've finished building a tree, then it keeps you from accidentally
trying to call anything but HTML::Element methods on it.  (I.e., if
you accidentally call C<$root-E<gt>parse_file(...)> on the
already-complete and elementified tree, then instead of charging ahead
and I<wreaking havoc>, it'll throw a fatal error -- since C<$root> is
now an object just of class HTML::Element which has no C<parse_file>
method.

Note that C<elementify> currently deletes all the private attributes of
C<$root> except for "_tag", "_parent", "_content", "_pos", and
"_implicit".  If anyone requests that I change this to leave in yet
more private attributes, I might do so, in future versions.

=head2 guts

 @nodes = $root->guts();
 $parent_for_nodes = $root->guts();

In list context (as in the first case), this method returns the topmost
non-implicit nodes in a tree.  This is useful when you're parsing HTML
code that you know doesn't expect an HTML document, but instead just
a fragment of an HTML document.  For example, if you wanted the parse
tree for a file consisting of just this:

  <li>I like pie!

Then you would get that with C<< @nodes = $root->guts(); >>.
It so happens that in this case, C<@nodes> will contain just one
element object, representing the C<< <li> >> node (with "I like pie!" being
its text child node).  However, consider if you were parsing this:

  <hr>Hooboy!<hr>

In that case, C<< $root->guts() >> would return three items:
an element object for the first C<< <hr> >>, a text string "Hooboy!", and
another C<< <hr> >> element object.

For cases where you want definitely one element (so you can treat it as
a "document fragment", roughly speaking), call C<guts()> in scalar
context, as in C<< $parent_for_nodes = $root->guts() >>. That works like
C<guts()> in list context; in fact, C<guts()> in list context would
have returned exactly one value, and if it would have been an object (as
opposed to a text string), then that's what C<guts> in scalar context
will return.  Otherwise, if C<guts()> in list context would have returned
no values at all, then C<guts()> in scalar context returns undef.  In
all other cases, C<guts()> in scalar context returns an implicit C<< <div> >>
element node, with children consisting of whatever nodes C<guts()>
in list context would have returned.  Note that that may detach those
nodes from C<$root>'s tree.

=head2 disembowel

  @nodes = $root->disembowel();
  $parent_for_nodes = $root->disembowel();

The C<disembowel()> method works just like the C<guts()> method, except
that disembowel definitively destroys the tree above the nodes that
are returned.  Usually when you want the guts from a tree, you're just
going to toss out the rest of the tree anyway, so this saves you the
bother.  (Remember, "disembowel" means "remove the guts from".)

=head1 INTERNAL METHODS

You should not need to call any of the following methods directly.

=head2 element_class

  $classname = $h->element_class;

This method returns the class which will be used for new elements.  It
defaults to HTML::Element, but can be overridden by subclassing or esoteric
means best left to those will will read the source and then not complain when
those esoteric means change.  (Just subclass.)

=head2 comment

Accept a "here's a comment" signal from HTML::Parser.

=head2 declaration

Accept a "here's a markup declaration" signal from HTML::Parser.

=head2 done

TODO: document

=head2 end

Either: Acccept an end-tag signal from HTML::Parser
Or: Method for closing currently open elements in some fairly complex
way, as used by other methods in this class.

TODO: Why is this hidden?

=head2 process

Accept a "here's a PI" signal from HTML::Parser.

=head2 start

Accept a signal from HTML::Parser for start-tags.

TODO: Why is this hidden?

=head2 stunt

TODO: document

=head2 stunted

TODO: document

=head2 text

Accept a "here's a text token" signal from HTML::Parser.

TODO: Why is this hidden?

=head2 tighten_up

Legacy

Redirects to L<HTML::Element/delete_ignorable_whitespace>.

=head2 warning

Wrapper for CORE::warn

TODO: why not just use carp?

=head1 SUBROUTINES

=head2 DEBUG

Are we in Debug mode?  This is a constant subroutine, to allow
compile-time optimizations.  To control debug mode, set
C<$HTML::TreeBuilder::DEBUG> I<before> loading HTML::TreeBuilder.

=head1 HTML AND ITS DISCONTENTS

HTML is rather harder to parse than people who write it generally
suspect.

Here's the problem: HTML is a kind of SGML that permits "minimization"
and "implication".  In short, this means that you don't have to close
every tag you open (because the opening of a subsequent tag may
implicitly close it), and if you use a tag that can't occur in the
context you seem to using it in, under certain conditions the parser
will be able to realize you mean to leave the current context and
enter the new one, that being the only one that your code could
correctly be interpreted in.

Now, this would all work flawlessly and unproblematically if: 1) all
the rules that both prescribe and describe HTML were (and had been)
clearly set out, and 2) everyone was aware of these rules and wrote
their code in compliance to them.

However, it didn't happen that way, and so most HTML pages are
difficult if not impossible to correctly parse with nearly any set of
straightforward SGML rules.  That's why the internals of
HTML::TreeBuilder consist of lots and lots of special cases -- instead
of being just a generic SGML parser with HTML DTD rules plugged in.

=head1 TRANSLATIONS?

The techniques that HTML::TreeBuilder uses to perform what I consider
very robust parses on everyday code are not things that can work only
in Perl.  To date, the algorithms at the center of HTML::TreeBuilder
have been implemented only in Perl, as far as I know; and I don't
foresee getting around to implementing them in any other language any
time soon.

If, however, anyone is looking for a semester project for an applied
programming class (or if they merely enjoy I<extra-curricular>
masochism), they might do well to see about choosing as a topic the
implementation/adaptation of these routines to any other interesting
programming language that you feel currently suffers from a lack of
robust HTML-parsing.  I welcome correspondence on this subject, and
point out that one can learn a great deal about languages by trying to
translate between them, and then comparing the result.

The HTML::TreeBuilder source may seem long and complex, but it is
rather well commented, and symbol names are generally
self-explanatory.  (You are encouraged to read the Mozilla HTML parser
source for comparison.)  Some of the complexity comes from little-used
features, and some of it comes from having the HTML tokenizer
(HTML::Parser) being a separate module, requiring somewhat of a
different interface than you'd find in a combined tokenizer and
tree-builder.  But most of the length of the source comes from the fact
that it's essentially a long list of special cases, with lots and lots
of sanity-checking, and sanity-recovery -- because, as Roseanne
Rosannadanna once said, "it's always I<something>".

Users looking to compare several HTML parsers should look at the
source for Raggett's Tidy
(C<E<lt>http://www.w3.org/People/Raggett/tidy/E<gt>>),
Mozilla
(C<E<lt>http://www.mozilla.org/E<gt>>),
and possibly root around the browsers section of Yahoo
to find the various open-source ones
(C<E<lt>http://dir.yahoo.com/Computers_and_Internet/Software/Internet/World_Wide_Web/Browsers/E<gt>>).

=head1 BUGS

* Framesets seem to work correctly now.  Email me if you get a strange
parse from a document with framesets.

* Really bad HTML code will, often as not, make for a somewhat
objectionable parse tree.  Regrettable, but unavoidably true.

* If you're running with C<implicit_tags> off (God help you!), consider
that C<< $tree->content_list >> probably contains the tree or grove from the
parse, and not C<$tree> itself (which will, oddly enough, be an implicit
C<< <html> >> element).  This seems counter-intuitive and problematic; but
seeing as how almost no HTML ever parses correctly with C<implicit_tags>
off, this interface oddity seems the least of your problems.

=head1 BUG REPORTS

When a document parses in a way different from how you think it
should, I ask that you report this to me as a bug.  The first thing
you should do is copy the document, trim out as much of it as you can
while still producing the bug in question, and I<then> email me that
mini-document I<and> the code you're using to parse it, to the HTML::Tree
bug queue at S<C<< <bug-html-tree at rt.cpan.org> >>>.

Include a note as to how it
parses (presumably including its C<< $tree->dump >> output), and then a
I<careful and clear> explanation of where you think the parser is
going astray, and how you would prefer that it work instead.

=head1 SEE ALSO

For more information about the HTML-Tree distribution: L<HTML::Tree>.

Modules used by HTML::TreeBuilder:
L<HTML::Parser>, L<HTML::Element>, L<HTML::Tagset>.

For converting between L<XML::DOM::Node>, L<HTML::Element>, and
L<XML::Element> trees: L<HTML::DOMbo>.

For opening a HTML file with automatic charset detection: L<IO::HTML>.

=head1 AUTHOR

Current maintainers:

=over

=item * Christopher J. Madsen S<C<< <perl AT cjmweb.net> >>>

=item * Jeff Fearn S<C<< <jfearn AT cpan.org> >>>

=back

Original HTML-Tree author:

=over

=item * Gisle Aas

=back

Former maintainers:

=over

=item * Sean M. Burke

=item * Andy Lester

=item * Pete Krawczyk S<C<< <petek AT cpan.org> >>>

=back

You can follow or contribute to HTML-Tree's development at
L<< https://github.com/kentfredric/HTML-Tree >>.

=head1 COPYRIGHT AND LICENSE

Copyright 1995-1998 Gisle Aas, 1999-2004 Sean M. Burke,
2005 Andy Lester, 2006 Pete Krawczyk, 2010 Jeff Fearn,
2012 Christopher J. Madsen.

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

The programs in this library are distributed in the hope that they
will be useful, but without any warranty; without even the implied
warranty of merchantability or fitness for a particular purpose.

=cut
PK       ! �֚+�z  �z     perl5/HTML/Tree/AboutObjects.podnu ��6�$        
#Time-stamp: "2001-02-23 20:07:25 MST" -*-Text-*-
# This document contains text in Perl "POD" format.
# Use a POD viewer like perldoc or perlman to render it.

=head1 NAME

HTML::Tree::AboutObjects -- article: "User's View of Object-Oriented Modules"

=head1 SYNOPSIS

  # This an article, not a module.

=head1 DESCRIPTION

The following article by Sean M. Burke first appeared in I<The Perl
Journal> #17 and is copyright 2000 The Perl Journal. It appears
courtesy of Jon Orwant and The Perl Journal.  This document may be
distributed under the same terms as Perl itself.

=head1 A User's View of Object-Oriented Modules

-- Sean M. Burke

The first time that most Perl programmers run into object-oriented
programming when they need to use a module whose interface is
object-oriented.  This is often a mystifying experience, since talk of
"methods" and "constructors" is unintelligible to programmers who
thought that functions and variables was all there was to worry about.

Articles and books that explain object-oriented programming (OOP), do so
in terms of how to program that way.  That's understandable, and if you
learn to write object-oriented code of your own, you'd find it easy to
use object-oriented code that others write.  But this approach is the
I<long> way around for people whose immediate goal is just to use
existing object-oriented modules, but who don't yet want to know all the
gory details of having to write such modules for themselves.

This article is for those programmers -- programmers who want to know
about objects from the perspective of using object-oriented modules. 

=head2 Modules and Their Functional Interfaces

Modules are the main way that Perl provides for bundling up code for
later use by yourself or others.  As I'm sure you can't help noticing
from reading
I<The Perl Journal>, CPAN (the Comprehensive Perl Archive
Network) is the repository for modules (or groups of modules) that
others have written, to do anything from composing music to accessing
Web pages.  A good deal of those modules even come with every
installation of Perl.

One module that you may have used before, and which is fairly typical in
its interface, is Text::Wrap.  It comes with Perl, so you don't even
need to install it from CPAN.  You use it in a program of yours, by
having your program code say early on:

  use Text::Wrap;

and after that, you can access a function called C<wrap>, which inserts
line-breaks in text that you feed it, so that the text will be wrapped to
seventy-two (or however many) columns.

The way this C<use Text::Wrap> business works is that the module
Text::Wrap exists as a file "Text/Wrap.pm" somewhere in one of your
library directories.  That file contains Perl code...

=over

Footnote: And mixed in with the Perl code, there's documentation, which
is what you read with "perldoc Text::Wrap".  The perldoc program simply
ignores the code and formats the documentation text, whereas "use
Text::Wrap" loads and runs the code while ignoring the documentation.

=back

...which, among other things, defines a function called C<Text::Wrap::wrap>,
and then C<exports> that function, which means that when you say C<wrap>
after having said "use Text::Wrap", you'll be actually calling the
C<Text::Wrap::wrap> function.  Some modules don't export their
functions, so you have to call them by their full name, like
C<Text::Wrap::wrap(...parameters...)>.

Regardless of whether the typical module exports the functions it
provides, a module is basically just a container for chunks of code that
do useful things.  The way the module allows for you to interact with
it, is its I<interface>.  And when, like with Text::Wrap, its interface
consists of functions, the module is said to have a B<functional
interface>.

=over

Footnote: the term "function" (and therefore "functionI<al>") has
various senses.  I'm using the term here in its broadest sense, to
refer to routines -- bits of code that are called by some name and
which take parameters and return some value.

=back

Using modules with functional interfaces is straightforward -- instead
of defining your own "wrap" function with C<sub wrap { ... }>, you
entrust "use Text::Wrap" to do that for you, along with whatever other
functions its defines and exports, according to the module's
documentation.  Without too much bother, you can even write your own
modules to contain your frequently used functions; I suggest having a look at
the C<perlmod> man page for more leads on doing this.

=head2 Modules with Object-Oriented Interfaces

So suppose that one day you want to write a program that will automate
the process of C<ftp>ing a bunch of files from one server down to your
local machine, and then off to another server.

A quick browse through search.cpan.org turns up the module "Net::FTP",
which you can download and install it using normal installation
instructions (unless your sysadmin has already installed it, as many
have).

Like Text::Wrap or any other module with a familiarly functional
interface, you start off using Net::FTP in your program by saying:

  use Net::FTP;

However, that's where the similarity ends.  The first hint of
difference is that the documentation for Net::FTP refers to it as a
B<class>.  A class is a kind of module, but one that has an
object-oriented interface.

Whereas modules like Text::Wrap
provide bits of useful code as I<functions>, to be called like
C<function(...parameters...)> or like
C<PackageName::function(...parameters...)>, Net::FTP and other modules
with object-oriented interfaces provide B<methods>.  Methods are sort of
like functions in that they have a name and parameters; but methods
look different, and are different, because you have to call them with a
syntax that has a class name or an object as a special argument.  I'll
explain the syntax for method calls, and then later explain what they
all mean.

Some methods are meant to be called as B<class methods>, with the class
name (same as the module name) as a special argument.  Class methods
look like this:

  ClassName->methodname(parameter1, parameter2, ...)
  ClassName->methodname()   # if no parameters
  ClassName->methodname     # same as above

which you will sometimes see written:

  methodname ClassName (parameter1, parameter2, ...)
  methodname ClassName      # if no parameters

Basically all class methods are for making new objects, and methods that
make objects are called "B<constructors>" (and the process of making them
is called "constructing" or "instantiating").  Constructor methods
typically have the name "new", or something including "new"
("new_from_file", etc.); but they can conceivably be named
anything -- DBI's constructor method is named "connect", for example.

The object that a constructor method returns is
typically captured in a scalar variable:

  $object = ClassName->new(param1, param2...);

Once you have an object (more later on exactly what that is), you can
use the other kind of method call syntax, the syntax for B<object method>
calls.  Calling object methods is just like class methods, except
that instead of the ClassName as the special argument,
you use an expression that yeilds an "object".  Usually this is
just a scalar variable that you earlier captured the
output of the constructor in.  Object method calls look like this:

  $object->methodname(parameter1, parameter2, ...);
  $object->methodname()   # if no parameters
  $object->methodname     # same as above
  
which is occasionally written as:

  methodname $object (parameter1, parameter2, ...)
  methodname $object      # if no parameters

Examples of method calls are:

  my $session1 = Net::FTP->new("ftp.myhost.com");
    # Calls a class method "new", from class Net::FTP,
    #  with the single parameter "ftp.myhost.com",
    #  and saves the return value (which is, as usual,
    #  an object), in $session1.
    # Could also be written:
    #  new Net::FTP('ftp.myhost.com')
  $session1->login("sburke","aoeuaoeu")
    || die "failed to login!\n";
     # calling the object method "login"
  print "Dir:\n", $session1->dir(), "\n";
  $session1->quit;
    # same as $session1->quit()
  print "Done\n";
  exit;

Incidentally, I suggest always using the syntaxes with parentheses and
"->" in them,

=over

Footnote: the character-pair "->" is supposed to look like an
arrow, not "negative greater-than"!

=back

and avoiding the syntaxes that start out "methodname $object" or
"methodname ModuleName".  When everything's going right, they all mean
the same thing as the "->" variants, but the syntax with "->" is more
visually distinct from function calls, as well as being immune to some
kinds of rare but puzzling ambiguities that can arise when you're trying
to call methods that have the same name as subroutines you've defined.

But, syntactic alternatives aside, all this talk of constructing objects
and object methods begs the question -- what I<is> an object?  There are
several angles to this question that the rest of this article will
answer in turn: what can you do with objects?  what's in an object?
what's an object value?  and why do some modules use objects at all? 

=head2 What Can You Do with Objects?

You've seen that you can make objects, and call object methods with
them.  But what are object methods for?  The answer depends on the class:

A Net::FTP object represents a session between your computer and an FTP
server.  So the methods you call on a Net::FTP object are for doing
whatever you'd need to do across an FTP connection.  You make the
session and log in:

  my $session = Net::FTP->new('ftp.aol.com');
  die "Couldn't connect!" unless defined $session;
    # The class method call to "new" will return
    # the new object if it goes OK, otherwise it
    # will return undef.
    
  $session->login('sburke', 'p@ssw3rD')
   || die "Did I change my password again?";
    # The object method "login" will give a true
    # return value if actually logs in, otherwise
    # it'll return false.
    
You can use the session object to change directory on that session:

  $session->cwd("/home/sburke/public_html")
     || die "Hey, that was REALLY supposed to work!";
   # if the cwd fails, it'll return false

...get files from the machine at the other end of the session...

  foreach my $f ('log_report_ua.txt', 'log_report_dom.txt',
                 'log_report_browsers.txt')
  {
    $session->get($f) || warn "Getting $f failed!"
  };

...and plenty else, ending finally with closing the connection:

  $session->quit();

In short, object methods are for doing things related to (or with)
whatever the object represents.  For FTP sessions, it's about sending
commands to the server at the other end of the connection, and that's
about it -- there, methods are for doing something to the world outside
the object, and the objects is just something that specifies what bit
of the world (well, what FTP session) to act upon.

With most other classes, however, the object itself stores some kind of
information, and it typically makes no sense to do things with such an
object without considering the data that's in the object.

=head2 What's I<in> an Object?

An object is (with rare exceptions) a data structure containing a
bunch of attributes, each of which has a value, as well as a name
that you use when you
read or set the attribute's value.  Some of the object's attributes are
private, meaning you'll never see them documented because they're not
for you to read or write; but most of the object's documented attributes
are at least readable, and usually writeable, by you.  Net::FTP objects
are a bit thin on attributes, so we'll use objects from the class
Business::US_Amort for this example.  Business::US_Amort is a very
simple class (available from CPAN) that I wrote for making calculations
to do with loans (specifically, amortization, using US-style
algorithms).

An object of the class Business::US_Amort represents a loan with
particular parameters, i.e., attributes.  The most basic attributes of a
"loan object" are its interest rate, its principal (how much money it's
for), and it's term (how long it'll take to repay).  You need to set
these attributes before anything else can be done with the object.  The
way to get at those attributes for loan objects is just like the
way to get at attributes for any class's objects: through accessors.
An B<accessor> is simply any method that accesses (whether reading or
writing, AKA getting or putting) some attribute in the given object.
Moreover, accessors are the B<only> way that you can change
an object's attributes.  (If a module's documentation wants you to
know about any other way, it'll tell you.)

Usually, for simplicity's sake, an accessor is named after the attribute
it reads or writes.  With Business::US_Amort objects, the accessors you
need to use first are C<principal>, C<interest_rate>, and C<term>.
Then, with at least those attributes set, you can call the C<run> method
to figure out several things about the loan.  Then you can call various
accessors, like C<total_paid_toward_interest>, to read the results:

  use Business::US_Amort;
  my $loan = Business::US_Amort->new;
  # Set the necessary attributes:
  $loan->principal(123654);
  $loan->interest_rate(9.25);
  $loan->term(20); # twenty years

  # NOW we know enough to calculate:
  $loan->run;
  
  # And see what came of that:
  print
    "Total paid toward interest: A WHOPPING ",
    $loan->total_paid_interest, "!!\n";

This illustrates a convention that's common with accessors: calling the
accessor with no arguments (as with $loan->total_paid_interest) usually
means to read the value of that attribute, but providing a value (as
with $loan->term(20)) means you want that attribute to be set to that
value.  This stands to reason: why would you be providing a value, if
not to set the attribute to that value?

Although a loan's term, principal, and interest rates are all single
numeric values, an objects values can any kind of scalar, or an array,
or even a hash.  Moreover, an attribute's value(s) can be objects
themselves.  For example, consider MIDI files (as I wrote about in
TPJ#13): a MIDI file usually consists of several tracks.  A MIDI file is
complex enough to merit being an object with attributes like its overall
tempo, the file-format variant it's in, and the list of instrument
tracks in the file.  But tracks themselves are complex enough to be
objects too, with attributes like their track-type, a list of MIDI
commands if they're a MIDI track, or raw data if they're not.  So I
ended up writing the MIDI modules so that the "tracks" attribute of a
MIDI::Opus object is an array of objects from the class MIDI::Track.
This may seem like a runaround -- you ask what's in one object, and get
I<another> object, or several!  But in this case, it exactly reflects
what the module is for -- MIDI files contain MIDI tracks, which then
contain data.

=head2 What is an Object Value?

When you call a constructor like Net::FTP->new(I<hostname>), you get
back an object value, a value you can later use, in combination with a
method name, to call object methods. 

Now, so far we've been pretending, in the above examples, that the
variables $session or $loan I<are> the objects you're dealing with.
This idea is innocuous up to a point, but it's really a misconception
that will, at best, limit you in what you know how to do.  The reality
is not that the variables $session or $query are objects; it's a little
more indirect -- they I<hold> values that symbolize objects.  The kind of
value that $session or $query hold is what I'm calling an object value. 

To understand what kind of value this is, first think about the other
kinds of scalar values you know about: The first two scalar values you
probably ever ran into in Perl are B<numbers> and B<strings>, which you
learned (or just assumed) will usually turn into each other on demand;
that is, the three-character string "2.5" can become the quantity two
and a half, and vice versa.  Then, especially if you started using
C<perl -w> early on, you learned about the B<undefined value>, which can
turn into 0 if you treat it as a number, or the empty-string if you
treat it as a string.

=over

Footnote: You may I<also> have been learning about references, in which
case you're ready to hear that object values are just a kind of
reference, except that they reflect the class that created thing they point
to, instead of merely being a plain old array reference, hash reference,
etc.  I<If> this makes makes sense to you, and you want to know more
about how objects are implemented in Perl, have a look at the
C<perltoot> man page. 

=back

And now you're learning about B<object values>.  An object value is a
value that points to a data structure somewhere in memory, which is
where all the attributes for this object are stored.  That data
structure as a whole belongs to a class (probably the one you named in
the constructor method, like ClassName->new), so that the object value
can be used as part of object method calls. 

If you want to actually I<see> what an object value is, you might try
just saying "print $object".  That'll get you something like this:

  Net::FTP=GLOB(0x20154240)

or

  Business::US_Amort=HASH(0x15424020)

That's not very helpful if you wanted to really get at the object's
insides, but that's because the object value is only a symbol for the
object.  This may all sound very abstruse and metaphysical, so a
real-world allegory might be very helpful:

=over

You get an advertisement in the mail saying that you have been
(im)personally selected to have the rare privilege of applying for a
credit card.  For whatever reason, I<this> offer sounds good to you, so you
fill out the form and mail it back to the credit card company.  They
gleefully approve the application and create your account, and send you
a card with a number on it.

Now, you can do things with the number on that card -- clerks at stores
can ring up things you want to buy, and charge your account by keying in
the number on the card.  You can pay for things you order online by
punching in the card number as part of your online order.  You can pay
off part of the account by sending the credit card people some of your
money (well, a check) with some note (usually the pre-printed slip)
that has the card number for the account you want to pay toward.  And you
should be able to call the credit card company's computer and ask it
things about the card, like its balance, its credit limit, its APR, and
maybe an itemization of recent purchases ad payments.

Now, what you're I<really> doing is manipulating a credit card
I<account>, a completely abstract entity with some data attached to it
(balance, APR, etc).  But for ease of access, you have a credit card
I<number> that is a symbol for that account.  Now, that symbol is just a
bunch of digits, and the number is effectively meaningless and useless
in and of itself -- but in the appropriate context, it's understood to
I<mean> the credit card account you're accessing.

=back

This is exactly the relationship between objects and object values, and
from this analogy, several facts about object values are a bit more
explicable:

* An object value does nothing in and of itself, but it's useful when
you use it in the context of an $object->method call, the same way that
a card number is useful in the context of some operation dealing with a
card account.

Moreover, several copies of the same object value all refer to the same
object, the same way that making several copies of your card number
won't change the fact that they all still refer to the same single
account (this is true whether you're "copying" the number by just
writing it down on different slips of paper, or whether you go to the
trouble of forging exact replicas of your own plastic credit card).  That's
why this:

  $x = Net::FTP->new("ftp.aol.com");
  $x->login("sburke", "aoeuaoeu");

does the same thing as this:

  $x = Net::FTP->new("ftp.aol.com");
  $y = $x;
  $z = $y;
  $z->login("sburke", "aoeuaoeu");

That is, $z and $y and $x are three different I<slots> for values,
but what's in those slots are all object values pointing to the same
object -- you don't have three different FTP connections, just three
variables with values pointing to the some single FTP connection.

* You can't tell much of anything about the object just by looking at
the object value, any more than you can see your credit account balance
by holding the plastic card up to the light, or by adding up the digits
in your credit card number.

* You can't just make up your own object values and have them work --
they can come only from constructor methods of the appropriate class.
Similarly, you get a credit card number I<only> by having a bank approve
your application for a credit card account -- at which point I<they>
let I<you> know what the number of your new card is.

Now, there's even more to the fact that you can't just make up your own
object value: even though you can print an object value and get a string
like "Net::FTP=GLOB(0x20154240)", that string is just a
I<representation> of an object value.

Internally, an object value has a basically different type from a
string, or a number, or the undefined value -- if $x holds a real
string, then that value's slot in memory says "this is a value of type
I<string>, and its characters are...", whereas if it's an object value,
the value's slot in memory says, "this is a value of type I<reference>,
and the location in memory that it points to is..." (and by looking at
what's at that location, Perl can tell the class of what's there). 

Perl programmers typically don't have to think about all these details
of Perl's internals.  Many other languages force you to be more
conscious of the differences between all of these (and also between
types of numbers, which are stored differently depending on their size
and whether they have fractional parts).  But Perl does its best to
hide the different types of scalars from you -- it turns numbers into
strings and back as needed, and takes the string or number
representation of undef or of object values as needed.  However, you
can't go from a string representation of an object value, back to an
object value.  And that's why this doesn't work:

   $x = Net::FTP->new('ftp.aol.com');
   $y = Net::FTP->new('ftp.netcom.com');
   $z = Net::FTP->new('ftp.qualcomm.com');
   $all = join(' ', $x,$y,$z);           # !!!
  ...later...
   ($aol, $netcom, $qualcomm) = split(' ', $all);  # !!!
   $aol->login("sburke", "aoeuaoeu");
   $netcom->login("sburke", "qjkxqjkx");
   $qualcomm->login("smb", "dhtndhtn");

This fails because $aol ends up holding merely the B<string representation>
of the object value from $x, not the object value itself -- when
C<join> tried to join the characters of the "strings" $x, $y, and $z,
Perl saw that they weren't strings at all, so it gave C<join> their
string representations.

Unfortunately, this distinction between object values and their string
representations doesn't really fit into the analogy of credit card
numbers, because credit card numbers really I<are> numbers -- even
thought they don't express any meaningful quantity, if you stored them
in a database as a quantity (as opposed to just an ASCII string),
that wouldn't stop them from being valid as credit card numbers.

This may seem rather academic, but there's there's two common mistakes
programmers new to objects often make, which make sense only in terms of
the distinction between object values and their string representations:

The first common error involves forgetting (or never having known in the
first place) that when you go to use a value as a hash key, Perl uses
the string representation of that value.  When you want to use the
numeric value two and a half as a key, Perl turns it into the
three-character string "2.5".  But if you then want to use that string
as a number, Perl will treat it as meaning two and a half, so you're
usually none the wiser that Perl converted the number to a string and
back.  But recall that Perl can't turn strings back into objects -- so
if you tried to use a Net::FTP object value as a hash key, Perl actually
used its string representation, like "Net::FTP=GLOB(0x20154240)", but
that string is unusable as an object value.  (Incidentally, there's
a module Tie::RefHash that implements hashes that I<do> let you use
real object-values as keys.)

The second common error with object values is in
trying to save an object value to disk (whether printing it to a
file, or storing it in a conventional database file).  All you'll get is the
string, which will be useless.

When you want to save an object and restore it later, you may find that
the object's class already provides a method specifically for this.  For
example, MIDI::Opus provides methods for writing an object to disk as a
standard MIDI file.  The file can later be read back into memory by
a MIDI::Opus constructor method, which will return a new MIDI::Opus
object representing whatever file you tell it to read into memory.
Similar methods are available with, for example, classes that
manipulate graphic images and can save them to files, which can be read
back later.

But some classes, like Business::US_Amort, provide no such methods for
storing an object in a file.  When this is the case, you can try
using any of the Data::Dumper, Storable, or FreezeThaw modules.  Using
these will be unproblematic for objects of most classes, but it may run
into limitations with others.  For example, a Business::US_Amort
object can be turned into a string with Data::Dumper, and that string
written to a file.  When it's restored later, its attributes will be
accessible as normal.  But in the unlikely case that the loan object was
saved in mid-calculation, the calculation may not be resumable.  This is
because of the way that that I<particular> class does its calculations,
but similar limitations may occur with objects from other classses.

But often, even I<wanting> to save an object is basically wrong -- what would
saving an ftp I<session> even mean?  Saving the hostname, username, and
password?  current directory on both machines?  the local TCP/IP port
number?  In the case of "saving" a Net::FTP object, you're better off
just saving whatever details you actually need for your own purposes,
so that you can make a new object later and just set those values for it.

=head2 So Why Do Some Modules Use Objects?

All these details of using objects are definitely enough to make you
wonder -- is it worth the bother?  If you're a module author, writing
your module with an object-oriented interface restricts the audience of
potential users to those who understand the basic concepts of objects
and object values, as well as Perl's syntax for calling methods.  Why
complicate things by having an object-oriented interface?

A somewhat esoteric answer is that a module has an object-oriented
interface because the module's insides are written in an
object-oriented style.  This article is about the basics of
object-oriented I<interfaces>, and it'd be going far afield to explain
what object-oriented I<design> is.  But the short story is that
object-oriented design is just one way of attacking messy problems.
It's a way that many programmers find very helpful (and which others
happen to find to be far more of a hassle than it's worth,
incidentally), and it just happens to show up for you, the module user,
as merely the style of interface. 

But a simpler answer is that a functional interface is sometimes a
hindrance, because it limits the number of things you can do at once --
limiting it, in fact, to one.  For many problems that some modules are
meant to solve, doing without an object-oriented interface would be like
wishing that Perl didn't use filehandles.  The ideas are rather simpler
-- just imagine that Perl let you access files, but I<only> one at a
time, with code like:

  open("foo.txt") || die "Can't open foo.txt: $!";
  while(readline) {
    print $_ if /bar/;
  }
  close;

That hypothetical kind of Perl would be simpler, by doing without
filehandles.  But you'd be out of luck if you wanted to read from
one file while reading from another, or read from two and print to a
third.

In the same way, a functional FTP module would be fine for just
uploading files to one server at a time, but it wouldn't allow you to
easily write programs that make need to use I<several> simultaneous
sessions (like "look at server A and server B, and if A has a file
called X.dat, then download it locally and then upload it to server B --
except if B has a file called Y.dat, in which case do it the other way
around").

Some kinds of problems that modules solve just lend themselves to an
object-oriented interface.  For those kinds of tasks, a functional
interface would be more familiar, but less powerful.  Learning to use
object-oriented modules' interfaces does require becoming comfortable
with the concepts from this article.  But in the end it will allow you
to use a broader range of modules and, with them, to write programs
that can do more.

B<[end body of article]>

=head2 [Author Credit]

Sean M. Burke has contributed several modules to CPAN, about half of
them object-oriented.

[The next section should be in a greybox:]

=head2 The Gory Details

For sake of clarity of explanation, I had to oversimplify some of the
facts about objects.  Here's a few of the gorier details:

* Every example I gave of a constructor was a class method.  But object
methods can be constructors, too, if the class was written to work that
way: $new = $old->copy, $node_y = $node_x->new_subnode, or the like.

* I've given the impression that there's two kinds of methods: object
methods and class methods.  In fact, the same method can be both,
because it's not the kind of method it is, but the kind of calls it's
written to accept -- calls that pass an object, or calls that pass a
class-name.

* The term "object value" isn't something you'll find used much anywhere
else.  It's just my shorthand for what would properly be called an
"object reference" or "reference to a blessed item".  In fact, people
usually say "object" when they properly mean a reference to that object.

* I mentioned creating objects with I<con>structors, but I didn't
mention destroying them with I<de>structor -- a destructor is a kind of
method that you call to tidy up the object once you're done with it, and
want it to neatly go away (close connections, delete temporary files,
free up memory, etc).  But because of the way Perl handles memory,
most modules won't require the user to know about destructors.

* I said that class method syntax has to have the class name, as in
$session = B<Net::FTP>->new($host).  Actually, you can instead use any
expression that returns a class name: $ftp_class = 'Net::FTP'; $session
= B<$ftp_class>->new($host).  Moreover, instead of the method name for
object- or class-method calls, you can use a scalar holding the method
name: $foo->B<$method>($host).  But, in practice, these syntaxes are
rarely useful.

And finally, to learn about objects from the perspective of writing
your own classes, see the C<perltoot> documentation,
or Damian Conway's exhaustive and clear book I<Object Oriented Perl>
(Manning Publications 1999, ISBN 1-884777-79-1).

=head1 BACK

Return to the L<HTML::Tree|HTML::Tree> docs.

=cut

PK       ! ����d  �d    perl5/HTML/Tree/Scanning.podnu ��6�$        
#Time-stamp: "2001-03-10 23:19:11 MST" -*-Text-*-
# This document contains text in Perl "POD" format.
# Use a POD viewer like perldoc or perlman to render it.

=head1 NAME

HTML::Tree::Scanning -- article: "Scanning HTML"

=head1 SYNOPSIS

  # This an article, not a module.

=head1 DESCRIPTION

The following article by Sean M. Burke first appeared in I<The Perl
Journal> #19 and is copyright 2000 The Perl Journal. It appears
courtesy of Jon Orwant and The Perl Journal.  This document may be
distributed under the same terms as Perl itself.

(Note that this is discussed in chapters 6 through 10 of the
book I<Perl and LWP> L<http://lwp.interglacial.com/> which
was written after the following documentation, and which is
available free online.)

=head1 Scanning HTML

-- Sean M. Burke

In I<The Perl Journal> issue 17, Ken MacFarlane's article "Parsing
HTML with HTML::Parser" describes how the HTML::Parser module scans
HTML source as a stream of start-tags, end-tags, text, comments, etc.
In TPJ #18, my "Trees" article kicked around the idea of tree-shaped
data structures.  Now I'll try to tie it together, in a discussion of
HTML trees.

The CPAN module HTML::TreeBuilder takes the
tags that HTML::Parser picks out, and builds a parse tree -- a
tree-shaped network of objects...

=over

Footnote:
And if you need a quick explanation of objects, see my TPJ17 article "A
User's View of Object-Oriented Modules"; or go whole hog and get Damian
Conway's excellent book I<Object-Oriented Perl>, from Manning
Publications.

=back

...representing the structured content of the HTML document.  And once
the document is parsed as a tree, you'll find the common tasks
of extracting data from that HTML document/tree to be quite
straightforward.

=head2 HTML::Parser, HTML::TreeBuilder, and HTML::Element

You use HTML::TreeBuilder to make a parse tree out of an HTML source
file, by simply saying:

  use HTML::TreeBuilder;
  my $tree = HTML::TreeBuilder->new();
  $tree->parse_file('foo.html');

and then C<$tree> contains a parse tree built from the HTML source from
the file "foo.html".  The way this parse tree is represented is with a
network of objects -- C<$tree> is the root, an element with tag-name
"html", and its children typically include a "head" and "body" element,
and so on.  Elements in the tree are objects of the class
HTML::Element.

So, if you take this source:

  <html><head><title>Doc 1</title></head>
  <body>
  Stuff <hr> 2000-08-17
  </body></html>
 
and feed it to HTML::TreeBuilder, it'll return a tree of objects that
looks like this:

               html
             /      \
         head        body
        /          /   |  \
     title    "Stuff"  hr  "2000-08-17"
       |
    "Doc 1"

This is a pretty simple document, but if it were any more complex,
it'd be a bit hard to draw in that style, since it's sprawl left and
right.  The same tree can be represented a bit more easily sideways,
with indenting:

  . html
     . head
        . title
           . "Doc 1"
     . body
        . "Stuff"
        . hr
        . "2000-08-17"

Either way expresses the same structure.  In that structure, the root
node is an object of the class HTML::Element

=over

Footnote:
Well actually, the root is of the class HTML::TreeBuilder, but that's
just a subclass of HTML::Element, plus the few extra methods like
C<parse_file> that elaborate the tree

=back

, with the tag name "html", and with two children: an HTML::Element
object whose tag names are "head" and "body".  And each of those
elements have children, and so on down.  Not all elements (as we'll
call the objects of class HTML::Element) have children -- the "hr"
element doesn't.  And note all nodes in the tree are elements -- the
text nodes ("Doc 1", "Stuff", and "2000-08-17") are just strings.

Objects of the class HTML::Element each have three noteworthy attributes:

=over

=item C<_tag> -- (best accessed as C<$e-E<gt>tag>)
this element's tag-name, lowercased (e.g., "em" for an "em" element).

=over

Footnote: Yes, this is misnamed.  In proper SGML terminology, this is
instead called a "GI", short for "generic identifier"; and the term
"tag" is used for a token of SGML source that represents either
the start of an element (a start-tag like "<em lang='fr'>") or the end
of an element (an end-tag like "</em>".  However, since more people
claim to have been abducted by aliens than to have ever seen the
SGML standard, and since both encounters typically involve a feeling of
"missing time", it's not surprising that the terminology of the SGML
standard is not closely followed.

=back

=item C<_parent> -- (best accessed as C<$e-E<gt>parent>)
the element that is C<$obj>'s parent, or undef if this element is the
root of its tree.

=item C<_content> -- (best accessed as C<$e-E<gt>content_list>)
the list of nodes (i.e., elements or text segments) that are C<$e>'s
children.

=back

Moreover, if an element object has any attributes in the SGML sense of
the word, then those are readable as C<$e-E<gt>attr('name')> -- for
example, with the object built from having parsed "E<lt>a
B<id='foo'>E<gt>barE<lt>/aE<gt>", C<$e-E<gt>attr('id')> will return
the string "foo".  Moreover, C<$e-E<gt>tag> on that object returns the
string "a", C<$e-E<gt>content_list> returns a list consisting of just
the single scalar "bar", and C<$e-E<gt>parent> returns the object
that's this node's parent -- which may be, for example, a "p" element.

And that's all that there is to it -- you throw HTML
source at TreeBuilder, and it returns a tree built of HTML::Element
objects and some text strings.

However, what do you I<do> with a tree of objects?  People code
information into HTML trees not for the fun of arranging elements, but
to represent the structure of specific text and images -- some text is
in this "li" element, some other text is in that heading, some
images are in that other table cell that has those attributes, and so on.

Now, it may happen that you're rendering that whole HTML tree into some
layout format.  Or you could be trying to make some systematic change to
the HTML tree before dumping it out as HTML source again.  But, in my
experience, by far the most common programming task that Perl
programmers face with HTML is in trying to extract some piece
of information from a larger document.  Since that's so common (and
also since it involves concepts that are basic to more complex tasks),
that is what the rest of this article will be about.

=head2 Scanning HTML trees

Suppose you have a thousand HTML documents, each of them a press
release.  They all start out:

  [...lots of leading images and junk...]
  <h1>ConGlomCo to Open New Corporate Office in Ougadougou</h1>
  BAKERSFIELD, CA, 2000-04-24 -- ConGlomCo's vice president in charge
  of world conquest, Rock Feldspar, announced today the opening of a
  new office in Ougadougou, the capital city of Burkino Faso, gateway
  to the bustling "Silicon Sahara" of Africa...
  [...etc...]

...and what you've got to do is, for each document, copy whatever text
is in the "h1" element, so that you can, for example, make a table of
contents of it.  Now, there are three ways to do this:

=over

=item * You can just use a regexp to scan the file for a text pattern.

For many very simple tasks, this will do fine.  Many HTML documents are,
in practice, very consistently formatted as far as placement of
linebreaks and whitespace, so you could just get away with scanning the
file like so:

  sub get_heading {
    my $filename = $_[0];
    local *HTML;
    open(HTML, $filename)
      or die "Couldn't open $filename);
    my $heading;
   Line:
    while(<HTML>) {
      if( m{<h1>(.*?)</h1>}i ) {  # match it!
        $heading = $1;
        last Line;
      }
    }
    close(HTML);
    warn "No heading in $filename?"
     unless defined $heading;
    return $heading;
  }

This is quick and fast, but awfully fragile -- if there's a newline in
the middle of a heading's text, it won't match the above regexp, and
you'll get an error.  The regexp will also fail if the "h1" element's
start-tag has any attributes.  If you have to adapt your code to fit
more kinds of start-tags, you'll end up basically reinventing part of
HTML::Parser, at which point you should probably just stop, and use
HTML::Parser itself:

=item * You can use HTML::Parser to scan the file for an "h1" start-tag
token, then capture all the text tokens until the "h1" close-tag.  This
approach is extensively covered in the Ken MacFarlane's TPJ17 article
"Parsing HTML with HTML::Parser".  (A variant of this approach is to use
HTML::TokeParser, which presents a different and rather handier
interface to the tokens that HTML::Parser picks out.)

Using HTML::Parser is less fragile than our first approach, since it's
not sensitive to the exact internal formatting of the start-tag (much
less whether it's split across two lines).  However, when you need more
information about the context of the "h1" element, or if you're having
to deal with any of the tricky bits of HTML, such as parsing of tables,
you'll find out the flat list of tokens that HTML::Parser returns
isn't immediately useful.  To get something useful out of those tokens,
you'll need to write code that knows some things about what elements
take no content (as with "hr" elements), and that a "</p>" end-tags
are omissible, so a "<p>" will end any currently
open paragraph -- and you're well on your way to pointlessly
reinventing much of the code in HTML::TreeBuilder

=over

Footnote:
And, as the person who last rewrote that module, I can attest that it
wasn't terribly easy to get right!  Never underestimate the perversity
of people coding HTML.

=back

, at which point you should probably just stop, and use
HTML::TreeBuilder itself:

=item * You can use HTML::Treebuilder, and scan the tree of element
objects that you get back.

=back

The last approach, using HTML::TreeBuilder, is the diametric opposite of
first approach:  The first approach involves just elementary Perl and one
regexp, whereas the TreeBuilder approach involves being at home with
the concept of tree-shaped data structures and modules with
object-oriented interfaces, as well as with the particular interfaces
that HTML::TreeBuilder and HTML::Element provide.

However, what the TreeBuilder approach has going for it is that it's
the most robust, because it involves dealing with HTML in its "native"
format -- it deals with the tree structure that HTML code represents,
without any consideration of how the source is coded and with what
tags omitted.

So, to extract the text from the "h1" elements of an HTML document:

  sub get_heading {
    my $tree = HTML::TreeBuilder->new;
    $tree->parse_file($_[0]);   # !
    my $heading;
    my $h1 = $tree->look_down('_tag', 'h1');  # !
    if($h1) {
      $heading = $h1->as_text;   # !
    } else {
      warn "No heading in $_[0]?";
    }
    $tree->delete; # clear memory!
    return $heading;
  }

This uses some unfamiliar methods that need explaining.  The
C<parse_file> method that we've seen before, builds a tree based on
source from the file given.  The C<delete> method is for marking a
tree's contents as available for garbage collection, when you're done
with the tree.  The C<as_text> method returns a string that contains
all the text bits that are children (or otherwise descendants) of the
given node -- to get the text content of the C<$h1> object, we could
just say:

  $heading = join '', $h1->content_list;

but that will work only if we're sure that the "h1" element's children
will be only text bits -- if the document contained:

  <h1>Local Man Sees <cite>Blade</cite> Again</h1>

then the sub-tree would be:

  . h1
    . "Local Man Sees "
    . cite
      . "Blade"
    . " Again'

so C<join '', $h1-E<gt>content_list> will be something like:

  Local Man Sees HTML::Element=HASH(0x15424040) Again

whereas C<$h1-E<gt>as_text> would yield:

  Local Man Sees Blade Again

and depending on what you're doing with the heading text, you might
want the C<as_HTML> method instead.  It returns the (sub)tree
represented as HTML source.  C<$h1-E<gt>as_HTML> would yield:

  <h1>Local Man Sees <cite>Blade</cite> Again</h1>

However, if you wanted the contents of C<$h1> as HTML, but not the
C<$h1> itself, you could say:

  join '',
    map(
      ref($_) ? $_->as_HTML : $_,
      $h1->content_list
    )

This C<map> iterates over the nodes in C<$h1>'s list of children; and
for each node that's just a text bit (as "Local Man Sees " is), it just
passes through that string value, and for each node that's an actual
object (causing C<ref> to be true), C<as_HTML> will used instead of the
string value of the object itself (which would be something quite
useless, as most object values are).  So that C<as_HTML> for the "cite"
element will be the string "<cite>BladeE<lt>/cite>".  And then,
finally, C<join> just puts into one string all the strings that the
C<map> returns.

Last but not least, the most important method in our C<get_heading> sub
is the C<look_down> method.  This method looks down at the subtree
starting at the given object (C<$h1>), looking for elements that meet
criteria you provide.

The criteria are specified in the method's argument list.  Each
criterion can consist of two scalars, a key and a value, which express
that you want elements that have that attribute (like "_tag", or
"src") with the given value ("h1"); or the criterion can be a
reference to a subroutine that, when called on the given element,
returns true if that is a node you're looking for.  If you specify
several criteria, then that's taken to mean that you want all the
elements that each satisfy I<all> the criteria.  (In other words,
there's an "implicit AND".)

And finally, there's a bit of an optimization -- if you call the
C<look_down> method in a scalar context, you get just the I<first> node
(or undef if none) -- and, in fact, once C<look_down> finds that first
matching element, it doesn't bother looking any further.

So the example:

  $h1 = $tree->look_down('_tag', 'h1');

returns the first element at-or-under C<$tree> whose C<"_tag">
attribute has the value C<"h1">.

=head2 Complex Criteria in Tree Scanning

Now, the above C<look_down> code looks like a lot of bother, with
barely more benefit than just grepping the file!  But consider if your
criteria were more complicated -- suppose you found that some of the
press releases that you were scanning had several "h1" elements,
possibly before or after the one you actually want.  For example:

  <h1><center>Visit Our Corporate Partner
   <br><a href="/dyna/clickthru"
     ><img src="/dyna/vend_ad"></a>
  </center></h1>
  <h1><center>ConGlomCo President Schreck to Visit Regional HQ
   <br><a href="/photos/Schreck_visit_large.jpg"
     ><img src="/photos/Schreck_visit.jpg"></a>
  </center></h1>

Here, you want to ignore the first "h1" element because it contains an
ad, and you want the text from the second "h1".  The problem is in
formalizing the way you know that it's an ad.  Since ad banners are
always entreating you to "visit" the sponsoring site, you could exclude
"h1" elements that contain the word "visit" under them:

  my $real_h1 = $tree->look_down(
    '_tag', 'h1',
    sub {
      $_[0]->as_text !~ m/\bvisit/i
    }
  );

The first criterion looks for "h1" elements, and the second criterion
limits those to only the ones whose text content doesn't match
C<m/\bvisit/>.  But unfortunately, that won't work for our example,
since the second "h1" mentions "ConGlomCo President Schreck to
I<Visit> Regional HQ".

Instead you could try looking for the first "h1" element that
doesn't contain an image:

  my $real_h1 = $tree->look_down(
    '_tag', 'h1',
    sub {
      not $_[0]->look_down('_tag', 'img')
    }
  );

This criterion sub might seem a bit odd, since it calls C<look_down>
as part of a larger C<look_down> operation, but that's fine.  Note that
when considered as a boolean value, a C<look_down> in a scalar context
value returns false (specifically, undef) if there's no matching element
at or under the given element; and it returns the first matching
element (which, being a reference and object, is always a true value),
if any matches.  So, here, 

  sub {
    not $_[0]->look_down('_tag', 'img')
  }

means "return true only if this element has no 'img' element as
descendants (and isn't an 'img' element itself)."

This correctly filters out the first "h1" that contains the ad, but it
also incorrectly filters out the second "h1" that contains a
non-advertisement photo besides the headline text you want.

There clearly are detectable differences between the first and second
"h1" elements -- the only second one contains the string "Schreck", and
we could just test for that:

  my $real_h1 = $tree->look_down(
    '_tag', 'h1',
    sub {
      $_[0]->as_text =~ m{Schreck}
    }
  );

And that works fine for this one example, but unless all thousand of
your press releases have "Schreck" in the headline, that's just not a
general solution.  However, if all the ads-in-"h1"s that you want to
exclude involve a link whose URL involves "/dyna/", then you can use
that:

  my $real_h1 = $tree->look_down(
    '_tag', 'h1',
    sub {
      my $link = $_[0]->look_down('_tag','a');
      return 1 unless $link;
        # no link means it's fine
      return 0 if $link->attr('href') =~ m{/dyna/};
        # a link to there is bad
      return 1; # otherwise okay
    }
  );

Or you can look at it another way and say that you want the first "h1"
element that either contains no images, or else whose image has a "src"
attribute whose value contains "/photos/":

  my $real_h1 = $tree->look_down(
    '_tag', 'h1',
    sub {
      my $img = $_[0]->look_down('_tag','img');
      return 1 unless $img;
        # no image means it's fine
      return 1 if $img->attr('src') =~ m{/photos/};
        # good if a photo
      return 0; # otherwise bad
    }
  );

Recall that this use of C<look_down> in a scalar context means to return
the first element at or under C<$tree> that matches all the criteria.
But if you notice that you can formulate criteria that'll match several
possible "h1" elements, some of which may be bogus but the I<last> one
of which is always the one you want, then you can use C<look_down> in a
list context, and just use the last element of that list:

  my @h1s = $tree->look_down(
    '_tag', 'h1',
    ...maybe more criteria...
  );
  die "What, no h1s here?" unless @h1s;
  my $real_h1 = $h1s[-1]; # last or only

=head2 A Case Study: Scanning Yahoo News's HTML

The above (somewhat contrived) case involves extracting data from a
bunch of pre-existing HTML files.  In that sort of situation, if your
code works for all the files, then you know that the code I<works> --
since the data it's meant to handle won't go changing or growing; and,
typically, once you've used the program, you'll never need to use it
again.

The other kind of situation faced in many data extraction tasks is
where the program is used recurringly to handle new data -- such as
from ever-changing Web pages.  As a real-world example of this,
consider a program that you could use (suppose it's crontabbed) to
extract headline-links from subsections of Yahoo News
(C<http://dailynews.yahoo.com/>).

Yahoo News has several subsections:

=over

=item http://dailynews.yahoo.com/h/tc/ for technology news

=item http://dailynews.yahoo.com/h/sc/ for science news

=item http://dailynews.yahoo.com/h/hl/ for health news

=item http://dailynews.yahoo.com/h/wl/ for world news

=item http://dailynews.yahoo.com/h/en/ for entertainment news

=back

and others.  All of them are built on the same basic HTML template --
and a scarily complicated template it is, especially when you look at
it with an eye toward making up rules that will select where the real
headline-links are, while screening out all the links to other parts of
Yahoo, other news services, etc.  You will need to puzzle
over the HTML source, and scrutinize the output of
C<$tree-E<gt>dump> on the parse tree of that HTML.

Sometimes the only way to pin down what you're after is by position in
the tree. For example, headlines of interest may be in the third
column of the second row of the second table element in a page:

  my $table = ( $tree->look_down('_tag','table') )[1];
  my $row2  = ( $table->look_down('_tag', 'tr' ) )[1];
  my $col3  = ( $row2->look-down('_tag', 'td')   )[2];
  ...then do things with $col3...

Or they may be all the links in a "p" element that has at least three
"br" elements as children:

  my $p = $tree->look_down(
    '_tag', 'p',
    sub {
      2 < grep { ref($_) and $_->tag eq 'br' }
               $_[0]->content_list
    }
  );
  @links = $p->look_down('_tag', 'a');

But almost always, you can get away with looking for properties of the
of the thing itself, rather than just looking for contexts.  Now, if
you're lucky, the document you're looking through has clear semantic
tagging, such is as useful in CSS -- note the
class="headlinelink" bit here:

  <a href="...long_news_url..." class="headlinelink">Elvis
  seen in tortilla</a>

If you find anything like that, you could leap right in and select
links with:

  @links = $tree->look_down('class','headlinelink');

Regrettably, your chances of seeing any sort of semantic markup
principles really being followed with actual HTML are pretty thin.

=over

Footnote:
In fact, your chances of finding a page that is simply free of HTML
errors are even thinner.  And surprisingly, sites like Amazon or Yahoo
are typically worse as far as quality of code than personal sites
whose entire production cycle involves simply being saved and uploaded
from Netscape Composer.

=back

The code may be sort of "accidentally semantic", however -- for example,
in a set of pages I was scanning recently, I found that looking for
"td" elements with a "width" attribute value of "375" got me exactly
what I wanted.  No-one designing that page ever conceived of
"width=375" as I<meaning> "this is a headline", but if you impute it
to mean that, it works.

An approach like this happens to work for the Yahoo News code, because
the headline-links are distinguished by the fact that they (and they
alone) contain a "b" element:

  <a href="...long_news_url..."><b>Elvis seen in tortilla</b></a>

or, diagrammed as a part of the parse tree:

  . a  [href="...long_news_url..."]
    . b
      . "Elvis seen in tortilla"

A rule that matches these can be formalized as "look for any 'a'
element that has only one daughter node, which must be a 'b' element".
And this is what it looks like when cooked up as a C<look_down>
expression and prefaced with a bit of code that retrieves the text of
the given Yahoo News page and feeds it to TreeBuilder:

  use strict;
  use HTML::TreeBuilder 2.97;
  use LWP::UserAgent;
  sub get_headlines {
    my $url = $_[0] || die "What URL?";
    
    my $response = LWP::UserAgent->new->request(
      HTTP::Request->new( GET => $url )
    );
    unless($response->is_success) {
      warn "Couldn't get $url: ", $response->status_line, "\n";
      return;
    }
    
    my $tree = HTML::TreeBuilder->new();
    $tree->parse($response->content);
    $tree->eof;
    
    my @out;
    foreach my $link (
      $tree->look_down(   # !
        '_tag', 'a',
        sub {
          return unless $_[0]->attr('href');
          my @c = $_[0]->content_list;
          @c == 1 and ref $c[0] and $c[0]->tag eq 'b';
        }
      )
    ) {
      push @out, [ $link->attr('href'), $link->as_text ];
    }
    
    warn "Odd, fewer than 6 stories in $url!" if @out < 6;
    $tree->delete;
    return @out;
  }

...and add a bit of code to actually call that routine and display the
results...

  foreach my $section (qw[tc sc hl wl en]) {
    my @links = get_headlines(
      "http://dailynews.yahoo.com/h/$section/"
    );
    print
      $section, ": ", scalar(@links), " stories\n",
      map(("  ", $_->[0], " : ", $_->[1], "\n"), @links),
      "\n";
  }

And we've got our own headline-extractor service!  This in and of
itself isn't no amazingly useful (since if you want to see the
headlines, you I<can> just look at the Yahoo News pages), but it could
easily be the basis for quite useful features like filtering the
headlines for matching certain keywords of interest to you.

Now, one of these days, Yahoo News will decide to change its HTML
template.  When this happens, this will appear to the above program as
there being no links that meet the given criteria; or, less likely,
dozens of erroneous links will meet the criteria.  In either case, the
criteria will have to be changed for the new template; they may just
need adjustment, or you may need to scrap them and start over.

=head2 I<Regardez, duvet!>

It's often quite a challenge to write criteria to match the desired
parts of an HTML parse tree.  Very often you I<can> pull it off with a
simple C<$tree-E<gt>look_down('_tag', 'h1')>, but sometimes you do
have to keep adding and refining criteria, until you might end up with
complex filters like what I've shown in this article.  The
benefit to learning how to deal with HTML parse trees is that one main
search tool, the C<look_down> method, can do most of the work, making
simple things easy, while still making hard things possible.

B<[end body of article]>

=head2 [Author Credit]

Sean M. Burke (C<sburke@cpan.org>) is the current maintainer of
C<HTML::TreeBuilder> and C<HTML::Element>, both originally by
Gisle Aas.

Sean adds: "I'd like to thank the folks who listened to me ramble
incessantly about HTML::TreeBuilder and HTML::Element at this year's Yet
Another Perl Conference and O'Reilly Open Source Software Convention."

=head1 BACK

Return to the L<HTML::Tree|HTML::Tree> docs.

=cut

PK       ! MD����  ��    perl5/HTML/Tree/AboutTrees.podnu ��6�$        
#Time-stamp: "2001-02-23 20:09:47 MST" -*-Text-*-
# This document contains text in Perl "POD" format.
# Use a POD viewer like perldoc or perlman to render it.

=head1 NAME

HTML::Tree::AboutTrees -- article on tree-shaped data structures in Perl

=head1 SYNOPSIS

  # This an article, not a module.

=head1 DESCRIPTION

The following article by Sean M. Burke first appeared in I<The Perl
Journal> #18 and is copyright 2000 The Perl Journal. It appears
courtesy of Jon Orwant and The Perl Journal.  This document may be
distributed under the same terms as Perl itself.

=head1 Trees

-- Sean M. Burke

=over

"AaaAAAaauugh!  Watch out for that tree!"
  -- I<George of the Jungle theme>

=back

Perl's facility with references, combined with its automatic management of
memory allocation, makes it straightforward to write programs that store data
in structures of arbitrary form and complexity.

But I've noticed that many programmers, especially those who started out
with more restrictive languages, seem at home with complex but uniform
data structures -- N-dimensional arrays, or more struct-like things like
hashes-of-arrays(-of-hashes(-of-hashes), etc.) -- but they're often uneasy
with building more freeform, less tabular structures, like
tree-shaped data structures.

But trees are easy to build and manage in Perl, as I'll demonstrate
by showing off how the HTML::Element class manages elements in an HTML
document tree, and by walking you through a from-scratch implementation
of game trees.  But first we need to nail down what we mean by a "tree".

=head2 Socratic Dialogues: "What is a Tree?"

My first brush with tree-shaped structures was in linguistics classes,
where tree diagrams are used to describe the syntax underlying natural
language sentences.  After learning my way around I<those> trees, I
started to wonder -- are what I'm used to calling "trees" the same as what
programmers call "trees"?  So I asked lots of helpful and patient
programmers how they would define a tree.  Many replied with a
answer in jargon that they could not really explain (understandable,
since explaining things, especially defining things, is harder
than people think):

=over

-- So what I<is> a "tree", a tree-shaped data structure?

-- A tree is a special case of an acyclic directed graph!

-- What's a "graph"?

-- Um... lines... and... you draw it... with... arcs! nodes!  um...

=back

The most helpful were folks who couldn't explain directly, but with
whom I could get into a rather Socratic dialog (where I<I> asked the
half-dim half-earnest questions), often with much doodling of
illustrations...

Question: so what's a tree?

Answer: A tree is a collection of nodes that are linked together in a,
well, tree-like way!  Like this I<[drawing on a napkin]:>

     A
    / \
   B   C
     / | \
    D  E  F 

Q: So what do these letters represent?

A: Each is a different node, a bunch of data.  Maybe C is a
bunch of data that stores a number, maybe a hash table, maybe nothing
at all besides the fact that it links to D, E, and F (which are other
nodes).

Q: So what're the lines between the nodes?

A: Links.  Also called "arcs".  They just symbolize the fact that each
node holds a list of nodes it links to.

Q: So what if I draw nodes and links, like this...

     B -- E
    / \  / \
   A   C    
    \ /
     E 

Is that still a tree?

A: No, not at all.  There's a lot of un-treelike things about that.
First off, E has a link coming off of it going into nowhere.  You can't have
a link to nothing -- you can only link to another node.  Second off, I
don't know what that sideways link between B and E means... 

Q: Okay, let's work our way up from something simpler.  Is this a tree...?

    A

A: Yes, I suppose.  It's a tree of just one node.

Q: And how about...

   A
   
   B
   
A: No, you can't just have nodes floating there, unattached.

Q: Okay, I'll link A and B.  How's this?

   A
   |
   B

A: Yup, that's a tree.  There's a node A, and a node B, and they're linked.

Q: How is that tree any different from this one...?

   B
   |
   A

A: Well, in both cases A and B are linked.  But it's in a different
direction.

Q: Direction?  What does the direction mean?

A: Well, it depends what the tree represents.  If it represents a
categorization, like this:

          citrus
       /    |    \
   orange  lemon  kumquat ...

then you mean to say that oranges, lemons, kumquats, etc., are a kind of
citrus.  But if you drew it upside down, you'd be saying, falsely, that
citrus is a kind of kumquat, a kind of lemon, and a kind of orange.
If the tree represented cause-and-effect (or at least what situations
could follow others), or represented what's a part of what, you
wouldn't want to get those backwards, either.  So with the nodes you
draw together on paper, one has to be over the other, so you can tell which
way the relationship in the tree works.

Q:  So are these two trees the same?

     A          A
    / \        / \
   B   C      B   \
                   C

A: Yes, although by convention we often try to line up things in the
same generation, like it is in the diagram on the left.

Q: "generation"?  This is a family tree?

A: No, not unless it's a family tree for just yeast cells or something
else that reproduces asexually.
But for sake of having lots of terms to use, we just pretend that links
in the tree represent the "is a child of" relationship, instead of "is a
kind of" or "is a part of", or "could result from", or whatever the real
relationship is.  So we get to borrow a lot of kinship words for
describing trees -- B and C are "children" (or "daughters") of A; A is
the "parent" (or "mother") of B and C.  Node C is a "sibling" (or
"sister") of node C; and so on, with terms like "descendants" (a node's
children, children's children, etc.), and "generation" (all the
nodes at the same "level" in the tree, i.e., are either all
grandchildren of the top node, or all great-grand-children, etc.), and
"lineage" or "ancestors" (parents, and parent's parents, etc., all the
way to the topmost node). 

So then we get to express rules in terms like "B<A node cannot have more
than one parent>", which means that this is not a valid tree:

    A
   / \
  B   C
   \ /
    E

And: "B<A node can't be its own parent>", which excludes this looped-up
connection:

    /\
   A  |
    \/

Or, put more generally: "B<A node can't be its own ancestor>", which
excludes the above loop, as well as the one here:

      /\
     Z  |
    /   |
   A    |
  / \   |
 B   C  |
      \/

That tree is excluded because A is a child of Z, and Z is a child of C,
and C is a child of A, which means A is its own great-grandparent.  So
this whole network can't be a tree, because it breaks the sort of
meta-rule: B<once any node in the supposed tree breaks the rules for
trees, you don't have a tree anymore.>

Q: Okay, now, are these two trees the same?

     A         A
   / | \     / | \
  B  C  D   D  C  B

A: It depends whether you're basing your concept of trees on each node
having a set (unordered list) of children, or an (ordered) list of
children.  It's a question of whether ordering is important for what
you're doing.  With my diagram of citrus types, ordering isn't
important, so these tree diagrams express the same thing:

          citrus
       /    |    \
   orange  lemon  kumquat

           citrus
       /     |    \
   kumquat  orange  lemon

because it doesn't make sense to say that oranges are "before" or
"after" kumquats in the whole botanical scheme of things.  (Unless, of
course, you I<are> using ordering to mean something, like a degree of
genetic similarity.)

But consider a tree that's a diagram of what steps are comprised in an
activity, to some degree of specificity:

           make tea
         /    |     \
   pour     infuse   serve
 hot water    / \
in cup/pot  /     \
           add     let
           tea     sit
          leaves

This means that making tea consists of putting hot water in a cup or
put, infusing it (which itself consists of adding tea leaves and letting
it sit), then serving it -- I<in that order>.  If you serve an empty
dry pot (sipping from empty cups, etc.), let it sit, add tea leaves,
and pour in hot water, then what you're doing is performance art, not
tea preparation:
           
        performance
            art
        /    |     \
   serve   infuse    pour
            / \       hot water
          /     \      in cup/pot
         let     add
         sit     tea
                leaves

Except for my having renamed the root, this tree is the same as
the making-tea tree as far as what's under what, but it differs
in order, and what the tree means makes the order important.

Q: Wait -- "root"?  What's a root?

A: Besides kinship terms like "mother" and "daughter", the jargon for
tree parts also has terms from real-life tree parts:  the part that
everything else grows from is called the root; and nodes that don't
have nodes attached to them (i.e., childless nodes) are called
"leaves".

Q: But you've been drawing all your trees with the root at the top and
leaves at the bottom.

A: Yes, but for some reason, that's the way everyone seems to think of
trees.  They can draw trees as above; or they can draw them sort of
sideways with indenting representing what nodes are children of what:

  * make tea
     * pour hot water in cup/pot
     * infuse
        * add tea leaves
        * let sit
     * serve

...but folks almost never seem to draw trees with the root at the
bottom.  So imagine it's based on spider plant in a hanging pot.
Unfortunately, spider plants I<aren't> botanically trees, they're
plants; but "spider plant diagram" is rather a mouthful, so let's just
call them trees.

=head2 Trees Defined Formally

In time, I digested all these assorted facts about programmers' ideas of
trees (which turned out to be just a more general case of linguistic
ideas of trees) into a single rule:

* A node is an item that contains ("is over", "is parent of", etc.)
zero or more other nodes.

From this you can build up formal definitions for useful terms, like so:

* A node's B<descendants> are defined as all its children, and all
their children, and so on.  Or, stated recursively: a node's
descendants are all its children, and all its children's descendants.
(And if it has no children, it has no descendants.)

* A node's B<ancestors> consist of its parent, and its parent's
parent, etc, up to the root.  Or, recursively: a node's ancestors
consist of its parent and its parent's ancestors.  (If it has no parent,
it has no ancestors.)

* A B<tree> is a root node and all the root's descendants.

And you can add a proviso or two to clarify exactly what I impute to the
word "other" in "other nodes":

* A node cannot contain itself, or contain any node that contains it,
etc.  Looking at it the other way: a node cannot be its own parent or
ancestor.

* A node can be root (i.e., no other node contains it) or can be
contained by only one parent; no node can be the child of two or more
parents.

Add to this the idea that children are sometimes ordered, and sometimes
not, and that's about all you need to know about defining what a tree
is.  From there it's a matter of using them.

=head2 Markup Language Trees: HTML-Tree

While not I<all> markup languages are inherently tree-like, the
best-known family of markup languages, HTML, SGML, and XML, are about
as tree-like as you can get.  In these languages, a document consists
of elements and character data in a tree structure where
there is one root element, and elements can contain either other
elements, or character data.

=over

Footnote:
For sake of simplicity, I'm glossing over
comments (<!-- ... -->), processing instructions (<?xml
version='1.0'>), and declarations (<!ELEMENT ...>, <!DOCTYPE ...>).
And I'm not bothering to distinguish entity references
(&lt;, &#64;) or CDATA sections (<![CDATA[ ...]]>) from normal text.

=back

For example, consider this HTML document:

  <html lang="en-US">
    <head>
      <title>
        Blank Document!
      </title>
    </head>
    <body bgcolor="#d010ff">
      I've got
      <em>
        something to saaaaay
      </em>
      !
    </body>
  </html>

I've indented this to point out what nodes (elements or text items) are
children of what, with each node on a line of its own.

The HTML::TreeBuilder module (in the CPAN distribution HTML-Tree)
does the work of taking HTML source and
building in memory the tree that the document source represents.

=over

Footnote: it requires the HTML::Parser module, which tokenizes the
source -- i.e., identifies each tag, bit of text, comment, etc.

=back

The trees structures that it builds represent bits of text with
normal Perl scalar string values; but elements are represented with
objects -- that is, chunks of data that belong to a
class (in this case, HTML::Element), a class that provides methods
(routines) for accessing the pieces of data in each element, and
otherwise doing things with elements.  (See my article in TPJ#17 for a
quick explanation of objects, the POD document C<perltoot> for a longer
explanation, or Damian Conway's excellent book I<Object-Oriented Perl>
for the full story.)

Each HTML::Element object contains a number of pieces of data:

* its element name ("html", "h1", etc., accessed as $element->tag)

* a list of elements (or text segments) that it contains, if any
(accessed as $element->content_list or $element->content, depending on
whether you want a list, or an arrayref)

* what element, if any, contains it (accessed as $element->parent)

* and any SGML attributes that the element has,
such as C<lang="en-US">, C<align="center">, etc. (accessed as
$element->attr('lang'), $element->attr('center'), etc.)

So, for example, when HTML::TreeBuilder builds the tree for the above
HTML document source, the object for the "body" element has these pieces of
data:

 * element name: "body"
 * nodes it contains:
    the string "I've got "
    the object for the "em" element
    the string "!"
 * its parent:
    the object for the "html" element
 * bgcolor: "#d010ff"

Now, once you have this tree of objects, almost anything you'd want to
do with it starts with searching the tree for some bit of information
in some element.

Accessing a piece of information in, say, a hash of hashes of hashes,
is straightforward:

  $password{'sean'}{'sburke1'}{'hpux'}

because you know that all data points in that structure are accessible
with that syntax, but with just different keys.  Now, the "em" element
in the above HTML tree does happen to be accessible
as the root's child #1's child #1:

  $root->content->[1]->content->[1]

But with trees, you typically don't know the exact location (via
indexes) of the data you're looking for.  Instead, finding what you want
will typically involve searching through the tree, seeing if every node is
the kind you want.  Searching the whole tree is simple enough -- look at
a given node, and if it's not what you want, look at its children, and
so on.  HTML-Tree provides several methods that do this for you, such as
C<find_by_tag_name>, which returns the elements (or the first element, if
called in scalar context) under a given node (typically the root) whose
tag name is whatever you specify.

For example, that "em" node can be found as:

  my $that_em = $root->find_by_tag_name('em');

or as:

  @ems = $root->find_by_tag_name('em');
   # will only have one element for this particular tree

Now, given an HTML document of whatever structure and complexity, if you
wanted to do something like change every

=over

E<lt>emE<gt>I<stuff>E<lt>/emE<gt>

=back

to

=over

E<lt>em class="funky"E<gt>
B<E<lt>bE<gt>[-E<lt>/bE<gt>>
I<stuff>
B<E<lt>bE<gt>-]E<lt>/bE<gt>>
E<lt>/emE<gt>

=back

the first step is to frame this operation in terms of what you're doing
to the tree.  You're changing this:

      em
       |
      ...

to this:

      em
    /  |  \  
   b  ...   b
   |        |
  "[-"     "-]"

In other words, you're finding all elements whose tag name is "em", 
setting its class attribute to "funky", and adding one child to the start
of its content list -- a new "b" element
whose content is the text string "[-" -- and one to the end of its
content list -- a new "b" element whose content is the text string "-]". 

Once you've got it in these terms, it's just a matter of running to the
HTML::Element documentation, and coding this up with calls to the
appropriate methods, like so:

  use HTML::Element 1.53;
  use HTML::TreeBuilder 2.96;
  # Build the tree by parsing the document
  my $root = HTML::TreeBuilder->new;
  $root->parse_file('whatever.html'); # source file
  
  # Now make new nodes where needed
  foreach my $em ($root->find_by_tag_name('em')) {
    $em->attr('class', 'funky'); # Set that attribute
    
    # Make the two new B nodes
    my $new1 = HTML::Element->new('b');
    my $new2 = HTML::Element->new('b');
    # Give them content (they have none at first)
    $new1->push_content('[-');
    $new2->push_content('-]');
    
    # And put 'em in place!
    $em->unshift_content($new1);
    $em->push_content($new2);
  }
  print
   "<!-- Looky see what I did! -->\n",
   $root->as_HTML(), "\n";

The class HTML::Element provides just about every method I can image you
needing, for manipulating trees made of HTML::Element objects.  (And
what it doesn't directly provide, it will give you the components to build
it with.)

=head2 Building Your Own Trees

Theoretically, any tree is pretty much like any other tree, so you could
use HTML::Element for anything you'd ever want to do with tree-arranged
objects.  However, as its name implies, HTML::Element is basically
I<for> HTML elements; it has lots of features that make sense only for
HTML elements (like the idea that every element must have a tag-name).
And it lacks some features that might be useful for general applications
-- such as any sort of checking to make sure that you're not trying to
arrange objects in a non-treelike way.  For a general-purpose tree class
that does have such features, you can use Tree::DAG_Node, also available
from CPAN. 

However, if your task is simple enough, you might find it overkill to
bother using Tree::DAG_Node.  And, in any case, I find that the best
way to learn how something works is to implement it (or something like
it, but simpler) yourself.  So I'll here discuss how you'd implement a tree
structure, I<without> using any of the existing classes for tree nodes.

=head2 Implementation: Game Trees for Alak

Suppose that the task at hand is to write a program that can play
against a human opponent at a strategic board game (as opposed to a
board game where there's an element of chance).  For most such games, a
"game tree" is an essential part of the program (as I will argue,
below), and this will be our test case for implementing a tree
structure from scratch.

For sake of simplicity, our game is not chess or backgammon, but instead
a much simpler game called Alak.  Alak was invented by the mathematician
A. K.  Dewdney, and described in his 1984 book I<Planiverse>. The rules
of Alak are simple:

=over

Footnote: Actually, I'm describing only my
interpretation of the rules Dewdney describes in I<Planiverse>.  Many
other interpretations are possible.

=back

* Alak is a two-player game played on a one-dimensional board with
eleven slots on it.  Each slot can hold at most one piece at a time.
There's two kinds of pieces, which I represent here as "x" and "o" --
x's belong to one player (called X), o's to the other (called O).

* The initial configuration of the board is:

   xxxx___oooo
   
For sake of the article, the slots are numbered from 1 (on the left) to
11 (on the right), and X always has the first move.

* The players take turns moving.  At each turn, each player can move
only one piece, once.  (This unlike checkers, where you move one piece
per move but get to keep moving it if you jump an your opponent's
piece.) A player cannot pass up on his turn.  A player can move any one
of his pieces to the next unoccupied slot to its right or left, which
may involve jumping over occupied slots.  A player cannot move a piece
off the side of the board.

* If a move creates a pattern where the opponent's pieces are
surrounded, on both sides, by two pieces of the mover's color (with no
intervening unoccupied blank slot), then those surrounded pieces are
removed from the board.

* The goal of the game is to remove all of your opponent's pieces, at
which point the game ends.  Removing all-but-one ends the game as
well, since the opponent can't surround you with one piece, and so will
always lose within a few moves anyway.

Consider, then, this rather short game where X starts:

  xxxx___oooo
    ^         Move 1: X moves from 3 (shown with caret) to 5
               (Note that any of X's pieces could move, but
               that the only place they could move to is 5.)
  xx_xx__oooo
          ^   Move 2: O moves from 9 to 7.
  xx_xx_oo_oo
     ^        Move 3: X moves from 4 to 6.
  xx__xxoo_oo
           ^  Move 4: O (stupidly) moves from 10 to 9.
  xx__xxooo_o
      ^       Move 5: X moves from 5 to 10, making the board
              "xx___xoooxo".  The three o's that X just
              surrounded are removed. 
  xx___x___xo
              O has only one piece, so has lost.

Now, move 4 could have gone quite the other way:

  xx__xxoo_oo
              Move 4: O moves from 8 to 4, making the board 
              "xx_oxxo__oo".  The surrounded x's are removed.
  xx_o__o__oo
  ^           Move 5: X moves from 1 to 2.
  _xxo__o__oo
        ^     Move 6: O moves from 7 to 6.
  _xxo_o___oo
   ^          Move 7: X moves from 2 to 5, removing the o at 4.
  __x_xo___oo
              ...and so on.

To teach a computer program to play Alak (as player X, say), it needs to
be able to look at the configuration of the board, figure out what moves
it can make, and weigh the benefit or costs, immediate or eventual, of
those moves.

So consider the board from just before move 3, and figure all the possible
moves X could make.  X has pieces in slots 1, 2, 4, and 5.  The leftmost
two x's (at 1 and 2) are up against the end of the board, so they
can move only right.  The other two x's (at 4 and 5) can move either
right or left:

  Starting board: xx_xx_oo_oo
   moving 1 to 3 gives _xxxx_oo_oo
   moving 2 to 3 gives x_xxx_oo_oo
   moving 4 to 3 gives xxx_x_oo_oo
   moving 5 to 3 gives xxxx__oo_oo
   moving 4 to 6 gives xx__xxoo_oo
   moving 5 to 6 gives xx_x_xoo_oo

For the computer to decide which of these is the best move to make, it
needs to quantify the benefit of these moves as a number -- call that
the "payoff".  The payoff of a move can be figured as just the number
of x pieces removed by the most recent move, minus the number of o
pieces removed by the most recent move.  (It so happens that the rules
of the game mean that no move can delete both o's and x's, but the
formula still applies.)  Since none of these moves removed any pieces,
all these moves have the same immediate payoff: 0.

Now, we could race ahead and write an Alak-playing program that could
use the immediate payoff to decide which is the best move to make.
And when there's more than one best move (as here, where all the moves
are equally good), it could choose randomly between the good
alternatives.  This strategy is simple to implement; but it makes for a
very dumb program.  Consider what O's response to each of the potential
moves (above) could be.  Nothing immediately suggests itself for the
first four possibilities (X having moved something to position 3), but
either of the last two (illustrated below) are pretty perilous,
because in either case O has the obvious option (which he would be
foolish to pass up) of removing x's from the board:

   xx_xx_oo_oo
      ^        X moves 4 to 6.
   xx__xxoo_oo
          ^    O moves 8 to 4, giving "xx_oxxo__oo".  The two
               surrounded x's are removed.
   xx_o__o__oo

or

   xx_xx_oo_oo
       ^       X moves 5 to 6.
   xx_x_xoo_oo
          ^    O moves 8 to 5, giving "xx_xoxo__oo".  The one
               surrounded x is removed.
   xx_xo_o__oo

Both contingencies are quite bad for X -- but this is not captured
by the fact that they start out with X thinking his move will be
harmless, having a payoff of zero.

So what's needed is for X to think I<more> than one step ahead -- to
consider not merely what it can do in this move, and what the payoff
is, but to consider what O might do in response, and the
payoff of those potential moves, and so on with X's possible responses
to those cases could be.  All these possibilities form a game tree -- a
tree where each node is a board, and its children are successors of
that node -- i.e., the boards that could result from every move
possible, given the parent's board.

But how to represent the tree, and how to represent the nodes?

Well, consider that a node holds several pieces of data:

1) the configuration of the board, which, being nice and simple and
one-dimensional, can be stored as just a string, like "xx_xx_oo_oo".

2) whose turn it is, X or O.  (Or: who moved last, from which we can
figure whose turn it is).

3) the successors (child nodes).

4) the immediate payoff of having moved to this board position from its
predecessor (parent node).

5) and what move gets us from our predecessor node to here.  (Granted,
knowing the board configuration before and after the move, it's easy to
figure out the move; but it's easier still to store it as one is
figuring out a node's successors.)

6) whatever else we might want to add later.

These could be stored equally well in an array or in a hash, but it's my
experience that hashes are best for cases where you have more than just
two or three bits of data, or especially when you might need to add new
bits of data.  Moreover, hash key names are mnemonic --
$node->{'last_move_payoff'} is plain as day, whereas it's not so easy having to
remember with an array that $node->[3] is where you decided to keep the
payoff.

=over

Footnote:
Of course, there are ways around that problem: just swear you'll never
use a real numeric index to access data in the array, and instead use
constants with mnemonic names:

  use strict;
  use constant idx_PAYOFF => 3;
  ...
  $n->[idx_PAYOFF]

Or use a pseudohash.  But I prefer to keep it simple, and use a hash.

These are, incidentally, the same arguments that
people weigh when trying to decide whether their object-oriented
modules should be based on blessed hashes, blessed arrays, or what.
Essentially the only difference here is that we're not blessing our
nodes or talking in terms of classes and methods.

[end footnote]

=back

So, we might as well represent nodes like so:

  $node = { # hashref
     'board'          => ...board string, e.g., "xx_x_xoo_oo"
     
     'last_move_payoff' => ...payoff of the move
                            that got us here.
                            
     'last_move_from' =>  ...the start...
     'last_move_to'   =>  ...and end point of the move
                              that got us here.  E.g., 5 and 6,
                              representing a move from 5 to 6.

     'whose_turn'     => ...whose move it then becomes.
                           just an 'x' or 'o'.
                              
     'successors' => ...the successors
  };

Note that we could have a field called something like 'last_move_who' to
denote who last moved, but since turns in Alak always alternate (and
no-one can pass), storing whose move it is now I<and> who last moved is
redundant -- if X last moved, it's O turn now, and vice versa.
I chose to have a 'whose_turn' field instead of a 'last_move_who', but
it doesn't really matter.  Either way, we'll end up inferring one from
the other at several points in the program.

When we want to store the successors of a node, should we use an array
or a hash?  On the one hand, the successors to $node aren't essentially
ordered, so there's no reason to use an array per se; on the other hand,
if we used a hash, with successor nodes as values, we don't have
anything particularly meaningful to use as keys.  (And we can't use the
successors themselves as keys, since the nodes are referred to by
hash references, and you can't use a reference as a hash key.)  Given no
particularly compelling reason to do otherwise, I choose to just use an
array to store all a node's successors, although the order is never
actually used for anything:

  $node = {
    ...
    'successors' => [ ...nodes... ],
    ...
  };

In any case, now that we've settled on what should be in a node, 
let's make a little sample tree out of a few nodes and see what we can
do with it:

  # Board just before move 3 in above game
  my $n0 = {
    'board' => 'xx_xx_oo_oo',
    'last_move_payoff' => 0,
    'last_move_from' =>  9,
    'last_move_to'   =>  7,
    'whose_turn' => 'x',
    'successors' => [],
  };

  # And, for now, just two of the successors:
  
  # X moves 4 to 6, giving xx__xxoo_oo
  my $n1 = {
    'board' => 'xx__xxoo_oo',
    'last_move_payoff' => 0,
    'last_move_from' =>  4,
    'last_move_to'   =>  6,
    'whose_turn' => 'o',
    'successors' => [],
  };

  # or X moves 5 to 6, giving xx_x_xoo_oo
  my $n2 = {
    'board' => 'xx_x_xoo_oo',
    'last_move_payoff' => 0,
    'last_move_from' =>  5,
    'last_move_to'   =>  6,
    'whose_turn' => 'o',
    'successors' => [],
  };

  # Now connect them...
  push @{$n0->{'successors'}}, $n1, $n2;

=head2 Digression: Links to Parents

In comparing what we store in an Alak game tree node to what
HTML::Element stores in HTML element nodes, you'll note one big
difference: every HTML::Element node contains a link to its parent,
whereas we don't have our Alak nodes keeping a link to theirs.

The reason this can be an important difference is because it can affect
how Perl knows when you're not using pieces of memory anymore.
Consider the tree we just built, above:

      node 0
     /      \
  node 1    node 2

There's two ways Perl knows you're using a piece of memory:
1) it's memory that belongs directly to a variable (i.e., is necessary
to hold that variable's value, or valueI<s> in the case of a hash or
array), or 2) it's a piece of memory that something holds a reference
to.  In the above code, Perl knows that the hash for node 0 (for board
"xx_xx_oo_oo") is in use because something (namely, the variable
C<$n0>) holds a reference to it.  Now, even if you followed the above
code with this:

  $n1 = $n2 = 'whatever';

to make your variables C<$n1> and C<$n2> stop holding references to
the hashes for the two successors of node 0, Perl would still know that
those hashes are still in use, because node 0's successors array holds
a reference to those hashes.  And Perl knows that node 0 is still in
use because something still holds a reference to it.  Now, if you
added:

  my $root = $n0;

This would change nothing -- there's just be I<two> things holding a
reference to the node 0 hash, which in turn holds a reference to the
node 1 and node 2 hashes.  And if you then added:

  $n0 = 'stuff';

still nothing would change, because something (C<$root>) still holds a
reference to the node 0 hash.  But once I<nothing> holds a reference to
the node 0 hash, Perl will know it can destroy that hash (and reclaim
the memory for later use, say), and once it does that, nothing will hold
a reference to the node 1 or the node 2 hashes, and those will be
destroyed too.

But consider if the node 1 and node 2 hashes each had an attribute
"parent" (or "predecessor") that held a reference to node 0.  If your
program stopped holding a reference to the node 0 hash, Perl could
I<not> then say that I<nothing> holds a reference to node 0 -- because
node 1 and node 2 still do.  So, the memory for nodes 0, 1, and 2 would
never get reclaimed (until your program ended, at which point Perl
destroys I<everything>).  If your program grew and discarded lots of
nodes in the game tree, but didn't let Perl know it could reclaim their
memory, your program could grow to use immense amounts of memory --
never a nice thing to have happen.  There's three ways around this:

1) When you're finished with a node, delete the reference each of its
children have to it (in this case, deleting $n1->{'parent'}, say).
When you're finished with a whole tree, just go through the whole tree
erasing links that children have to their children.

2) Reconsider whether you really need to have each node hold a reference
to its parent.  Just not having those links will avoid the whole
problem.

3) use the WeakRef module with Perl 5.6 or later.  This allows you to
"weaken" some references (like the references that node 1 and 2 could
hold to their parent) so that they don't count when Perl goes asking
whether anything holds a reference to a given piece of memory.  This
wonderful new module eliminates the headaches that can often crop up
with either of the two previous methods. 

It so happens that our Alak program is simple enough that we don't need
for our nodes to have links to their parents, so the second solution is
fine.  But in a more advanced program, the first or third solutions
might be unavoidable.

=head2 Recursively Printing the Tree

I don't like working blind -- if I have any kind of a complex data
structure in memory for a program I'm working on, the first thing I do
is write something that can dump that structure to the screen so I can
make sure that what I I<think> is in memory really I<is> what's in
memory.  Now, I could just use the "x" pretty-printer command in Perl's
interactive debugger, or I could have the program use the
C<Data::Dumper> module.  But in this case, I think the output from those
is rather too verbose.  Once we have trees with dozens of nodes in them,
we'll really want a dump of the tree to be as concise as possible,
hopefully just one line per node.  What I'd like is something that can
print C<$n0> and its successors (see above) as something like:

  xx_xx_oo_oo  (O moved 9 to 7, 0 payoff)
    xx__xxoo_oo  (X moved 4 to 6, 0 payoff)
    xx_x_xoo_oo  (X moved 5 to 6, 0 payoff)

A subroutine to print a line for a given node, and then do that again for
each successor, would look something like:

  sub dump_tree {
    my $n = $_[0]; # "n" is for node
    print
      ...something expressing $n'n content...
    foreach my $s (@{$n->{'successors'}}) {
      # "s for successor
      dump($s);
    }
  }

And we could just start that out with a call to C<dump_tree($n0)>.

Since this routine...

=over

Footnote:
I first wrote this routine starting out with "sub dump {".  But when
I tried actually calling C<dump($n0)>, Perl would dump core!  Imagine
my shock when I discovered that this is absolutely to be expected --
Perl provides a built-in function called C<dump>, the purpose of which
is to, yes, make Perl dump core.  Calling our routine "dump_tree"
instead of "dump" neatly avoids that problem.

=back

...does its work (dumping the subtree at and under the
given node) by calling itself, it's B<recursive>.  However, there's a
special term for this kind of recursion across a tree: traversal.  To
B<traverse> a tree means to do something to a node, and to traverse its
children.  There's two prototypical ways to do this, depending on what
happens when:

  traversing X in pre-order:
    * do something to X
    * then traverse X's children

  traversing X in post-order:
    * traverse X's children
    * then do something to X

Dumping the tree to the screen the way we want it happens to be a matter
of pre-order traversal, since the thing we do (print a description of
the node) happens before we recurse into the successors.

When we try writing the C<print> statement for our above C<dump_tree>,
we can get something like:

  sub dump_tree {
    my $n = $_[0];

    # "xx_xx_oo_oo  (O moved 9 to 7, 0 payoff)"
    print
      $n->{'board'}, "  (",
      ($n->{'whose_turn'} eq 'o' ? 'X' : 'O'),
      # Infer who last moved from whose turn it is now.
      " moved ", $n->{'last_move_from'},
      " to ",    $n->{'last_move_to'},
      ", ",      $n->{'last_move_payoff'},
      " payoff)\n",
    ;

    foreach my $s (@{$n->{'successors'}}) {
      dump_tree($s);
    }
  }

If we run this on $n0 from above, we get this:

  xx_xx_oo_oo  (O moved 9 to 7, 0 payoff)
  xx__xxoo_oo  (X moved 4 to 6, 0 payoff)
  xx_x_xoo_oo  (X moved 5 to 6, 0 payoff)

Each line on its own is fine, but we forget to allow for indenting, and
without that we can't tell what's a child of what.  (Imagine if the
first successor had successors of its own -- you wouldn't be able to
tell if it were a child, or a sibling.)  To get indenting, we'll need
to have the instances of the C<dump_tree> routine know how far down in
the tree they're being called, by passing a depth parameter between
them:

  sub dump_tree {
    my $n = $_[0];
    my $depth = $_[1];
    $depth = 0 unless defined $depth;
    print
      "  " x $depth,
      ...stuff...
    foreach my $s (@{$n->{'successors'}}) {
      dump_tree($s, $depth + 1);
    }
  }

When we call C<dump_tree($n0)>, C<$depth> (from C<$_[1]>) is undefined, so
gets set to 0, which translates into an indenting of no spaces.  But when 
C<dump_tree> invokes itself on C<$n0>'s children, those instances see
C<$depth> + 1 as their C<$_[1]>, giving appropriate indenting.

=over

Footnote:
Passing values around between different invocations of a recursive
routine, as shown, is a decent way to share the data.  Another way
to share the data is by keeping it in a global variable, like C<$Depth>,
initially set to 0.  Each time C<dump_tree> is about to recurse, it must
C<++$Depth>, and when it's back, it must C<--$Depth>. 

Or, if the reader is familiar with closures, consider this approach:

  sub dump_tree {
    # A wrapper around calls to a recursive closure:
    my $start_node = $_[0];
    my $depth = 0;
     # to be shared across calls to $recursor.
    my $recursor;
    $recursor = sub {
      my $n = $_[0];
      print "  " x $depth,
        ...stuff...
      ++$depth;
      foreach my $s (@{$n->{'successors'}}) {
        $recursor->($s);
      }
      --$depth;
    }
    $recursor->($start_node); # start recursing
    undef $recursor;
  }

The reader with an advanced understanding of Perl's reference-count-based
garbage collection is invited to consider why it is currently necessary
to undef $recursor (or otherwise change its value) after all recursion
is done.

The reader whose mind is perverse in other ways is invited to consider
how (or when!) passing a depth parameter around is unnecessary because
of information that Perl's C<caller(N)> function reports! 

[end footnote]

=back

=head2 Growing the Tree

Our C<dump_tree> routine works fine for the sample tree we've got, so
now we should get the program working on making its own trees, starting
from a given board.

In C<Games::Alak> (the CPAN-released version of Alak that uses
essentially the same code that we're currently discussing the
tree-related parts of), there is a routine called C<figure_successors>
that, given one childless node, will figure out all its possible
successors.  That is, it looks at the current board, looks at every piece
belonging to the player whose turn it is, and considers the effect of
moving each piece every possible way -- notably, it figures out the
immediate payoff, and if that move would end the game, it notes that by
setting an "endgame" entry in that node's hash.  (That way, we know that
that's a node that I<can't> have successors.)

In the code for C<Games::Alak>, C<figure_successors> does all these things,
in a rather straightforward way.  I won't walk you through the details
of the C<figure_successors> code I've written, since the code has
nothing much to do with trees, and is all just implementation of the Alak
rules for what can move where, with what result.  Especially interested
readers can puzzle over that part of code in the source listing in the
archive from CPAN, but others can just assume that it works as described
above.

But consider that C<figure_successors>, regardless of its inner
workings, does not grow the I<tree>; it only makes one set of successors
for one node at a time.  It has to be up to a different routine to call
C<figure_successors>, and to keep applying it as needed, in order to
make a nice big tree that our game-playing program can base its
decisions on.

Now, we could do this by just starting from one node, applying
C<figure_successors> to it, then applying C<figure_successors> on all
the resulting children, and so on:

  sub grow {  # Just a first attempt at this!
    my $n = $_[0];
    figure_successors($n);
     unless
      @{$n->{'successors'}}
        # already has successors.
      or $n->{'endgame'}
        # can't have successors.
    }
    foreach my $s (@{$n->{'successors'}}) {
      grow($s); # recurse
    }
  }

If you have a game tree for tic-tac-toe, and you grow it without
limitation (as above), you will soon enough have a fully "solved" tree,
where every node that I<can> have successors I<does>, and all the leaves
of the tree are I<all> the possible endgames (where, in each case, the
board is filled).  But a game of Alak is different from tic-tac-toe,
because it can, in theory, go on forever.  For example, the following
sequence of moves is quite possible:

  xxxx___oooo
  xxx_x__oooo
  xxx_x_o_ooo
  xxxx__o_ooo (x moved back)
  xxxx___oooo (o moved back)
  ...repeat forever...

So if you tried using our above attempt at a C<grow> routine, Perl would
happily start trying to construct an infinitely deep tree, containing
an infinite number of nodes, consuming an infinite amount of memory, and
requiring an infinite amount of time.  As the old saying goes: "You
can't have everything -- where would you put it?"  So we have to place
limits on how much we'll grow the tree.

There's more than one way to do this:

1. We could grow the tree until we hit some limit on the number of
nodes we'll allow in the tree. 

2. We could grow the tree until we hit some limit on the amount of time
we're willing to spend. 

3. Or we could grow the tree until it is fully fleshed out to a certain
depth.

Since we already know to track depth (as we did in writing C<dump_tree>),
we'll do it that way, the third way.  The implementation for that third
approach is also pretty straightforward:

  $Max_depth = 3;
  sub grow {
    my $n = $_[0];
    my $depth = $_[1] || 0;
    figure_successors($n)
     unless
      $depth >= $Max_depth
      or @{$n->{'successors'}}
      or $n->{'endgame'}
    }
    foreach my $s (@{$n->{'successors'}}) {
      grow($s, $depth + 1);
    }
    # If we're at $Max_depth, then figure_successors
    #  didn't get called, so there's no successors
    #  to recurse under -- that's what stops recursion.
  }

If we start from a single node (whether it's a node for the starting board
"xxxx___oooo", or for whatever board the computer is faced with), set
C<$Max_depth> to 4, and apply C<grow> to it, it will grow the tree to
include several hundred nodes.

=over

Footnote:
If at each move there are four pieces that can move, and they can each
move right or left, the "branching factor" of the tree is eight, giving
a tree with 1 (depth 0) + 8 (depth 1) + 8 ** 2 + 8 ** 3 + 8 ** 4  =
4681 nodes in it.  But, in practice, not all pieces can move in both
directions (none of the x pieces in "xxxx___oooo" can move left, for
example), and there may be fewer than four pieces, if some were lost.
For example, there are 801 nodes in a tree of depth four starting
from "xxxx___oooo", suggesting an average branching factor of about
five (801 ** (1/4) is about 5.3), not eight.

=back

What we need to derive from that tree is the information about what
are the best moves for X.  The simplest way to consider the payoff of
different successors is to just average them -- but what we average
isn't always their immediate payoffs (because that'd leave us using
only one generation of information), but the average payoff of I<their>
successors, if any.  We can formalize this as:

  To figure a node's average payoff:
    If the node has successors:
      Figure each successor's average payoff.
      My average payoff is the average of theirs.
    Otherwise:
      My average payoff is my immediate payoff.

Since this involves recursing into the successors I<before> doing
anything with the current node, this will traverse the tree
I<in post-order>.

We could work that up as a routine of its own, and apply that to the
tree after we've applied C<grow> to it.  But since we'd never
grow the tree without also figuring the average benefit, we might as well
make that figuring part of the C<grow> routine itself:

  $Max_depth = 3;
  sub grow {
    my $n = $_[0];
    my $depth = $_[1] || 0;
    figure_successors($n);
     unless
      $depth >= $Max_depth
      or @{$n->{'successors'}}
      or $n->{'endgame'}
    }

    if(@{$n->{'successors'}}) {
      my $a_payoff_sum = 0;
      foreach my $s (@{$n->{'successors'}}) {
        grow($s, $depth + 1);  # RECURSE
        $a_payoff_sum += $s->{'average_payoff'};
      }
      $n->{'average_payoff'}
       = $a_payoff_sum / @{$n->{'successors'}};
    } else {
      $n->{'average_payoff'}
       = $n->{'last_move_payoff'};
    }
  }

So, by time C<grow> has applied to a node (wherever in the tree it is),
it will have figured successors if possible (which, in turn, sets
C<last_move_payoff> for each node it creates), and will have set
C<average_benefit>.

Beyond this, all that's needed is to start the board out with a root
note of "xxxx___oooo", and have the computer (X) take turns with the
user (O) until someone wins.  Whenever it's O's turn, C<Games::Alak>
presents a prompt to the user, letting him know the state of the current
board, and asking what move he selects.  When it's X's turn, the
computer grows the game tree as necessary (using just the C<grow>
routine from above), then selects the move with the highest average
payoff (or one of the highest, in case of a tie).

In either case, "selecting" a move means just setting that move's node
as the new root of the program's game tree.  Its sibling nodes and their
descendants (the boards that I<didn't> get selected) and its parent node
will be erased from memory, since they will no longer be in use (as Perl
can tell by the fact that nothing holds references to them anymore).

The interface code in C<Games::Alak> (the code that prompts the user for
his move) actually supports quite a few options besides just moving --
including dumping the game tree to a specified depth (using a slightly
fancier version of C<dump_tree>, above), resetting the game, changing
C<$Max_depth> in the middle of the game, and quitting the game.  Like
C<figure_successors>, it's a bit too long to print here, but interested
users are welcome to peruse (and freely modify) the code, as well as to
enjoy just playing the game.

Now, in practice, there's more to game trees than this: for games with a
larger branching factor than Alak has (which is most!), game trees of
depth four or larger would contain too many nodes to be manageable, most
of those nodes being strategically quite uninteresting for either
player; dealing with game trees specifically is therefore a matter of
recognizing uninteresting contingencies and not bothering to grow the
tree under them.

=over

Footnote:
For example, to choose a straightforward case: if O has a choice between
moves that put him in immediate danger of X winning and moves that
don't, then O won't ever choose the dangerous moves (and if he does, the
computer will know enough to end the game), so there's no point in
growing the tree any further beneath those nodes.

=back

But this sample implementation should illustrate the basics of
how to build and manipulate a simple tree structure in memory.
And once you've understood the basics of tree storage here, you should
be ready to better understand the complexities and peculiarities of 
other systems for creating, accessing, and changing trees, including
Tree::DAG_Node, HTML::Element, XML::DOM, or related formalisms
like XPath and XSL.

B<[end body of article]>

=head2 [Author Credit]

Sean M. Burke (C<sburke@cpan.org>) is a tree-dwelling hominid.

=head2 References

Dewdney, A[lexander] K[eewatin].  1984.  I<Planiverse: Computer Contact
with a Two-Dimensional World.>  Poseidon Press, New York.

Knuth, Donald Ervin.  1997.  I<Art of Computer Programming, Volume 1,
Third Edition: Fundamental Algorithms>.  Addison-Wesley,  Reading, MA.

Wirth, Niklaus.  1976.  I<Algorithms + Data Structures = Programs>
Prentice-Hall, Englewood Cliffs, NJ.

Worth, Stan and Allman Sheldon.  Circa 1967.  I<George of the Jungle>
theme.  [music by Jay Ward.]

Wirth's classic, currently and lamentably out of print, has a good
section on trees.  I find it clearer than Knuth's (if not quite as
encyclopedic), probably because Wirth's example code is in a
block-structured high-level language (basically Pascal), instead
of in assembler (MIX).  I believe the book was re-issued in the
1980s under the titles I<Algorithms and Data Structures> and, in a
German edition, I<Algorithmen und Datenstrukturen>.  Cheap copies
of these editions should be available through used book services
such as C<abebooks.com>.

Worth's classic, however, is available on the
soundtrack to the 1997 I<George of the Jungle> movie, as
performed by The Presidents of the United States of America.

=head1 BACK

Return to the L<HTML::Tree|HTML::Tree> docs.

=cut

PK       ! v��  �    perl5/HTML/AsSubs.pmnu ��6�$        package HTML::AsSubs;

# ABSTRACT: functions that construct a HTML syntax tree


use warnings;
use strict;
use vars qw(@ISA @EXPORT);

our $VERSION = '5.07'; # VERSION from OurPkgVersion

require HTML::Element;
require Exporter;
@ISA = qw(Exporter);

# Problem: exports so damned much.  Has no concept of "export only HTML4
#  elements".  TODO:?? make something that make functions that just
#  wrap XML::Generator calls?


use vars qw(@TAGS);
@TAGS = qw(html
    head title base link meta isindex nextid script style
    body h1 h2 h3 h4 h5 h6 p pre div blockquote
    a img br hr
    ol ul dir menu li
    dl dt dd
    dfn cite code em kbd samp strong var address span
    b i u tt
    center font big small strike
    sub sup
    table tr td th caption
    form input select option textarea
    object applet param
    map area
    frame frameset noframe
);

for (@TAGS) {
    my $code;
    $code = "sub $_ { _elem('$_', \@_); }\n";
    push( @EXPORT, $_ );
## no critic
    eval $code;
## use critic
    if ($@) {
        die $@;
    }
}


sub _elem {
    my $tag = shift;
    my $attributes;
    if ( @_ and defined $_[0] and ref( $_[0] ) eq "HASH" ) {
        $attributes = shift;
    }
    my $elem = HTML::Element->new( $tag, %$attributes );
    $elem->push_content(@_);
    $elem;
}

1;

__END__

=pod

=head1 NAME

HTML::AsSubs - functions that construct a HTML syntax tree

=head1 VERSION

This document describes version 5.07 of
HTML::AsSubs, released August 31, 2017
as part of L<HTML-Tree|HTML::Tree>.

=head1 SYNOPSIS

 use HTML::AsSubs;
 $h = body(
	   h1("This is the heading"),
	   p("This is the first paragraph which contains a ",
	     a({href=>'link.html'}, "link"),
	     " and an ",
	     img({src=>'img.gif', alt=>'image'}),
	     "."
	    ),
	  );
 print $h->as_HTML;

=head1 DESCRIPTION

This module exports functions that can be used to construct various
HTML elements. The functions are named after the tags of the
corresponding HTML element and are all written in lower case. If the
first argument is a hash reference then it will be used to initialize the
attributes of this element. The remaining arguments are regarded as
content.

For a similar idea (i.e., it's another case where the syntax tree
of the Perl source mirrors the syntax tree of the HTML produced),
see HTML::Element's C<new_from_lol> method.

For what I now think is a cleaner implementation of this same idea,
see the excellent module C<XML::Generator>, which is what I suggest
for actual real-life use.  (I suggest this over C<HTML::AsSubs> and
over C<CGI.pm>'s HTML-making functions.)

=head1 ACKNOWLEDGEMENT

This module was inspired by the following message:

 Date: Tue, 4 Oct 1994 16:11:30 +0100
 Subject: Wow! I have a large lightbulb above my head!

 Take a moment to consider these lines:

 %OVERLOAD=( '""' => sub { join("", @{$_[0]}) } );

 sub html { my($type)=shift; bless ["<$type>", @_, "</$type>"]; }

 :-)  I *love* Perl 5!  Thankyou Larry and Ilya.

 Regards,
 Tim Bunce.

 p.s. If you didn't get it, think about recursive data types: html(html())
 p.p.s. I'll turn this into a much more practical example in a day or two.
 p.p.p.s. It's a pity that overloads are not inherited. Is this a bug?

=head1 BUGS

The exported link() function overrides the builtin link() function.
The exported tr() function must be called using &tr(...) syntax
because it clashes with the builtin tr/../../ operator.

=head1 SEE ALSO

L<HTML::Element>, L<XML::Generator>

=head2 html head title base link meta isindex nextid script style body h1 h2 h3 h4 h5 h6 p pre div blockquote a img br hr ol ul dir menu li dl dt dd dfn cite code em kbd samp strong var address span b i u tt center font big small strike sub sup table tr td th caption form input select option textarea object applet param map area frame frameset noframe

A bunch of methods for creating tags.

=head1 Private Functions

=head2 _elem()

The _elem() function is wrapped by all the html 'tag' functions. It
takes a tag-name, optional hashref of attributes and a list of content
as parameters.

=head1 AUTHOR

Current maintainers:

=over

=item * Christopher J. Madsen S<C<< <perl AT cjmweb.net> >>>

=item * Jeff Fearn S<C<< <jfearn AT cpan.org> >>>

=back

Original HTML-Tree author:

=over

=item * Gisle Aas

=back

Former maintainers:

=over

=item * Sean M. Burke

=item * Andy Lester

=item * Pete Krawczyk S<C<< <petek AT cpan.org> >>>

=back

You can follow or contribute to HTML-Tree's development at
L<< https://github.com/kentfredric/HTML-Tree >>.

=head1 COPYRIGHT AND LICENSE

Copyright 1995-1998 Gisle Aas, 1999-2004 Sean M. Burke,
2005 Andy Lester, 2006 Pete Krawczyk, 2010 Jeff Fearn,
2012 Christopher J. Madsen.

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

The programs in this library are distributed in the hope that they
will be useful, but without any warranty; without even the implied
warranty of merchantability or fitness for a particular purpose.

=cut
PK       ! �xl��* �*   perl5/HTML/Element.pmnu ��6�$        package HTML::Element;

# ABSTRACT: Class for objects that represent HTML elements

use strict;
use warnings;

our $VERSION = '5.07'; # VERSION from OurPkgVersion

use Carp           ();
use HTML::Entities ();
use HTML::Tagset   ();
use integer;    # vroom vroom!

# This controls encoding entities on output.
# When set entities won't be re-encoded.
# Defaulting off because parser defaults to unencoding entities
our $encoded_content = 0;

use vars qw($html_uc $Debug $ID_COUNTER $VERSION %list_type_to_sub);

# Set up support for weak references, if possible:
my $using_weaken;

#=head1 CLASS METHODS


sub Use_Weak_Refs {
    my $self_or_class = shift;

    if (@_) {    # set
        $using_weaken = !! shift; # Normalize boolean value
        Carp::croak("The installed Scalar::Util lacks support for weak references")
              if $using_weaken and not defined &Scalar::Util::weaken;

        no warnings 'redefine';
        *_weaken = $using_weaken ? \&Scalar::Util::weaken : sub ($) {};
    } # end if setting value

    return $using_weaken;
} # end Use_Weak_Refs

BEGIN {
    # Attempt to import weaken from Scalar::Util, but don't complain
    # if we can't.  Also, rename it to _weaken.
    require Scalar::Util;

    __PACKAGE__->Use_Weak_Refs(defined &Scalar::Util::weaken);
}

sub import {
    my $class = shift;

    for (@_) {
        if (/^-(no_?)?weak$/) {
            $class->Use_Weak_Refs(not $1);
        } else {
            Carp::croak("$_ is not exported by the $class module");
        }
    }
} # end import


$Debug = 0 unless defined $Debug;

#=head1 SUBROUTINES


sub Version {
    Carp::carp("Deprecated subroutine HTML::Element::Version called");
    $VERSION;
}

my $nillio = [];

*HTML::Element::emptyElement   = \%HTML::Tagset::emptyElement;      # legacy
*HTML::Element::optionalEndTag = \%HTML::Tagset::optionalEndTag;    # legacy
*HTML::Element::linkElements   = \%HTML::Tagset::linkElements;      # legacy
*HTML::Element::boolean_attr   = \%HTML::Tagset::boolean_attr;      # legacy
*HTML::Element::canTighten     = \%HTML::Tagset::canTighten;        # legacy

# Constants for signalling back to the traverser:
my $travsignal_package = __PACKAGE__ . '::_travsignal';
my ( $ABORT, $PRUNE, $PRUNE_SOFTLY, $OK, $PRUNE_UP )
    = map { my $x = $_; bless \$x, $travsignal_package; }
    qw(
    ABORT  PRUNE   PRUNE_SOFTLY   OK   PRUNE_UP
);


## Comments from Father Chrysostomos RT #58880
## The sole purpose for empty parentheses after a sub name is to make it
## parse as a 0-ary (nihilary?) function. I.e., ABORT+1 should parse as
## ABORT()+1, not ABORT(+1). The parentheses also tell perl that it can
### be inlined.
##Deparse is really useful for demonstrating this:
##$ perl -MO=Deparse,-p -e 'sub ABORT {7} print ABORT+8'
# Vs
# perl -MO=Deparse,-p -e 'sub ABORT() {7} print ABORT+8'
#
# With the parentheses, it not only makes it parse as a term.
# It even resolves the constant at compile-time, making the code run faster.

## no critic
sub ABORT ()        {$ABORT}
sub PRUNE ()        {$PRUNE}
sub PRUNE_SOFTLY () {$PRUNE_SOFTLY}
sub OK ()           {$OK}
sub PRUNE_UP ()     {$PRUNE_UP}
## use critic

$html_uc = 0;

# set to 1 if you want tag and attribute names from starttag and endtag
#  to be uc'd

# regexs for XML names
# http://www.w3.org/TR/2006/REC-xml11-20060816/NT-NameStartChar
my $START_CHAR
    = qr/(?:\:|[A-Z]|_|[a-z]|[\x{C0}-\x{D6}]|[\x{D8}-\x{F6}]|[\x{F8}-\x{2FF}]|[\x{370}-\x{37D}]|[\x{37F}-\x{1FFF}]|[\x{200C}-\x{200D}]|[\x{2070}-\x{218F}]|[\x{2C00}-\x{2FEF}]|[\x{3001}-\x{D7FF}]|[\x{F900}-\x{FDCF}]|[\x{FDF0}-\x{FFFD}]|[\x{10000}-\x{EFFFF}])/;

# http://www.w3.org/TR/2006/REC-xml11-20060816/#NT-NameChar
my $NAME_CHAR
    = qr/(?:$START_CHAR|-|\.|[0-9]|\x{B7}|[\x{0300}-\x{036F}]|[\x{203F}-\x{2040}])/;

# Elements that does not have corresponding end tags (i.e. are empty)

#==========================================================================

#=head1 BASIC METHODS


#
# An HTML::Element is represented by blessed hash reference, much like
# Tree::DAG_Node objects.  Key-names not starting with '_' are reserved
# for the SGML attributes of the element.
# The following special keys are used:
#
#    '_tag':    The tag name (i.e., the generic identifier)
#    '_parent': A reference to the HTML::Element above (when forming a tree)
#    '_pos':    The current position (a reference to a HTML::Element) is
#               where inserts will be placed (look at the insert_element
#               method)  If not set, the implicit value is the object itself.
#    '_content': A ref to an array of nodes under this.
#                It might not be set.
#
# Example: <img src="gisle.jpg" alt="Gisle's photo"> is represented like this:
#
#  bless {
#     _tag => 'img',
#     src  => 'gisle.jpg',
#     alt  => "Gisle's photo",
#  }, 'HTML::Element';
#

sub new {
    my $class = shift;
    $class = ref($class) || $class;

    my $tag = shift;
    Carp::croak("No tagname") unless defined $tag and length $tag;
    Carp::croak "\"$tag\" isn't a good tag name!"
        if $tag =~ m/[<>\/\x00-\x20]/;    # minimal sanity, certainly!
    my $self = bless { _tag => scalar( $class->_fold_case($tag) ) }, $class;
    my ( $attr, $val );
    while ( ( $attr, $val ) = splice( @_, 0, 2 ) ) {
## RT #42209 why does this default to the attribute name and not remain unset or the empty string?
        $val = $attr unless defined $val;
        $self->{ $class->_fold_case($attr) } = $val;
    }
    if ( $tag eq 'html' ) {
        $self->{'_pos'} = undef;
    }
    _weaken($self->{'_parent'}) if $self->{'_parent'};
    return $self;
}


sub attr {
    my $self = shift;
    my $attr = scalar( $self->_fold_case(shift) );
    if (@_) {    # set
        if ( defined $_[0] ) {
            my $old = $self->{$attr};
            $self->{$attr} = $_[0];
            return $old;
        }
        else {    # delete, actually
            return delete $self->{$attr};
        }
    }
    else {        # get
        return $self->{$attr};
    }
}


sub tag {
    my $self = shift;
    if (@_) {    # set
        $self->{'_tag'} = $self->_fold_case( $_[0] );
    }
    else {       # get
        $self->{'_tag'};
    }
}


sub parent {
    my $self = shift;
    if (@_) {    # set
        Carp::croak "an element can't be made its own parent"
            if defined $_[0] and ref $_[0] and $self eq $_[0];    # sanity
        _weaken($self->{'_parent'} = $_[0]);
    }
    else {
        $self->{'_parent'};                                       # get
    }
}


sub content_list {
    return wantarray
        ? @{ shift->{'_content'} || return () }
        : scalar @{ shift->{'_content'} || return 0 };
}


# a read-only method!  can't say $h->content( [] )!
sub content {
    return shift->{'_content'};
}


sub content_array_ref {
    return shift->{'_content'} ||= [];
}


sub content_refs_list {
    return \( @{ shift->{'_content'} || return () } );
}


sub implicit {
    return shift->attr( '_implicit', @_ );
}


sub pos {
    my $self = shift;
    my $pos  = $self->{'_pos'};
    if (@_) {    # set
        my $parm = shift;
        if ( defined $parm and $parm ne $self ) {
            $self->{'_pos'} = $parm;    # means that element
        }
        else {
            $self->{'_pos'} = undef;    # means $self
        }
    }
    return $pos if defined($pos);
    return $self;
}


sub all_attr {
    return %{ $_[0] };

    # Yes, trivial.  But no other way for the user to do the same
    #  without breaking encapsulation.
    # And if our object representation changes, this method's behavior
    #  should stay the same.
}

sub all_attr_names {
    return keys %{ $_[0] };
}


sub all_external_attr {
    my $self = $_[0];
    return map( ( length($_) && substr( $_, 0, 1 ) eq '_' )
        ? ()
        : ( $_, $self->{$_} ),
        keys %$self );
}

sub all_external_attr_names {
    return grep !( length($_) && substr( $_, 0, 1 ) eq '_' ), keys %{ $_[0] };
}


sub id {
    if ( @_ == 1 ) {
        return $_[0]{'id'};
    }
    elsif ( @_ == 2 ) {
        if ( defined $_[1] ) {
            return $_[0]{'id'} = $_[1];
        }
        else {
            return delete $_[0]{'id'};
        }
    }
    else {
        Carp::croak '$node->id can\'t take ' . scalar(@_) . ' parameters!';
    }
}


sub _gensym {
    unless ( defined $ID_COUNTER ) {

        # start it out...
        $ID_COUNTER = sprintf( '%04x', rand(0x1000) );
        $ID_COUNTER =~ tr<0-9a-f><J-NP-Z>;    # yes, skip letter "oh"
        $ID_COUNTER .= '00000';
    }
    ++$ID_COUNTER;
}

sub idf {
    my $nparms = scalar @_;

    if ( $nparms == 1 ) {
        my $x;
        if ( defined( $x = $_[0]{'id'} ) and length $x ) {
            return $x;
        }
        else {
            return $_[0]{'id'} = _gensym();
        }
    }
    if ( $nparms == 2 ) {
        if ( defined $_[1] ) {
            return $_[0]{'id'} = $_[1];
        }
        else {
            return delete $_[0]{'id'};
        }
    }
    Carp::croak '$node->idf can\'t take ' . scalar(@_) . ' parameters!';
}


sub push_content {
    my $self = shift;
    return $self unless @_;

    my $content = ( $self->{'_content'} ||= [] );
    for (@_) {
        if ( ref($_) eq 'ARRAY' ) {

            # magically call new_from_lol
            push @$content, $self->new_from_lol($_);
            _weaken($content->[-1]->{'_parent'} = $self);
        }
        elsif ( ref($_) ) {    # insert an element
            $_->detach if $_->{'_parent'};
            _weaken($_->{'_parent'} = $self);
            push( @$content, $_ );
        }
        else {                 # insert text segment
            if ( @$content && !ref $content->[-1] ) {

                # last content element is also text segment -- append
                $content->[-1] .= $_;
            }
            else {
                push( @$content, $_ );
            }
        }
    }
    return $self;
}


sub unshift_content {
    my $self = shift;
    return $self unless @_;

    my $content = ( $self->{'_content'} ||= [] );
    for ( reverse @_ ) {    # so they get added in the order specified
        if ( ref($_) eq 'ARRAY' ) {

            # magically call new_from_lol
            unshift @$content, $self->new_from_lol($_);
            _weaken($content->[0]->{'_parent'} = $self);
        }
        elsif ( ref $_ ) {    # insert an element
            $_->detach if $_->{'_parent'};
            _weaken($_->{'_parent'} = $self);
            unshift( @$content, $_ );
        }
        else {                # insert text segment
            if ( @$content && !ref $content->[0] ) {

                # last content element is also text segment -- prepend
                $content->[0] = $_ . $content->[0];
            }
            else {
                unshift( @$content, $_ );
            }
        }
    }
    return $self;
}

# Cf.  splice ARRAY,OFFSET,LENGTH,LIST


sub splice_content {
    my ( $self, $offset, $length, @to_add ) = @_;
    Carp::croak "splice_content requires at least one argument"
        if @_ < 2;    # at least $h->splice_content($offset);

    my $content = ( $self->{'_content'} ||= [] );

    # prep the list

    my @out;
    if ( @_ > 2 ) {    # self, offset, length, ...
        foreach my $n (@to_add) {
            if ( ref($n) eq 'ARRAY' ) {
                $n = $self->new_from_lol($n);
                _weaken($n->{'_parent'} = $self);
            }
            elsif ( ref($n) ) {
                $n->detach;
                _weaken($n->{'_parent'} = $self);
            }
        }
        @out = splice @$content, $offset, $length, @to_add;
    }
    else {    #  self, offset
        @out = splice @$content, $offset;
    }
    foreach my $n (@out) {
        $n->{'_parent'} = undef if ref $n;
    }
    return @out;
}


sub detach {
    my $self = $_[0];
    return undef unless ( my $parent = $self->{'_parent'} );
    $self->{'_parent'} = undef;
    my $cohort = $parent->{'_content'} || return $parent;
    @$cohort = grep { not( ref($_) and $_ eq $self ) } @$cohort;

    # filter $self out, if parent has any evident content

    return $parent;
}


sub detach_content {
    my $c = $_[0]->{'_content'} || return ();    # in case of no content
    for (@$c) {
        $_->{'_parent'} = undef if ref $_;
    }
    return splice @$c;
}


sub replace_with {
    my ( $self, @replacers ) = @_;
    Carp::croak "the target node has no parent"
        unless my ($parent) = $self->{'_parent'};

    my $parent_content = $parent->{'_content'};
    Carp::croak "the target node's parent has no content!?"
        unless $parent_content and @$parent_content;

    my $replacers_contains_self;
    for (@replacers) {
        if ( !ref $_ ) {

            # noop
        }
        elsif ( $_ eq $self ) {

            # noop, but check that it's there just once.
            Carp::croak "Replacement list contains several copies of target!"
                if $replacers_contains_self++;
        }
        elsif ( $_ eq $parent ) {
            Carp::croak "Can't replace an item with its parent!";
        }
        elsif ( ref($_) eq 'ARRAY' ) {
            $_ = $self->new_from_lol($_);
            _weaken($_->{'_parent'} = $parent);
        }
        else {
            $_->detach;
            _weaken($_->{'_parent'} = $parent);

            # each of these are necessary
        }
    }    # for @replacers
    @$parent_content = map { ( ref($_) and $_ eq $self ) ? @replacers : $_ }
        @$parent_content;

    $self->{'_parent'} = undef unless $replacers_contains_self;

    # if replacers does contain self, then the parent attribute is fine as-is

    return $self;
}


sub preinsert {
    my $self = shift;
    return $self unless @_;
    return $self->replace_with( @_, $self );
}


sub postinsert {
    my $self = shift;
    return $self unless @_;
    return $self->replace_with( $self, @_ );
}


sub replace_with_content {
    my $self = $_[0];
    Carp::croak "the target node has no parent"
        unless my ($parent) = $self->{'_parent'};

    my $parent_content = $parent->{'_content'};
    Carp::croak "the target node's parent has no content!?"
        unless $parent_content and @$parent_content;

    my $content_r = $self->{'_content'} || [];
    @$parent_content = map { ( ref($_) and $_ eq $self ) ? @$content_r : $_ }
        @$parent_content;

    $self->{'_parent'} = undef;    # detach $self from its parent

    # Update parentage link, removing from $self's content list
    for ( splice @$content_r ) { _weaken($_->{'_parent'} = $parent) if ref $_ }

    return $self;                  # note: doesn't destroy it.
}


sub delete_content {
    for (
        splice @{
            delete( $_[0]->{'_content'} )

                # Deleting it here (while holding its value, for the moment)
                #  will keep calls to detach() from trying to uselessly filter
                #  the list (as they won't be able to see it once it's been
                #  deleted)
                || return ( $_[0] )    # in case of no content
        },
        0

        # the splice is so we can null the array too, just in case
        # something somewhere holds a ref to it
        )
    {
        $_->delete if ref $_;
    }
    $_[0];
}


# two handy aliases
sub destroy         { shift->delete(@_) }
sub destroy_content { shift->delete_content(@_) }

sub delete {
    my $self = $_[0];
    $self->delete_content    # recurse down
        if $self->{'_content'} && @{ $self->{'_content'} };

    $self->detach if $self->{'_parent'} and $self->{'_parent'}{'_content'};

    # not the typical case

    %$self = ();             # null out the whole object on the way out
    return;
}


sub clone {

    #print "Cloning $_[0]\n";
    my $it = shift;
    Carp::croak "clone() can be called only as an object method"
        unless ref $it;
    Carp::croak "clone() takes no arguments" if @_;

    my $new = bless {%$it}, ref($it);    # COPY!!! HOOBOY!
    delete @$new{ '_content', '_parent', '_pos', '_head', '_body' };

    # clone any contents
    if ( $it->{'_content'} and @{ $it->{'_content'} } ) {
        $new->{'_content'}
            = [ ref($it)->clone_list( @{ $it->{'_content'} } ) ];
        for ( @{ $new->{'_content'} } ) {
            _weaken($_->{'_parent'} = $new) if ref $_;
        }
    }

    return $new;
}


sub clone_list {
    Carp::croak "clone_list can be called only as a class method"
        if ref shift @_;

    # all that does is get me here
    return map {
        ref($_)
            ? $_->clone    # copy by method
            : $_           # copy by evaluation
    } @_;
}


sub normalize_content {
    my $start = $_[0];
    my $c;
    return
        unless $c = $start->{'_content'} and ref $c and @$c;   # nothing to do
        # TODO: if we start having text elements, deal with catenating those too?
    my @stretches = (undef);    # start with a barrier

    # I suppose this could be rewritten to treat stretches as it goes, instead
    #  of at the end.  But feh.

    # Scan:
    for ( my $i = 0; $i < @$c; ++$i ) {
        if ( defined $c->[$i] and ref $c->[$i] ) {    # not a text segment
            if ( $stretches[0] ) {

                # put in a barrier
                if ( $stretches[0][1] == 1 ) {

                    #print "Nixing stretch at ", $i-1, "\n";
                    undef $stretches[0]; # nix the previous one-node "stretch"
                }
                else {

                    #print "End of stretch at ", $i-1, "\n";
                    unshift @stretches, undef;
                }
            }

            # else no need for a barrier
        }
        else {                           # text segment
            $c->[$i] = '' unless defined $c->[$i];
            if ( $stretches[0] ) {
                ++$stretches[0][1];      # increase length
            }
            else {

                #print "New stretch at $i\n";
                unshift @stretches, [ $i, 1 ];    # start and length
            }
        }
    }

    # Now combine.  Note that @stretches is in reverse order, so the indexes
    # still make sense as we work our way thru (i.e., backwards thru $c).
    foreach my $s (@stretches) {
        if ( $s and $s->[1] > 1 ) {

            #print "Stretch at ", $s->[0], " for ", $s->[1], "\n";
            $c->[ $s->[0] ]
                .= join( '', splice( @$c, $s->[0] + 1, $s->[1] - 1 ) )

                # append the subsequent ones onto the first one.
        }
    }
    return;
}


sub delete_ignorable_whitespace {

    # This doesn't delete all sorts of whitespace that won't actually
    #  be used in rendering, tho -- that's up to the rendering application.
    # For example:
    #   <input type='text' name='foo'>
    #     [some whitespace]
    #   <input type='text' name='bar'>
    # The WS between the two elements /will/ get used by the renderer.
    # But here:
    #   <input type='hidden' name='foo' value='1'>
    #     [some whitespace]
    #   <input type='text' name='bar' value='2'>
    # the WS between them won't be rendered in any way, presumably.

    #my $Debug = 4;
    die "delete_ignorable_whitespace can be called only as an object method"
        unless ref $_[0];

    print "About to tighten up...\n" if $Debug > 2;
    my (@to_do) = ( $_[0] );    # Start off.
    my ( $i, $sibs, $ptag, $this );    # scratch for the loop...
    while (@to_do) {
        if (   ( $ptag = ( $this = shift @to_do )->{'_tag'} ) eq 'pre'
            or $ptag eq 'textarea'
            or $HTML::Tagset::isCDATA_Parent{$ptag} )
        {

            # block the traversal under those
            print "Blocking traversal under $ptag\n" if $Debug;
            next;
        }
        next unless ( $sibs = $this->{'_content'} and @$sibs );
        for ( $i = $#$sibs; $i >= 0; --$i ) {   # work backwards thru the list
            if ( ref $sibs->[$i] ) {
                unshift @to_do, $sibs->[$i];

                # yes, this happens in pre order -- we're going backwards
                # thru this sibling list.  I doubt it actually matters, tho.
                next;
            }
            next if $sibs->[$i] =~ m<[^\n\r\f\t ]>s;   # it's /all/ whitespace

            print "Under $ptag whose canTighten ",
                "value is ", 0 + $HTML::Element::canTighten{$ptag}, ".\n"
                if $Debug > 3;

            # It's all whitespace...

            if ( $i == 0 ) {
                if ( @$sibs == 1 ) {                   # I'm an only child
                    next unless $HTML::Element::canTighten{$ptag};    # parent
                }
                else {    # I'm leftmost of many
                          # if either my parent or sib are eligible, I'm good.
                    next
                        unless $HTML::Element::canTighten{$ptag}    # parent
                            or (ref $sibs->[1]
                                and $HTML::Element::canTighten{ $sibs->[1]
                                        {'_tag'} }    # right sib
                            );
                }
            }
            elsif ( $i == $#$sibs ) {                 # I'm rightmost of many
                    # if either my parent or sib are eligible, I'm good.
                next
                    unless $HTML::Element::canTighten{$ptag}    # parent
                        or (ref $sibs->[ $i - 1 ]
                            and $HTML::Element::canTighten{ $sibs->[ $i - 1 ]
                                    {'_tag'} }                  # left sib
                        );
            }
            else {    # I'm the piggy in the middle
                      # My parent doesn't matter -- it all depends on my sibs
                next
                    unless ref $sibs->[ $i - 1 ]
                        or ref $sibs->[ $i + 1 ];

                # if NEITHER sib is a node, quit

                next if

                    # bailout condition: if BOTH are INeligible nodes
                    #  (as opposed to being text, or being eligible nodes)
                    ref $sibs->[ $i - 1 ]
                        and ref $sibs->[ $i + 1 ]
                        and !$HTML::Element::canTighten{ $sibs->[ $i - 1 ]
                                {'_tag'} }    # left sib
                        and !$HTML::Element::canTighten{ $sibs->[ $i + 1 ]
                                {'_tag'} }    # right sib
                ;
            }

       # Unknown tags aren't in canTighten and so AREN'T subject to tightening

            print "  delendum: child $i of $ptag\n" if $Debug > 3;
            splice @$sibs, $i, 1;
        }

        # end of the loop-over-children
    }

    # end of the while loop.

    return;
}


sub insert_element {
    my ( $self, $tag, $implicit ) = @_;
    return $self->pos() unless $tag;    # noop if nothing to insert

    my $e;
    if ( ref $tag ) {
        $e   = $tag;
        $tag = $e->tag;
    }
    else {    # just a tag name -- so make the element
        $e = $self->element_class->new($tag);
        ++( $self->{'_element_count'} ) if exists $self->{'_element_count'};

        # undocumented.  see TreeBuilder.
    }

    $e->{'_implicit'} = 1 if $implicit;

    my $pos = $self->{'_pos'};
    $pos = $self unless defined $pos;

    $pos->push_content($e);

    $self->{'_pos'} = $pos = $e
        unless $self->_empty_element_map->{$tag} || $e->{'_empty_element'};

    $pos;
}

#==========================================================================
# Some things to override in XML::Element

sub _empty_element_map {
    \%HTML::Element::emptyElement;
}

sub _fold_case_LC {
    if (wantarray) {
        shift;
        map lc($_), @_;
    }
    else {
        return lc( $_[1] );
    }
}

sub _fold_case_NOT {
    if (wantarray) {
        shift;
        @_;
    }
    else {
        return $_[1];
    }
}

*_fold_case = \&_fold_case_LC;

#==========================================================================

#=head1 DUMPING METHODS


sub dump {
    my ( $self, $fh, $depth ) = @_;
    $fh    = *STDOUT{IO} unless defined $fh;
    $depth = 0           unless defined $depth;
    print $fh "  " x $depth, $self->starttag, " \@", $self->address,
        $self->{'_implicit'} ? " (IMPLICIT)\n" : "\n";
    for ( @{ $self->{'_content'} } ) {
        if ( ref $_ ) {    # element
            $_->dump( $fh, $depth + 1 );    # recurse
        }
        else {                              # text node
            print $fh "  " x ( $depth + 1 );
            if ( length($_) > 65 or m<[\x00-\x1F]> ) {

                # it needs prettyin' up somehow or other
                my $x
                    = ( length($_) <= 65 )
                    ? $_
                    : ( substr( $_, 0, 65 ) . '...' );
                $x =~ s<([\x00-\x1F])>
                     <'\\x'.(unpack("H2",$1))>eg;
                print $fh qq{"$x"\n};
            }
            else {
                print $fh qq{"$_"\n};
            }
        }
    }
}


sub as_HTML {
    my ( $self, $entities, $indent, $omissible_map ) = @_;

    #my $indent_on = defined($indent) && length($indent);
    my @html = ();

    $omissible_map ||= \%HTML::Element::optionalEndTag;
    my $empty_element_map = $self->_empty_element_map;

    my $last_tag_tightenable    = 0;
    my $this_tag_tightenable    = 0;
    my $nonindentable_ancestors = 0;    # count of nonindentible tags over us.

    my ( $tag, $node, $start, $depth ); # per-iteration scratch

    if ( defined($indent) && length($indent) ) {
        $self->traverse(
            sub {
                ( $node, $start, $depth ) = @_;
                if ( ref $node ) {      # it's an element

                    # detect bogus classes. RT #35948, #61673
                    $node->can('starttag')
                        or Carp::confess( "Object of class "
                            . ref($node)
                            . " cannot be processed by HTML::Element" );

                    $tag = $node->{'_tag'};

                    if ($start) {       # on the way in
                        if ((   $this_tag_tightenable
                                = $HTML::Element::canTighten{$tag}
                            )
                            and !$nonindentable_ancestors
                            and $last_tag_tightenable
                            )
                        {
                            push
                                @html,
                                "\n",
                                $indent x $depth,
                                $node->starttag($entities),
                                ;
                        }
                        else {
                            push( @html, $node->starttag($entities) );
                        }
                        $last_tag_tightenable = $this_tag_tightenable;

                        ++$nonindentable_ancestors
                            if $tag eq 'pre' or $tag eq 'textarea'
                                or $HTML::Tagset::isCDATA_Parent{$tag};

                    }
                    elsif (
                        not(   $empty_element_map->{$tag}
                            or $omissible_map->{$tag} )
                        )
                    {

                        # on the way out
                        if (   $tag eq 'pre' or $tag eq 'textarea'
                            or $HTML::Tagset::isCDATA_Parent{$tag} )
                        {
                            --$nonindentable_ancestors;
                            $last_tag_tightenable
                                = $HTML::Element::canTighten{$tag};
                            push @html, $node->endtag;

                        }
                        else {    # general case
                            if ((   $this_tag_tightenable
                                    = $HTML::Element::canTighten{$tag}
                                )
                                and !$nonindentable_ancestors
                                and $last_tag_tightenable
                                )
                            {
                                push
                                    @html,
                                    "\n",
                                    $indent x $depth,
                                    $node->endtag,
                                    ;
                            }
                            else {
                                push @html, $node->endtag;
                            }
                            $last_tag_tightenable = $this_tag_tightenable;

                           #print "$tag tightenable: $this_tag_tightenable\n";
                        }
                    }
                }
                else {    # it's a text segment

                    $last_tag_tightenable = 0;    # I guess this is right
                    HTML::Entities::encode_entities( $node, $entities )

                        # That does magic things if $entities is undef.
                        unless (
                        ( defined($entities) && !length($entities) )

                        # If there's no entity to encode, don't call it
                        || $HTML::Tagset::isCDATA_Parent{ $_[3]{'_tag'} }

                        # To keep from amp-escaping children of script et al.
                        # That doesn't deal with descendants; but then, CDATA
                        #  parents shouldn't /have/ descendants other than a
                        #  text children (or comments?)
                        || $encoded_content
                        );
                    if ($nonindentable_ancestors) {
                        push @html, $node;    # say no go
                    }
                    else {
                        if ($last_tag_tightenable) {
                            $node =~ s<[\n\r\f\t ]+>< >s;

                            #$node =~ s< $><>s;
                            $node =~ s<^ ><>s;
                            push
                                @html,
                                "\n",
                                $indent x $depth,
                                $node,

           #Text::Wrap::wrap($indent x $depth, $indent x $depth, "\n" . $node)
                                ;
                        }
                        else {
                            push
                                @html,
                                $node,

                                #Text::Wrap::wrap('', $indent x $depth, $node)
                                ;
                        }
                    }
                }
                1;    # keep traversing
            }
        );            # End of parms to traverse()
    }
    else {            # no indenting -- much simpler code
        $self->traverse(
            sub {
                ( $node, $start ) = @_;
                if ( ref $node ) {

                    # detect bogus classes. RT #35948
                    $node->isa( $self->element_class )
                        or Carp::confess( "Object of class "
                            . ref($node)
                            . " cannot be processed by HTML::Element" );

                    $tag = $node->{'_tag'};
                    if ($start) {    # on the way in
                        push( @html, $node->starttag($entities) );
                    }
                    elsif (
                        not(   $empty_element_map->{$tag}
                            or $omissible_map->{$tag} )
                        )
                    {

                        # on the way out
                        push( @html, $node->endtag );
                    }
                }
                else {

                    # simple text content
                    HTML::Entities::encode_entities( $node, $entities )

                        # That does magic things if $entities is undef.
                        unless (
                        ( defined($entities) && !length($entities) )

                        # If there's no entity to encode, don't call it
                        || $HTML::Tagset::isCDATA_Parent{ $_[3]{'_tag'} }

                        # To keep from amp-escaping children of script et al.
                        # That doesn't deal with descendants; but then, CDATA
                        #  parents shouldn't /have/ descendants other than a
                        #  text children (or comments?)
                        || $encoded_content
                        );
                    push( @html, $node );
                }
                1;    # keep traversing
            }
        );            # End of parms to traverse()
    }

    if ( $self->{_store_declarations} && defined $self->{_decl} ) {
        unshift @html, sprintf "<!%s>\n", $self->{_decl}->{text};
    }

    return join( '', @html );
}


sub as_text {

    # Yet another iteratively implemented traverser
    my ( $this, %options ) = @_;
    my $skip_dels = $options{'skip_dels'} || 0;
    my (@pile) = ($this);
    my $tag;
    my $text = '';
    while (@pile) {
        if ( !defined( $pile[0] ) ) {    # undef!
                                         # no-op
        }
        elsif ( !ref( $pile[0] ) ) {     # text bit!  save it!
            $text .= shift @pile;
        }
        else {                           # it's a ref -- traverse under it
            unshift @pile, @{ $this->{'_content'} || $nillio }
                unless ( $tag = ( $this = shift @pile )->{'_tag'} ) eq 'style'
                or $tag eq 'script'
                or ( $skip_dels and $tag eq 'del' );
        }
    }
    return $text;
}

# extra_chars added for RT #26436
sub as_trimmed_text {
    my ( $this, %options ) = @_;
    my $text = $this->as_text(%options);
    my $extra_chars = defined $options{'extra_chars'}
                        ? $options{'extra_chars'} : '';

    $text =~ s/[\n\r\f\t$extra_chars ]+$//s;
    $text =~ s/^[\n\r\f\t$extra_chars ]+//s;
    $text =~ s/[\n\r\f\t$extra_chars ]+/ /g;
    return $text;
}

sub as_text_trimmed { shift->as_trimmed_text(@_) }   # alias, because I forget


# TODO: make it wrap, if not indent?

sub as_XML {

    # based an as_HTML
    my ($self) = @_;

    #my $indent_on = defined($indent) && length($indent);
    my @xml               = ();
    my $empty_element_map = $self->_empty_element_map;

    my ( $tag, $node, $start );    # per-iteration scratch
    $self->traverse(
        sub {
            ( $node, $start ) = @_;
            if ( ref $node ) {     # it's an element
                $tag = $node->{'_tag'};
                if ($start) {      # on the way in

                    foreach my $attr ( $node->all_attr_names() ) {
                        Carp::croak(
                            "$tag has an invalid attribute name '$attr'")
                            unless ( $attr eq '/' || $self->_valid_name($attr) );
                    }

                    if ( $empty_element_map->{$tag}
                        and !@{ $node->{'_content'} || $nillio } )
                    {
                        push( @xml, $node->starttag_XML( undef, 1 ) );
                    }
                    else {
                        push( @xml, $node->starttag_XML(undef) );
                    }
                }
                else {    # on the way out
                    unless ( $empty_element_map->{$tag}
                        and !@{ $node->{'_content'} || $nillio } )
                    {
                        push( @xml, $node->endtag_XML() );
                    }     # otherwise it will have been an <... /> tag.
                }
            }
            else {        # it's just text
                _xml_escape($node);
                push( @xml, $node );
            }
            1;            # keep traversing
        }
    );

    join( '', @xml, "\n" );
}

sub _xml_escape {

# DESTRUCTIVE (a.k.a. "in-place")
# Five required escapes: http://www.w3.org/TR/2006/REC-xml11-20060816/#syntax
# We allow & if it's part of a valid escape already: http://www.w3.org/TR/2006/REC-xml11-20060816/#sec-references
    foreach my $x (@_) {

        # In strings with no encoded entities all & should be encoded.
        if ($encoded_content) {
            $x
                =~ s/&(?!                 # An ampersand that isn't followed by...
                (\#\d+; |                 # A hash mark, digits and semicolon, or
                \#x[\da-f]+; |            # A hash mark, "x", hex digits and semicolon, or
                $START_CHAR$NAME_CHAR+; ) # A valid unicode entity name and semicolon
           )/&amp;/gx;    # Needs to be escaped to amp
        }
        else {
            $x =~ s/&/&amp;/g;
        }

        # simple character escapes
        $x =~ s/</&lt;/g;
        $x =~ s/>/&gt;/g;
        $x =~ s/"/&quot;/g;
        $x =~ s/'/&apos;/g;
    }
    return;
}


# NOTES:
#
# It's been suggested that attribute names be made :-keywords:
#   (:_tag "img" :border 0 :src "pie.png" :usemap "#main.map")
# However, it seems that Scheme has no such data type as :-keywords.
# So, for the moment at least, I tend toward simplicity, uniformity,
#  and universality, where everything a string or a list.

sub as_Lisp_form {
    my @out;

    my $sub;
    my $depth = 0;
    my ( @list, $val );
    $sub = sub {    # Recursor
        my $self = $_[0];
        @list = ( '_tag', $self->{'_tag'} );
        @list = () unless defined $list[-1];    # unlikely

        for ( sort keys %$self ) {              # predictable ordering
            next
                if $_ eq '_content'
                    or $_ eq '_tag'
                    or $_ eq '_parent'
                    or $_ eq '/';

            # Leave the other private attributes, I guess.
            push @list, $_, $val
                if defined( $val = $self->{$_} );    # and !ref $val;
        }

        for (@list) {

            # octal-escape it
            s<([^\x20\x21\x23\x27-\x5B\x5D-\x7E])>
         <sprintf('\\%03o',ord($1))>eg;
            $_ = qq{"$_"};
        }
        push @out, ( '  ' x $depth ) . '(' . join ' ', splice @list;
        if ( @{ $self->{'_content'} || $nillio } ) {
            $out[-1] .= " \"_content\" (\n";
            ++$depth;
            foreach my $c ( @{ $self->{'_content'} } ) {
                if ( ref($c) ) {

                    # an element -- recurse
                    $sub->($c);
                }
                else {

                    # a text segment -- stick it in and octal-escape it
                    push @out, $c;
                    $out[-1] =~ s<([^\x20\x21\x23\x27-\x5B\x5D-\x7E])>
             <sprintf('\\%03o',ord($1))>eg;

                    # And quote and indent it.
                    $out[-1] .= "\"\n";
                    $out[-1] = ( '  ' x $depth ) . '"' . $out[-1];
                }
            }
            --$depth;
            substr( $out[-1], -1 )
                = "))\n";    # end of _content and of the element
        }
        else {
            $out[-1] .= ")\n";
        }
        return;
    };

    $sub->( $_[0] );
    undef $sub;
    return join '', @out;
}


sub format {
    my ( $self, $formatter ) = @_;
    unless ( defined $formatter ) {
        # RECOMMEND PREREQ: HTML::FormatText
        require HTML::FormatText;
        $formatter = HTML::FormatText->new();
    }
    $formatter->format($self);
}


sub starttag {
    my ( $self, $entities ) = @_;

    my $name = $self->{'_tag'};

    return $self->{'text'}              if $name eq '~literal';
    return "<!" . $self->{'text'} . ">" if $name eq '~declaration';
    return "<?" . $self->{'text'} . ">" if $name eq '~pi';

    if ( $name eq '~comment' ) {
        if ( ref( $self->{'text'} || '' ) eq 'ARRAY' ) {

            # Does this ever get used?  And is this right?
            return
                "<!"
                . join( ' ', map( "--$_--", @{ $self->{'text'} } ) ) . ">";
        }
        else {
            return "<!--" . $self->{'text'} . "-->";
        }
    }

    my $tag = $html_uc ? "<\U$name" : "<\L$name";
    my $val;
    for ( sort keys %$self ) {    # predictable ordering
        next if !length $_ or m/^_/s or $_ eq '/';
        $val = $self->{$_};
        next if !defined $val;    # or ref $val;
        if ($_ eq $val &&         # if attribute is boolean, for this element
            exists( $HTML::Element::boolean_attr{$name} )
            && (ref( $HTML::Element::boolean_attr{$name} )
                ? $HTML::Element::boolean_attr{$name}{$_}
                : $HTML::Element::boolean_attr{$name} eq $_
            )
            )
        {
            $tag .= $html_uc ? " \U$_" : " \L$_";
        }
        else {                    # non-boolean attribute

            if ( ref $val eq 'HTML::Element'
                and $val->{_tag} eq '~literal' )
            {
                $val = $val->{text};
            }
            else {
                HTML::Entities::encode_entities( $val, $entities )
                    unless (
                    defined($entities) && !length($entities)
                    || $encoded_content

                    );
            }

            $val = qq{"$val"};
            $tag .= $html_uc ? qq{ \U$_\E=$val} : qq{ \L$_\E=$val};
        }
    }    # for keys
    if ( scalar $self->content_list == 0
        && $self->_empty_element_map->{ $self->tag } )
    {
        return $tag . " />";
    }
    else {
        return $tag . ">";
    }
}


sub starttag_XML {
    my ($self) = @_;

    # and a third parameter to signal emptiness?

    my $name = $self->{'_tag'};

    return $self->{'text'}               if $name eq '~literal';
    return '<!' . $self->{'text'} . '>'  if $name eq '~declaration';
    return "<?" . $self->{'text'} . "?>" if $name eq '~pi';

    if ( $name eq '~comment' ) {
        if ( ref( $self->{'text'} || '' ) eq 'ARRAY' ) {

            # Does this ever get used?  And is this right?
            $name = join( ' ', @{ $self->{'text'} } );
        }
        else {
            $name = $self->{'text'};
        }
        $name =~ s/--/-&#45;/g;    # can't have double --'s in XML comments
        return "<!--$name-->";
    }

    my $tag = "<$name";
    my $val;
    for ( sort keys %$self ) {     # predictable ordering
        next if !length $_ or m/^_/s or $_ eq '/';

        # Hm -- what to do if val is undef?
        # I suppose that shouldn't ever happen.
        next if !defined( $val = $self->{$_} );    # or ref $val;
        _xml_escape($val);
        $tag .= qq{ $_="$val"};
    }
    @_ == 3 ? "$tag />" : "$tag>";
}


sub endtag {
    $html_uc ? "</\U$_[0]->{'_tag'}>" : "</\L$_[0]->{'_tag'}>";
}

sub endtag_XML {
    "</$_[0]->{'_tag'}>";
}

#==========================================================================
# This, ladies and germs, is an iterative implementation of a
# recursive algorithm.  DON'T TRY THIS AT HOME.
# Basically, the algorithm says:
#
# To traverse:
#   1: pre-order visit this node
#   2: traverse any children of this node
#   3: post-order visit this node, unless it's a text segment,
#       or a prototypically empty node (like "br", etc.)
# Add to that the consideration of the callbacks' return values,
# so you can block visitation of the children, or siblings, or
# abort the whole excursion, etc.
#
# So, why all this hassle with making the code iterative?
# It makes for real speed, because it eliminates the whole
# hassle of Perl having to allocate scratch space for each
# instance of the recursive sub.  Since the algorithm
# is basically simple (and not all recursive ones are!) and
# has few necessary lexicals (basically just the current node's
# content list, and the current position in it), it was relatively
# straightforward to store that information not as the frame
# of a sub, but as a stack, i.e., a simple Perl array (well, two
# of them, actually: one for content-listrefs, one for indexes of
# current position in each of those).

my $NIL = [];

sub traverse {
    my ( $start, $callback, $ignore_text ) = @_;

    Carp::croak "traverse can be called only as an object method"
        unless ref $start;

    Carp::croak('must provide a callback for traverse()!')
        unless defined $callback and ref $callback;

    # Elementary type-checking:
    my ( $c_pre, $c_post );
    if ( UNIVERSAL::isa( $callback, 'CODE' ) ) {
        $c_pre = $c_post = $callback;
    }
    elsif ( UNIVERSAL::isa( $callback, 'ARRAY' ) ) {
        ( $c_pre, $c_post ) = @$callback;
        Carp::croak(
            "pre-order callback \"$c_pre\" is true but not a coderef!")
            if $c_pre and not UNIVERSAL::isa( $c_pre, 'CODE' );
        Carp::croak(
            "pre-order callback \"$c_post\" is true but not a coderef!")
            if $c_post and not UNIVERSAL::isa( $c_post, 'CODE' );
        return $start unless $c_pre or $c_post;

        # otherwise there'd be nothing to actually do!
    }
    else {
        Carp::croak("$callback is not a known kind of reference")
            unless ref($callback);
    }

    my $empty_element_map = $start->_empty_element_map;

    my (@C) = [$start];    # a stack containing lists of children
    my (@I) = (-1);        # initial value must be -1 for each list
         # a stack of indexes to current position in corresponding lists in @C
         # In each of these, 0 is the active point

    # scratch:
    my ($rv,           # return value of callback
        $this,         # current node
        $content_r,    # child list of $this
    );

    # THE BIG LOOP
    while (@C) {

        # Move to next item in this frame
        if ( !defined( $I[0] ) or ++$I[0] >= @{ $C[0] } ) {

            # We either went off the end of this list, or aborted the list
            # So call the post-order callback:
            if (    $c_post
                and defined $I[0]
                and @C > 1

                # to keep the next line from autovivifying
                and defined( $this = $C[1][ $I[1] ] )    # sanity, and
                     # suppress callbacks on exiting the fictional top frame
                and ref($this)    # sanity
                and not(
                    $this->{'_empty_element'}
                    || ( $empty_element_map->{ $this->{'_tag'} || '' }
                        && !@{ $this->{'_content'} } )    # RT #49932
                )    # things that don't get post-order callbacks
                )
            {
                shift @I;
                shift @C;

                #print "Post! at depth", scalar(@I), "\n";
                $rv = $c_post->(

                    #map $_, # copy to avoid any messiness
                    $this,     # 0: this
                    0,         # 1: startflag (0 for post-order call)
                    @I - 1,    # 2: depth
                );

                if ( defined($rv) and ref($rv) eq $travsignal_package ) {
                    $rv = $$rv;    #deref
                    if ( $rv eq 'ABORT' ) {
                        last;      # end of this excursion!
                    }
                    elsif ( $rv eq 'PRUNE' ) {

                        # NOOP on post!!
                    }
                    elsif ( $rv eq 'PRUNE_SOFTLY' ) {

                        # NOOP on post!!
                    }
                    elsif ( $rv eq 'OK' ) {

                        # noop
                    }
                    elsif ( $rv eq 'PRUNE_UP' ) {
                        $I[0] = undef;
                    }
                    else {
                        die "Unknown travsignal $rv\n";

                        # should never happen
                    }
                }
            }
            else {
                shift @I;
                shift @C;
            }
            next;
        }

        $this = $C[0][ $I[0] ];

        if ($c_pre) {
            if ( defined $this and ref $this ) {    # element
                $rv = $c_pre->(

                    #map $_, # copy to avoid any messiness
                    $this,     # 0: this
                    1,         # 1: startflag (1 for pre-order call)
                    @I - 1,    # 2: depth
                );
            }
            else {             # text segment
                next if $ignore_text;
                $rv = $c_pre->(

                    #map $_, # copy to avoid any messiness
                    $this,           # 0: this
                    1,               # 1: startflag (1 for pre-order call)
                    @I - 1,          # 2: depth
                    $C[1][ $I[1] ],  # 3: parent
                                     # And there will always be a $C[1], since
                             #  we can't start traversing at a text node
                    $I[0]    # 4: index of self in parent's content list
                );
            }
            if ( not $rv ) {    # returned false.  Same as PRUNE.
                next;           # prune
            }
            elsif ( ref($rv) eq $travsignal_package ) {
                $rv = $$rv;     # deref
                if ( $rv eq 'ABORT' ) {
                    last;       # end of this excursion!
                }
                elsif ( $rv eq 'PRUNE' ) {
                    next;
                }
                elsif ( $rv eq 'PRUNE_SOFTLY' ) {
                    if (ref($this)
                        and not( $this->{'_empty_element'}
                            || $empty_element_map->{ $this->{'_tag'} || '' } )
                        )
                    {

             # push a dummy empty content list just to trigger a post callback
                        unshift @I, -1;
                        unshift @C, $NIL;
                    }
                    next;
                }
                elsif ( $rv eq 'OK' ) {

                    # noop
                }
                elsif ( $rv eq 'PRUNE_UP' ) {
                    $I[0] = undef;
                    next;

                    # equivalent of last'ing out of the current child list.

            # Used to have PRUNE_UP_SOFTLY and ABORT_SOFTLY here, but the code
            # for these was seriously upsetting, served no particularly clear
            # purpose, and could not, I think, be easily implemented with a
            # recursive routine.  All bad things!
                }
                else {
                    die "Unknown travsignal $rv\n";

                    # should never happen
                }
            }

            # else fall thru to meaning same as \'OK'.
        }

        # end of pre-order calling

        # Now queue up content list for the current element...
        if (ref $this
            and not(    # ...except for those which...
                not( $content_r = $this->{'_content'} and @$content_r )

                # ...have empty content lists...
                and $this->{'_empty_element'}
                || $empty_element_map->{ $this->{'_tag'} || '' }

                # ...and that don't get post-order callbacks
            )
            )
        {
            unshift @I, -1;
            unshift @C, $content_r || $NIL;

            #print $this->{'_tag'}, " ($this) adds content_r ", $C[0], "\n";
        }
    }
    return $start;
}


sub is_inside {
    my $self = shift;
    return 0 unless @_; # if no items specified, I guess this is right.

    my $current = $self;
    # the loop starts by looking at the given element

    if (scalar @_ == 1) {
        while ( defined $current and ref $current ) {
            return 1 if $current eq $_[0] || $current->{'_tag'} eq $_[0];
            $current = $current->{'_parent'};
        }
        return 0;
    } else {
        my %elements = map { $_ => 1 } @_;
        while ( defined $current and ref $current ) {
            return 1 if $elements{$current} || $elements{ $current->{'_tag'} };
            $current = $current->{'_parent'};
        }
    }
    return 0;
}


sub is_empty {
    my $self = shift;
    !$self->{'_content'} || !@{ $self->{'_content'} };
}


sub pindex {
    my $self = shift;

    my $parent = $self->{'_parent'}    || return undef;
    my $pc     = $parent->{'_content'} || return undef;
    for ( my $i = 0; $i < @$pc; ++$i ) {
        return $i if ref $pc->[$i] and $pc->[$i] eq $self;
    }
    return undef;               # we shouldn't ever get here
}

#--------------------------------------------------------------------------


sub left {
    Carp::croak "left() is supposed to be an object method"
        unless ref $_[0];
    my $pc = ( $_[0]->{'_parent'} || return )->{'_content'}
        || die "parent is childless?";

    die "parent is childless" unless @$pc;
    return if @$pc == 1;    # I'm an only child

    if (wantarray) {
        my @out;
        foreach my $j (@$pc) {
            return @out if ref $j and $j eq $_[0];
            push @out, $j;
        }
    }
    else {
        for ( my $i = 0; $i < @$pc; ++$i ) {
            return $i ? $pc->[ $i - 1 ] : undef
                if ref $pc->[$i] and $pc->[$i] eq $_[0];
        }
    }

    die "I'm not in my parent's content list?";
    return;
}


sub right {
    Carp::croak "right() is supposed to be an object method"
        unless ref $_[0];
    my $pc = ( $_[0]->{'_parent'} || return )->{'_content'}
        || die "parent is childless?";

    die "parent is childless" unless @$pc;
    return if @$pc == 1;    # I'm an only child

    if (wantarray) {
        my ( @out, $seen );
        foreach my $j (@$pc) {
            if ($seen) {
                push @out, $j;
            }
            else {
                $seen = 1 if ref $j and $j eq $_[0];
            }
        }
        die "I'm not in my parent's content list?" unless $seen;
        return @out;
    }
    else {
        for ( my $i = 0; $i < @$pc; ++$i ) {
            return +( $i == $#$pc ) ? undef : $pc->[ $i + 1 ]
                if ref $pc->[$i] and $pc->[$i] eq $_[0];
        }
        die "I'm not in my parent's content list?";
        return;
    }
}

#--------------------------------------------------------------------------


sub address {
    if ( @_ == 1 ) {    # report-address form
        return join(
            '.',
            reverse(    # so it starts at the top
                map( $_->pindex() || '0',    # so that root's undef -> '0'
                    $_[0],                   # self and...
                    $_[0]->lineage )
            )
        );
    }
    else {                                   # get-node-at-address
        my @stack = split( /\./, $_[1] );
        my $here;

        if ( @stack and !length $stack[0] ) {    # relative addressing
            $here = $_[0];
            shift @stack;
        }
        else {                                   # absolute addressing
            return undef unless 0 == shift @stack; # pop the initial 0-for-root
            $here = $_[0]->root;
        }

        while (@stack) {
            return undef
                unless $here->{'_content'}
                    and @{ $here->{'_content'} } > $stack[0];

            # make sure the index isn't too high
            $here = $here->{'_content'}[ shift @stack ];
            return undef if @stack and not ref $here;

            # we hit a text node when we expected a non-terminal element node
        }

        return $here;
    }
}


sub depth {
    my $here  = $_[0];
    my $depth = 0;
    while ( defined( $here = $here->{'_parent'} ) and ref($here) ) {
        ++$depth;
    }
    return $depth;
}


sub root {
    my $here = my $root = shift;
    while ( defined( $here = $here->{'_parent'} ) and ref($here) ) {
        $root = $here;
    }
    return $root;
}


sub lineage {
    my $here = shift;
    my @lineage;
    while ( defined( $here = $here->{'_parent'} ) and ref($here) ) {
        push @lineage, $here;
    }
    return @lineage;
}


sub lineage_tag_names {
    my $here = my $start = shift;
    my @lineage_names;
    while ( defined( $here = $here->{'_parent'} ) and ref($here) ) {
        push @lineage_names, $here->{'_tag'};
    }
    return @lineage_names;
}


sub descendents { shift->descendants(@_) }

sub descendants {
    my $start = shift;
    if (wantarray) {
        my @descendants;
        $start->traverse(
            [    # pre-order sub only
                sub {
                    push( @descendants, $_[0] );
                    return 1;
                },
                undef    # no post
            ],
            1,           # ignore text
        );
        shift @descendants;    # so $self doesn't appear in the list
        return @descendants;
    }
    else {                     # just returns a scalar
        my $descendants = -1;    # to offset $self being counted
        $start->traverse(
            [                    # pre-order sub only
                sub {
                    ++$descendants;
                    return 1;
                },
                undef            # no post
            ],
            1,                   # ignore text
        );
        return $descendants;
    }
}


sub find { shift->find_by_tag_name(@_) }

# yup, a handy alias

sub find_by_tag_name {
    my (@pile) = shift(@_);    # start out the to-do stack for the traverser
    Carp::croak "find_by_tag_name can be called only as an object method"
        unless ref $pile[0];
    return () unless @_;
    my (@tags) = $pile[0]->_fold_case(@_);
    my ( @matching, $this, $this_tag );
    while (@pile) {
        $this_tag = ( $this = shift @pile )->{'_tag'};
        foreach my $t (@tags) {
            if ( $t eq $this_tag ) {
                if (wantarray) {
                    push @matching, $this;
                    last;
                }
                else {
                    return $this;
                }
            }
        }
        unshift @pile, grep ref($_), @{ $this->{'_content'} || next };
    }
    return @matching if wantarray;
    return;
}


sub find_by_attribute {

    # We could limit this to non-internal attributes, but hey.
    my ( $self, $attribute, $value ) = @_;
    Carp::croak "Attribute must be a defined value!"
        unless defined $attribute;
    $attribute = $self->_fold_case($attribute);

    my @matching;
    my $wantarray = wantarray;
    my $quit;
    $self->traverse(
        [    # pre-order only
            sub {
                if ( exists $_[0]{$attribute}
                    and $_[0]{$attribute} eq $value )
                {
                    push @matching, $_[0];
                    return HTML::Element::ABORT
                        unless $wantarray;    # only take the first
                }
                1;                            # keep traversing
            },
            undef                             # no post
        ],
        1,                                    # yes, ignore text nodes.
    );

    if ($wantarray) {
        return @matching;
    }
    else {
        return $matching[0];
    }
}

#--------------------------------------------------------------------------


sub look_down {
    ref( $_[0] ) or Carp::croak "look_down works only as an object method";

    my @criteria;
    for ( my $i = 1; $i < @_; ) {
        Carp::croak "Can't use undef as an attribute name"
            unless defined $_[$i];
        if ( ref $_[$i] ) {
            Carp::croak "A " . ref( $_[$i] ) . " value is not a criterion"
                unless ref $_[$i] eq 'CODE';
            push @criteria, $_[ $i++ ];
        }
        else {
            Carp::croak "param list to look_down ends in a key!" if $i == $#_;
            push @criteria, [
                scalar( $_[0]->_fold_case( $_[$i] ) ),
                defined( $_[ $i + 1 ] )
                ? ( ( ref $_[ $i + 1 ] ? $_[ $i + 1 ] : lc( $_[ $i + 1 ] ) ),
                    ref( $_[ $i + 1 ] )
                    )

                    # yes, leave that LC!
                : undef
            ];
            $i += 2;
        }
    }
    Carp::croak "No criteria?" unless @criteria;

    my (@pile) = ( $_[0] );
    my ( @matching, $val, $this );
Node:
    while ( defined( $this = shift @pile ) ) {

        # Yet another traverser implemented with merely iterative code.
        foreach my $c (@criteria) {
            if ( ref($c) eq 'CODE' ) {
                next Node unless $c->($this);    # jump to the continue block
            }
            else {                               # it's an attr-value pair
                next Node                        # jump to the continue block
                    if                           # two values are unequal if:
                        ( defined( $val = $this->{ $c->[0] } ) )
                    ? (     !defined $c->[ 1
                                ]    # actual is def, critval is undef => fail
                                     # allow regex matching
                                     # allow regex matching
                                or (
                                  $c->[2] eq 'Regexp'
                                ? $val !~ $c->[1]
                                : ( ref $val ne $c->[2]

                                        # have unequal ref values => fail
                                        or lc($val) ne lc( $c->[1] )

                                       # have unequal lc string values => fail
                                )
                                )
                        )
                    : (     defined $c->[1]
                        )    # actual is undef, critval is def => fail
            }
        }

        # We make it this far only if all the criteria passed.
        return $this unless wantarray;
        push @matching, $this;
    }
    continue {
        unshift @pile, grep ref($_), @{ $this->{'_content'} || $nillio };
    }
    return @matching if wantarray;
    return;
}


sub look_up {
    ref( $_[0] ) or Carp::croak "look_up works only as an object method";

    my @criteria;
    for ( my $i = 1; $i < @_; ) {
        Carp::croak "Can't use undef as an attribute name"
            unless defined $_[$i];
        if ( ref $_[$i] ) {
            Carp::croak "A " . ref( $_[$i] ) . " value is not a criterion"
                unless ref $_[$i] eq 'CODE';
            push @criteria, $_[ $i++ ];
        }
        else {
            Carp::croak "param list to look_up ends in a key!" if $i == $#_;
            push @criteria, [
                scalar( $_[0]->_fold_case( $_[$i] ) ),
                defined( $_[ $i + 1 ] )
                ? ( ( ref $_[ $i + 1 ] ? $_[ $i + 1 ] : lc( $_[ $i + 1 ] ) ),
                    ref( $_[ $i + 1 ] )
                    )
                : undef    # Yes, leave that LC!
            ];
            $i += 2;
        }
    }
    Carp::croak "No criteria?" unless @criteria;

    my ( @matching, $val );
    my $this = $_[0];
Node:
    while (1) {

       # You'll notice that the code here is almost the same as for look_down.
        foreach my $c (@criteria) {
            if ( ref($c) eq 'CODE' ) {
                next Node unless $c->($this);    # jump to the continue block
            }
            else {                               # it's an attr-value pair
                next Node                        # jump to the continue block
                    if                           # two values are unequal if:
                        ( defined( $val = $this->{ $c->[0] } ) )
                    ? (     !defined $c->[ 1
                                ]    # actual is def, critval is undef => fail
                                or (
                                  $c->[2] eq 'Regexp'
                                ? $val !~ $c->[1]
                                : ( ref $val ne $c->[2]

                                        # have unequal ref values => fail
                                        or lc($val) ne $c->[1]

                                       # have unequal lc string values => fail
                                )
                                )
                        )
                    : (     defined $c->[1]
                        )    # actual is undef, critval is def => fail
            }
        }

        # We make it this far only if all the criteria passed.
        return $this unless wantarray;
        push @matching, $this;
    }
    continue {
        last unless defined( $this = $this->{'_parent'} ) and ref $this;
    }

    return @matching if wantarray;
    return;
}

#--------------------------------------------------------------------------


sub attr_get_i {
    if ( @_ > 2 ) {
        my $self = shift;
        Carp::croak "No attribute names can be undef!"
            if grep !defined($_), @_;
        my @attributes = $self->_fold_case(@_);
        if (wantarray) {
            my @out;
            foreach my $x ( $self, $self->lineage ) {
                push @out,
                    map { exists( $x->{$_} ) ? $x->{$_} : () } @attributes;
            }
            return @out;
        }
        else {
            foreach my $x ( $self, $self->lineage ) {
                foreach my $attribute (@attributes) {
                    return $x->{$attribute}
                        if exists $x->{$attribute};    # found
                }
            }
            return;                                    # never found
        }
    }
    else {

        # Single-attribute search.  Simpler, most common, so optimize
        #  for the most common case
        Carp::croak "Attribute name must be a defined value!"
            unless defined $_[1];
        my $self      = $_[0];
        my $attribute = $self->_fold_case( $_[1] );
        if (wantarray) {                               # list context
            return
                map { exists( $_->{$attribute} ) ? $_->{$attribute} : () }
                $self, $self->lineage;
        }
        else {                                         # scalar context
            foreach my $x ( $self, $self->lineage ) {
                return $x->{$attribute} if exists $x->{$attribute};    # found
            }
            return;    # never found
        }
    }
}


sub tagname_map {
    my (@pile) = $_[0];    # start out the to-do stack for the traverser
    Carp::croak "find_by_tag_name can be called only as an object method"
        unless ref $pile[0];
    my ( %map, $this_tag, $this );
    while (@pile) {
        $this_tag = ''
            unless defined( $this_tag = ( $this = shift @pile )->{'_tag'} )
        ;    # dance around the strange case of having an undef tagname.
        push @{ $map{$this_tag} ||= [] }, $this;    # add to map
        unshift @pile, grep ref($_),
            @{ $this->{'_content'} || next };       # traverse
    }
    return \%map;
}


sub extract_links {
    my $start = shift;

    my %wantType;
    @wantType{ $start->_fold_case(@_) } = (1) x @_;    # if there were any
    my $wantType = scalar(@_);

    my @links;

    # TODO: add xml:link?

    my ( $link_attrs, $tag, $self, $val );    # scratch for each iteration
    $start->traverse(
        [   sub {                             # pre-order call only
                $self = $_[0];

                $tag = $self->{'_tag'};
                return 1
                    if $wantType && !$wantType{$tag};    # if we're selective

                if (defined(
                        $link_attrs = $HTML::Element::linkElements{$tag}
                    )
                    )
                {

                    # If this is a tag that has any link attributes,
                    #  look over possibly present link attributes,
                    #  saving the value, if found.
                    for ( ref($link_attrs) ? @$link_attrs : $link_attrs ) {
                        if ( defined( $val = $self->attr($_) ) ) {
                            push( @links, [ $val, $self, $_, $tag ] );
                        }
                    }
                }
                1;    # return true, so we keep recursing
            },
            undef
        ],
        1,            # ignore text nodes
    );
    \@links;
}


sub simplify_pres {
    my $pre = 0;

    my $sub;
    my $line;
    $sub = sub {
        ++$pre if $_[0]->{'_tag'} eq 'pre';
        foreach my $it ( @{ $_[0]->{'_content'} || return } ) {
            if ( ref $it ) {
                $sub->($it);    # recurse!
            }
            elsif ($pre) {

                #$it =~ s/(?:(?:\cm\cj*)|(?:\cj))/\n/g;

                $it = join "\n", map {
                    ;
                    $line = $_;
                    while (
                        $line
                        =~ s/^([^\t]*)(\t+)/$1.(" " x ((length($2)<<3)-(length($1)&7)))/e

              # Sort of adapted from Text::Tabs -- yes, it's hardwired-in that
              # tabs are at every EIGHTH column.
                        )
                    {
                    }
                    $line;
                    }
                    split /(?:(?:\cm\cj*)|(?:\cj))/, $it, -1;
            }
        }
        --$pre if $_[0]->{'_tag'} eq 'pre';
        return;
    };
    $sub->( $_[0] );

    undef $sub;
    return;
}


sub same_as {
    die 'same_as() takes only one argument: $h->same_as($i)' unless @_ == 2;
    my ( $h, $i ) = @_[ 0, 1 ];
    die "same_as() can be called only as an object method" unless ref $h;

    return 0 unless defined $i and ref $i;

    # An element can't be same_as anything but another element!
    # They needn't be of the same class, tho.

    return 1 if $h eq $i;

    # special (if rare) case: anything is the same as... itself!

    # assumes that no content lists in/under $h or $i contain subsequent
    #  text segments, like: ['foo', ' bar']

    # compare attributes now.
    #print "Comparing tags of $h and $i...\n";

    return 0 unless $h->{'_tag'} eq $i->{'_tag'};

    # only significant attribute whose name starts with "_"

    #print "Comparing attributes of $h and $i...\n";
    # Compare attributes, but only the real ones.
    {

        # Bear in mind that the average element has very few attributes,
        #  and that element names are rather short.
        # (Values are a different story.)

    # XXX I would think that /^[^_]/ would be faster, at least easier to read.
        my @keys_h
            = sort grep { length $_ and substr( $_, 0, 1 ) ne '_' } keys %$h;
        my @keys_i
            = sort grep { length $_ and substr( $_, 0, 1 ) ne '_' } keys %$i;

        return 0 unless @keys_h == @keys_i;

        # different number of real attributes?  they're different.
        for ( my $x = 0; $x < @keys_h; ++$x ) {
            return 0
                unless $keys_h[$x] eq $keys_i[$x] and    # same key name
                    $h->{ $keys_h[$x] } eq $i->{ $keys_h[$x] };   # same value
             # Should this test for definedness on values?
             # People shouldn't be putting undef in attribute values, I think.
        }
    }

    #print "Comparing children of $h and $i...\n";
    my $hcl = $h->{'_content'} || [];
    my $icl = $i->{'_content'} || [];

    return 0 unless @$hcl == @$icl;

    # different numbers of children?  they're different.

    if (@$hcl) {

        # compare each of the children:
        for ( my $x = 0; $x < @$hcl; ++$x ) {
            if ( ref $hcl->[$x] ) {
                return 0 unless ref( $icl->[$x] );

                # an element can't be the same as a text segment
                # Both elements:
                return 0 unless $hcl->[$x]->same_as( $icl->[$x] );  # RECURSE!
            }
            else {
                return 0 if ref( $icl->[$x] );

                # a text segment can't be the same as an element
                # Both text segments:
                return 0 unless $hcl->[$x] eq $icl->[$x];
            }
        }
    }

    return 1;    # passed all the tests!
}


sub new_from_lol {
    my $class = shift;
    $class = ref($class) || $class;

  # calling as an object method is just the same as ref($h)->new_from_lol(...)
    my $lol = $_[1];

    my @ancestor_lols;

    # So we can make sure there's no cyclicities in this lol.
    # That would be perverse, but one never knows.
    my ( $sub, $k, $v, $node );    # last three are scratch values
    $sub = sub {

        #print "Building for $_[0]\n";
        my $lol = $_[0];
        return unless @$lol;
        my ( @attributes, @children );
        Carp::croak "Cyclicity detected in source LOL tree, around $lol?!?"
            if grep( $_ eq $lol, @ancestor_lols );
        push @ancestor_lols, $lol;

        my $tag_name = 'null';

        # Recursion in in here:
        for ( my $i = 0; $i < @$lol; ++$i ) {    # Iterate over children
            if ( ref( $lol->[$i] ) eq 'ARRAY' )
            {    # subtree: most common thing in loltree
                push @children, $sub->( $lol->[$i] );
            }
            elsif ( !ref( $lol->[$i] ) ) {
                if ( $i == 0 ) {    # name
                    $tag_name = $lol->[$i];
                    Carp::croak "\"$tag_name\" isn't a good tag name!"
                        if $tag_name =~ m/[<>\/\x00-\x20]/
                    ;               # minimal sanity, certainly!
                }
                else {              # text segment child
                    push @children, $lol->[$i];
                }
            }
            elsif ( ref( $lol->[$i] ) eq 'HASH' ) {    # attribute hashref
                keys %{ $lol->[$i] };   # reset the each-counter, just in case
                while ( ( $k, $v ) = each %{ $lol->[$i] } ) {
                    push @attributes, $class->_fold_case($k), $v
                        if defined $v
                            and $k ne '_name'
                            and $k ne '_content'
                            and $k ne '_parent';

                    # enforce /some/ sanity!
                }
            }
            elsif ( UNIVERSAL::isa( $lol->[$i], __PACKAGE__ ) ) {
                if ( $lol->[$i]->{'_parent'} ) {    # if claimed
                        #print "About to clone ", $lol->[$i], "\n";
                    push @children, $lol->[$i]->clone();
                }
                else {
                    push @children, $lol->[$i];    # if unclaimed...
                         #print "Claiming ", $lol->[$i], "\n";
                    $lol->[$i]->{'_parent'} = 1;    # claim it NOW
                      # This WILL be replaced by the correct value once we actually
                      #  construct the parent, just after the end of this loop...
                }
            }
            else {
                Carp::croak "new_from_lol doesn't handle references of type "
                    . ref( $lol->[$i] );
            }
        }

        pop @ancestor_lols;
        $node = $class->new($tag_name);

        #print "Children: @children\n";

        if ( $class eq __PACKAGE__ ) {    # Special-case it, for speed:
            %$node = ( %$node, @attributes ) if @attributes;

            #print join(' ', $node, ' ' , map("<$_>", %$node), "\n");
            if (@children) {
                $node->{'_content'} = \@children;
                foreach my $c (@children) {
                    _weaken($c->{'_parent'} = $node)
                        if ref $c;
                }
            }
        }
        else {                            # Do it the clean way...
                                          #print "Done neatly\n";
            while (@attributes) { $node->attr( splice @attributes, 0, 2 ) }
            $node->push_content(
                  map { _weaken($_->{'_parent'} = $node) if ref $_; $_ }
                    @children )
                if @children;
        }

        return $node;
    };

    # End of sub definition.

    if (wantarray) {
        my (@nodes) = map { ; ( ref($_) eq 'ARRAY' ) ? $sub->($_) : $_ } @_;
        # Let text bits pass thru, I guess.  This makes this act more like
        #  unshift_content et al.  Undocumented.

        undef $sub;
        # so it won't be in its own frame, so its refcount can hit 0

        return @nodes;
    }
    else {
        Carp::croak "new_from_lol in scalar context needs exactly one lol"
            unless @_ == 1;
        return $_[0] unless ref( $_[0] ) eq 'ARRAY';
        # used to be a fatal error.  still undocumented tho.

        $node = $sub->( $_[0] );
        undef $sub;
        # so it won't be in its own frame, so its refcount can hit 0

        return $node;
    }
}


sub objectify_text {
    my (@stack) = ( $_[0] );

    my ($this);
    while (@stack) {
        foreach my $c ( @{ ( $this = shift @stack )->{'_content'} } ) {
            if ( ref($c) ) {
                unshift @stack, $c;    # visit it later.
            }
            else {
                $c = $this->element_class->new(
                    '~text',
                    'text'    => $c,
                    '_parent' => $this
                );
            }
        }
    }
    return;
}

sub deobjectify_text {
    my (@stack) = ( $_[0] );
    my ($old_node);

    if ( $_[0]{'_tag'} eq '~text' ) {    # special case
            # Puts the $old_node variable to a different purpose
        if ( $_[0]{'_parent'} ) {
            $_[0]->replace_with( $old_node = delete $_[0]{'text'} )->delete;
        }
        else {    # well, that's that, then!
            $old_node = delete $_[0]{'text'};
        }

        if ( ref( $_[0] ) eq __PACKAGE__ ) {    # common case
            %{ $_[0] } = ();                    # poof!
        }
        else {

            # play nice:
            delete $_[0]{'_parent'};
            $_[0]->delete;
        }
        return '' unless defined $old_node;     # sanity!
        return $old_node;
    }

    while (@stack) {
        foreach my $c ( @{ ( shift @stack )->{'_content'} } ) {
            if ( ref($c) ) {
                if ( $c->{'_tag'} eq '~text' ) {
                    $c = ( $old_node = $c )->{'text'};
                    if ( ref($old_node) eq __PACKAGE__ ) {    # common case
                        %$old_node = ();                      # poof!
                    }
                    else {

                        # play nice:
                        delete $old_node->{'_parent'};
                        $old_node->delete;
                    }
                }
                else {
                    unshift @stack, $c;    # visit it later.
                }
            }
        }
    }

    return undef;
}


{

    # The next three subs are basically copied from Number::Latin,
    # based on a one-liner by Abigail.  Yes, I could simply require that
    # module, and a Roman numeral module too, but really, HTML-Tree already
    # has enough dependecies as it is; and anyhow, I don't need the functions
    # that do latin2int or roman2int.
    no integer;

    sub _int2latin {
        return unless defined $_[0];
        return '0' if $_[0] < 1 and $_[0] > -1;
        return '-' . _i2l( abs int $_[0] )
            if $_[0] <= -1;    # tolerate negatives
        return _i2l( int $_[0] );
    }

    sub _int2LATIN {

        # just the above plus uc
        return unless defined $_[0];
        return '0' if $_[0] < 1 and $_[0] > -1;
        return '-' . uc( _i2l( abs int $_[0] ) )
            if $_[0] <= -1;    # tolerate negs
        return uc( _i2l( int $_[0] ) );
    }

    my @alpha = ( 'a' .. 'z' );

    sub _i2l {                 # the real work
        my $int = $_[0] || return "";
        _i2l( int( ( $int - 1 ) / 26 ) )
            . $alpha[ $int % 26 - 1 ];    # yes, recursive
            # Yes, 26 => is (26 % 26 - 1), which is -1 => Z!
    }
}

{

    # And now, some much less impressive Roman numerals code:

    my (@i) = ( '', qw(I II III IV V VI VII VIII IX) );
    my (@x) = ( '', qw(X XX XXX XL L LX LXX LXXX XC) );
    my (@c) = ( '', qw(C CC CCC CD D DC DCC DCCC CM) );
    my (@m) = ( '', qw(M MM MMM) );

    sub _int2ROMAN {
        my ( $i, $pref );
        return '0'
            if 0 == ( $i = int( $_[0] || 0 ) );    # zero is a special case
        return $i + 0 if $i <= -4000 or $i >= 4000;

       # Because over 3999 would require non-ASCII chars, like D-with-)-inside
        if ( $i < 0 ) {    # grumble grumble tolerate negatives grumble
            $pref = '-';
            $i    = abs($i);
        }
        else {
            $pref = '';    # normal case
        }

        my ( $x, $c, $m ) = ( 0, 0, 0 );
        if ( $i >= 10 ) {
            $x = $i / 10;
            $i %= 10;
            if ( $x >= 10 ) {
                $c = $x / 10;
                $x %= 10;
                if ( $c >= 10 ) { $m = $c / 10; $c %= 10; }
            }
        }

        #print "m$m c$c x$x i$i\n";

        return join( '', $pref, $m[$m], $c[$c], $x[$x], $i[$i] );
    }

    sub _int2roman { lc( _int2ROMAN( $_[0] ) ) }
}

sub _int2int { $_[0] }    # dummy

%list_type_to_sub = (
    'I' => \&_int2ROMAN,
    'i' => \&_int2roman,
    'A' => \&_int2LATIN,
    'a' => \&_int2latin,
    '1' => \&_int2int,
);

sub number_lists {
    my (@stack) = ( $_[0] );
    my ( $this, $tag, $counter, $numberer );    # scratch
    while (@stack) {    # yup, pre-order-traverser idiom
        if ( ( $tag = ( $this = shift @stack )->{'_tag'} ) eq 'ol' ) {

            # Prep some things:
            $counter
                = ( ( $this->{'start'} || '' ) =~ m<^\s*(\d{1,7})\s*$>s )
                ? $1
                : 1;
            $numberer = $list_type_to_sub{ $this->{'type'} || '' }
                || $list_type_to_sub{'1'};

            # Immeditately iterate over all children
            foreach my $c ( @{ $this->{'_content'} || next } ) {
                next unless ref $c;
                unshift @stack, $c;
                if ( $c->{'_tag'} eq 'li' ) {
                    $counter = $1
                        if (
                        ( $c->{'value'} || '' ) =~ m<^\s*(\d{1,7})\s*$>s );
                    $c->{'_bullet'} = $numberer->($counter) . '.';
                    ++$counter;
                }
            }

        }
        elsif ( $tag eq 'ul' or $tag eq 'dir' or $tag eq 'menu' ) {

            # Immeditately iterate over all children
            foreach my $c ( @{ $this->{'_content'} || next } ) {
                next unless ref $c;
                unshift @stack, $c;
                $c->{'_bullet'} = '*' if $c->{'_tag'} eq 'li';
            }

        }
        else {
            foreach my $c ( @{ $this->{'_content'} || next } ) {
                unshift @stack, $c if ref $c;
            }
        }
    }
    return;
}


sub has_insane_linkage {
    my @pile = ( $_[0] );
    my ( $c, $i, $p, $this );    # scratch

    # Another iterative traverser; this time much simpler because
    #  only in pre-order:
    my %parent_of = ( $_[0], 'TOP-OF-SCAN' );
    while (@pile) {
        $this = shift @pile;
        $c = $this->{'_content'} || next;
        return ( $this, "_content attribute is true but nonref." )
            unless ref($c) eq 'ARRAY';
        next unless @$c;
        for ( $i = 0; $i < @$c; ++$i ) {
            return ( $this, "Child $i is undef" )
                unless defined $c->[$i];
            if ( ref( $c->[$i] ) ) {
                return ( $c->[$i], "appears in its own content list" )
                    if $c->[$i] eq $this;
                return ( $c->[$i],
                    "appears twice in the tree: once under $this, once under $parent_of{$c->[$i]}"
                ) if exists $parent_of{ $c->[$i] };
                $parent_of{ $c->[$i] } = '' . $this;

                # might as well just use the stringification of it.

                return ( $c->[$i],
                    "_parent attribute is wrong (not defined)" )
                    unless defined( $p = $c->[$i]{'_parent'} );
                return ( $c->[$i], "_parent attribute is wrong (nonref)" )
                    unless ref($p);
                return ( $c->[$i],
                    "_parent attribute is wrong (is $p; should be $this)" )
                    unless $p eq $this;
            }
        }
        unshift @pile, grep ref($_), @$c;

        # queue up more things on the pile stack
    }
    return;    #okay
}

sub _asserts_fail {    # to be run on trusted documents only
    my (@pile) = ( $_[0] );
    my ( @errors, $this, $id, $assert, $parent, $rv );
    while (@pile) {
        $this = shift @pile;
        if ( defined( $assert = $this->{'assert'} ) ) {
            $id = ( $this->{'id'} ||= $this->address )
                ;      # don't use '0' as an ID, okay?
            unless ( ref($assert) ) {

                package main;
## no critic
                $assert = $this->{'assert'} = (
                    $assert =~ m/\bsub\b/
                    ? eval($assert)
                    : eval("sub {  $assert\n}")
                );
## use critic
                if ($@) {
                    push @errors,
                        [ $this, "assertion at $id broke in eval: $@" ];
                    $assert = $this->{'assert'} = sub { };
                }
            }
            $parent = $this->{'_parent'};
            $rv     = undef;
            eval {
                $rv = $assert->(
                    $this, $this->{'_tag'}, $this->{'_id'},    # 0,1,2
                    $parent
                    ? ( $parent, $parent->{'_tag'}, $parent->{'id'} )
                    : ()                                       # 3,4,5
                );
            };
            if ($@) {
                push @errors, [ $this, "assertion at $id died: $@" ];
            }
            elsif ( !$rv ) {
                push @errors, [ $this, "assertion at $id failed" ];
            }

            # else OK
        }
        push @pile, grep ref($_), @{ $this->{'_content'} || next };
    }
    return @errors;
}

## _valid_name
#  validate XML style attribute names
#  http://www.w3.org/TR/2006/REC-xml11-20060816/#NT-Name

sub _valid_name {
    my $self = shift;
    my $attr = shift
        or Carp::croak("sub valid_name requires an attribute name");

    return (0) unless ( $attr =~ /^$START_CHAR$NAME_CHAR+$/ );

    return (1);
}


sub element_class {
    $_[0]->{_element_class} || __PACKAGE__;
}

1;


1;

__END__

=pod

=head1 NAME

HTML::Element - Class for objects that represent HTML elements

=head1 VERSION

This document describes version 5.07 of
HTML::Element, released August 31, 2017
as part of L<HTML-Tree|HTML::Tree>.

=head1 SYNOPSIS

    use HTML::Element;
    $a = HTML::Element->new('a', href => 'http://www.perl.com/');
    $a->push_content("The Perl Homepage");

    $tag = $a->tag;
    print "$tag starts out as:",  $a->starttag, "\n";
    print "$tag ends as:",  $a->endtag, "\n";
    print "$tag\'s href attribute is: ", $a->attr('href'), "\n";

    $links_r = $a->extract_links();
    print "Hey, I found ", scalar(@$links_r), " links.\n";

    print "And that, as HTML, is: ", $a->as_HTML, "\n";
    $a = $a->delete;

=head1 DESCRIPTION

(This class is part of the L<HTML::Tree|HTML::Tree> dist.)

Objects of the HTML::Element class can be used to represent elements
of HTML document trees.  These objects have attributes, notably attributes that
designates each element's parent and content.  The content is an array
of text segments and other HTML::Element objects.  A tree with HTML::Element
objects as nodes can represent the syntax tree for a HTML document.

=head1 HOW WE REPRESENT TREES

Consider this HTML document:

  <html lang='en-US'>
    <head>
      <title>Stuff</title>
      <meta name='author' content='Jojo'>
    </head>
    <body>
     <h1>I like potatoes!</h1>
    </body>
  </html>

Building a syntax tree out of it makes a tree-structure in memory
that could be diagrammed as:

                     html (lang='en-US')
                      / \
                    /     \
                  /         \
                head        body
               /\               \
             /    \               \
           /        \               \
         title     meta              h1
          |       (name='author',     |
       "Stuff"    content='Jojo')    "I like potatoes"

This is the traditional way to diagram a tree, with the "root" at the
top, and it's this kind of diagram that people have in mind when they
say, for example, that "the meta element is under the head element
instead of under the body element".  (The same is also said with
"inside" instead of "under" -- the use of "inside" makes more sense
when you're looking at the HTML source.)

Another way to represent the above tree is with indenting:

  html (attributes: lang='en-US')
    head
      title
        "Stuff"
      meta (attributes: name='author' content='Jojo')
    body
      h1
        "I like potatoes"

Incidentally, diagramming with indenting works much better for very
large trees, and is easier for a program to generate.  The C<< $tree->dump >>
method uses indentation just that way.

However you diagram the tree, it's stored the same in memory -- it's a
network of objects, each of which has attributes like so:

  element #1:  _tag: 'html'
               _parent: none
               _content: [element #2, element #5]
               lang: 'en-US'

  element #2:  _tag: 'head'
               _parent: element #1
               _content: [element #3, element #4]

  element #3:  _tag: 'title'
               _parent: element #2
               _content: [text segment "Stuff"]

  element #4   _tag: 'meta'
               _parent: element #2
               _content: none
               name: author
               content: Jojo

  element #5   _tag: 'body'
               _parent: element #1
               _content: [element #6]

  element #6   _tag: 'h1'
               _parent: element #5
               _content: [text segment "I like potatoes"]

The "treeness" of the tree-structure that these elements comprise is
not an aspect of any particular object, but is emergent from the
relatedness attributes (_parent and _content) of these element-objects
and from how you use them to get from element to element.

While you could access the content of a tree by writing code that says
"access the 'src' attribute of the root's I<first> child's I<seventh>
child's I<third> child", you're more likely to have to scan the contents
of a tree, looking for whatever nodes, or kinds of nodes, you want to
do something with.  The most straightforward way to look over a tree
is to "traverse" it; an HTML::Element method (C<< $h->traverse >>) is
provided for this purpose; and several other HTML::Element methods are
based on it.

(For everything you ever wanted to know about trees, and then some,
see Niklaus Wirth's I<Algorithms + Data Structures = Programs> or
Donald Knuth's I<The Art of Computer Programming, Volume 1>.)

=head2 Weak References

TL;DR summary: S<C<use HTML::TreeBuilder 5 -weak;>> and forget about
the C<delete> method (except for pruning a node from a tree).

Because HTML::Element stores a reference to the parent element, Perl's
reference-count garbage collection doesn't work properly with
HTML::Element trees.  Starting with version 5.00, HTML::Element uses
weak references (if available) to prevent that problem.  Weak
references were introduced in Perl 5.6.0, but you also need a version
of L<Scalar::Util> that provides the C<weaken> function.

Weak references are enabled by default.  If you want to be certain
they're in use, you can say S<C<use HTML::Element 5 -weak;>>.  You
must include the version number; previous versions of HTML::Element
ignored the import list entirely.

To disable weak references, you can say S<C<use HTML::Element -noweak;>>.
This is a global setting.  B<This feature is deprecated> and is
provided only as a quick fix for broken code.  If your code does not
work properly with weak references, you should fix it immediately, as
weak references may become mandatory in a future version.  Generally,
all you need to do is keep a reference to the root of the tree until
you're done working with it.

Because HTML::TreeBuilder is a subclass of HTML::Element, you can also
import C<-weak> or C<-noweak> from HTML::TreeBuilder: e.g.
S<C<use HTML::TreeBuilder: 5 -weak;>>.

=head1 BASIC METHODS

=head2 new

  $h = HTML::Element->new('tag', 'attrname' => 'value', ... );

This constructor method returns a new HTML::Element object.  The tag
name is a required argument; it will be forced to lowercase.
Optionally, you can specify other initial attributes at object
creation time.

=head2 attr

  $value = $h->attr('attr');
  $old_value = $h->attr('attr', $new_value);

Returns (optionally sets) the value of the given attribute of C<$h>.  The
attribute name (but not the value, if provided) is forced to
lowercase.  If trying to read the value of an attribute not present
for this element, the return value is undef.
If setting a new value, the old value of that attribute is
returned.

If methods are provided for accessing an attribute (like C<< $h->tag >> for
"_tag", C<< $h->content_list >>, etc. below), use those instead of calling
attr C<< $h->attr >>, whether for reading or setting.

Note that setting an attribute to C<undef> (as opposed to "", the empty
string) actually deletes the attribute.

=head2 tag

  $tagname = $h->tag();
  $h->tag('tagname');

Returns (optionally sets) the tag name (also known as the generic
identifier) for the element C<$h>.  In setting, the tag name is always
converted to lower case.

There are four kinds of "pseudo-elements" that show up as
HTML::Element objects:

=over

=item Comment pseudo-elements

These are element objects with a C<$h-E<gt>tag> value of "~comment",
and the content of the comment is stored in the "text" attribute
(C<$h-E<gt>attr("text")>).  For example, parsing this code with
HTML::TreeBuilder...

  <!-- I like Pie.
     Pie is good
  -->

produces an HTML::Element object with these attributes:

  "_tag",
  "~comment",
  "text",
  " I like Pie.\n     Pie is good\n  "

=item Declaration pseudo-elements

Declarations (rarely encountered) are represented as HTML::Element
objects with a tag name of "~declaration", and content in the "text"
attribute.  For example, this:

  <!DOCTYPE foo>

produces an element whose attributes include:

  "_tag", "~declaration", "text", "DOCTYPE foo"

=item Processing instruction pseudo-elements

PIs (rarely encountered) are represented as HTML::Element objects with
a tag name of "~pi", and content in the "text" attribute.  For
example, this:

  <?stuff foo?>

produces an element whose attributes include:

  "_tag", "~pi", "text", "stuff foo?"

(assuming a recent version of HTML::Parser)

=item ~literal pseudo-elements

These objects are not currently produced by HTML::TreeBuilder, but can
be used to represent a "super-literal" -- i.e., a literal you want to
be immune from escaping.  (Yes, I just made that term up.)

That is, this is useful if you want to insert code into a tree that
you plan to dump out with C<as_HTML>, where you want, for some reason,
to suppress C<as_HTML>'s normal behavior of amp-quoting text segments.

For example, this:

  my $literal = HTML::Element->new('~literal',
    'text' => 'x < 4 & y > 7'
  );
  my $span = HTML::Element->new('span');
  $span->push_content($literal);
  print $span->as_HTML;

prints this:

  <span>x < 4 & y > 7</span>

Whereas this:

  my $span = HTML::Element->new('span');
  $span->push_content('x < 4 & y > 7');
    # normal text segment
  print $span->as_HTML;

prints this:

  <span>x &lt; 4 &amp; y &gt; 7</span>

Unless you're inserting lots of pre-cooked code into existing trees,
and dumping them out again, it's not likely that you'll find
C<~literal> pseudo-elements useful.

=back

=head2 parent

  $parent = $h->parent();
  $h->parent($new_parent);

Returns (optionally sets) the parent (aka "container") for this element.
The parent should either be undef, or should be another element.

You B<should not> use this to directly set the parent of an element.
Instead use any of the other methods under "Structure-Modifying
Methods", below.

Note that C<< not($h->parent) >> is a simple test for whether C<$h> is the
root of its subtree.

=head2 content_list

  @content = $h->content_list();
  $num_children = $h->content_list();

Returns a list of the child nodes of this element -- i.e., what
nodes (elements or text segments) are inside/under this element. (Note
that this may be an empty list.)

In a scalar context, this returns the count of the items,
as you may expect.

=head2 content

  $content_array_ref = $h->content(); # may return undef

This somewhat deprecated method returns the content of this element;
but unlike content_list, this returns either undef (which you should
understand to mean no content), or a I<reference to the array> of
content items, each of which is either a text segment (a string, i.e.,
a defined non-reference scalar value), or an HTML::Element object.
Note that even if an arrayref is returned, it may be a reference to an
empty array.

While older code should feel free to continue to use C<< $h->content >>,
new code should use C<< $h->content_list >> in almost all conceivable
cases.  It is my experience that in most cases this leads to simpler
code anyway, since it means one can say:

    @children = $h->content_list;

instead of the inelegant:

    @children = @{$h->content || []};

If you do use C<< $h->content >> (or C<< $h->content_array_ref >>), you should not
use the reference returned by it (assuming it returned a reference,
and not undef) to directly set or change the content of an element or
text segment!  Instead use L<content_refs_list> or any of the other
methods under "Structure-Modifying Methods", below.

=head2 content_array_ref

  $content_array_ref = $h->content_array_ref(); # never undef

This is like C<content> (with all its caveats and deprecations) except
that it is guaranteed to return an array reference.  That is, if the
given node has no C<_content> attribute, the C<content> method would
return that undef, but C<content_array_ref> would set the given node's
C<_content> value to C<[]> (a reference to a new, empty array), and
return that.

=head2 content_refs_list

  @content_refs = $h->content_refs_list;

This returns a list of scalar references to each element of C<$h>'s
content list.  This is useful in case you want to in-place edit any
large text segments without having to get a copy of the current value
of that segment value, modify that copy, then use the
C<splice_content> to replace the old with the new.  Instead, here you
can in-place edit:

    foreach my $item_r ($h->content_refs_list) {
        next if ref $$item_r;
        $$item_r =~ s/honour/honor/g;
    }

You I<could> currently achieve the same affect with:

    foreach my $item (@{ $h->content_array_ref }) {
        # deprecated!
        next if ref $item;
        $item =~ s/honour/honor/g;
    }

...except that using the return value of C<< $h->content >> or
C<< $h->content_array_ref >> to do that is deprecated, and just might stop
working in the future.

=head2 implicit

  $is_implicit = $h->implicit();
  $h->implicit($make_implicit);

Returns (optionally sets) the "_implicit" attribute.  This attribute is
a flag that's used for indicating that the element was not originally
present in the source, but was added to the parse tree (by
HTML::TreeBuilder, for example) in order to conform to the rules of
HTML structure.

=head2 pos

  $pos = $h->pos();
  $h->pos($element);

Returns (and optionally sets) the "_pos" (for "current I<pos>ition")
pointer of C<$h>.  This attribute is a pointer used during some
parsing operations, whose value is whatever HTML::Element element
at or under C<$h> is currently "open", where C<< $h->insert_element(NEW) >>
will actually insert a new element.

(This has nothing to do with the Perl function called C<pos>, for
controlling where regular expression matching starts.)

If you set C<< $h->pos($element) >>, be sure that C<$element> is
either C<$h>, or an element under C<$h>.

If you've been modifying the tree under C<$h> and are no longer
sure C<< $h->pos >> is valid, you can enforce validity with:

    $h->pos(undef) unless $h->pos->is_inside($h);

=head2 all_attr

  %attr = $h->all_attr();

Returns all this element's attributes and values, as key-value pairs.
This will include any "internal" attributes (i.e., ones not present
in the original element, and which will not be represented if/when you
call C<< $h->as_HTML >>).  Internal attributes are distinguished by the fact
that the first character of their key (not value! key!) is an
underscore ("_").

Example output of C<< $h->all_attr() >> :
C<'_parent', >I<[object_value]>C< , '_tag', 'em', 'lang', 'en-US',
'_content', >I<[array-ref value]>.

=head2 all_attr_names

  @names = $h->all_attr_names();
  $num_attrs = $h->all_attr_names();

Like C<all_attr>, but only returns the names of the attributes.
In scalar context, returns the number of attributes.

Example output of C<< $h->all_attr_names() >> :
C<'_parent', '_tag', 'lang', '_content', >.

=head2 all_external_attr

  %attr = $h->all_external_attr();

Like C<all_attr>, except that internal attributes are not present.

=head2 all_external_attr_names

  @names = $h->all_external_attr_names();
  $num_attrs = $h->all_external_attr_names();

Like C<all_attr_names>, except that internal attributes' names
are not present (or counted).

=head2 id

  $id = $h->id();
  $h->id($string);

Returns (optionally sets to C<$string>) the "id" attribute.
C<< $h->id(undef) >> deletes the "id" attribute.

C<< $h->id(...) >> is basically equivalent to C<< $h->attr('id', ...) >>,
except that when setting the attribute, this method returns the new value,
not the old value.

=head2 idf

  $id = $h->idf();
  $h->idf($string);

Just like the C<id> method, except that if you call C<< $h->idf() >> and
no "id" attribute is defined for this element, then it's set to a
likely-to-be-unique value, and returned.  (The "f" is for "force".)

=head1 STRUCTURE-MODIFYING METHODS

These methods are provided for modifying the content of trees
by adding or changing nodes as parents or children of other nodes.

=head2 push_content

  $h->push_content($element_or_text, ...);

Adds the specified items to the I<end> of the content list of the
element C<$h>.  The items of content to be added should each be either a
text segment (a string), an HTML::Element object, or an arrayref.
Arrayrefs are fed thru C<< $h->new_from_lol(that_arrayref) >> to
convert them into elements, before being added to the content
list of C<$h>.  This means you can say things concise things like:

  $body->push_content(
    ['br'],
    ['ul',
      map ['li', $_], qw(Peaches Apples Pears Mangos)
    ]
  );

See the L</new_from_lol> method's documentation, far below, for more
explanation.

Returns C<$h> (the element itself).

The push_content method will try to consolidate adjacent text segments
while adding to the content list.  That's to say, if C<$h>'s C<content_list> is

  ('foo bar ', $some_node, 'baz!')

and you call

   $h->push_content('quack?');

then the resulting content list will be this:

  ('foo bar ', $some_node, 'baz!quack?')

and not this:

  ('foo bar ', $some_node, 'baz!', 'quack?')

If that latter is what you want, you'll have to override the
feature of consolidating text by using splice_content,
as in:

  $h->splice_content(scalar($h->content_list),0,'quack?');

Similarly, if you wanted to add 'Skronk' to the beginning of
the content list, calling this:

   $h->unshift_content('Skronk');

then the resulting content list will be this:

  ('Skronkfoo bar ', $some_node, 'baz!')

and not this:

  ('Skronk', 'foo bar ', $some_node, 'baz!')

What you'd to do get the latter is:

  $h->splice_content(0,0,'Skronk');

=head2 unshift_content

  $h->unshift_content($element_or_text, ...)

Just like C<push_content>, but adds to the I<beginning> of the C<$h>
element's content list.

The items of content to be added should each be
either a text segment (a string), an HTML::Element object, or
an arrayref (which is fed thru C<new_from_lol>).

The unshift_content method will try to consolidate adjacent text segments
while adding to the content list.  See above for a discussion of this.

Returns C<$h> (the element itself).

=head2 splice_content

  @removed = $h->splice_content($offset, $length,
                                $element_or_text, ...);

Detaches the elements from C<$h>'s list of content-nodes, starting at
C<$offset> and continuing for C<$length> items, replacing them with the
elements of the following list, if any.  Returns the elements (if any)
removed from the content-list.  If C<$offset> is negative, then it starts
that far from the end of the array, just like Perl's normal C<splice>
function.  If C<$length> and the following list is omitted, removes
everything from C<$offset> onward.

The items of content to be added (if any) should each be either a text
segment (a string), an arrayref (which is fed thru L</new_from_lol>),
or an HTML::Element object that's not already
a child of C<$h>.

=head2 detach

  $old_parent = $h->detach();

This unlinks C<$h> from its parent, by setting its 'parent' attribute to
undef, and by removing it from the content list of its parent (if it
had one).  The return value is the parent that was detached from (or
undef, if C<$h> had no parent to start with).  Note that neither C<$h> nor
its parent are explicitly destroyed.

=head2 detach_content

  @old_content = $h->detach_content();

This unlinks all of C<$h>'s children from C<$h>, and returns them.
Note that these are not explicitly destroyed; for that, you
can just use C<< $h->delete_content >>.

=head2 replace_with

  $h->replace_with( $element_or_text, ... )

This replaces C<$h> in its parent's content list with the nodes
specified.  The element C<$h> (which by then may have no parent)
is returned.  This causes a fatal error if C<$h> has no parent.
The list of nodes to insert may contain C<$h>, but at most once.
Aside from that possible exception, the nodes to insert should not
already be children of C<$h>'s parent.

Also, note that this method does not destroy C<$h> if weak references are
turned off -- use C<< $h->replace_with(...)->delete >> if you need that.

=head2 preinsert

  $h->preinsert($element_or_text...);

Inserts the given nodes right BEFORE C<$h> in C<$h>'s parent's
content list.  This causes a fatal error if C<$h> has no parent.
None of the given nodes should be C<$h> or other children of C<$h>.
Returns C<$h>.

=head2 postinsert

  $h->postinsert($element_or_text...)

Inserts the given nodes right AFTER C<$h> in C<$h>'s parent's content
list.  This causes a fatal error if C<$h> has no parent.  None of
the given nodes should be C<$h> or other children of C<$h>.  Returns
C<$h>.

=head2 replace_with_content

  $h->replace_with_content();

This replaces C<$h> in its parent's content list with its own content.
The element C<$h> (which by then has no parent or content of its own) is
returned.  This causes a fatal error if C<$h> has no parent.  Also, note
that this does not destroy C<$h> if weak references are turned off -- use
C<< $h->replace_with_content->delete >> if you need that.

=head2 delete_content

  $h->delete_content();
  $h->destroy_content(); # alias

Clears the content of C<$h>, calling C<< $h->delete >> for each content
element.  Compare with C<< $h->detach_content >>.

Returns C<$h>.

C<destroy_content> is an alias for this method.

=head2 delete

  $h->delete();
  $h->destroy(); # alias

Detaches this element from its parent (if it has one) and explicitly
destroys the element and all its descendants.  The return value is
the empty list (or C<undef> in scalar context).

Before version 5.00 of HTML::Element, you had to call C<delete> when
you were finished with the tree, or your program would leak memory.
This is no longer necessary if weak references are enabled, see
L</"Weak References">.

=head2 destroy

An alias for L</delete>.

=head2 destroy_content

An alias for L</delete_content>.

=head2 clone

  $copy = $h->clone();

Returns a copy of the element (whose children are clones (recursively)
of the original's children, if any).

The returned element is parentless.  Any '_pos' attributes present in the
source element/tree will be absent in the copy.  For that and other reasons,
the clone of an HTML::TreeBuilder object that's in mid-parse (i.e, the head
of a tree that HTML::TreeBuilder is elaborating) cannot (currently) be used
to continue the parse.

You are free to clone HTML::TreeBuilder trees, just as long as:
1) they're done being parsed, or 2) you don't expect to resume parsing
into the clone.  (You can continue parsing into the original; it is
never affected.)

=head2 clone_list

  @copies = HTML::Element->clone_list(...nodes...);

Returns a list consisting of a copy of each node given.
Text segments are simply copied; elements are cloned by
calling C<< $it->clone >> on each of them.

Note that this must be called as a class method, not as an instance
method.  C<clone_list> will croak if called as an instance method.
You can also call it like so:

    ref($h)->clone_list(...nodes...)

=head2 normalize_content

  $h->normalize_content

Normalizes the content of C<$h> -- i.e., concatenates any adjacent
text nodes.  (Any undefined text segments are turned into empty-strings.)
Note that this does not recurse into C<$h>'s descendants.

=head2 delete_ignorable_whitespace

  $h->delete_ignorable_whitespace()

This traverses under C<$h> and deletes any text segments that are ignorable
whitespace.  You should not use this if C<$h> is under a C<< <pre> >> element.

=head2 insert_element

  $h->insert_element($element, $implicit);

Inserts (via push_content) a new element under the element at
C<< $h->pos() >>.  Then updates C<< $h->pos() >> to point to the inserted
element, unless $element is a prototypically empty element like
C<< <br> >>, C<< <hr> >>, C<< <img> >>, etc.
The new C<< $h->pos() >> is returned.  This
method is useful only if your particular tree task involves setting
C<< $h->pos() >>.

=head1 DUMPING METHODS

=head2 dump

  $h->dump()
  $h->dump(*FH)  ; # or *FH{IO} or $fh_obj

Prints the element and all its children to STDOUT (or to a specified
filehandle), in a format useful
only for debugging.  The structure of the document is shown by
indentation (no end tags).

=head2 as_HTML

  $s = $h->as_HTML();
  $s = $h->as_HTML($entities);
  $s = $h->as_HTML($entities, $indent_char);
  $s = $h->as_HTML($entities, $indent_char, \%optional_end_tags);

Returns a string representing in HTML the element and its
descendants.  The optional argument C<$entities> specifies a string of
the entities to encode.  For compatibility with previous versions,
specify C<'E<lt>E<gt>&'> here.  If omitted or undef, I<all> unsafe
characters are encoded as HTML entities.  See L<HTML::Entities> for
details.  If passed an empty string, no entities are encoded.

If $indent_char is specified and defined, the HTML to be output is
intented, using the string you specify (which you probably should
set to "\t", or some number of spaces, if you specify it).

If C<\%optional_end_tags> is specified and defined, it should be
a reference to a hash that holds a true value for every tag name
whose end tag is optional.  Defaults to
C<\%HTML::Element::optionalEndTag>, which is an alias to
C<%HTML::Tagset::optionalEndTag>, which, at time of writing, contains
true values for C<p, li, dt, dd>.  A useful value to pass is an empty
hashref, C<{}>, which means that no end-tags are optional for this dump.
Otherwise, possibly consider copying C<%HTML::Tagset::optionalEndTag> to a
hash of your own, adding or deleting values as you like, and passing
a reference to that hash.

=head2 as_text

  $s = $h->as_text();
  $s = $h->as_text(skip_dels => 1);

Returns a string consisting of only the text parts of the element's
descendants.  Any whitespace inside the element is included unchanged,
but whitespace not in the tree is never added.  But remember that
whitespace may be ignored or compacted by HTML::TreeBuilder during
parsing (depending on the value of the C<ignore_ignorable_whitespace>
and C<no_space_compacting> attributes).  Also, since whitespace is
never added during parsing,

  HTML::TreeBuilder->new_from_content("<p>a</p><p>b</p>")
                   ->as_text;

returns C<"ab">, not C<"a b"> or C<"a\nb">.

Text under C<< <script> >> or C<< <style> >> elements is never
included in what's returned.  If C<skip_dels> is true, then text
content under C<< <del> >> nodes is not included in what's returned.

=head2 as_trimmed_text

  $s = $h->as_trimmed_text(...);
  $s = $h->as_trimmed_text(extra_chars => '\xA0'); # remove &nbsp;
  $s = $h->as_text_trimmed(...); # alias

This is just like C<as_text(...)> except that leading and trailing
whitespace is deleted, and any internal whitespace is collapsed.

This will not remove non-breaking spaces, Unicode spaces, or any other
non-ASCII whitespace unless you supply the extra characters as
a string argument (e.g. C<< $h->as_trimmed_text(extra_chars => '\xA0') >>).
C<extra_chars> may be any string that can appear inside a character
class, including ranges like C<a-z>, POSIX character classes like
C<[:alpha:]>, and character class escapes like C<\p{Zs}>.

=head2 as_XML

  $s = $h->as_XML()

Returns a string representing in XML the element and its descendants.

The XML is not indented.

=head2 as_Lisp_form

  $s = $h->as_Lisp_form();

Returns a string representing the element and its descendants as a
Lisp form.  Unsafe characters are encoded as octal escapes.

The Lisp form is indented, and contains external ("href", etc.)  as
well as internal attributes ("_tag", "_content", "_implicit", etc.),
except for "_parent", which is omitted.

Current example output for a given element:

  ("_tag" "img" "border" "0" "src" "pie.png" "usemap" "#main.map")

=head2 format

  $s = $h->format; # use HTML::FormatText
  $s = $h->format($formatter);

Formats text output. Defaults to HTML::FormatText.

Takes a second argument that is a reference to a formatter.

=head2 starttag

  $start = $h->starttag();
  $start = $h->starttag($entities);

Returns a string representing the complete start tag for the element.
I.e., leading "<", tag name, attributes, and trailing ">".
All values are surrounded with
double-quotes, and appropriate characters are encoded.  If C<$entities>
is omitted or undef, I<all> unsafe characters are encoded as HTML
entities.  See L<HTML::Entities> for details.  If you specify some
value for C<$entities>, remember to include the double-quote character in
it.  (Previous versions of this module would basically behave as if
C<'&"E<gt>'> were specified for C<$entities>.)  If C<$entities> is
an empty string, no entity is escaped.

=head2 starttag_XML

  $start = $h->starttag_XML();

Returns a string representing the complete start tag for the element.

=head2 endtag

  $end = $h->endtag();

Returns a string representing the complete end tag for this element.
I.e., "</", tag name, and ">".

=head2 endtag_XML

  $end = $h->endtag_XML();

Returns a string representing the complete end tag for this element.
I.e., "</", tag name, and ">".

=head1 SECONDARY STRUCTURAL METHODS

These methods all involve some structural aspect of the tree;
either they report some aspect of the tree's structure, or they involve
traversal down the tree, or walking up the tree.

=head2 is_inside

  $inside = $h->is_inside('tag', $element, ...);

Returns true if the C<$h> element is, or is contained anywhere inside an
element that is any of the ones listed, or whose tag name is any of
the tag names listed.  You can use any mix of elements and tag names.

=head2 is_empty

  $empty = $h->is_empty();

Returns true if C<$h> has no content, i.e., has no elements or text
segments under it.  In other words, this returns true if C<$h> is a leaf
node, AKA a terminal node.  Do not confuse this sense of "empty" with
another sense that it can have in SGML/HTML/XML terminology, which
means that the element in question is of the type (like HTML's C<< <hr> >>,
C<< <br> >>, C<< <img> >>, etc.) that I<can't> have any content.

That is, a particular C<< <p> >> element may happen to have no content, so
$that_p_element->is_empty will be true -- even though the prototypical
C<< <p> >> element isn't "empty" (not in the way that the prototypical
C<< <hr> >> element is).

If you think this might make for potentially confusing code, consider
simply using the clearer exact equivalent:  C<< not($h->content_list) >>.

=head2 pindex

  $index = $h->pindex();

Return the index of the element in its parent's contents array, such
that C<$h> would equal

  $h->parent->content->[$h->pindex]
  # or
  ($h->parent->content_list)[$h->pindex]

assuming C<$h> isn't root.  If the element C<$h> is root, then
C<< $h->pindex >> returns C<undef>.

=head2 left

  $element = $h->left();
  @elements = $h->left();

In scalar context: returns the node that's the immediate left sibling
of C<$h>.  If C<$h> is the leftmost (or only) child of its parent (or has no
parent), then this returns undef.

In list context: returns all the nodes that're the left siblings of C<$h>
(starting with the leftmost).  If C<$h> is the leftmost (or only) child
of its parent (or has no parent), then this returns an empty list.

(See also C<< $h->preinsert(LIST) >>.)

=head2 right

  $element = $h->right();
  @elements = $h->right();

In scalar context: returns the node that's the immediate right sibling
of C<$h>.  If C<$h> is the rightmost (or only) child of its parent (or has
no parent), then this returns C<undef>.

In list context: returns all the nodes that're the right siblings of
C<$h>, starting with the leftmost.  If C<$h> is the rightmost (or only) child
of its parent (or has no parent), then this returns an empty list.

(See also C<< $h->postinsert(LIST) >>.)

=head2 address

  $address = $h->address();
  $element_or_text = $h->address($address);

The first form (with no parameter) returns a string representing the
location of C<$h> in the tree it is a member of.
The address consists of numbers joined by a '.', starting with '0',
and followed by the pindexes of the nodes in the tree that are
ancestors of C<$h>, starting from the top.

So if the way to get to a node starting at the root is to go to child
2 of the root, then child 10 of that, and then child 0 of that, and
then you're there -- then that node's address is "0.2.10.0".

As a bit of a special case, the address of the root is simply "0".

I forsee this being used mainly for debugging, but you may
find your own uses for it.

  $element_or_text = $h->address($address);

This form returns the node (whether element or text-segment) at
the given address in the tree that C<$h> is a part of.  (That is,
the address is resolved starting from C<< $h->root >>.)

If there is no node at the given address, this returns C<undef>.

You can specify "relative addressing" (i.e., that indexing is supposed
to start from C<$h> and not from C<< $h->root >>) by having the address start
with a period -- e.g., C<< $h->address(".3.2") >> will look at child 3 of C<$h>,
and child 2 of that.

=head2 depth

  $depth = $h->depth();

Returns a number expressing C<$h>'s depth within its tree, i.e., how many
steps away it is from the root.  If C<$h> has no parent (i.e., is root),
its depth is 0.

=head2 root

  $root = $h->root();

Returns the element that's the top of C<$h>'s tree.  If C<$h> is
root, this just returns C<$h>.  (If you want to test whether C<$h>
I<is> the root, instead of asking what its root is, just test
C<< not($h->parent) >>.)

=head2 lineage

  @lineage = $h->lineage();

Returns the list of C<$h>'s ancestors, starting with its parent,
and then that parent's parent, and so on, up to the root.  If C<$h>
is root, this returns an empty list.

If you simply want a count of the number of elements in C<$h>'s lineage,
use C<< $h->depth >>.

=head2 lineage_tag_names

  @names = $h->lineage_tag_names();

Returns the list of the tag names of C<$h>'s ancestors, starting
with its parent, and that parent's parent, and so on, up to the
root.  If C<$h> is root, this returns an empty list.
Example output: C<('em', 'td', 'tr', 'table', 'body', 'html')>

Equivalent to:

  map { $_->tag } $h->lineage;

=head2 descendants

  @descendants = $h->descendants();

In list context, returns the list of all C<$h>'s descendant elements,
listed in pre-order (i.e., an element appears before its
content-elements).  Text segments DO NOT appear in the list.
In scalar context, returns a count of all such elements.

=head2 descendents

This is just an alias to the C<descendants> method, for people who
can't spell.

=head2 find_by_tag_name

  @elements = $h->find_by_tag_name('tag', ...);
  $first_match = $h->find_by_tag_name('tag', ...);

In list context, returns a list of elements at or under C<$h> that have
any of the specified tag names.  In scalar context, returns the first
(in pre-order traversal of the tree) such element found, or undef if
none.

=head2 find

This is just an alias to C<find_by_tag_name>.  (There was once
going to be a whole find_* family of methods, but then C<look_down>
filled that niche, so there turned out not to be much reason for the
verboseness of the name "find_by_tag_name".)

=head2 find_by_attribute

  @elements = $h->find_by_attribute('attribute', 'value');
  $first_match = $h->find_by_attribute('attribute', 'value');

In a list context, returns a list of elements at or under C<$h> that have
the specified attribute, and have the given value for that attribute.
In a scalar context, returns the first (in pre-order traversal of the
tree) such element found, or undef if none.

This method is B<deprecated> in favor of the more expressive
C<look_down> method, which new code should use instead.

=head2 look_down

  @elements = $h->look_down( ...criteria... );
  $first_match = $h->look_down( ...criteria... );

This starts at C<$h> and looks thru its element descendants (in
pre-order), looking for elements matching the criteria you specify.
In list context, returns all elements that match all the given
criteria; in scalar context, returns the first such element (or undef,
if nothing matched).

There are three kinds of criteria you can specify:

=over

=item (attr_name, attr_value)

This means you're looking for an element with that value for that
attribute.  Example: C<"alt", "pix!">.  Consider that you can search
on internal attribute values too: C<"_tag", "p">.

=item (attr_name, qr/.../)

This means you're looking for an element whose value for that
attribute matches the specified Regexp object.

=item a coderef

This means you're looking for elements where coderef->(each_element)
returns true.  Example:

  my @wide_pix_images = $h->look_down(
    _tag => "img",
    alt  => "pix!",
    sub { $_[0]->attr('width') > 350 }
  );

=back

Note that C<(attr_name, attr_value)> and C<(attr_name, qr/.../)>
criteria are almost always faster than coderef
criteria, so should presumably be put before them in your list of
criteria.  That is, in the example above, the sub ref is called only
for elements that have already passed the criteria of having a "_tag"
attribute with value "img", and an "alt" attribute with value "pix!".
If the coderef were first, it would be called on every element, and
I<then> what elements pass that criterion (i.e., elements for which
the coderef returned true) would be checked for their "_tag" and "alt"
attributes.

Note that comparison of string attribute-values against the string
value in C<(attr_name, attr_value)> is case-INsensitive!  A criterion
of C<('align', 'right')> I<will> match an element whose "align" value
is "RIGHT", or "right" or "rIGhT", etc.

Note also that C<look_down> considers "" (empty-string) and undef to
be different things, in attribute values.  So this:

  $h->look_down("alt", "")

will find elements I<with> an "alt" attribute, but where the value for
the "alt" attribute is "".  But this:

  $h->look_down("alt", undef)

is the same as:

  $h->look_down(sub { !defined($_[0]->attr('alt')) } )

That is, it finds elements that do not have an "alt" attribute at all
(or that do have an "alt" attribute, but with a value of undef --
which is not normally possible).

Note that when you give several criteria, this is taken to mean you're
looking for elements that match I<all> your criterion, not just I<any>
of them.  In other words, there is an implicit "and", not an "or".  So
if you wanted to express that you wanted to find elements with a
"name" attribute with the value "foo" I<or> with an "id" attribute
with the value "baz", you'd have to do it like:

  @them = $h->look_down(
    sub {
      # the lcs are to fold case
      lc($_[0]->attr('name')) eq 'foo'
      or lc($_[0]->attr('id')) eq 'baz'
    }
  );

Coderef criteria are more expressive than C<(attr_name, attr_value)>
and C<(attr_name, qr/.../)>
criteria, and all C<(attr_name, attr_value)>
and C<(attr_name, qr/.../)>
criteria could be
expressed in terms of coderefs.  However, C<(attr_name, attr_value)>
and C<(attr_name, qr/.../)>
criteria are a convenient shorthand.  (In fact, C<look_down> itself is
basically "shorthand" too, since anything you can do with C<look_down>
you could do by traversing the tree, either with the C<traverse>
method or with a routine of your own.  However, C<look_down> often
makes for very concise and clear code.)

=head2 look_up

  @elements = $h->look_up( ...criteria... );
  $first_match = $h->look_up( ...criteria... );

This is identical to C<< $h->look_down >>, except that whereas
C<< $h->look_down >>
basically scans over the list:

   ($h, $h->descendants)

C<< $h->look_up >> instead scans over the list

   ($h, $h->lineage)

So, for example, this returns all ancestors of C<$h> (possibly including
C<$h> itself) that are C<< <td> >> elements with an "align" attribute with a
value of "right" (or "RIGHT", etc.):

   $h->look_up("_tag", "td", "align", "right");

=head2 traverse

  $h->traverse(...options...)

Lengthy discussion of HTML::Element's unnecessary and confusing
C<traverse> method has been moved to a separate file:
L<HTML::Element::traverse>

=head2 attr_get_i

  @values = $h->attr_get_i('attribute');
  $first_value = $h->attr_get_i('attribute');

In list context, returns a list consisting of the values of the given
attribute for C<$h> and for all its ancestors starting from C<$h> and
working its way up.  Nodes with no such attribute are skipped.
("attr_get_i" stands for "attribute get, with inheritance".)
In scalar context, returns the first such value, or undef if none.

Consider a document consisting of:

   <html lang='i-klingon'>
     <head><title>Pati Pata</title></head>
     <body>
       <h1 lang='la'>Stuff</h1>
       <p lang='es-MX' align='center'>
         Foo bar baz <cite>Quux</cite>.
       </p>
       <p>Hooboy.</p>
     </body>
   </html>

If C<$h> is the C<< <cite> >> element, C<< $h->attr_get_i("lang") >>
in list context will return the list C<('es-MX', 'i-klingon')>.
In scalar context, it will return the value C<'es-MX'>.

If you call with multiple attribute names...

  @values = $h->attr_get_i('a1', 'a2', 'a3');
  $first_value = $h->attr_get_i('a1', 'a2', 'a3');

...in list context, this will return a list consisting of
the values of these attributes which exist in C<$h> and its ancestors.
In scalar context, this returns the first value (i.e., the value of
the first existing attribute from the first element that has
any of the attributes listed).  So, in the above example,

  $h->attr_get_i('lang', 'align');

will return:

   ('es-MX', 'center', 'i-klingon') # in list context
  or
   'es-MX' # in scalar context.

But note that this:

 $h->attr_get_i('align', 'lang');

will return:

   ('center', 'es-MX', 'i-klingon') # in list context
  or
   'center' # in scalar context.

=head2 tagname_map

  $hash_ref = $h->tagname_map();

Scans across C<$h> and all its descendants, and makes a hash (a
reference to which is returned) where each entry consists of a key
that's a tag name, and a value that's a reference to a list to all
elements that have that tag name.  I.e., this method returns:

   {
     # Across $h and all descendants...
     'a'   => [ ...list of all <a>   elements... ],
     'em'  => [ ...list of all <em>  elements... ],
     'img' => [ ...list of all <img> elements... ],
   }

(There are entries in the hash for only those tagnames that occur
at/under C<$h> -- so if there's no C<< <img> >> elements, there'll be no
"img" entry in the returned hashref.)

Example usage:

    my $map_r = $h->tagname_map();
    my @heading_tags = sort grep m/^h\d$/s, keys %$map_r;
    if(@heading_tags) {
      print "Heading levels used: @heading_tags\n";
    } else {
      print "No headings.\n"
    }

=head2 extract_links

  $links_array_ref = $h->extract_links();
  $links_array_ref = $h->extract_links(@wantedTypes);

Returns links found by traversing the element and all of its children
and looking for attributes (like "href" in an C<< <a> >> element, or "src" in
an C<< <img> >> element) whose values represent links.  The return value is a
I<reference> to an array.  Each element of the array is reference to
an array with I<four> items: the link-value, the element that has the
attribute with that link-value, and the name of that attribute, and
the tagname of that element.
(Example: C<['http://www.suck.com/',> I<$elem_obj> C<, 'href', 'a']>.)
You may or may not end up using the
element itself -- for some purposes, you may use only the link value.

You might specify that you want to extract links from just some kinds
of elements (instead of the default, which is to extract links from
I<all> the kinds of elements known to have attributes whose values
represent links).  For instance, if you want to extract links from
only C<< <a> >> and C<< <img> >> elements, you could code it like this:

  for (@{  $e->extract_links('a', 'img')  }) {
      my($link, $element, $attr, $tag) = @$_;
      print
        "Hey, there's a $tag that links to ",
        $link, ", in its $attr attribute, at ",
        $element->address(), ".\n";
  }

=head2 simplify_pres

  $h->simplify_pres();

In text bits under PRE elements that are at/under C<$h>, this routine
nativizes all newlines, and expands all tabs.

That is, if you read a file with lines delimited by C<\cm\cj>'s, the
text under PRE areas will have C<\cm\cj>'s instead of C<\n>'s. Calling
C<< $h->simplify_pres >> on such a tree will turn C<\cm\cj>'s into
C<\n>'s.

Tabs are expanded to however many spaces it takes to get
to the next 8th column -- the usual way of expanding them.

=head2 same_as

  $equal = $h->same_as($i)

Returns true if C<$h> and C<$i> are both elements representing the same tree
of elements, each with the same tag name, with the same explicit
attributes (i.e., not counting attributes whose names start with "_"),
and with the same content (textual, comments, etc.).

Sameness of descendant elements is tested, recursively, with
C<< $child1->same_as($child_2) >>, and sameness of text segments is tested
with C<$segment1 eq $segment2>.

=head2 new_from_lol

  $h = HTML::Element->new_from_lol($array_ref);
  @elements = HTML::Element->new_from_lol($array_ref, ...);

Resursively constructs a tree of nodes, based on the (non-cyclic)
data structure represented by each C<$array_ref>, where that is a reference
to an array of arrays (of arrays (of arrays (etc.))).

In each arrayref in that structure, different kinds of values are
treated as follows:

=over

=item * Arrayrefs

Arrayrefs are considered to
designate a sub-tree representing children for the node constructed
from the current arrayref.

=item * Hashrefs

Hashrefs are considered to contain
attribute-value pairs to add to the element to be constructed from
the current arrayref

=item * Text segments

Text segments at the start of any arrayref
will be considered to specify the name of the element to be
constructed from the current arrayref; all other text segments will
be considered to specify text segments as children for the current
arrayref.

=item * Elements

Existing element objects are either inserted into the treelet
constructed, or clones of them are.  That is, when the lol-tree is
being traversed and elements constructed based what's in it, if
an existing element object is found, if it has no parent, then it is
added directly to the treelet constructed; but if it has a parent,
then C<$that_node-E<gt>clone> is added to the treelet at the
appropriate place.

=back

An example will hopefully make this more obvious:

  my $h = HTML::Element->new_from_lol(
    ['html',
      ['head',
        [ 'title', 'I like stuff!' ],
      ],
      ['body',
        {'lang', 'en-JP', _implicit => 1},
        'stuff',
        ['p', 'um, p < 4!', {'class' => 'par123'}],
        ['div', {foo => 'bar'}, '123'],
      ]
    ]
  );
  $h->dump;

Will print this:

  <html> @0
    <head> @0.0
      <title> @0.0.0
        "I like stuff!"
    <body lang="en-JP"> @0.1 (IMPLICIT)
      "stuff"
      <p class="par123"> @0.1.1
        "um, p < 4!"
      <div foo="bar"> @0.1.2
        "123"

And printing $h->as_HTML will give something like:

  <html><head><title>I like stuff!</title></head>
  <body lang="en-JP">stuff<p class="par123">um, p &lt; 4!
  <div foo="bar">123</div></body></html>

You can even do fancy things with C<map>:

  $body->push_content(
    # push_content implicitly calls new_from_lol on arrayrefs...
    ['br'],
    ['blockquote',
      ['h2', 'Pictures!'],
      map ['p', $_],
      $body2->look_down("_tag", "img"),
        # images, to be copied from that other tree.
    ],
    # and more stuff:
    ['ul',
      map ['li', ['a', {'href'=>"$_.png"}, $_ ] ],
      qw(Peaches Apples Pears Mangos)
    ],
  );

In scalar context, you must supply exactly one arrayref.  In list
context, you can pass a list of arrayrefs, and L<new_from_lol> will
return a list of elements, one for each arrayref.

  @elements = HTML::Element->new_from_lol(
    ['hr'],
    ['p', 'And there, on the door, was a hook!'],
  );
   # constructs two elements.

=head2 objectify_text

  $h->objectify_text();

This turns any text nodes under C<$h> from mere text segments (strings)
into real objects, pseudo-elements with a tag-name of "~text", and the
actual text content in an attribute called "text".  (For a discussion
of pseudo-elements, see the L</"tag"> method, far above.)  This method is
provided because, for some purposes, it is convenient or necessary to
be able, for a given text node, to ask what element is its parent; and
clearly this is not possible if a node is just a text string.

Note that these "~text" objects are not recognized as text nodes by
methods like L</as_text>.  Presumably you will want to call
C<< $h->objectify_text >>, perform whatever task that you needed that for,
and then call C<< $h->deobjectify_text >> before calling anything like
C<< $h->as_text >>.

=head2 deobjectify_text

  $h->deobjectify_text();

This undoes the effect of C<< $h->objectify_text >>.  That is, it takes any
"~text" pseudo-elements in the tree at/under C<$h>, and deletes each one,
replacing each with the content of its "text" attribute.

Note that if C<$h> itself is a "~text" pseudo-element, it will be
destroyed -- a condition you may need to treat specially in your
calling code (since it means you can't very well do anything with C<$h>
after that).  So that you can detect that condition, if C<$h> is itself a
"~text" pseudo-element, then this method returns the value of the
"text" attribute, which should be a defined value; in all other cases,
it returns undef.

(This method assumes that no "~text" pseudo-element has any children.)

=head2 number_lists

  $h->number_lists();

For every UL, OL, DIR, and MENU element at/under C<$h>, this sets a
"_bullet" attribute for every child LI element.  For LI children of an
OL, the "_bullet" attribute's value will be something like "4.", "d.",
"D.", "IV.", or "iv.", depending on the OL element's "type" attribute.
LI children of a UL, DIR, or MENU get their "_bullet" attribute set
to "*".
There should be no other LIs (i.e., except as children of OL, UL, DIR,
or MENU elements), and if there are, they are unaffected.

=head2 has_insane_linkage

  $h->has_insane_linkage

This method is for testing whether this element or the elements
under it have linkage attributes (_parent and _content) whose values
are deeply aberrant: if there are undefs in a content list; if an
element appears in the content lists of more than one element;
if the _parent attribute of an element doesn't match its actual
parent; or if an element appears as its own descendant (i.e.,
if there is a cyclicity in the tree).

This returns empty list (or false, in scalar context) if the subtree's
linkage methods are sane; otherwise it returns two items (or true, in
scalar context): the element where the error occurred, and a string
describing the error.

This method is provided is mainly for debugging and troubleshooting --
it should be I<quite impossible> for any document constructed via
HTML::TreeBuilder to parse into a non-sane tree (since it's not
the content of the tree per se that's in question, but whether
the tree in memory was properly constructed); and it I<should> be
impossible for you to produce an insane tree just thru reasonable
use of normal documented structure-modifying methods.  But if you're
constructing your own trees, and your program is going into infinite
loops as during calls to traverse() or any of the secondary
structural methods, as part of debugging, consider calling
C<has_insane_linkage> on the tree.

=head2 element_class

  $classname = $h->element_class();

This method returns the class which will be used for new elements.  It
defaults to HTML::Element, but can be overridden by subclassing or esoteric
means best left to those will will read the source and then not complain when
those esoteric means change.  (Just subclass.)

=head1 CLASS METHODS

=head2 Use_Weak_Refs

  $enabled = HTML::Element->Use_Weak_Refs;
  HTML::Element->Use_Weak_Refs( $enabled );

This method allows you to check whether weak reference support is
enabled, and to enable or disable it. For details, see L</"Weak References">.
C<$enabled> is true if weak references are enabled.

You should not switch this in the middle of your program, and you
probably shouldn't use it at all.  Existing trees are not affected by
this method (until you start modifying nodes in them).

Throws an exception if you attempt to enable weak references and your
Perl or Scalar::Util does not support them.

Disabling weak reference support is deprecated.

=head1 SUBROUTINES

=head2 Version

This subroutine is deprecated.  Please use the standard VERSION method
(e.g. C<< HTML::Element->VERSION >>) instead.

=head2 ABORT OK PRUNE PRUNE_SOFTLY PRUNE_UP

Constants for signalling back to the traverser

=for Pod::Coverage as_text_trimmed

=head1 BUGS

* If you want to free the memory associated with a tree built of
HTML::Element nodes, and you have disabled weak references, then you
will have to delete it explicitly using the L</delete> method.
See L</"Weak References">.

* There's almost nothing to stop you from making a "tree" with
cyclicities (loops) in it, which could, for example, make the
traverse method go into an infinite loop.  So don't make
cyclicities!  (If all you're doing is parsing HTML files,
and looking at the resulting trees, this will never be a problem
for you.)

* There's no way to represent comments or processing directives
in a tree with HTML::Elements.  Not yet, at least.

* There's (currently) nothing to stop you from using an undefined
value as a text segment.  If you're running under C<perl -w>, however,
this may make HTML::Element's code produce a slew of warnings.

=head1 NOTES ON SUBCLASSING

You are welcome to derive subclasses from HTML::Element, but you
should be aware that the code in HTML::Element makes certain
assumptions about elements (and I'm using "element" to mean ONLY an
object of class HTML::Element, or of a subclass of HTML::Element):

* The value of an element's _parent attribute must either be undef or
otherwise false, or must be an element.

* The value of an element's _content attribute must either be undef or
otherwise false, or a reference to an (unblessed) array.  The array
may be empty; but if it has items, they must ALL be either mere
strings (text segments), or elements.

* The value of an element's _tag attribute should, at least, be a
string of printable characters.

Moreover, bear these rules in mind:

* Do not break encapsulation on objects.  That is, access their
contents only thru $obj->attr or more specific methods.

* You should think twice before completely overriding any of the
methods that HTML::Element provides.  (Overriding with a method that
calls the superclass method is not so bad, though.)

=head1 SEE ALSO

L<HTML::Tree>; L<HTML::TreeBuilder>; L<HTML::AsSubs>; L<HTML::Tagset>;
and, for the morbidly curious, L<HTML::Element::traverse>.

=head1 ACKNOWLEDGEMENTS

Thanks to Mark-Jason Dominus for a POD suggestion.

=head1 AUTHOR

Current maintainers:

=over

=item * Christopher J. Madsen S<C<< <perl AT cjmweb.net> >>>

=item * Jeff Fearn S<C<< <jfearn AT cpan.org> >>>

=back

Original HTML-Tree author:

=over

=item * Gisle Aas

=back

Former maintainers:

=over

=item * Sean M. Burke

=item * Andy Lester

=item * Pete Krawczyk S<C<< <petek AT cpan.org> >>>

=back

You can follow or contribute to HTML-Tree's development at
L<< https://github.com/kentfredric/HTML-Tree >>.

=head1 COPYRIGHT AND LICENSE

Copyright 1995-1998 Gisle Aas, 1999-2004 Sean M. Burke,
2005 Andy Lester, 2006 Pete Krawczyk, 2010 Jeff Fearn,
2012 Christopher J. Madsen.

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

The programs in this library are distributed in the hope that they
will be useful, but without any warranty; without even the implied
warranty of merchantability or fitness for a particular purpose.

=cut
PK       ! >:_�_�  _�    perl5/HTML/Form.pmnu ��6�$        package HTML::Form;

use strict;
use URI;
use Carp ();
use Encode ();

use vars qw($VERSION);
our $VERSION = '6.07';

my %form_tags = map {$_ => 1} qw(input textarea button select option);

my %type2class = (
 text     => "TextInput",
 password => "TextInput",
 hidden   => "TextInput",
 textarea => "TextInput",

 "reset"  => "IgnoreInput",

 radio    => "ListInput",
 checkbox => "ListInput",
 option   => "ListInput",

 button   => "SubmitInput",
 submit   => "SubmitInput",
 image    => "ImageInput",
 file     => "FileInput",

 keygen   => "KeygenInput",
);

# The new HTML5 input types
%type2class = (%type2class, map { $_ => 'TextInput' } qw(
    tel search url email
    datetime date month week time datetime-local
    number range color
));

# ABSTRACT: Class that represents an HTML form element


sub parse
{
    my $class = shift;
    my $html = shift;
    unshift(@_, "base") if @_ == 1;
    my %opt = @_;

    require HTML::TokeParser;
    my $p = HTML::TokeParser->new(ref($html) ? $html->decoded_content(ref => 1) : \$html);
    die "Failed to create HTML::TokeParser object" unless $p;

    my $base_uri = delete $opt{base};
    my $charset = delete $opt{charset};
    my $strict = delete $opt{strict};
    my $verbose = delete $opt{verbose};

    if ($^W) {
	Carp::carp("Unrecognized option $_ in HTML::Form->parse") for sort keys %opt;
    }

    unless (defined $base_uri) {
	if (ref($html)) {
	    $base_uri = $html->base;
	}
	else {
	    Carp::croak("HTML::Form::parse: No \$base_uri provided");
	}
    }
    unless (defined $charset) {
	if (ref($html) and $html->can("content_charset")) {
	    $charset = $html->content_charset;
	}
	unless ($charset) {
	    $charset = "UTF-8";
	}
    }

    my @forms;
    my $f;  # current form

    my %openselect; # index to the open instance of a select

    while (my $t = $p->get_tag) {
	my($tag,$attr) = @$t;
	if ($tag eq "form") {
	    my $action = delete $attr->{'action'};
	    $action = "" unless defined $action;
	    $action = URI->new_abs($action, $base_uri);
	    $f = $class->new($attr->{'method'},
			     $action,
			     $attr->{'enctype'});
            $f->accept_charset($attr->{'accept-charset'}) if $attr->{'accept-charset'};
	    $f->{default_charset} = $charset;
	    $f->{attr} = $attr;
	    $f->strict(1) if $strict;
            %openselect = ();
	    push(@forms, $f);
	    my(%labels, $current_label);
	    while (my $t = $p->get_tag) {
		my($tag, $attr) = @$t;
		last if $tag eq "/form";

		if ($tag ne 'textarea') {
		    # if we are inside a label tag, then keep
		    # appending any text to the current label
		    if(defined $current_label) {
		        $current_label = join " ",
		            grep { defined and length }
		            $current_label,
		            $p->get_phrase;
		    }
		}

		if ($tag eq "input") {
		    $attr->{value_name} =
		        exists $attr->{id} && exists $labels{$attr->{id}} ? $labels{$attr->{id}} :
			defined $current_label                            ?  $current_label      :
		        $p->get_phrase;
		}

		if ($tag eq "label") {
		    $current_label = $p->get_phrase;
		    $labels{ $attr->{for} } = $current_label
		        if exists $attr->{for};
		}
		elsif ($tag eq "/label") {
		    $current_label = undef;
		}
		elsif ($tag eq "input") {
		    my $type = delete $attr->{type} || "text";
		    $f->push_input($type, $attr, $verbose);
		}
                elsif ($tag eq "button") {
                    my $type = delete $attr->{type} || "submit";
                    $f->push_input($type, $attr, $verbose);
                }
		elsif ($tag eq "textarea") {
		    $attr->{textarea_value} = $attr->{value}
		        if exists $attr->{value};
		    my $text = $p->get_text("/textarea");
		    $attr->{value} = $text;
		    $f->push_input("textarea", $attr, $verbose);
		}
		elsif ($tag eq "select") {
		    # rename attributes reserved to come for the option tag
		    for ("value", "value_name") {
			$attr->{"select_$_"} = delete $attr->{$_}
			    if exists $attr->{$_};
		    }
		    # count this new select option separately
		    my $name = $attr->{name};
		    $name = "" unless defined $name;
		    $openselect{$name}++;

		    while ($t = $p->get_tag) {
			my $tag = shift @$t;
			last if $tag eq "/select";
			next if $tag =~ m,/?optgroup,;
			next if $tag eq "/option";
			if ($tag eq "option") {
			    my %a = %{$t->[0]};
			    # rename keys so they don't clash with %attr
			    for (keys %a) {
				next if $_ eq "value";
				$a{"option_$_"} = delete $a{$_};
			    }
			    while (my($k,$v) = each %$attr) {
				$a{$k} = $v;
			    }
			    $a{value_name} = $p->get_trimmed_text;
			    $a{value} = delete $a{value_name}
				unless defined $a{value};
			    $a{idx} = $openselect{$name};
			    $f->push_input("option", \%a, $verbose);
			}
			else {
			    warn("Bad <select> tag '$tag' in $base_uri\n") if $verbose;
			    if ($tag eq "/form" ||
				$tag eq "input" ||
				$tag eq "textarea" ||
				$tag eq "select" ||
				$tag eq "keygen")
			    {
				# MSIE implicitly terminates the <select> here, so we
				# try to do the same.  Actually the MSIE behaviour
				# appears really strange:  <input> and <textarea>
				# do implicitly close, but not <select>, <keygen> or
				# </form>.
				my $type = ($tag =~ s,^/,,) ? "E" : "S";
				$p->unget_token([$type, $tag, @$t]);
				last;
			    }
			}
		    }
		}
		elsif ($tag eq "keygen") {
		    $f->push_input("keygen", $attr, $verbose);
		}
	    }
	}
	elsif ($form_tags{$tag}) {
	    warn("<$tag> outside <form> in $base_uri\n") if $verbose;
	}
    }
    for (@forms) {
	$_->fixup;
    }

    wantarray ? @forms : $forms[0];
}

sub new {
    my $class = shift;
    my $self = bless {}, $class;
    $self->{method} = uc(shift  || "GET");
    $self->{action} = shift  || Carp::croak("No action defined");
    $self->{enctype} = lc(shift || "application/x-www-form-urlencoded");
    $self->{accept_charset} = "UNKNOWN";
    $self->{default_charset} = "UTF-8";
    $self->{inputs} = [@_];
    $self;
}


sub push_input
{
    my($self, $type, $attr, $verbose) = @_;
    $type = lc $type;
    my $class = $type2class{$type};
    unless ($class) {
	Carp::carp("Unknown input type '$type'") if $verbose;
	$class = "TextInput";
    }
    $class = "HTML::Form::$class";
    my @extra;
    push(@extra, readonly => 1) if $type eq "hidden";
    push(@extra, strict => 1) if $self->{strict};
    if ($type eq "file" && exists $attr->{value}) {
	# it's not safe to trust the value set by the server
	# the user always needs to explicitly set the names of files to upload
	$attr->{orig_value} = delete $attr->{value};
    }
    delete $attr->{type}; # don't confuse the type argument
    my $input = $class->new(type => $type, %$attr, @extra);
    $input->add_to_form($self);
}


BEGIN {
    # Set up some accessors
    for (qw(method action enctype accept_charset)) {
	my $m = $_;
	no strict 'refs';
	*{$m} = sub {
	    my $self = shift;
	    my $old = $self->{$m};
	    $self->{$m} = shift if @_;
	    $old;
	};
    }
    *uri = \&action;  # alias
}


sub attr {
    my $self = shift;
    my $name = shift;
    return undef unless defined $name;

    my $old = $self->{attr}{$name};
    $self->{attr}{$name} = shift if @_;
    return $old;
}


sub strict {
    my $self = shift;
    my $old = $self->{strict};
    if (@_) {
	$self->{strict} = shift;
	for my $input (@{$self->{inputs}}) {
	    $input->strict($self->{strict});
	}
    }
    return $old;
}


sub inputs
{
    my $self = shift;
    @{$self->{'inputs'}};
}


sub find_input
{
    my($self, $name, $type, $no) = @_;
    die "Invalid index $no"
        if defined $no && $no < 1;
    if (wantarray) {
        warn "find_input called in list context with index specified\n"
            if defined $no;
	my @res;
	my $c;
	for (@{$self->{'inputs'}}) {
	    next if defined($name) && !$_->selected($name);
	    next if $type && $type ne $_->{type};
	    $c++;
	    next if $no && $no != $c;
	    push(@res, $_);
	}
	return @res;

    }
    else {
	$no ||= 1;
	for (@{$self->{'inputs'}}) {
	    next if defined($name) && !$_->selected($name);
	    next if $type && $type ne $_->{type};
	    next if --$no;
	    return $_;
	}
	return undef;
    }
}

sub fixup
{
    my $self = shift;
    for (@{$self->{'inputs'}}) {
	$_->fixup;
    }
}


sub value
{
    my $self = shift;
    my $key  = shift;
    my $input = $self->find_input($key);
    unless ($input) {
	Carp::croak("No such field '$key'") if $self->{strict};
	return undef unless @_;
	$input = $self->push_input("text", { name => $key, value => "" });
    }
    local $Carp::CarpLevel = 1;
    $input->value(@_);
}


sub param {
    my $self = shift;
    if (@_) {
        my $name = shift;
        my @inputs;
        for ($self->inputs) {
            my $n = $_->name;
            next if !defined($n) || $n ne $name;
            push(@inputs, $_);
        }

        if (@_) {
            # set
            die "No '$name' parameter exists" unless @inputs;
	    my @v = @_;
	    @v = @{$v[0]} if @v == 1 && ref($v[0]);
            while (@v) {
                my $v = shift @v;
                my $err;
                for my $i (0 .. @inputs-1) {
                    eval {
                        $inputs[$i]->value($v);
                    };
                    unless ($@) {
                        undef($err);
                        splice(@inputs, $i, 1);
                        last;
                    }
                    $err ||= $@;
                }
                die $err if $err;
            }

	    # the rest of the input should be cleared
	    for (@inputs) {
		$_->value(undef);
	    }
        }
        else {
            # get
            my @v;
            for (@inputs) {
		if (defined(my $v = $_->value)) {
		    push(@v, $v);
		}
            }
            return wantarray ? @v : $v[0];
        }
    }
    else {
        # list parameter names
        my @n;
        my %seen;
        for ($self->inputs) {
            my $n = $_->name;
            next if !defined($n) || $seen{$n}++;
            push(@n, $n);
        }
        return @n;
    }
}


sub try_others
{
    my($self, $cb) = @_;
    my @try;
    for (@{$self->{'inputs'}}) {
	my @not_tried_yet = $_->other_possible_values;
	next unless @not_tried_yet;
	push(@try, [\@not_tried_yet, $_]);
    }
    return unless @try;
    $self->_try($cb, \@try, 0);
}

sub _try
{
    my($self, $cb, $try, $i) = @_;
    for (@{$try->[$i][0]}) {
	$try->[$i][1]->value($_);
	&$cb($self);
	$self->_try($cb, $try, $i+1) if $i+1 < @$try;
    }
}


sub make_request
{
    my $self = shift;
    my $method  = uc $self->{'method'};
    my $uri     = $self->{'action'};
    my $enctype = $self->{'enctype'};
    my @form    = $self->form;

    my $charset = $self->accept_charset eq "UNKNOWN" ? $self->{default_charset} : $self->accept_charset;
    foreach my $fi (@form) {
	$fi = Encode::encode($charset, $fi) unless ref($fi);
    }

    if ($method eq "GET") {
	require HTTP::Request;
	$uri = URI->new($uri, "http");
	$uri->query_form(@form);
	return HTTP::Request->new(GET => $uri);
    }
    elsif ($method eq "POST") {
	require HTTP::Request::Common;
	return HTTP::Request::Common::POST($uri, \@form,
					   Content_Type => $enctype);
    }
    else {
	Carp::croak("Unknown method '$method'");
    }
}


sub click
{
    my $self = shift;
    my $name;
    $name = shift if (@_ % 2) == 1;  # odd number of arguments

    # try to find first submit button to activate
    for (@{$self->{'inputs'}}) {
        next unless $_->can("click");
        next if $name && !$_->selected($name);
	next if $_->disabled;
	return $_->click($self, @_);
    }
    Carp::croak("No clickable input with name $name") if $name;
    $self->make_request;
}


sub form
{
    my $self = shift;
    map { $_->form_name_value($self) } @{$self->{'inputs'}};
}


sub dump
{
    my $self = shift;
    my $method  = $self->{'method'};
    my $uri     = $self->{'action'};
    my $enctype = $self->{'enctype'};
    my $dump = "$method $uri";
    $dump .= " ($enctype)"
	if $enctype ne "application/x-www-form-urlencoded";
    $dump .= " [$self->{attr}{name}]"
    	if exists $self->{attr}{name};
    $dump .= "\n";
    for ($self->inputs) {
	$dump .= "  " . $_->dump . "\n";
    }
    print STDERR $dump unless defined wantarray;
    $dump;
}


#---------------------------------------------------
package HTML::Form::Input;


sub new
{
    my $class = shift;
    my $self = bless {@_}, $class;
    $self;
}

sub add_to_form
{
    my($self, $form) = @_;
    push(@{$form->{'inputs'}}, $self);
    $self;
}

sub strict {
    my $self = shift;
    my $old = $self->{strict};
    if (@_) {
	$self->{strict} = shift;
    }
    $old;
}

sub fixup {}


sub type
{
    shift->{type};
}


sub name
{
    my $self = shift;
    my $old = $self->{name};
    $self->{name} = shift if @_;
    $old;
}

sub id
{
    my $self = shift;
    my $old = $self->{id};
    $self->{id} = shift if @_;
    $old;
}

sub class
{
    my $self = shift;
    my $old = $self->{class};
    $self->{class} = shift if @_;
    $old;
}

sub selected {
    my($self, $sel) = @_;
    return undef unless defined $sel;
    my $attr =
        $sel =~ s/^\^// ? "name"  :
        $sel =~ s/^#//  ? "id"    :
        $sel =~ s/^\.// ? "class" :
	                  "name";
    return 0 unless defined $self->{$attr};
    return $self->{$attr} eq $sel;
}

sub value
{
    my $self = shift;
    my $old = $self->{value};
    $self->{value} = shift if @_;
    $old;
}

sub autocomplete
{
    my $self = shift;
    my $old = $self->{autocomplete};
    $self->{autocomplete} = shift if @_;
    $old;
}


sub possible_values
{
    return;
}


sub other_possible_values
{
    return;
}


sub value_names {
    return
}


sub readonly {
    my $self = shift;
    my $old = $self->{readonly};
    $self->{readonly} = shift if @_;
    $old;
}


sub disabled {
    my $self = shift;
    my $old = $self->{disabled};
    $self->{disabled} = shift if @_;
    $old;
}


sub form_name_value
{
    my $self = shift;
    my $name = $self->{'name'};
    return unless defined $name;
    return if $self->disabled;
    my $value = $self->value;
    return unless defined $value;
    return ($name => $value);
}

sub dump
{
    my $self = shift;
    my $name = $self->name;
    $name = "<NONAME>" unless defined $name;
    my $value = $self->value;
    $value = "<UNDEF>" unless defined $value;
    my $dump = "$name=$value";

    my $type = $self->type;

    $type .= " disabled" if $self->disabled;
    $type .= " readonly" if $self->readonly;
    return sprintf "%-30s %s", $dump, "($type)" unless $self->{menu};

    my @menu;
    my $i = 0;
    for (@{$self->{menu}}) {
	my $opt = $_->{value};
	$opt = "<UNDEF>" unless defined $opt;
	$opt .= "/$_->{name}"
	    if defined $_->{name} && length $_->{name} && $_->{name} ne $opt;
	substr($opt,0,0) = "-" if $_->{disabled};
	if (exists $self->{current} && $self->{current} == $i) {
	    substr($opt,0,0) = "!" unless $_->{seen};
	    substr($opt,0,0) = "*";
	}
	else {
	    substr($opt,0,0) = ":" if $_->{seen};
	}
	push(@menu, $opt);
	$i++;
    }

    return sprintf "%-30s %-10s %s", $dump, "($type)", "[" . join("|", @menu) . "]";
}


#---------------------------------------------------
package HTML::Form::TextInput;
@HTML::Form::TextInput::ISA=qw(HTML::Form::Input);

#input/text
#input/password
#input/hidden
#textarea

sub value
{
    my $self = shift;
    my $old = $self->{value};
    $old = "" unless defined $old;
    if (@_) {
        Carp::croak("Input '$self->{name}' is readonly")
	    if $self->{strict} && $self->{readonly};
        my $new = shift;
        my $n = exists $self->{maxlength} ? $self->{maxlength} : undef;
        Carp::croak("Input '$self->{name}' has maxlength '$n'")
	    if $self->{strict} && defined($n) && defined($new) && length($new) > $n;
	$self->{value} = $new;
    }
    $old;
}

#---------------------------------------------------
package HTML::Form::IgnoreInput;
@HTML::Form::IgnoreInput::ISA=qw(HTML::Form::Input);

#input/button
#input/reset

sub value { return }


#---------------------------------------------------
package HTML::Form::ListInput;
@HTML::Form::ListInput::ISA=qw(HTML::Form::Input);

#select/option   (val1, val2, ....)
#input/radio     (undef, val1, val2,...)
#input/checkbox  (undef, value)
#select-multiple/option (undef, value)

sub new
{
    my $class = shift;
    my $self = $class->SUPER::new(@_);

    my $value = delete $self->{value};
    my $value_name = delete $self->{value_name};
    my $type = $self->{type};

    if ($type eq "checkbox") {
	$value = "on" unless defined $value;
	$self->{menu} = [
	    { value => undef, name => "off", },
            { value => $value, name => $value_name, },
        ];
	$self->{current} = (delete $self->{checked}) ? 1 : 0;
	;
    }
    else {
	$self->{option_disabled}++
	    if $type eq "radio" && delete $self->{disabled};
	$self->{menu} = [
            {value => $value, name => $value_name},
        ];
	my $checked = $self->{checked} || $self->{option_selected};
	delete $self->{checked};
	delete $self->{option_selected};
	if (exists $self->{multiple}) {
	    unshift(@{$self->{menu}}, { value => undef, name => "off"});
	    $self->{current} = $checked ? 1 : 0;
	}
	else {
	    $self->{current} = 0 if $checked;
	}
    }
    $self;
}

sub add_to_form
{
    my($self, $form) = @_;
    my $type = $self->type;

    return $self->SUPER::add_to_form($form)
	if $type eq "checkbox";

    if ($type eq "option" && exists $self->{multiple}) {
	$self->{disabled} ||= delete $self->{option_disabled};
	return $self->SUPER::add_to_form($form);
    }

    die "Assert" if @{$self->{menu}} != 1;
    my $m = $self->{menu}[0];
    $m->{disabled}++ if delete $self->{option_disabled};

    my $prev = $form->find_input($self->{name}, $self->{type}, $self->{idx});
    return $self->SUPER::add_to_form($form) unless $prev;

    # merge menus
    $prev->{current} = @{$prev->{menu}} if exists $self->{current};
    push(@{$prev->{menu}}, $m);
}

sub fixup
{
    my $self = shift;
    if ($self->{type} eq "option" && !(exists $self->{current})) {
	$self->{current} = 0;
    }
    $self->{menu}[$self->{current}]{seen}++ if exists $self->{current};
}

sub disabled
{
    my $self = shift;
    my $type = $self->type;

    my $old = $self->{disabled} || _menu_all_disabled(@{$self->{menu}});
    if (@_) {
	my $v = shift;
	$self->{disabled} = $v;
        for (@{$self->{menu}}) {
            $_->{disabled} = $v;
        }
    }
    return $old;
}

sub _menu_all_disabled {
    for (@_) {
	return 0 unless $_->{disabled};
    }
    return 1;
}

sub value
{
    my $self = shift;
    my $old;
    $old = $self->{menu}[$self->{current}]{value} if exists $self->{current};
    $old = $self->{value} if exists $self->{value};
    if (@_) {
	my $i = 0;
	my $val = shift;
	my $cur;
	my $disabled;
	for (@{$self->{menu}}) {
	    if ((defined($val) && defined($_->{value}) && $val eq $_->{value}) ||
		(!defined($val) && !defined($_->{value}))
	       )
	    {
		$cur = $i;
		$disabled = $_->{disabled};
		last unless $disabled;
	    }
	    $i++;
	}
	if (!(defined $cur) || $disabled) {
	    if (defined $val) {
		# try to search among the alternative names as well
		my $i = 0;
		my $cur_ignorecase;
		my $lc_val = lc($val);
		for (@{$self->{menu}}) {
		    if (defined $_->{name}) {
			if ($val eq $_->{name}) {
			    $disabled = $_->{disabled};
			    $cur = $i;
			    last unless $disabled;
			}
			if (!defined($cur_ignorecase) && $lc_val eq lc($_->{name})) {
			    $cur_ignorecase = $i;
			}
		    }
		    $i++;
		}
		unless (defined $cur) {
		    $cur = $cur_ignorecase;
		    if (defined $cur) {
			$disabled = $self->{menu}[$cur]{disabled};
		    }
		    elsif ($self->{strict}) {
			my $n = $self->name;
		        Carp::croak("Illegal value '$val' for field '$n'");
		    }
		}
	    }
	    elsif ($self->{strict}) {
		my $n = $self->name;
	        Carp::croak("The '$n' field can't be unchecked");
	    }
	}
	if ($self->{strict} && $disabled) {
	    my $n = $self->name;
	    Carp::croak("The value '$val' has been disabled for field '$n'");
	}
	if (defined $cur) {
	    $self->{current} = $cur;
	    $self->{menu}[$cur]{seen}++;
	    delete $self->{value};
	}
	else {
	    $self->{value} = $val;
	    delete $self->{current};
	}
    }
    $old;
}


sub check
{
    my $self = shift;
    $self->{current} = 1;
    $self->{menu}[1]{seen}++;
}

sub possible_values
{
    my $self = shift;
    map $_->{value}, grep !$_->{disabled}, @{$self->{menu}};
}

sub other_possible_values
{
    my $self = shift;
    map $_->{value}, grep !$_->{seen} && !$_->{disabled}, @{$self->{menu}};
}

sub value_names {
    my $self = shift;
    my @names;
    for (@{$self->{menu}}) {
	my $n = $_->{name};
	$n = $_->{value} unless defined $n;
	push(@names, $n);
    }
    @names;
}


#---------------------------------------------------
package HTML::Form::SubmitInput;
@HTML::Form::SubmitInput::ISA=qw(HTML::Form::Input);

#input/image
#input/submit


sub click
{
    my($self,$form,$x,$y) = @_;
    for ($x, $y) { $_ = 1 unless defined; }
    local($self->{clicked}) = [$x,$y];
    return $form->make_request;
}

sub form_name_value
{
    my $self = shift;
    return unless $self->{clicked};
    return $self->SUPER::form_name_value(@_);
}


#---------------------------------------------------
package HTML::Form::ImageInput;
@HTML::Form::ImageInput::ISA=qw(HTML::Form::SubmitInput);

sub form_name_value
{
    my $self = shift;
    my $clicked = $self->{clicked};
    return unless $clicked;
    return if $self->{disabled};
    my $name = $self->{name};
    $name = (defined($name) && length($name)) ? "$name." : "";
    return ("${name}x" => $clicked->[0],
	    "${name}y" => $clicked->[1]
	   );
}

#---------------------------------------------------
package HTML::Form::FileInput;
@HTML::Form::FileInput::ISA=qw(HTML::Form::TextInput);


sub file {
    my $self = shift;
    $self->value(@_);
}


sub filename {
    my $self = shift;
    my $old = $self->{filename};
    $self->{filename} = shift if @_;
    $old = $self->file unless defined $old;
    $old;
}


sub content {
    my $self = shift;
    my $old = $self->{content};
    $self->{content} = shift if @_;
    $old;
}


sub headers {
    my $self = shift;
    my $old = $self->{headers} || [];
    $self->{headers} = [@_] if @_;
    @$old;
}

sub form_name_value {
    my($self, $form) = @_;
    return $self->SUPER::form_name_value($form)
	if $form->method ne "POST" ||
	   $form->enctype ne "multipart/form-data";

    my $name = $self->name;
    return unless defined $name;
    return if $self->{disabled};

    my $file = $self->file;
    my $filename = $self->filename;
    my @headers = $self->headers;
    my $content = $self->content;
    if (defined $content) {
	$filename = $file unless defined $filename;
	$file = undef;
	unshift(@headers, "Content" => $content);
    }
    elsif (!defined($file) || length($file) == 0) {
	return;
    }

    # legacy (this used to be the way to do it)
    if (ref($file) eq "ARRAY") {
	my $f = shift @$file;
	my $fn = shift @$file;
	push(@headers, @$file);
	$file = $f;
	$filename = $fn unless defined $filename;
    }

    return ($name => [$file, $filename, @headers]);
}

package HTML::Form::KeygenInput;
@HTML::Form::KeygenInput::ISA=qw(HTML::Form::Input);

sub challenge {
    my $self = shift;
    return $self->{challenge};
}

sub keytype {
    my $self = shift;
    return lc($self->{keytype} || 'rsa');
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

HTML::Form - Class that represents an HTML form element

=head1 VERSION

version 6.07

=head1 SYNOPSIS

 use HTML::Form;
 $form = HTML::Form->parse($html, $base_uri);
 $form->value(query => "Perl");

 use LWP::UserAgent;
 $ua = LWP::UserAgent->new;
 $response = $ua->request($form->click);

=head1 DESCRIPTION

Objects of the C<HTML::Form> class represents a single HTML
C<E<lt>formE<gt> ... E<lt>/formE<gt>> instance.  A form consists of a
sequence of inputs that usually have names, and which can take on
various values.  The state of a form can be tweaked and it can then be
asked to provide L<HTTP::Request> objects that can be passed to the
request() method of L<LWP::UserAgent>.

The following methods are available:

=over 4

=item @forms = HTML::Form->parse( $html_document, $base_uri )

=item @forms = HTML::Form->parse( $html_document, base => $base_uri, %opt )

=item @forms = HTML::Form->parse( $response, %opt )

The parse() class method will parse an HTML document and build up
C<HTML::Form> objects for each <form> element found.  If called in scalar
context only returns the first <form>.  Returns an empty list if there
are no forms to be found.

The required arguments is the HTML document to parse ($html_document) and the
URI used to retrieve the document ($base_uri).  The base URI is needed to resolve
relative action URIs.  The provided HTML document should be a Unicode string
(or US-ASCII).

By default HTML::Form assumes that the original document was UTF-8 encoded and
thus encode forms that don't specify an explicit I<accept-charset> as UTF-8.
The charset assumed can be overridden by providing the C<charset> option to
parse().  It's a good idea to be explicit about this parameter as well, thus
the recommended simplest invocation becomes:

    my @forms = HTML::Form->parse(
        Encode::decode($encoding, $html_document_bytes),
        base => $base_uri,
	charset => $encoding,
    );

If the document was retrieved with LWP then the response object provide methods
to obtain a proper value for C<base> and C<charset>:

    my $ua = LWP::UserAgent->new;
    my $response = $ua->get("http://www.example.com/form.html");
    my @forms = HTML::Form->parse($response->decoded_content,
	base => $response->base,
	charset => $response->content_charset,
    );

In fact, the parse() method can parse from an L<HTTP::Response> object
directly, so the example above can be more conveniently written as:

    my $ua = LWP::UserAgent->new;
    my $response = $ua->get("http://www.example.com/form.html");
    my @forms = HTML::Form->parse($response);

Note that any object that implements a decoded_content(), base() and
content_charset() method with similar behaviour as L<HTTP::Response> will do.

Additional options might be passed in to control how the parse method
behaves.  The following are all the options currently recognized:

=over

=item C<< base => $uri >>

This is the URI used to retrieve the original document.  This option is not optional ;-)

=item C<< charset => $str >>

Specify what charset the original document was encoded in.  This is used as
the default for accept_charset.  If not provided this defaults to "UTF-8".

=item C<< verbose => $bool >>

Warn (print messages to STDERR) about any bad HTML form constructs found.
You can trap these with $SIG{__WARN__}.  The default is not to issue warnings.

=item C<< strict => $bool >>

Initialize any form objects with the given strict attribute.
If the strict is turned on the methods that change values of the form will croak if you try
to set illegal values or modify readonly fields.
The default is not to be strict.

=back

=item $form->push_input( $type, \%attr, $verbose )

This method adds additional inputs to the form.
The first argument is the type of input (e.g. hidden, option, etc.).
The second argument is a reference to a hash of the input attributes.
The third argument is optional, and will issue warnings about unknown input types.

Example:

    push_input( 'hidden', {
        name  => 'NewFormElement',
        id    => 'NewFormElementId',
        value => 'some value',
    });

=item $method = $form->method

=item $form->method( $new_method )

This method is gets/sets the I<method> name used for the
L<HTTP::Request> generated.  It is a string like "GET" or "POST".

=item $action = $form->action

=item $form->action( $new_action )

This method gets/sets the URI which we want to apply the request
I<method> to.

=item $enctype = $form->enctype

=item $form->enctype( $new_enctype )

This method gets/sets the encoding type for the form data.  It is a
string like "application/x-www-form-urlencoded" or "multipart/form-data".

=item $accept = $form->accept_charset

=item $form->accept_charset( $new_accept )

This method gets/sets the list of charset encodings that the server processing
the form accepts. Current implementation supports only one-element lists.
Default value is "UNKNOWN" which we interpret as a request to use document
charset as specified by the 'charset' parameter of the parse() method.

=item $value = $form->attr( $name )

=item $form->attr( $name, $new_value )

This method give access to the original HTML attributes of the <form> tag.
The $name should always be passed in lower case.

Example:

   @f = HTML::Form->parse( $html, $foo );
   @f = grep $_->attr("id") eq "foo", @f;
   die "No form named 'foo' found" unless @f;
   $foo = shift @f;

=item $bool = $form->strict

=item $form->strict( $bool )

Gets/sets the strict attribute of a form.  If the strict is turned on
the methods that change values of the form will croak if you try to
set illegal values or modify readonly fields.  The default is not to be strict.

=item @inputs = $form->inputs

This method returns the list of inputs in the form.  If called in
scalar context it returns the number of inputs contained in the form.
See L</INPUTS> for what methods are available for the input objects
returned.

=item $input = $form->find_input( $selector )

=item $input = $form->find_input( $selector, $type )

=item $input = $form->find_input( $selector, $type, $index )

=item @inputs = $form->find_input( $selector )

=item @inputs = $form->find_input( $selector, $type )

This method is used to locate specific inputs within the form.  All
inputs that match the arguments given are returned.  In scalar context
only the first is returned, or C<undef> if none match.

If $selector is not C<undef>, then the input's name, id, class attribute must
match.  A selector prefixed with '#' must match the id attribute of the input.
A selector prefixed with '.' matches the class attribute.  A selector prefixed
with '^' or with no prefix matches the name attribute.

If $type is not C<undef>, then the input must have the specified type.
The following type names are used: "text", "password", "hidden",
"textarea", "file", "image", "submit", "radio", "checkbox" and "option".

The $index is the sequence number of the input matched where 1 is the
first.  If combined with $name and/or $type, then it selects the I<n>th
input with the given name and/or type.

=item $value = $form->value( $selector )

=item $form->value( $selector, $new_value )

The value() method can be used to get/set the value of some input.  If
strict is enabled and no input has the indicated name, then this method will croak.

If multiple inputs have the same name, only the first one will be
affected.

The call:

    $form->value('foo')

is basically a short-hand for:

    $form->find_input('foo')->value;

=item @names = $form->param

=item @values = $form->param( $name )

=item $form->param( $name, $value, ... )

=item $form->param( $name, \@values )

Alternative interface to examining and setting the values of the form.

If called without arguments then it returns the names of all the
inputs in the form.  The names will not repeat even if multiple inputs
have the same name.  In scalar context the number of different names
is returned.

If called with a single argument then it returns the value or values
of inputs with the given name.  If called in scalar context only the
first value is returned.  If no input exists with the given name, then
C<undef> is returned.

If called with 2 or more arguments then it will set values of the
named inputs.  This form will croak if no inputs have the given name
or if any of the values provided does not fit.  Values can also be
provided as a reference to an array.  This form will allow unsetting
all values with the given name as well.

This interface resembles that of the param() function of the CGI
module.

=item $form->try_others( \&callback )

This method will iterate over all permutations of unvisited enumerated
values (<select>, <radio>, <checkbox>) and invoke the callback for
each.  The callback is passed the $form as argument.  The return value
from the callback is ignored and the try_others() method itself does
not return anything.

=item $request = $form->make_request

Will return an L<HTTP::Request> object that reflects the current setting
of the form.  You might want to use the click() method instead.

=item $request = $form->click

=item $request = $form->click( $selector )

=item $request = $form->click( $x, $y )

=item $request = $form->click( $selector, $x, $y )

Will "click" on the first clickable input (which will be of type
C<submit> or C<image>).  The result of clicking is an L<HTTP::Request>
object that can then be passed to L<LWP::UserAgent> if you want to
obtain the server response.

If a $selector is specified, we will click on the first clickable input
matching the selector, and the method will croak if no matching clickable
input is found.  If $selector is I<not> specified, then it
is ok if the form contains no clickable inputs.  In this case the
click() method returns the same request as the make_request() method
would do.  See description of the find_input() method above for how
the $selector is specified.

If there are multiple clickable inputs with the same name, then there
is no way to get the click() method of the C<HTML::Form> to click on
any but the first.  If you need this you would have to locate the
input with find_input() and invoke the click() method on the given
input yourself.

A click coordinate pair can also be provided, but this only makes a
difference if you clicked on an image.  The default coordinate is
(1,1).  The upper-left corner of the image is (0,0), but some badly
coded CGI scripts are known to not recognize this.  Therefore (1,1) was
selected as a safer default.

=item @kw = $form->form

Returns the current setting as a sequence of key/value pairs.  Note
that keys might be repeated, which means that some values might be
lost if the return values are assigned to a hash.

In scalar context this method returns the number of key/value pairs
generated.

=item $form->dump

Returns a textual representation of current state of the form.  Mainly
useful for debugging.  If called in void context, then the dump is
printed on STDERR.

=back

=head1 INPUTS

An C<HTML::Form> objects contains a sequence of I<inputs>.  References to
the inputs can be obtained with the $form->inputs or $form->find_input
methods.

Note that there is I<not> a one-to-one correspondence between input
I<objects> and E<lt>inputE<gt> I<elements> in the HTML document.  An
input object basically represents a name/value pair, so when multiple
HTML elements contribute to the same name/value pair in the submitted
form they are combined.

The input elements that are mapped one-to-one are "text", "textarea",
"password", "hidden", "file", "image", "submit" and "checkbox".  For
the "radio" and "option" inputs the story is not as simple: All
E<lt>input type="radio"E<gt> elements with the same name will
contribute to the same input radio object.  The number of radio input
objects will be the same as the number of distinct names used for the
E<lt>input type="radio"E<gt> elements.  For a E<lt>selectE<gt> element
without the C<multiple> attribute there will be one input object of
type of "option".  For a E<lt>select multipleE<gt> element there will
be one input object for each contained E<lt>optionE<gt> element.  Each
one of these option objects will have the same name.

The following methods are available for the I<input> objects:

=over 4

=item $input->type

Returns the type of this input.  The type is one of the following
strings: "text", "password", "hidden", "textarea", "file", "image", "submit",
"radio", "checkbox" or "option".

=item $name = $input->name

=item $input->name( $new_name )

This method can be used to get/set the current name of the input.

=item $input->id

=item $input->class

These methods can be used to get/set the current id or class attribute for the input.

=item $input->selected( $selector )

Returns TRUE if the given selector matched the input.  See the description of
the find_input() method above for a description of the selector syntax.

=item $value = $input->value

=item $input->value( $new_value )

This method can be used to get/set the current value of an
input.

If strict is enabled and the input only can take an enumerated list of values,
then it is an error to try to set it to something else and the method will
croak if you try.

You will also be able to set the value of read-only inputs, but a
warning will be generated if running under C<perl -w>.

=item $autocomplete = $input->autocomplete

=item $input->autocomplete( $new_autocomplete )

This method can be used to get/set the current value (if any) of C<autcomplete> for the input.

=item $input->possible_values

Returns a list of all values that an input can take.  For inputs that
do not have discrete values, this returns an empty list.

=item $input->other_possible_values

Returns a list of all values not tried yet.

=item $input->value_names

For some inputs the values can have names that are different from the
values themselves.  The number of names returned by this method will
match the number of values reported by $input->possible_values.

When setting values using the value() method it is also possible to
use the value names in place of the value itself.

=item $bool = $input->readonly

=item $input->readonly( $bool )

This method is used to get/set the value of the readonly attribute.
You are allowed to modify the value of readonly inputs, but setting
the value will generate some noise when warnings are enabled.  Hidden
fields always start out readonly.

=item $bool = $input->disabled

=item $input->disabled( $bool )

This method is used to get/set the value of the disabled attribute.
Disabled inputs do not contribute any key/value pairs for the form
value.

=item $input->form_name_value

Returns a (possible empty) list of key/value pairs that should be
incorporated in the form value from this input.

=item $input->check

Some input types represent toggles that can be turned on/off.  This
includes "checkbox" and "option" inputs.  Calling this method turns
this input on without having to know the value name.  If the input is
already on, then nothing happens.

This has the same effect as:

    $input->value($input->possible_values[1]);

The input can be turned off with:

    $input->value(undef);

=item $input->click($form, $x, $y)

Some input types (currently "submit" buttons and "images") can be
clicked to submit the form.  The click() method returns the
corresponding L<HTTP::Request> object.

=back

If the input is of type C<file>, then it has these additional methods:

=over 4

=item $input->file

This is just an alias for the value() method.  It sets the filename to
read data from.

For security reasons this field will never be initialized from the parsing
of a form.  This prevents the server from triggering stealth uploads of
arbitrary files from the client machine.

=item $filename = $input->filename

=item $input->filename( $new_filename )

This get/sets the filename reported to the server during file upload.
This attribute defaults to the value reported by the file() method.

=item $content = $input->content

=item $input->content( $new_content )

This get/sets the file content provided to the server during file
upload.  This method can be used if you do not want the content to be
read from an actual file.

=item @headers = $input->headers

=item input->headers($key => $value, .... )

This get/set additional header fields describing the file uploaded.
This can for instance be used to set the C<Content-Type> reported for
the file.

=back

=head1 SEE ALSO

L<LWP>, L<LWP::UserAgent>, L<HTML::Parser>

=head1 AUTHOR

Gisle Aas <gisle@activestate.com>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 1998 by Gisle Aas.

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

=cut
PK       ! Ror�D� D�   perl5/Path/Tiny.pmnu ��6�$        use 5.008001;
use strict;
use warnings;

package Path::Tiny;
# ABSTRACT: File path utility

our $VERSION = '0.114';

# Dependencies
use Config;
use Exporter 5.57   (qw/import/);
use File::Spec 0.86 ();          # shipped with 5.8.1
use Carp ();

our @EXPORT    = qw/path/;
our @EXPORT_OK = qw/cwd rootdir tempfile tempdir/;

use constant {
    PATH     => 0,
    CANON    => 1,
    VOL      => 2,
    DIR      => 3,
    FILE     => 4,
    TEMP     => 5,
    IS_WIN32 => ( $^O eq 'MSWin32' ),
};

use overload (
    q{""}    => sub    { $_[0]->[PATH] },
    bool     => sub () { 1 },
    fallback => 1,
);

# FREEZE/THAW per Sereal/CBOR/Types::Serialiser protocol
sub FREEZE { return $_[0]->[PATH] }
sub THAW   { return path( $_[2] ) }
{ no warnings 'once'; *TO_JSON = *FREEZE };

my $HAS_UU; # has Unicode::UTF8; lazily populated

sub _check_UU {
    local $SIG{__DIE__}; # prevent outer handler from being called
    !!eval {
        require Unicode::UTF8;
        Unicode::UTF8->VERSION(0.58);
        1;
    };
}

my $HAS_PU;              # has PerlIO::utf8_strict; lazily populated

sub _check_PU {
    local $SIG{__DIE__}; # prevent outer handler from being called
    !!eval {
        # MUST preload Encode or $SIG{__DIE__} localization fails
        # on some Perl 5.8.8 (maybe other 5.8.*) compiled with -O2.
        require Encode;
        require PerlIO::utf8_strict;
        PerlIO::utf8_strict->VERSION(0.003);
        1;
    };
}

my $HAS_FLOCK = $Config{d_flock} || $Config{d_fcntl_can_lock} || $Config{d_lockf};

# notions of "root" directories differ on Win32: \\server\dir\ or C:\ or \
my $SLASH      = qr{[\\/]};
my $NOTSLASH   = qr{[^\\/]};
my $DRV_VOL    = qr{[a-z]:}i;
my $UNC_VOL    = qr{$SLASH $SLASH $NOTSLASH+ $SLASH $NOTSLASH+}x;
my $WIN32_ROOT = qr{(?: $UNC_VOL $SLASH | $DRV_VOL $SLASH | $SLASH )}x;

sub _win32_vol {
    my ( $path, $drv ) = @_;
    require Cwd;
    my $dcwd = eval { Cwd::getdcwd($drv) }; # C: -> C:\some\cwd
    # getdcwd on non-existent drive returns empty string
    # so just use the original drive Z: -> Z:
    $dcwd = "$drv" unless defined $dcwd && length $dcwd;
    # normalize dwcd to end with a slash: might be C:\some\cwd or D:\ or Z:
    $dcwd =~ s{$SLASH?\z}{/};
    # make the path absolute with dcwd
    $path =~ s{^$DRV_VOL}{$dcwd};
    return $path;
}

# This is a string test for before we have the object; see is_rootdir for well-formed
# object test
sub _is_root {
    return IS_WIN32() ? ( $_[0] =~ /^$WIN32_ROOT\z/ ) : ( $_[0] eq '/' );
}

BEGIN {
    *_same = IS_WIN32() ? sub { lc( $_[0] ) eq lc( $_[1] ) } : sub { $_[0] eq $_[1] };
}

# mode bits encoded for chmod in symbolic mode
my %MODEBITS = ( om => 0007, gm => 0070, um => 0700 ); ## no critic
{ my $m = 0; $MODEBITS{$_} = ( 1 << $m++ ) for qw/ox ow or gx gw gr ux uw ur/ };

sub _symbolic_chmod {
    my ( $mode, $symbolic ) = @_;
    for my $clause ( split /,\s*/, $symbolic ) {
        if ( $clause =~ m{\A([augo]+)([=+-])([rwx]+)\z} ) {
            my ( $who, $action, $perms ) = ( $1, $2, $3 );
            $who =~ s/a/ugo/g;
            for my $w ( split //, $who ) {
                my $p = 0;
                $p |= $MODEBITS{"$w$_"} for split //, $perms;
                if ( $action eq '=' ) {
                    $mode = ( $mode & ~$MODEBITS{"${w}m"} ) | $p;
                }
                else {
                    $mode = $action eq "+" ? ( $mode | $p ) : ( $mode & ~$p );
                }
            }
        }
        else {
            Carp::croak("Invalid mode clause '$clause' for chmod()");
        }
    }
    return $mode;
}

# flock doesn't work on NFS on BSD or on some filesystems like lustre.
# Since program authors often can't control or detect that, we warn once
# instead of being fatal if we can detect it and people who need it strict
# can fatalize the 'flock' category

#<<< No perltidy
{ package flock; use warnings::register }
#>>>

my $WARNED_NO_FLOCK = 0;

sub _throw {
    my ( $self, $function, $file, $msg ) = @_;
    if (   $function =~ /^flock/
        && $! =~ /operation not supported|function not implemented/i
        && !warnings::fatal_enabled('flock') )
    {
        if ( !$WARNED_NO_FLOCK ) {
            warnings::warn( flock => "Flock not available: '$!': continuing in unsafe mode" );
            $WARNED_NO_FLOCK++;
        }
    }
    else {
        $msg = $! unless defined $msg;
        Path::Tiny::Error->throw( $function, ( defined $file ? $file : $self->[PATH] ),
            $msg );
    }
    return;
}

# cheapo option validation
sub _get_args {
    my ( $raw, @valid ) = @_;
    if ( defined($raw) && ref($raw) ne 'HASH' ) {
        my ( undef, undef, undef, $called_as ) = caller(1);
        $called_as =~ s{^.*::}{};
        Carp::croak("Options for $called_as must be a hash reference");
    }
    my $cooked = {};
    for my $k (@valid) {
        $cooked->{$k} = delete $raw->{$k} if exists $raw->{$k};
    }
    if ( keys %$raw ) {
        my ( undef, undef, undef, $called_as ) = caller(1);
        $called_as =~ s{^.*::}{};
        Carp::croak( "Invalid option(s) for $called_as: " . join( ", ", keys %$raw ) );
    }
    return $cooked;
}

#--------------------------------------------------------------------------#
# Constructors
#--------------------------------------------------------------------------#

#pod =construct path
#pod
#pod     $path = path("foo/bar");
#pod     $path = path("/tmp", "file.txt"); # list
#pod     $path = path(".");                # cwd
#pod     $path = path("~user/file.txt");   # tilde processing
#pod
#pod Constructs a C<Path::Tiny> object.  It doesn't matter if you give a file or
#pod directory path.  It's still up to you to call directory-like methods only on
#pod directories and file-like methods only on files.  This function is exported
#pod automatically by default.
#pod
#pod The first argument must be defined and have non-zero length or an exception
#pod will be thrown.  This prevents subtle, dangerous errors with code like
#pod C<< path( maybe_undef() )->remove_tree >>.
#pod
#pod If the first component of the path is a tilde ('~') then the component will be
#pod replaced with the output of C<glob('~')>.  If the first component of the path
#pod is a tilde followed by a user name then the component will be replaced with
#pod output of C<glob('~username')>.  Behaviour for non-existent users depends on
#pod the output of C<glob> on the system.
#pod
#pod On Windows, if the path consists of a drive identifier without a path component
#pod (C<C:> or C<D:>), it will be expanded to the absolute path of the current
#pod directory on that volume using C<Cwd::getdcwd()>.
#pod
#pod If called with a single C<Path::Tiny> argument, the original is returned unless
#pod the original is holding a temporary file or directory reference in which case a
#pod stringified copy is made.
#pod
#pod     $path = path("foo/bar");
#pod     $temp = Path::Tiny->tempfile;
#pod
#pod     $p2 = path($path); # like $p2 = $path
#pod     $t2 = path($temp); # like $t2 = path( "$temp" )
#pod
#pod This optimizes copies without proliferating references unexpectedly if a copy is
#pod made by code outside your control.
#pod
#pod Current API available since 0.017.
#pod
#pod =cut

sub path {
    my $path = shift;
    Carp::croak("Path::Tiny paths require defined, positive-length parts")
      unless 1 + @_ == grep { defined && length } $path, @_;

    # non-temp Path::Tiny objects are effectively immutable and can be reused
    if ( !@_ && ref($path) eq __PACKAGE__ && !$path->[TEMP] ) {
        return $path;
    }

    # stringify objects
    $path = "$path";

    # expand relative volume paths on windows; put trailing slash on UNC root
    if ( IS_WIN32() ) {
        $path = _win32_vol( $path, $1 ) if $path =~ m{^($DRV_VOL)(?:$NOTSLASH|\z)};
        $path .= "/" if $path =~ m{^$UNC_VOL\z};
    }

    # concatenations stringifies objects, too
    if (@_) {
        $path .= ( _is_root($path) ? "" : "/" ) . join( "/", @_ );
    }

    # canonicalize, but with unix slashes and put back trailing volume slash
    my $cpath = $path = File::Spec->canonpath($path);
    $path =~ tr[\\][/] if IS_WIN32();
    $path = "/" if $path eq '/..'; # for old File::Spec
    $path .= "/" if IS_WIN32() && $path =~ m{^$UNC_VOL\z};

    # root paths must always have a trailing slash, but other paths must not
    if ( _is_root($path) ) {
        $path =~ s{/?\z}{/};
    }
    else {
        $path =~ s{/\z}{};
    }

    # do any tilde expansions
    if ( $path =~ m{^(~[^/]*).*} ) {
        require File::Glob;
        my ($homedir) = File::Glob::bsd_glob($1);
        $homedir =~ tr[\\][/] if IS_WIN32();
        $path =~ s{^(~[^/]*)}{$homedir};
    }

    bless [ $path, $cpath ], __PACKAGE__;
}

#pod =construct new
#pod
#pod     $path = Path::Tiny->new("foo/bar");
#pod
#pod This is just like C<path>, but with method call overhead.  (Why would you
#pod do that?)
#pod
#pod Current API available since 0.001.
#pod
#pod =cut

sub new { shift; path(@_) }

#pod =construct cwd
#pod
#pod     $path = Path::Tiny->cwd; # path( Cwd::getcwd )
#pod     $path = cwd; # optional export
#pod
#pod Gives you the absolute path to the current directory as a C<Path::Tiny> object.
#pod This is slightly faster than C<< path(".")->absolute >>.
#pod
#pod C<cwd> may be exported on request and used as a function instead of as a
#pod method.
#pod
#pod Current API available since 0.018.
#pod
#pod =cut

sub cwd {
    require Cwd;
    return path( Cwd::getcwd() );
}

#pod =construct rootdir
#pod
#pod     $path = Path::Tiny->rootdir; # /
#pod     $path = rootdir;             # optional export 
#pod
#pod Gives you C<< File::Spec->rootdir >> as a C<Path::Tiny> object if you're too
#pod picky for C<path("/")>.
#pod
#pod C<rootdir> may be exported on request and used as a function instead of as a
#pod method.
#pod
#pod Current API available since 0.018.
#pod
#pod =cut

sub rootdir { path( File::Spec->rootdir ) }

#pod =construct tempfile, tempdir
#pod
#pod     $temp = Path::Tiny->tempfile( @options );
#pod     $temp = Path::Tiny->tempdir( @options );
#pod     $temp = tempfile( @options ); # optional export
#pod     $temp = tempdir( @options );  # optional export
#pod
#pod C<tempfile> passes the options to C<< File::Temp->new >> and returns a C<Path::Tiny>
#pod object with the file name.  The C<TMPDIR> option is enabled by default.
#pod
#pod The resulting C<File::Temp> object is cached. When the C<Path::Tiny> object is
#pod destroyed, the C<File::Temp> object will be as well.
#pod
#pod C<File::Temp> annoyingly requires you to specify a custom template in slightly
#pod different ways depending on which function or method you call, but
#pod C<Path::Tiny> lets you ignore that and can take either a leading template or a
#pod C<TEMPLATE> option and does the right thing.
#pod
#pod     $temp = Path::Tiny->tempfile( "customXXXXXXXX" );             # ok
#pod     $temp = Path::Tiny->tempfile( TEMPLATE => "customXXXXXXXX" ); # ok
#pod
#pod The tempfile path object will be normalized to have an absolute path, even if
#pod created in a relative directory using C<DIR>.  If you want it to have
#pod the C<realpath> instead, pass a leading options hash like this:
#pod
#pod     $real_temp = tempfile({realpath => 1}, @options);
#pod
#pod C<tempdir> is just like C<tempfile>, except it calls
#pod C<< File::Temp->newdir >> instead.
#pod
#pod Both C<tempfile> and C<tempdir> may be exported on request and used as
#pod functions instead of as methods.
#pod
#pod B<Note>: for tempfiles, the filehandles from File::Temp are closed and not
#pod reused.  This is not as secure as using File::Temp handles directly, but is
#pod less prone to deadlocks or access problems on some platforms.  Think of what
#pod C<Path::Tiny> gives you to be just a temporary file B<name> that gets cleaned
#pod up.
#pod
#pod B<Note 2>: if you don't want these cleaned up automatically when the object
#pod is destroyed, File::Temp requires different options for directories and
#pod files.  Use C<< CLEANUP => 0 >> for directories and C<< UNLINK => 0 >> for
#pod files.
#pod
#pod B<Note 3>: Don't lose the temporary object by chaining a method call instead
#pod of storing it:
#pod
#pod     my $lost = tempdir()->child("foo"); # tempdir cleaned up right away
#pod
#pod B<Note 4>: The cached object may be accessed with the L</cached_temp> method.
#pod Keeping a reference to, or modifying the cached object may break the
#pod behavior documented above and is not supported.  Use at your own risk.
#pod
#pod Current API available since 0.097.
#pod
#pod =cut

sub tempfile {
    shift if @_ && $_[0] eq 'Path::Tiny'; # called as method
    my $opts = ( @_ && ref $_[0] eq 'HASH' ) ? shift @_ : {};
    $opts = _get_args( $opts, qw/realpath/ );

    my ( $maybe_template, $args ) = _parse_file_temp_args(@_);
    # File::Temp->new demands TEMPLATE
    $args->{TEMPLATE} = $maybe_template->[0] if @$maybe_template;

    require File::Temp;
    my $temp = File::Temp->new( TMPDIR => 1, %$args );
    close $temp;
    my $self = $opts->{realpath} ? path($temp)->realpath : path($temp)->absolute;
    $self->[TEMP] = $temp;                # keep object alive while we are
    return $self;
}

sub tempdir {
    shift if @_ && $_[0] eq 'Path::Tiny'; # called as method
    my $opts = ( @_ && ref $_[0] eq 'HASH' ) ? shift @_ : {};
    $opts = _get_args( $opts, qw/realpath/ );

    my ( $maybe_template, $args ) = _parse_file_temp_args(@_);

    # File::Temp->newdir demands leading template
    require File::Temp;
    my $temp = File::Temp->newdir( @$maybe_template, TMPDIR => 1, %$args );
    my $self = $opts->{realpath} ? path($temp)->realpath : path($temp)->absolute;
    $self->[TEMP] = $temp;                # keep object alive while we are
    # Some ActiveState Perls for Windows break Cwd in ways that lead
    # File::Temp to get confused about what path to remove; this
    # monkey-patches the object with our own view of the absolute path
    $temp->{REALNAME} = $self->[CANON] if IS_WIN32;
    return $self;
}

# normalize the various ways File::Temp does templates
sub _parse_file_temp_args {
    my $leading_template = ( scalar(@_) % 2 == 1 ? shift(@_) : '' );
    my %args = @_;
    %args = map { uc($_), $args{$_} } keys %args;
    my @template = (
          exists $args{TEMPLATE} ? delete $args{TEMPLATE}
        : $leading_template      ? $leading_template
        :                          ()
    );
    return ( \@template, \%args );
}

#--------------------------------------------------------------------------#
# Private methods
#--------------------------------------------------------------------------#

sub _splitpath {
    my ($self) = @_;
    @{$self}[ VOL, DIR, FILE ] = File::Spec->splitpath( $self->[PATH] );
}

sub _resolve_symlinks {
    my ($self) = @_;
    my $new = $self;
    my ( $count, %seen ) = 0;
    while ( -l $new->[PATH] ) {
        if ( $seen{ $new->[PATH] }++ ) {
            $self->_throw( 'readlink', $self->[PATH], "symlink loop detected" );
        }
        if ( ++$count > 100 ) {
            $self->_throw( 'readlink', $self->[PATH], "maximum symlink depth exceeded" );
        }
        my $resolved = readlink $new->[PATH] or $new->_throw( 'readlink', $new->[PATH] );
        $resolved = path($resolved);
        $new = $resolved->is_absolute ? $resolved : $new->sibling($resolved);
    }
    return $new;
}

#--------------------------------------------------------------------------#
# Public methods
#--------------------------------------------------------------------------#

#pod =method absolute
#pod
#pod     $abs = path("foo/bar")->absolute;
#pod     $abs = path("foo/bar")->absolute("/tmp");
#pod
#pod Returns a new C<Path::Tiny> object with an absolute path (or itself if already
#pod absolute).  If no argument is given, the current directory is used as the
#pod absolute base path.  If an argument is given, it will be converted to an
#pod absolute path (if it is not already) and used as the absolute base path.
#pod
#pod This will not resolve upward directories ("foo/../bar") unless C<canonpath>
#pod in L<File::Spec> would normally do so on your platform.  If you need them
#pod resolved, you must call the more expensive C<realpath> method instead.
#pod
#pod On Windows, an absolute path without a volume component will have it added
#pod based on the current drive.
#pod
#pod Current API available since 0.101.
#pod
#pod =cut

sub absolute {
    my ( $self, $base ) = @_;

    # absolute paths handled differently by OS
    if (IS_WIN32) {
        return $self if length $self->volume;
        # add missing volume
        if ( $self->is_absolute ) {
            require Cwd;
            # use Win32::GetCwd not Cwd::getdcwd because we're sure
            # to have the former but not necessarily the latter
            my ($drv) = Win32::GetCwd() =~ /^($DRV_VOL | $UNC_VOL)/x;
            return path( $drv . $self->[PATH] );
        }
    }
    else {
        return $self if $self->is_absolute;
    }

    # no base means use current directory as base
    require Cwd;
    return path( Cwd::getcwd(), $_[0]->[PATH] ) unless defined $base;

    # relative base should be made absolute; we check is_absolute rather
    # than unconditionally make base absolute so that "/foo" doesn't become
    # "C:/foo" on Windows.
    $base = path($base);
    return path( ( $base->is_absolute ? $base : $base->absolute ), $_[0]->[PATH] );
}

#pod =method append, append_raw, append_utf8
#pod
#pod     path("foo.txt")->append(@data);
#pod     path("foo.txt")->append(\@data);
#pod     path("foo.txt")->append({binmode => ":raw"}, @data);
#pod     path("foo.txt")->append_raw(@data);
#pod     path("foo.txt")->append_utf8(@data);
#pod
#pod Appends data to a file.  The file is locked with C<flock> prior to writing
#pod and closed afterwards.  An optional hash reference may be used to pass
#pod options.  Valid options are:
#pod
#pod =for :list
#pod * C<binmode>: passed to C<binmode()> on the handle used for writing.
#pod * C<truncate>: truncates the file after locking and before appending
#pod
#pod The C<truncate> option is a way to replace the contents of a file
#pod B<in place>, unlike L</spew> which writes to a temporary file and then
#pod replaces the original (if it exists).
#pod
#pod C<append_raw> is like C<append> with a C<binmode> of C<:unix> for fast,
#pod unbuffered, raw write.
#pod
#pod C<append_utf8> is like C<append> with a C<binmode> of
#pod C<:unix:encoding(UTF-8)> (or L<PerlIO::utf8_strict>).  If L<Unicode::UTF8>
#pod 0.58+ is installed, a raw append will be done instead on the data encoded
#pod with C<Unicode::UTF8>.
#pod
#pod Current API available since 0.060.
#pod
#pod =cut

sub append {
    my ( $self, @data ) = @_;
    my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {};
    $args = _get_args( $args, qw/binmode truncate/ );
    my $binmode = $args->{binmode};
    $binmode = ( ( caller(0) )[10] || {} )->{'open>'} unless defined $binmode;
    my $mode = $args->{truncate} ? ">" : ">>";
    my $fh = $self->filehandle( { locked => 1 }, $mode, $binmode );
    print {$fh} map { ref eq 'ARRAY' ? @$_ : $_ } @data;
    close $fh or $self->_throw('close');
}

sub append_raw {
    my ( $self, @data ) = @_;
    my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {};
    $args = _get_args( $args, qw/binmode truncate/ );
    $args->{binmode} = ':unix';
    append( $self, $args, @data );
}

sub append_utf8 {
    my ( $self, @data ) = @_;
    my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {};
    $args = _get_args( $args, qw/binmode truncate/ );
    if ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) {
        $args->{binmode} = ":unix";
        append( $self, $args, map { Unicode::UTF8::encode_utf8($_) } @data );
    }
    elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
        $args->{binmode} = ":unix:utf8_strict";
        append( $self, $args, @data );
    }
    else {
        $args->{binmode} = ":unix:encoding(UTF-8)";
        append( $self, $args, @data );
    }
}

#pod =method assert
#pod
#pod     $path = path("foo.txt")->assert( sub { $_->exists } );
#pod
#pod Returns the invocant after asserting that a code reference argument returns
#pod true.  When the assertion code reference runs, it will have the invocant
#pod object in the C<$_> variable.  If it returns false, an exception will be
#pod thrown.  The assertion code reference may also throw its own exception.
#pod
#pod If no assertion is provided, the invocant is returned without error.
#pod
#pod Current API available since 0.062.
#pod
#pod =cut

sub assert {
    my ( $self, $assertion ) = @_;
    return $self unless $assertion;
    if ( ref $assertion eq 'CODE' ) {
        local $_ = $self;
        $assertion->()
          or Path::Tiny::Error->throw( "assert", $self->[PATH], "failed assertion" );
    }
    else {
        Carp::croak("argument to assert must be a code reference argument");
    }
    return $self;
}

#pod =method basename
#pod
#pod     $name = path("foo/bar.txt")->basename;        # bar.txt
#pod     $name = path("foo.txt")->basename('.txt');    # foo
#pod     $name = path("foo.txt")->basename(qr/.txt/);  # foo
#pod     $name = path("foo.txt")->basename(@suffixes);
#pod
#pod Returns the file portion or last directory portion of a path.
#pod
#pod Given a list of suffixes as strings or regular expressions, any that match at
#pod the end of the file portion or last directory portion will be removed before
#pod the result is returned.
#pod
#pod Current API available since 0.054.
#pod
#pod =cut

sub basename {
    my ( $self, @suffixes ) = @_;
    $self->_splitpath unless defined $self->[FILE];
    my $file = $self->[FILE];
    for my $s (@suffixes) {
        my $re = ref($s) eq 'Regexp' ? qr/$s\z/ : qr/\Q$s\E\z/;
        last if $file =~ s/$re//;
    }
    return $file;
}

#pod =method canonpath
#pod
#pod     $canonical = path("foo/bar")->canonpath; # foo\bar on Windows
#pod
#pod Returns a string with the canonical format of the path name for
#pod the platform.  In particular, this means directory separators
#pod will be C<\> on Windows.
#pod
#pod Current API available since 0.001.
#pod
#pod =cut

sub canonpath { $_[0]->[CANON] }

#pod =method cached_temp
#pod
#pod Returns the cached C<File::Temp> or C<File::Temp::Dir> object if the
#pod C<Path::Tiny> object was created with C</tempfile> or C</tempdir>.
#pod If there is no such object, this method throws.
#pod
#pod B<WARNING>: Keeping a reference to, or modifying the cached object may
#pod break the behavior documented for temporary files and directories created
#pod with C<Path::Tiny> and is not supported.  Use at your own risk.
#pod
#pod Current API available since 0.101.
#pod
#pod =cut

sub cached_temp {
    my $self = shift;
    $self->_throw( "cached_temp", $self, "has no cached File::Temp object" )
      unless defined $self->[TEMP];
    return $self->[TEMP];
}

#pod =method child
#pod
#pod     $file = path("/tmp")->child("foo.txt"); # "/tmp/foo.txt"
#pod     $file = path("/tmp")->child(@parts);
#pod
#pod Returns a new C<Path::Tiny> object relative to the original.  Works
#pod like C<catfile> or C<catdir> from File::Spec, but without caring about
#pod file or directories.
#pod
#pod B<WARNING>: because the argument could contain C<..> or refer to symlinks,
#pod there is no guarantee that the new path refers to an actual descendent of
#pod the original.  If this is important to you, transform parent and child with
#pod L</realpath> and check them with L</subsumes>.
#pod
#pod Current API available since 0.001.
#pod
#pod =cut

sub child {
    my ( $self, @parts ) = @_;
    return path( $self->[PATH], @parts );
}

#pod =method children
#pod
#pod     @paths = path("/tmp")->children;
#pod     @paths = path("/tmp")->children( qr/\.txt\z/ );
#pod
#pod Returns a list of C<Path::Tiny> objects for all files and directories
#pod within a directory.  Excludes "." and ".." automatically.
#pod
#pod If an optional C<qr//> argument is provided, it only returns objects for child
#pod names that match the given regular expression.  Only the base name is used
#pod for matching:
#pod
#pod     @paths = path("/tmp")->children( qr/^foo/ );
#pod     # matches children like the glob foo*
#pod
#pod Current API available since 0.028.
#pod
#pod =cut

sub children {
    my ( $self, $filter ) = @_;
    my $dh;
    opendir $dh, $self->[PATH] or $self->_throw('opendir');
    my @children = readdir $dh;
    closedir $dh or $self->_throw('closedir');

    if ( not defined $filter ) {
        @children = grep { $_ ne '.' && $_ ne '..' } @children;
    }
    elsif ( $filter && ref($filter) eq 'Regexp' ) {
        @children = grep { $_ ne '.' && $_ ne '..' && $_ =~ $filter } @children;
    }
    else {
        Carp::croak("Invalid argument '$filter' for children()");
    }

    return map { path( $self->[PATH], $_ ) } @children;
}

#pod =method chmod
#pod
#pod     path("foo.txt")->chmod(0777);
#pod     path("foo.txt")->chmod("0755");
#pod     path("foo.txt")->chmod("go-w");
#pod     path("foo.txt")->chmod("a=r,u+wx");
#pod
#pod Sets file or directory permissions.  The argument can be a numeric mode, a
#pod octal string beginning with a "0" or a limited subset of the symbolic mode use
#pod by F</bin/chmod>.
#pod
#pod The symbolic mode must be a comma-delimited list of mode clauses.  Clauses must
#pod match C<< qr/\A([augo]+)([=+-])([rwx]+)\z/ >>, which defines "who", "op" and
#pod "perms" parameters for each clause.  Unlike F</bin/chmod>, all three parameters
#pod are required for each clause, multiple ops are not allowed and permissions
#pod C<stugoX> are not supported.  (See L<File::chmod> for more complex needs.)
#pod
#pod Current API available since 0.053.
#pod
#pod =cut

sub chmod {
    my ( $self, $new_mode ) = @_;

    my $mode;
    if ( $new_mode =~ /\d/ ) {
        $mode = ( $new_mode =~ /^0/ ? oct($new_mode) : $new_mode );
    }
    elsif ( $new_mode =~ /[=+-]/ ) {
        $mode = _symbolic_chmod( $self->stat->mode & 07777, $new_mode ); ## no critic
    }
    else {
        Carp::croak("Invalid mode argument '$new_mode' for chmod()");
    }

    CORE::chmod( $mode, $self->[PATH] ) or $self->_throw("chmod");

    return 1;
}

#pod =method copy
#pod
#pod     path("/tmp/foo.txt")->copy("/tmp/bar.txt");
#pod
#pod Copies the current path to the given destination using L<File::Copy>'s
#pod C<copy> function. Upon success, returns the C<Path::Tiny> object for the
#pod newly copied file.
#pod
#pod Current API available since 0.070.
#pod
#pod =cut

# XXX do recursively for directories?
sub copy {
    my ( $self, $dest ) = @_;
    require File::Copy;
    File::Copy::copy( $self->[PATH], $dest )
      or Carp::croak("copy failed for $self to $dest: $!");

    return -d $dest ? path( $dest, $self->basename ) : path($dest);
}

#pod =method digest
#pod
#pod     $obj = path("/tmp/foo.txt")->digest;        # SHA-256
#pod     $obj = path("/tmp/foo.txt")->digest("MD5"); # user-selected
#pod     $obj = path("/tmp/foo.txt")->digest( { chunk_size => 1e6 }, "MD5" );
#pod
#pod Returns a hexadecimal digest for a file.  An optional hash reference of options may
#pod be given.  The only option is C<chunk_size>.  If C<chunk_size> is given, that many
#pod bytes will be read at a time.  If not provided, the entire file will be slurped
#pod into memory to compute the digest.
#pod
#pod Any subsequent arguments are passed to the constructor for L<Digest> to select
#pod an algorithm.  If no arguments are given, the default is SHA-256.
#pod
#pod Current API available since 0.056.
#pod
#pod =cut

sub digest {
    my ( $self, @opts ) = @_;
    my $args = ( @opts && ref $opts[0] eq 'HASH' ) ? shift @opts : {};
    $args = _get_args( $args, qw/chunk_size/ );
    unshift @opts, 'SHA-256' unless @opts;
    require Digest;
    my $digest = Digest->new(@opts);
    if ( $args->{chunk_size} ) {
        my $fh = $self->filehandle( { locked => 1 }, "<", ":unix" );
        my $buf;
        $digest->add($buf) while read $fh, $buf, $args->{chunk_size};
    }
    else {
        $digest->add( $self->slurp_raw );
    }
    return $digest->hexdigest;
}

#pod =method dirname (deprecated)
#pod
#pod     $name = path("/tmp/foo.txt")->dirname; # "/tmp/"
#pod
#pod Returns the directory portion you would get from calling
#pod C<< File::Spec->splitpath( $path->stringify ) >> or C<"."> for a path without a
#pod parent directory portion.  Because L<File::Spec> is inconsistent, the result
#pod might or might not have a trailing slash.  Because of this, this method is
#pod B<deprecated>.
#pod
#pod A better, more consistently approach is likely C<< $path->parent->stringify >>,
#pod which will not have a trailing slash except for a root directory.
#pod
#pod Deprecated in 0.056.
#pod
#pod =cut

sub dirname {
    my ($self) = @_;
    $self->_splitpath unless defined $self->[DIR];
    return length $self->[DIR] ? $self->[DIR] : ".";
}

#pod =method edit, edit_raw, edit_utf8
#pod
#pod     path("foo.txt")->edit( \&callback, $options );
#pod     path("foo.txt")->edit_utf8( \&callback );
#pod     path("foo.txt")->edit_raw( \&callback );
#pod
#pod These are convenience methods that allow "editing" a file using a single
#pod callback argument. They slurp the file using C<slurp>, place the contents
#pod inside a localized C<$_> variable, call the callback function (without
#pod arguments), and then write C<$_> (presumably mutated) back to the
#pod file with C<spew>.
#pod
#pod An optional hash reference may be used to pass options.  The only option is
#pod C<binmode>, which is passed to C<slurp> and C<spew>.
#pod
#pod C<edit_utf8> and C<edit_raw> act like their respective C<slurp_*> and
#pod C<spew_*> methods.
#pod
#pod Current API available since 0.077.
#pod
#pod =cut

sub edit {
    my $self = shift;
    my $cb   = shift;
    my $args = _get_args( shift, qw/binmode/ );
    Carp::croak("Callback for edit() must be a code reference")
      unless defined($cb) && ref($cb) eq 'CODE';

    local $_ =
      $self->slurp( exists( $args->{binmode} ) ? { binmode => $args->{binmode} } : () );
    $cb->();
    $self->spew( $args, $_ );

    return;
}

# this is done long-hand to benefit from slurp_utf8 optimizations
sub edit_utf8 {
    my ( $self, $cb ) = @_;
    Carp::croak("Callback for edit_utf8() must be a code reference")
      unless defined($cb) && ref($cb) eq 'CODE';

    local $_ = $self->slurp_utf8;
    $cb->();
    $self->spew_utf8($_);

    return;
}

sub edit_raw { $_[2] = { binmode => ":unix" }; goto &edit }

#pod =method edit_lines, edit_lines_utf8, edit_lines_raw
#pod
#pod     path("foo.txt")->edit_lines( \&callback, $options );
#pod     path("foo.txt")->edit_lines_utf8( \&callback );
#pod     path("foo.txt")->edit_lines_raw( \&callback );
#pod
#pod These are convenience methods that allow "editing" a file's lines using a
#pod single callback argument.  They iterate over the file: for each line, the
#pod line is put into a localized C<$_> variable, the callback function is
#pod executed (without arguments) and then C<$_> is written to a temporary file.
#pod When iteration is finished, the temporary file is atomically renamed over
#pod the original.
#pod
#pod An optional hash reference may be used to pass options.  The only option is
#pod C<binmode>, which is passed to the method that open handles for reading and
#pod writing.
#pod
#pod C<edit_lines_utf8> and C<edit_lines_raw> act like their respective
#pod C<slurp_*> and C<spew_*> methods.
#pod
#pod Current API available since 0.077.
#pod
#pod =cut

sub edit_lines {
    my $self = shift;
    my $cb   = shift;
    my $args = _get_args( shift, qw/binmode/ );
    Carp::croak("Callback for edit_lines() must be a code reference")
      unless defined($cb) && ref($cb) eq 'CODE';

    my $binmode = $args->{binmode};
    # get default binmode from caller's lexical scope (see "perldoc open")
    $binmode = ( ( caller(0) )[10] || {} )->{'open>'} unless defined $binmode;

    # writing need to follow the link and create the tempfile in the same
    # dir for later atomic rename
    my $resolved_path = $self->_resolve_symlinks;
    my $temp          = path( $resolved_path . $$ . int( rand( 2**31 ) ) );

    my $temp_fh = $temp->filehandle( { exclusive => 1, locked => 1 }, ">", $binmode );
    my $in_fh = $self->filehandle( { locked => 1 }, '<', $binmode );

    local $_;
    while (<$in_fh>) {
        $cb->();
        $temp_fh->print($_);
    }

    close $temp_fh or $self->_throw( 'close', $temp );
    close $in_fh or $self->_throw('close');

    return $temp->move($resolved_path);
}

sub edit_lines_raw { $_[2] = { binmode => ":unix" }; goto &edit_lines }

sub edit_lines_utf8 {
    $_[2] = { binmode => ":raw:encoding(UTF-8)" };
    goto &edit_lines;
}

#pod =method exists, is_file, is_dir
#pod
#pod     if ( path("/tmp")->exists ) { ... }     # -e
#pod     if ( path("/tmp")->is_dir ) { ... }     # -d
#pod     if ( path("/tmp")->is_file ) { ... }    # -e && ! -d
#pod
#pod Implements file test operations, this means the file or directory actually has
#pod to exist on the filesystem.  Until then, it's just a path.
#pod
#pod B<Note>: C<is_file> is not C<-f> because C<-f> is not the opposite of C<-d>.
#pod C<-f> means "plain file", excluding symlinks, devices, etc. that often can be
#pod read just like files.
#pod
#pod Use C<-f> instead if you really mean to check for a plain file.
#pod
#pod Current API available since 0.053.
#pod
#pod =cut

sub exists { -e $_[0]->[PATH] }

sub is_file { -e $_[0]->[PATH] && !-d _ }

sub is_dir { -d $_[0]->[PATH] }

#pod =method filehandle
#pod
#pod     $fh = path("/tmp/foo.txt")->filehandle($mode, $binmode);
#pod     $fh = path("/tmp/foo.txt")->filehandle({ locked => 1 }, $mode, $binmode);
#pod     $fh = path("/tmp/foo.txt")->filehandle({ exclusive => 1  }, $mode, $binmode);
#pod
#pod Returns an open file handle.  The C<$mode> argument must be a Perl-style
#pod read/write mode string ("<" ,">", ">>", etc.).  If a C<$binmode>
#pod is given, it is set during the C<open> call.
#pod
#pod An optional hash reference may be used to pass options.
#pod
#pod The C<locked> option governs file locking; if true, handles opened for writing,
#pod appending or read-write are locked with C<LOCK_EX>; otherwise, they are
#pod locked with C<LOCK_SH>.  When using C<locked>, ">" or "+>" modes will delay
#pod truncation until after the lock is acquired.
#pod
#pod The C<exclusive> option causes the open() call to fail if the file already
#pod exists.  This corresponds to the O_EXCL flag to sysopen / open(2).
#pod C<exclusive> implies C<locked> and will set it for you if you forget it.
#pod
#pod See C<openr>, C<openw>, C<openrw>, and C<opena> for sugar.
#pod
#pod Current API available since 0.066.
#pod
#pod =cut

# Note: must put binmode on open line, not subsequent binmode() call, so things
# like ":unix" actually stop perlio/crlf from being added

sub filehandle {
    my ( $self, @args ) = @_;
    my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {};
    $args = _get_args( $args, qw/locked exclusive/ );
    $args->{locked} = 1 if $args->{exclusive};
    my ( $opentype, $binmode ) = @args;

    $opentype = "<" unless defined $opentype;
    Carp::croak("Invalid file mode '$opentype'")
      unless grep { $opentype eq $_ } qw/< +< > +> >> +>>/;

    $binmode = ( ( caller(0) )[10] || {} )->{ 'open' . substr( $opentype, -1, 1 ) }
      unless defined $binmode;
    $binmode = "" unless defined $binmode;

    my ( $fh, $lock, $trunc );
    if ( $HAS_FLOCK && $args->{locked} && !$ENV{PERL_PATH_TINY_NO_FLOCK} ) {
        require Fcntl;
        # truncating file modes shouldn't truncate until lock acquired
        if ( grep { $opentype eq $_ } qw( > +> ) ) {
            # sysopen in write mode without truncation
            my $flags = $opentype eq ">" ? Fcntl::O_WRONLY() : Fcntl::O_RDWR();
            $flags |= Fcntl::O_CREAT();
            $flags |= Fcntl::O_EXCL() if $args->{exclusive};
            sysopen( $fh, $self->[PATH], $flags ) or $self->_throw("sysopen");

            # fix up the binmode since sysopen() can't specify layers like
            # open() and binmode() can't start with just :unix like open()
            if ( $binmode =~ s/^:unix// ) {
                # eliminate pseudo-layers
                binmode( $fh, ":raw" ) or $self->_throw("binmode (:raw)");
                # strip off real layers until only :unix is left
                while ( 1 < ( my $layers =()= PerlIO::get_layers( $fh, output => 1 ) ) ) {
                    binmode( $fh, ":pop" ) or $self->_throw("binmode (:pop)");
                }
            }

            # apply any remaining binmode layers
            if ( length $binmode ) {
                binmode( $fh, $binmode ) or $self->_throw("binmode ($binmode)");
            }

            # ask for lock and truncation
            $lock  = Fcntl::LOCK_EX();
            $trunc = 1;
        }
        elsif ( $^O eq 'aix' && $opentype eq "<" ) {
            # AIX can only lock write handles, so upgrade to RW and LOCK_EX if
            # the file is writable; otherwise give up on locking.  N.B.
            # checking -w before open to determine the open mode is an
            # unavoidable race condition
            if ( -w $self->[PATH] ) {
                $opentype = "+<";
                $lock     = Fcntl::LOCK_EX();
            }
        }
        else {
            $lock = $opentype eq "<" ? Fcntl::LOCK_SH() : Fcntl::LOCK_EX();
        }
    }

    unless ($fh) {
        my $mode = $opentype . $binmode;
        open $fh, $mode, $self->[PATH] or $self->_throw("open ($mode)");
    }

    do { flock( $fh, $lock ) or $self->_throw("flock ($lock)") } if $lock;
    do { truncate( $fh, 0 ) or $self->_throw("truncate") } if $trunc;

    return $fh;
}

#pod =method is_absolute, is_relative
#pod
#pod     if ( path("/tmp")->is_absolute ) { ... }
#pod     if ( path("/tmp")->is_relative ) { ... }
#pod
#pod Booleans for whether the path appears absolute or relative.
#pod
#pod Current API available since 0.001.
#pod
#pod =cut

sub is_absolute { substr( $_[0]->dirname, 0, 1 ) eq '/' }

sub is_relative { substr( $_[0]->dirname, 0, 1 ) ne '/' }

#pod =method is_rootdir
#pod
#pod     while ( ! $path->is_rootdir ) {
#pod         $path = $path->parent;
#pod         ...
#pod     }
#pod
#pod Boolean for whether the path is the root directory of the volume.  I.e. the
#pod C<dirname> is C<q[/]> and the C<basename> is C<q[]>.
#pod
#pod This works even on C<MSWin32> with drives and UNC volumes:
#pod
#pod     path("C:/")->is_rootdir;             # true
#pod     path("//server/share/")->is_rootdir; #true
#pod
#pod Current API available since 0.038.
#pod
#pod =cut

sub is_rootdir {
    my ($self) = @_;
    $self->_splitpath unless defined $self->[DIR];
    return $self->[DIR] eq '/' && $self->[FILE] eq '';
}

#pod =method iterator
#pod
#pod     $iter = path("/tmp")->iterator( \%options );
#pod
#pod Returns a code reference that walks a directory lazily.  Each invocation
#pod returns a C<Path::Tiny> object or undef when the iterator is exhausted.
#pod
#pod     $iter = path("/tmp")->iterator;
#pod     while ( $path = $iter->() ) {
#pod         ...
#pod     }
#pod
#pod The current and parent directory entries ("." and "..") will not
#pod be included.
#pod
#pod If the C<recurse> option is true, the iterator will walk the directory
#pod recursively, breadth-first.  If the C<follow_symlinks> option is also true,
#pod directory links will be followed recursively.  There is no protection against
#pod loops when following links. If a directory is not readable, it will not be
#pod followed.
#pod
#pod The default is the same as:
#pod
#pod     $iter = path("/tmp")->iterator( {
#pod         recurse         => 0,
#pod         follow_symlinks => 0,
#pod     } );
#pod
#pod For a more powerful, recursive iterator with built-in loop avoidance, see
#pod L<Path::Iterator::Rule>.
#pod
#pod See also L</visit>.
#pod
#pod Current API available since 0.016.
#pod
#pod =cut

sub iterator {
    my $self = shift;
    my $args = _get_args( shift, qw/recurse follow_symlinks/ );
    my @dirs = $self;
    my $current;
    return sub {
        my $next;
        while (@dirs) {
            if ( ref $dirs[0] eq 'Path::Tiny' ) {
                if ( !-r $dirs[0] ) {
                    # Directory is missing or not readable, so skip it.  There
                    # is still a race condition possible between the check and
                    # the opendir, but we can't easily differentiate between
                    # error cases that are OK to skip and those that we want
                    # to be exceptions, so we live with the race and let opendir
                    # be fatal.
                    shift @dirs and next;
                }
                $current = $dirs[0];
                my $dh;
                opendir( $dh, $current->[PATH] )
                  or $self->_throw( 'opendir', $current->[PATH] );
                $dirs[0] = $dh;
                if ( -l $current->[PATH] && !$args->{follow_symlinks} ) {
                    # Symlink attack! It was a real dir, but is now a symlink!
                    # N.B. we check *after* opendir so the attacker has to win
                    # two races: replace dir with symlink before opendir and
                    # replace symlink with dir before -l check above
                    shift @dirs and next;
                }
            }
            while ( defined( $next = readdir $dirs[0] ) ) {
                next if $next eq '.' || $next eq '..';
                my $path = $current->child($next);
                push @dirs, $path
                  if $args->{recurse} && -d $path && !( !$args->{follow_symlinks} && -l $path );
                return $path;
            }
            shift @dirs;
        }
        return;
    };
}

#pod =method lines, lines_raw, lines_utf8
#pod
#pod     @contents = path("/tmp/foo.txt")->lines;
#pod     @contents = path("/tmp/foo.txt")->lines(\%options);
#pod     @contents = path("/tmp/foo.txt")->lines_raw;
#pod     @contents = path("/tmp/foo.txt")->lines_utf8;
#pod
#pod     @contents = path("/tmp/foo.txt")->lines( { chomp => 1, count => 4 } );
#pod
#pod Returns a list of lines from a file.  Optionally takes a hash-reference of
#pod options.  Valid options are C<binmode>, C<count> and C<chomp>.
#pod
#pod If C<binmode> is provided, it will be set on the handle prior to reading.
#pod
#pod If a positive C<count> is provided, that many lines will be returned from the
#pod start of the file.  If a negative C<count> is provided, the entire file will be
#pod read, but only C<abs(count)> will be kept and returned.  If C<abs(count)>
#pod exceeds the number of lines in the file, all lines will be returned.
#pod
#pod If C<chomp> is set, any end-of-line character sequences (C<CR>, C<CRLF>, or
#pod C<LF>) will be removed from the lines returned.
#pod
#pod Because the return is a list, C<lines> in scalar context will return the number
#pod of lines (and throw away the data).
#pod
#pod     $number_of_lines = path("/tmp/foo.txt")->lines;
#pod
#pod C<lines_raw> is like C<lines> with a C<binmode> of C<:raw>.  We use C<:raw>
#pod instead of C<:unix> so PerlIO buffering can manage reading by line.
#pod
#pod C<lines_utf8> is like C<lines> with a C<binmode> of C<:raw:encoding(UTF-8)>
#pod (or L<PerlIO::utf8_strict>).  If L<Unicode::UTF8> 0.58+ is installed, a raw
#pod UTF-8 slurp will be done and then the lines will be split.  This is
#pod actually faster than relying on C<:encoding(UTF-8)>, though a bit memory
#pod intensive.  If memory use is a concern, consider C<openr_utf8> and
#pod iterating directly on the handle.
#pod
#pod Current API available since 0.065.
#pod
#pod =cut

sub lines {
    my $self    = shift;
    my $args    = _get_args( shift, qw/binmode chomp count/ );
    my $binmode = $args->{binmode};
    $binmode = ( ( caller(0) )[10] || {} )->{'open<'} unless defined $binmode;
    my $fh = $self->filehandle( { locked => 1 }, "<", $binmode );
    my $chomp = $args->{chomp};
    # XXX more efficient to read @lines then chomp(@lines) vs map?
    if ( $args->{count} ) {
        my ( $counter, $mod, @result ) = ( 0, abs( $args->{count} ) );
        while ( my $line = <$fh> ) {
            $line =~ s/(?:\x{0d}?\x{0a}|\x{0d})\z// if $chomp;
            $result[ $counter++ ] = $line;
            # for positive count, terminate after right number of lines
            last if $counter == $args->{count};
            # for negative count, eventually wrap around in the result array
            $counter %= $mod;
        }
        # reorder results if full and wrapped somewhere in the middle
        splice( @result, 0, 0, splice( @result, $counter ) )
          if @result == $mod && $counter % $mod;
        return @result;
    }
    elsif ($chomp) {
        return map { s/(?:\x{0d}?\x{0a}|\x{0d})\z//; $_ } <$fh>; ## no critic
    }
    else {
        return wantarray ? <$fh> : ( my $count =()= <$fh> );
    }
}

sub lines_raw {
    my $self = shift;
    my $args = _get_args( shift, qw/binmode chomp count/ );
    if ( $args->{chomp} && !$args->{count} ) {
        return split /\n/, slurp_raw($self);                    ## no critic
    }
    else {
        $args->{binmode} = ":raw";
        return lines( $self, $args );
    }
}

my $CRLF = qr/(?:\x{0d}?\x{0a}|\x{0d})/;

sub lines_utf8 {
    my $self = shift;
    my $args = _get_args( shift, qw/binmode chomp count/ );
    if (   ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) )
        && $args->{chomp}
        && !$args->{count} )
    {
        my $slurp = slurp_utf8($self);
        $slurp =~ s/$CRLF\z//; # like chomp, but full CR?LF|CR
        return split $CRLF, $slurp, -1; ## no critic
    }
    elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
        $args->{binmode} = ":unix:utf8_strict";
        return lines( $self, $args );
    }
    else {
        $args->{binmode} = ":raw:encoding(UTF-8)";
        return lines( $self, $args );
    }
}

#pod =method mkpath
#pod
#pod     path("foo/bar/baz")->mkpath;
#pod     path("foo/bar/baz")->mkpath( \%options );
#pod
#pod Like calling C<make_path> from L<File::Path>.  An optional hash reference
#pod is passed through to C<make_path>.  Errors will be trapped and an exception
#pod thrown.  Returns the list of directories created or an empty list if
#pod the directories already exist, just like C<make_path>.
#pod
#pod Current API available since 0.001.
#pod
#pod =cut

sub mkpath {
    my ( $self, $args ) = @_;
    $args = {} unless ref $args eq 'HASH';
    my $err;
    $args->{error} = \$err unless defined $args->{error};
    require File::Path;
    my @dirs = File::Path::make_path( $self->[PATH], $args );
    if ( $err && @$err ) {
        my ( $file, $message ) = %{ $err->[0] };
        Carp::croak("mkpath failed for $file: $message");
    }
    return @dirs;
}

#pod =method move
#pod
#pod     path("foo.txt")->move("bar.txt");
#pod
#pod Move the current path to the given destination path using Perl's
#pod built-in L<rename|perlfunc/rename> function. Returns the result
#pod of the C<rename> function (except it throws an exception if it fails).
#pod
#pod Current API available since 0.001.
#pod
#pod =cut

sub move {
    my ( $self, $dst ) = @_;

    return rename( $self->[PATH], $dst )
      || $self->_throw( 'rename', $self->[PATH] . "' -> '$dst" );
}

#pod =method openr, openw, openrw, opena
#pod
#pod     $fh = path("foo.txt")->openr($binmode);  # read
#pod     $fh = path("foo.txt")->openr_raw;
#pod     $fh = path("foo.txt")->openr_utf8;
#pod
#pod     $fh = path("foo.txt")->openw($binmode);  # write
#pod     $fh = path("foo.txt")->openw_raw;
#pod     $fh = path("foo.txt")->openw_utf8;
#pod
#pod     $fh = path("foo.txt")->opena($binmode);  # append
#pod     $fh = path("foo.txt")->opena_raw;
#pod     $fh = path("foo.txt")->opena_utf8;
#pod
#pod     $fh = path("foo.txt")->openrw($binmode); # read/write
#pod     $fh = path("foo.txt")->openrw_raw;
#pod     $fh = path("foo.txt")->openrw_utf8;
#pod
#pod Returns a file handle opened in the specified mode.  The C<openr> style methods
#pod take a single C<binmode> argument.  All of the C<open*> methods have
#pod C<open*_raw> and C<open*_utf8> equivalents that use C<:raw> and
#pod C<:raw:encoding(UTF-8)>, respectively.
#pod
#pod An optional hash reference may be used to pass options.  The only option is
#pod C<locked>.  If true, handles opened for writing, appending or read-write are
#pod locked with C<LOCK_EX>; otherwise, they are locked for C<LOCK_SH>.
#pod
#pod     $fh = path("foo.txt")->openrw_utf8( { locked => 1 } );
#pod
#pod See L</filehandle> for more on locking.
#pod
#pod Current API available since 0.011.
#pod
#pod =cut

# map method names to corresponding open mode
my %opens = (
    opena  => ">>",
    openr  => "<",
    openw  => ">",
    openrw => "+<"
);

while ( my ( $k, $v ) = each %opens ) {
    no strict 'refs';
    # must check for lexical IO mode hint
    *{$k} = sub {
        my ( $self, @args ) = @_;
        my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {};
        $args = _get_args( $args, qw/locked/ );
        my ($binmode) = @args;
        $binmode = ( ( caller(0) )[10] || {} )->{ 'open' . substr( $v, -1, 1 ) }
          unless defined $binmode;
        $self->filehandle( $args, $v, $binmode );
    };
    *{ $k . "_raw" } = sub {
        my ( $self, @args ) = @_;
        my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {};
        $args = _get_args( $args, qw/locked/ );
        $self->filehandle( $args, $v, ":raw" );
    };
    *{ $k . "_utf8" } = sub {
        my ( $self, @args ) = @_;
        my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {};
        $args = _get_args( $args, qw/locked/ );
        $self->filehandle( $args, $v, ":raw:encoding(UTF-8)" );
    };
}

#pod =method parent
#pod
#pod     $parent = path("foo/bar/baz")->parent; # foo/bar
#pod     $parent = path("foo/wibble.txt")->parent; # foo
#pod
#pod     $parent = path("foo/bar/baz")->parent(2); # foo
#pod
#pod Returns a C<Path::Tiny> object corresponding to the parent directory of the
#pod original directory or file. An optional positive integer argument is the number
#pod of parent directories upwards to return.  C<parent> by itself is equivalent to
#pod C<parent(1)>.
#pod
#pod Current API available since 0.014.
#pod
#pod =cut

# XXX this is ugly and coverage is incomplete.  I think it's there for windows
# so need to check coverage there and compare
sub parent {
    my ( $self, $level ) = @_;
    $level = 1 unless defined $level && $level > 0;
    $self->_splitpath unless defined $self->[FILE];
    my $parent;
    if ( length $self->[FILE] ) {
        if ( $self->[FILE] eq '.' || $self->[FILE] eq ".." ) {
            $parent = path( $self->[PATH] . "/.." );
        }
        else {
            $parent = path( _non_empty( $self->[VOL] . $self->[DIR] ) );
        }
    }
    elsif ( length $self->[DIR] ) {
        # because of symlinks, any internal updir requires us to
        # just add more updirs at the end
        if ( $self->[DIR] =~ m{(?:^\.\./|/\.\./|/\.\.\z)} ) {
            $parent = path( $self->[VOL] . $self->[DIR] . "/.." );
        }
        else {
            ( my $dir = $self->[DIR] ) =~ s{/[^\/]+/\z}{/};
            $parent = path( $self->[VOL] . $dir );
        }
    }
    else {
        $parent = path( _non_empty( $self->[VOL] ) );
    }
    return $level == 1 ? $parent : $parent->parent( $level - 1 );
}

sub _non_empty {
    my ($string) = shift;
    return ( ( defined($string) && length($string) ) ? $string : "." );
}

#pod =method realpath
#pod
#pod     $real = path("/baz/foo/../bar")->realpath;
#pod     $real = path("foo/../bar")->realpath;
#pod
#pod Returns a new C<Path::Tiny> object with all symbolic links and upward directory
#pod parts resolved using L<Cwd>'s C<realpath>.  Compared to C<absolute>, this is
#pod more expensive as it must actually consult the filesystem.
#pod
#pod If the parent path can't be resolved (e.g. if it includes directories that
#pod don't exist), an exception will be thrown:
#pod
#pod     $real = path("doesnt_exist/foo")->realpath; # dies
#pod
#pod However, if the parent path exists and only the last component (e.g. filename)
#pod doesn't exist, the realpath will be the realpath of the parent plus the
#pod non-existent last component:
#pod
#pod     $real = path("./aasdlfasdlf")->realpath; # works
#pod
#pod The underlying L<Cwd> module usually worked this way on Unix, but died on
#pod Windows (and some Unixes) if the full path didn't exist.  As of version 0.064,
#pod it's safe to use anywhere.
#pod
#pod Current API available since 0.001.
#pod
#pod =cut

# Win32 and some Unixes need parent path resolved separately so realpath
# doesn't throw an error resolving non-existent basename
sub realpath {
    my $self = shift;
    $self = $self->_resolve_symlinks;
    require Cwd;
    $self->_splitpath if !defined $self->[FILE];
    my $check_parent =
      length $self->[FILE] && $self->[FILE] ne '.' && $self->[FILE] ne '..';
    my $realpath = eval {
        # pure-perl Cwd can carp
        local $SIG{__WARN__} = sub { };
        Cwd::realpath( $check_parent ? $self->parent->[PATH] : $self->[PATH] );
    };
    # parent realpath must exist; not all Cwd::realpath will error if it doesn't
    $self->_throw("resolving realpath")
      unless defined $realpath && length $realpath && -e $realpath;
    return ( $check_parent ? path( $realpath, $self->[FILE] ) : path($realpath) );
}

#pod =method relative
#pod
#pod     $rel = path("/tmp/foo/bar")->relative("/tmp"); # foo/bar
#pod
#pod Returns a C<Path::Tiny> object with a path relative to a new base path
#pod given as an argument.  If no argument is given, the current directory will
#pod be used as the new base path.
#pod
#pod If either path is already relative, it will be made absolute based on the
#pod current directly before determining the new relative path.
#pod
#pod The algorithm is roughly as follows:
#pod
#pod =for :list
#pod * If the original and new base path are on different volumes, an exception
#pod   will be thrown.
#pod * If the original and new base are identical, the relative path is C<".">.
#pod * If the new base subsumes the original, the relative path is the original
#pod   path with the new base chopped off the front
#pod * If the new base does not subsume the original, a common prefix path is
#pod   determined (possibly the root directory) and the relative path will
#pod   consist of updirs (C<"..">) to reach the common prefix, followed by the
#pod   original path less the common prefix.
#pod
#pod Unlike C<File::Spec::abs2rel>, in the last case above, the calculation based
#pod on a common prefix takes into account symlinks that could affect the updir
#pod process.  Given an original path "/A/B" and a new base "/A/C",
#pod (where "A", "B" and "C" could each have multiple path components):
#pod
#pod =for :list
#pod * Symlinks in "A" don't change the result unless the last component of A is
#pod   a symlink and the first component of "C" is an updir.
#pod * Symlinks in "B" don't change the result and will exist in the result as
#pod   given.
#pod * Symlinks and updirs in "C" must be resolved to actual paths, taking into
#pod   account the possibility that not all path components might exist on the
#pod   filesystem.
#pod
#pod Current API available since 0.001.  New algorithm (that accounts for
#pod symlinks) available since 0.079.
#pod
#pod =cut

sub relative {
    my ( $self, $base ) = @_;
    $base = path( defined $base && length $base ? $base : '.' );

    # relative paths must be converted to absolute first
    $self = $self->absolute if $self->is_relative;
    $base = $base->absolute if $base->is_relative;

    # normalize volumes if they exist
    $self = $self->absolute if !length $self->volume && length $base->volume;
    $base = $base->absolute if length $self->volume  && !length $base->volume;

    # can't make paths relative across volumes
    if ( !_same( $self->volume, $base->volume ) ) {
        Carp::croak("relative() can't cross volumes: '$self' vs '$base'");
    }

    # if same absolute path, relative is current directory
    return path(".") if _same( $self->[PATH], $base->[PATH] );

    # if base is a prefix of self, chop prefix off self
    if ( $base->subsumes($self) ) {
        $base = "" if $base->is_rootdir;
        my $relative = "$self";
        $relative =~ s{\A\Q$base/}{};
        return path($relative);
    }

    # base is not a prefix, so must find a common prefix (even if root)
    my ( @common, @self_parts, @base_parts );
    @base_parts = split /\//, $base->_just_filepath;

    # if self is rootdir, then common directory is root (shown as empty
    # string for later joins); otherwise, must be computed from path parts.
    if ( $self->is_rootdir ) {
        @common = ("");
        shift @base_parts;
    }
    else {
        @self_parts = split /\//, $self->_just_filepath;

        while ( @self_parts && @base_parts && _same( $self_parts[0], $base_parts[0] ) ) {
            push @common, shift @base_parts;
            shift @self_parts;
        }
    }

    # if there are any symlinks from common to base, we have a problem, as
    # you can't guarantee that updir from base reaches the common prefix;
    # we must resolve symlinks and try again; likewise, any updirs are
    # a problem as it throws off calculation of updirs needed to get from
    # self's path to the common prefix.
    if ( my $new_base = $self->_resolve_between( \@common, \@base_parts ) ) {
        return $self->relative($new_base);
    }

    # otherwise, symlinks in common or from common to A don't matter as
    # those don't involve updirs
    my @new_path = ( ("..") x ( 0+ @base_parts ), @self_parts );
    return path(@new_path);
}

sub _just_filepath {
    my $self     = shift;
    my $self_vol = $self->volume;
    return "$self" if !length $self_vol;

    ( my $self_path = "$self" ) =~ s{\A\Q$self_vol}{};

    return $self_path;
}

sub _resolve_between {
    my ( $self, $common, $base ) = @_;
    my $path = $self->volume . join( "/", @$common );
    my $changed = 0;
    for my $p (@$base) {
        $path .= "/$p";
        if ( $p eq '..' ) {
            $changed = 1;
            if ( -e $path ) {
                $path = path($path)->realpath->[PATH];
            }
            else {
                $path =~ s{/[^/]+/..\z}{/};
            }
        }
        if ( -l $path ) {
            $changed = 1;
            $path    = path($path)->realpath->[PATH];
        }
    }
    return $changed ? path($path) : undef;
}

#pod =method remove
#pod
#pod     path("foo.txt")->remove;
#pod
#pod This is just like C<unlink>, except for its error handling: if the path does
#pod not exist, it returns false; if deleting the file fails, it throws an
#pod exception.
#pod
#pod Current API available since 0.012.
#pod
#pod =cut

sub remove {
    my $self = shift;

    return 0 if !-e $self->[PATH] && !-l $self->[PATH];

    return unlink( $self->[PATH] ) || $self->_throw('unlink');
}

#pod =method remove_tree
#pod
#pod     # directory
#pod     path("foo/bar/baz")->remove_tree;
#pod     path("foo/bar/baz")->remove_tree( \%options );
#pod     path("foo/bar/baz")->remove_tree( { safe => 0 } ); # force remove
#pod
#pod Like calling C<remove_tree> from L<File::Path>, but defaults to C<safe> mode.
#pod An optional hash reference is passed through to C<remove_tree>.  Errors will be
#pod trapped and an exception thrown.  Returns the number of directories deleted,
#pod just like C<remove_tree>.
#pod
#pod If you want to remove a directory only if it is empty, use the built-in
#pod C<rmdir> function instead.
#pod
#pod     rmdir path("foo/bar/baz/");
#pod
#pod Current API available since 0.013.
#pod
#pod =cut

sub remove_tree {
    my ( $self, $args ) = @_;
    return 0 if !-e $self->[PATH] && !-l $self->[PATH];
    $args = {} unless ref $args eq 'HASH';
    my $err;
    $args->{error} = \$err unless defined $args->{error};
    $args->{safe}  = 1     unless defined $args->{safe};
    require File::Path;
    my $count = File::Path::remove_tree( $self->[PATH], $args );

    if ( $err && @$err ) {
        my ( $file, $message ) = %{ $err->[0] };
        Carp::croak("remove_tree failed for $file: $message");
    }
    return $count;
}

#pod =method sibling
#pod
#pod     $foo = path("/tmp/foo.txt");
#pod     $sib = $foo->sibling("bar.txt");        # /tmp/bar.txt
#pod     $sib = $foo->sibling("baz", "bam.txt"); # /tmp/baz/bam.txt
#pod
#pod Returns a new C<Path::Tiny> object relative to the parent of the original.
#pod This is slightly more efficient than C<< $path->parent->child(...) >>.
#pod
#pod Current API available since 0.058.
#pod
#pod =cut

sub sibling {
    my $self = shift;
    return path( $self->parent->[PATH], @_ );
}

#pod =method slurp, slurp_raw, slurp_utf8
#pod
#pod     $data = path("foo.txt")->slurp;
#pod     $data = path("foo.txt")->slurp( {binmode => ":raw"} );
#pod     $data = path("foo.txt")->slurp_raw;
#pod     $data = path("foo.txt")->slurp_utf8;
#pod
#pod Reads file contents into a scalar.  Takes an optional hash reference which may
#pod be used to pass options.  The only available option is C<binmode>, which is
#pod passed to C<binmode()> on the handle used for reading.
#pod
#pod C<slurp_raw> is like C<slurp> with a C<binmode> of C<:unix> for
#pod a fast, unbuffered, raw read.
#pod
#pod C<slurp_utf8> is like C<slurp> with a C<binmode> of
#pod C<:unix:encoding(UTF-8)> (or L<PerlIO::utf8_strict>).  If L<Unicode::UTF8>
#pod 0.58+ is installed, a raw slurp will be done instead and the result decoded
#pod with C<Unicode::UTF8>.  This is just as strict and is roughly an order of
#pod magnitude faster than using C<:encoding(UTF-8)>.
#pod
#pod B<Note>: C<slurp> and friends lock the filehandle before slurping.  If
#pod you plan to slurp from a file created with L<File::Temp>, be sure to
#pod close other handles or open without locking to avoid a deadlock:
#pod
#pod     my $tempfile = File::Temp->new(EXLOCK => 0);
#pod     my $guts = path($tempfile)->slurp;
#pod
#pod Current API available since 0.004.
#pod
#pod =cut

sub slurp {
    my $self    = shift;
    my $args    = _get_args( shift, qw/binmode/ );
    my $binmode = $args->{binmode};
    $binmode = ( ( caller(0) )[10] || {} )->{'open<'} unless defined $binmode;
    my $fh = $self->filehandle( { locked => 1 }, "<", $binmode );
    if ( ( defined($binmode) ? $binmode : "" ) eq ":unix"
        and my $size = -s $fh )
    {
        my $buf;
        read $fh, $buf, $size; # File::Slurp in a nutshell
        return $buf;
    }
    else {
        local $/;
        return scalar <$fh>;
    }
}

sub slurp_raw { $_[1] = { binmode => ":unix" }; goto &slurp }

sub slurp_utf8 {
    if ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) {
        return Unicode::UTF8::decode_utf8( slurp( $_[0], { binmode => ":unix" } ) );
    }
    elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
        $_[1] = { binmode => ":unix:utf8_strict" };
        goto &slurp;
    }
    else {
        $_[1] = { binmode => ":raw:encoding(UTF-8)" };
        goto &slurp;
    }
}

#pod =method spew, spew_raw, spew_utf8
#pod
#pod     path("foo.txt")->spew(@data);
#pod     path("foo.txt")->spew(\@data);
#pod     path("foo.txt")->spew({binmode => ":raw"}, @data);
#pod     path("foo.txt")->spew_raw(@data);
#pod     path("foo.txt")->spew_utf8(@data);
#pod
#pod Writes data to a file atomically.  The file is written to a temporary file in
#pod the same directory, then renamed over the original.  An optional hash reference
#pod may be used to pass options.  The only option is C<binmode>, which is passed to
#pod C<binmode()> on the handle used for writing.
#pod
#pod C<spew_raw> is like C<spew> with a C<binmode> of C<:unix> for a fast,
#pod unbuffered, raw write.
#pod
#pod C<spew_utf8> is like C<spew> with a C<binmode> of C<:unix:encoding(UTF-8)>
#pod (or L<PerlIO::utf8_strict>).  If L<Unicode::UTF8> 0.58+ is installed, a raw
#pod spew will be done instead on the data encoded with C<Unicode::UTF8>.
#pod
#pod B<NOTE>: because the file is written to a temporary file and then renamed, the
#pod new file will wind up with permissions based on your current umask.  This is a
#pod feature to protect you from a race condition that would otherwise give
#pod different permissions than you might expect.  If you really want to keep the
#pod original mode flags, use L</append> with the C<truncate> option.
#pod
#pod Current API available since 0.011.
#pod
#pod =cut

# XXX add "unsafe" option to disable flocking and atomic?  Check benchmarks on append() first.
sub spew {
    my ( $self, @data ) = @_;
    my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {};
    $args = _get_args( $args, qw/binmode/ );
    my $binmode = $args->{binmode};
    # get default binmode from caller's lexical scope (see "perldoc open")
    $binmode = ( ( caller(0) )[10] || {} )->{'open>'} unless defined $binmode;

    # spewing need to follow the link
    # and create the tempfile in the same dir
    my $resolved_path = $self->_resolve_symlinks;

    my $temp = path( $resolved_path . $$ . int( rand( 2**31 ) ) );
    my $fh = $temp->filehandle( { exclusive => 1, locked => 1 }, ">", $binmode );
    print {$fh} map { ref eq 'ARRAY' ? @$_ : $_ } @data;
    close $fh or $self->_throw( 'close', $temp->[PATH] );

    return $temp->move($resolved_path);
}

sub spew_raw { splice @_, 1, 0, { binmode => ":unix" }; goto &spew }

sub spew_utf8 {
    if ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) {
        my $self = shift;
        spew(
            $self,
            { binmode => ":unix" },
            map { Unicode::UTF8::encode_utf8($_) } map { ref eq 'ARRAY' ? @$_ : $_ } @_
        );
    }
    elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
        splice @_, 1, 0, { binmode => ":unix:utf8_strict" };
        goto &spew;
    }
    else {
        splice @_, 1, 0, { binmode => ":unix:encoding(UTF-8)" };
        goto &spew;
    }
}

#pod =method stat, lstat
#pod
#pod     $stat = path("foo.txt")->stat;
#pod     $stat = path("/some/symlink")->lstat;
#pod
#pod Like calling C<stat> or C<lstat> from L<File::stat>.
#pod
#pod Current API available since 0.001.
#pod
#pod =cut

# XXX break out individual stat() components as subs?
sub stat {
    my $self = shift;
    require File::stat;
    return File::stat::stat( $self->[PATH] ) || $self->_throw('stat');
}

sub lstat {
    my $self = shift;
    require File::stat;
    return File::stat::lstat( $self->[PATH] ) || $self->_throw('lstat');
}

#pod =method stringify
#pod
#pod     $path = path("foo.txt");
#pod     say $path->stringify; # same as "$path"
#pod
#pod Returns a string representation of the path.  Unlike C<canonpath>, this method
#pod returns the path standardized with Unix-style C</> directory separators.
#pod
#pod Current API available since 0.001.
#pod
#pod =cut

sub stringify { $_[0]->[PATH] }

#pod =method subsumes
#pod
#pod     path("foo/bar")->subsumes("foo/bar/baz"); # true
#pod     path("/foo/bar")->subsumes("/foo/baz");   # false
#pod
#pod Returns true if the first path is a prefix of the second path at a directory
#pod boundary.
#pod
#pod This B<does not> resolve parent directory entries (C<..>) or symlinks:
#pod
#pod     path("foo/bar")->subsumes("foo/bar/../baz"); # true
#pod
#pod If such things are important to you, ensure that both paths are resolved to
#pod the filesystem with C<realpath>:
#pod
#pod     my $p1 = path("foo/bar")->realpath;
#pod     my $p2 = path("foo/bar/../baz")->realpath;
#pod     if ( $p1->subsumes($p2) ) { ... }
#pod
#pod Current API available since 0.048.
#pod
#pod =cut

sub subsumes {
    my $self = shift;
    Carp::croak("subsumes() requires a defined, positive-length argument")
      unless defined $_[0];
    my $other = path(shift);

    # normalize absolute vs relative
    if ( $self->is_absolute && !$other->is_absolute ) {
        $other = $other->absolute;
    }
    elsif ( $other->is_absolute && !$self->is_absolute ) {
        $self = $self->absolute;
    }

    # normalize volume vs non-volume; do this after absolute path
    # adjustments above since that might add volumes already
    if ( length $self->volume && !length $other->volume ) {
        $other = $other->absolute;
    }
    elsif ( length $other->volume && !length $self->volume ) {
        $self = $self->absolute;
    }

    if ( $self->[PATH] eq '.' ) {
        return !!1; # cwd subsumes everything relative
    }
    elsif ( $self->is_rootdir ) {
        # a root directory ("/", "c:/") already ends with a separator
        return $other->[PATH] =~ m{^\Q$self->[PATH]\E};
    }
    else {
        # exact match or prefix breaking at a separator
        return $other->[PATH] =~ m{^\Q$self->[PATH]\E(?:/|\z)};
    }
}

#pod =method touch
#pod
#pod     path("foo.txt")->touch;
#pod     path("foo.txt")->touch($epoch_secs);
#pod
#pod Like the Unix C<touch> utility.  Creates the file if it doesn't exist, or else
#pod changes the modification and access times to the current time.  If the first
#pod argument is the epoch seconds then it will be used.
#pod
#pod Returns the path object so it can be easily chained with other methods:
#pod
#pod     # won't die if foo.txt doesn't exist
#pod     $content = path("foo.txt")->touch->slurp;
#pod
#pod Current API available since 0.015.
#pod
#pod =cut

sub touch {
    my ( $self, $epoch ) = @_;
    if ( !-e $self->[PATH] ) {
        my $fh = $self->openw;
        close $fh or $self->_throw('close');
    }
    if ( defined $epoch ) {
        utime $epoch, $epoch, $self->[PATH]
          or $self->_throw("utime ($epoch)");
    }
    else {
        # literal undef prevents warnings :-(
        utime undef, undef, $self->[PATH]
          or $self->_throw("utime ()");
    }
    return $self;
}

#pod =method touchpath
#pod
#pod     path("bar/baz/foo.txt")->touchpath;
#pod
#pod Combines C<mkpath> and C<touch>.  Creates the parent directory if it doesn't exist,
#pod before touching the file.  Returns the path object like C<touch> does.
#pod
#pod Current API available since 0.022.
#pod
#pod =cut

sub touchpath {
    my ($self) = @_;
    my $parent = $self->parent;
    $parent->mkpath unless $parent->exists;
    $self->touch;
}

#pod =method visit
#pod
#pod     path("/tmp")->visit( \&callback, \%options );
#pod
#pod Executes a callback for each child of a directory.  It returns a hash
#pod reference with any state accumulated during iteration.
#pod
#pod The options are the same as for L</iterator> (which it uses internally):
#pod C<recurse> and C<follow_symlinks>.  Both default to false.
#pod
#pod The callback function will receive a C<Path::Tiny> object as the first argument
#pod and a hash reference to accumulate state as the second argument.  For example:
#pod
#pod     # collect files sizes
#pod     my $sizes = path("/tmp")->visit(
#pod         sub {
#pod             my ($path, $state) = @_;
#pod             return if $path->is_dir;
#pod             $state->{$path} = -s $path;
#pod         },
#pod         { recurse => 1 }
#pod     );
#pod
#pod For convenience, the C<Path::Tiny> object will also be locally aliased as the
#pod C<$_> global variable:
#pod
#pod     # print paths matching /foo/
#pod     path("/tmp")->visit( sub { say if /foo/ }, { recurse => 1} );
#pod
#pod If the callback returns a B<reference> to a false scalar value, iteration will
#pod terminate.  This is not the same as "pruning" a directory search; this just
#pod stops all iteration and returns the state hash reference.
#pod
#pod     # find up to 10 files larger than 100K
#pod     my $files = path("/tmp")->visit(
#pod         sub {
#pod             my ($path, $state) = @_;
#pod             $state->{$path}++ if -s $path > 102400
#pod             return \0 if keys %$state == 10;
#pod         },
#pod         { recurse => 1 }
#pod     );
#pod
#pod If you want more flexible iteration, use a module like L<Path::Iterator::Rule>.
#pod
#pod Current API available since 0.062.
#pod
#pod =cut

sub visit {
    my $self = shift;
    my $cb   = shift;
    my $args = _get_args( shift, qw/recurse follow_symlinks/ );
    Carp::croak("Callback for visit() must be a code reference")
      unless defined($cb) && ref($cb) eq 'CODE';
    my $next  = $self->iterator($args);
    my $state = {};
    while ( my $file = $next->() ) {
        local $_ = $file;
        my $r = $cb->( $file, $state );
        last if ref($r) eq 'SCALAR' && !$$r;
    }
    return $state;
}

#pod =method volume
#pod
#pod     $vol = path("/tmp/foo.txt")->volume;   # ""
#pod     $vol = path("C:/tmp/foo.txt")->volume; # "C:"
#pod
#pod Returns the volume portion of the path.  This is equivalent
#pod to what L<File::Spec> would give from C<splitpath> and thus
#pod usually is the empty string on Unix-like operating systems or the
#pod drive letter for an absolute path on C<MSWin32>.
#pod
#pod Current API available since 0.001.
#pod
#pod =cut

sub volume {
    my ($self) = @_;
    $self->_splitpath unless defined $self->[VOL];
    return $self->[VOL];
}

package Path::Tiny::Error;

our @CARP_NOT = qw/Path::Tiny/;

use overload ( q{""} => sub { (shift)->{msg} }, fallback => 1 );

sub throw {
    my ( $class, $op, $file, $err ) = @_;
    chomp( my $trace = Carp::shortmess );
    my $msg = "Error $op on '$file': $err$trace\n";
    die bless { op => $op, file => $file, err => $err, msg => $msg }, $class;
}

1;


# vim: ts=4 sts=4 sw=4 et:

__END__

=pod

=encoding UTF-8

=head1 NAME

Path::Tiny - File path utility

=head1 VERSION

version 0.114

=head1 SYNOPSIS

  use Path::Tiny;

  # creating Path::Tiny objects

  $dir = path("/tmp");
  $foo = path("foo.txt");

  $subdir = $dir->child("foo");
  $bar = $subdir->child("bar.txt");

  # stringifies as cleaned up path

  $file = path("./foo.txt");
  print $file; # "foo.txt"

  # reading files

  $guts = $file->slurp;
  $guts = $file->slurp_utf8;

  @lines = $file->lines;
  @lines = $file->lines_utf8;

  ($head) = $file->lines( {count => 1} );
  ($tail) = $file->lines( {count => -1} );

  # writing files

  $bar->spew( @data );
  $bar->spew_utf8( @data );

  # reading directories

  for ( $dir->children ) { ... }

  $iter = $dir->iterator;
  while ( my $next = $iter->() ) { ... }

=head1 DESCRIPTION

This module provides a small, fast utility for working with file paths.  It is
friendlier to use than L<File::Spec> and provides easy access to functions from
several other core file handling modules.  It aims to be smaller and faster
than many alternatives on CPAN, while helping people do many common things in
consistent and less error-prone ways.

Path::Tiny does not try to work for anything except Unix-like and Win32
platforms.  Even then, it might break if you try something particularly obscure
or tortuous.  (Quick!  What does this mean:
C<< ///../../..//./././a//b/.././c/././ >>?  And how does it differ on Win32?)

All paths are forced to have Unix-style forward slashes.  Stringifying
the object gives you back the path (after some clean up).

File input/output methods C<flock> handles before reading or writing,
as appropriate (if supported by the platform and/or filesystem).

The C<*_utf8> methods (C<slurp_utf8>, C<lines_utf8>, etc.) operate in raw
mode.  On Windows, that means they will not have CRLF translation from the
C<:crlf> IO layer.  Installing L<Unicode::UTF8> 0.58 or later will speed up
C<*_utf8> situations in many cases and is highly recommended.
Alternatively, installing L<PerlIO::utf8_strict> 0.003 or later will be
used in place of the default C<:encoding(UTF-8)>.

This module depends heavily on PerlIO layers for correct operation and thus
requires Perl 5.008001 or later.

=head1 CONSTRUCTORS

=head2 path

    $path = path("foo/bar");
    $path = path("/tmp", "file.txt"); # list
    $path = path(".");                # cwd
    $path = path("~user/file.txt");   # tilde processing

Constructs a C<Path::Tiny> object.  It doesn't matter if you give a file or
directory path.  It's still up to you to call directory-like methods only on
directories and file-like methods only on files.  This function is exported
automatically by default.

The first argument must be defined and have non-zero length or an exception
will be thrown.  This prevents subtle, dangerous errors with code like
C<< path( maybe_undef() )->remove_tree >>.

If the first component of the path is a tilde ('~') then the component will be
replaced with the output of C<glob('~')>.  If the first component of the path
is a tilde followed by a user name then the component will be replaced with
output of C<glob('~username')>.  Behaviour for non-existent users depends on
the output of C<glob> on the system.

On Windows, if the path consists of a drive identifier without a path component
(C<C:> or C<D:>), it will be expanded to the absolute path of the current
directory on that volume using C<Cwd::getdcwd()>.

If called with a single C<Path::Tiny> argument, the original is returned unless
the original is holding a temporary file or directory reference in which case a
stringified copy is made.

    $path = path("foo/bar");
    $temp = Path::Tiny->tempfile;

    $p2 = path($path); # like $p2 = $path
    $t2 = path($temp); # like $t2 = path( "$temp" )

This optimizes copies without proliferating references unexpectedly if a copy is
made by code outside your control.

Current API available since 0.017.

=head2 new

    $path = Path::Tiny->new("foo/bar");

This is just like C<path>, but with method call overhead.  (Why would you
do that?)

Current API available since 0.001.

=head2 cwd

    $path = Path::Tiny->cwd; # path( Cwd::getcwd )
    $path = cwd; # optional export

Gives you the absolute path to the current directory as a C<Path::Tiny> object.
This is slightly faster than C<< path(".")->absolute >>.

C<cwd> may be exported on request and used as a function instead of as a
method.

Current API available since 0.018.

=head2 rootdir

    $path = Path::Tiny->rootdir; # /
    $path = rootdir;             # optional export 

Gives you C<< File::Spec->rootdir >> as a C<Path::Tiny> object if you're too
picky for C<path("/")>.

C<rootdir> may be exported on request and used as a function instead of as a
method.

Current API available since 0.018.

=head2 tempfile, tempdir

    $temp = Path::Tiny->tempfile( @options );
    $temp = Path::Tiny->tempdir( @options );
    $temp = tempfile( @options ); # optional export
    $temp = tempdir( @options );  # optional export

C<tempfile> passes the options to C<< File::Temp->new >> and returns a C<Path::Tiny>
object with the file name.  The C<TMPDIR> option is enabled by default.

The resulting C<File::Temp> object is cached. When the C<Path::Tiny> object is
destroyed, the C<File::Temp> object will be as well.

C<File::Temp> annoyingly requires you to specify a custom template in slightly
different ways depending on which function or method you call, but
C<Path::Tiny> lets you ignore that and can take either a leading template or a
C<TEMPLATE> option and does the right thing.

    $temp = Path::Tiny->tempfile( "customXXXXXXXX" );             # ok
    $temp = Path::Tiny->tempfile( TEMPLATE => "customXXXXXXXX" ); # ok

The tempfile path object will be normalized to have an absolute path, even if
created in a relative directory using C<DIR>.  If you want it to have
the C<realpath> instead, pass a leading options hash like this:

    $real_temp = tempfile({realpath => 1}, @options);

C<tempdir> is just like C<tempfile>, except it calls
C<< File::Temp->newdir >> instead.

Both C<tempfile> and C<tempdir> may be exported on request and used as
functions instead of as methods.

B<Note>: for tempfiles, the filehandles from File::Temp are closed and not
reused.  This is not as secure as using File::Temp handles directly, but is
less prone to deadlocks or access problems on some platforms.  Think of what
C<Path::Tiny> gives you to be just a temporary file B<name> that gets cleaned
up.

B<Note 2>: if you don't want these cleaned up automatically when the object
is destroyed, File::Temp requires different options for directories and
files.  Use C<< CLEANUP => 0 >> for directories and C<< UNLINK => 0 >> for
files.

B<Note 3>: Don't lose the temporary object by chaining a method call instead
of storing it:

    my $lost = tempdir()->child("foo"); # tempdir cleaned up right away

B<Note 4>: The cached object may be accessed with the L</cached_temp> method.
Keeping a reference to, or modifying the cached object may break the
behavior documented above and is not supported.  Use at your own risk.

Current API available since 0.097.

=head1 METHODS

=head2 absolute

    $abs = path("foo/bar")->absolute;
    $abs = path("foo/bar")->absolute("/tmp");

Returns a new C<Path::Tiny> object with an absolute path (or itself if already
absolute).  If no argument is given, the current directory is used as the
absolute base path.  If an argument is given, it will be converted to an
absolute path (if it is not already) and used as the absolute base path.

This will not resolve upward directories ("foo/../bar") unless C<canonpath>
in L<File::Spec> would normally do so on your platform.  If you need them
resolved, you must call the more expensive C<realpath> method instead.

On Windows, an absolute path without a volume component will have it added
based on the current drive.

Current API available since 0.101.

=head2 append, append_raw, append_utf8

    path("foo.txt")->append(@data);
    path("foo.txt")->append(\@data);
    path("foo.txt")->append({binmode => ":raw"}, @data);
    path("foo.txt")->append_raw(@data);
    path("foo.txt")->append_utf8(@data);

Appends data to a file.  The file is locked with C<flock> prior to writing
and closed afterwards.  An optional hash reference may be used to pass
options.  Valid options are:

=over 4

=item *

C<binmode>: passed to C<binmode()> on the handle used for writing.

=item *

C<truncate>: truncates the file after locking and before appending

=back

The C<truncate> option is a way to replace the contents of a file
B<in place>, unlike L</spew> which writes to a temporary file and then
replaces the original (if it exists).

C<append_raw> is like C<append> with a C<binmode> of C<:unix> for fast,
unbuffered, raw write.

C<append_utf8> is like C<append> with a C<binmode> of
C<:unix:encoding(UTF-8)> (or L<PerlIO::utf8_strict>).  If L<Unicode::UTF8>
0.58+ is installed, a raw append will be done instead on the data encoded
with C<Unicode::UTF8>.

Current API available since 0.060.

=head2 assert

    $path = path("foo.txt")->assert( sub { $_->exists } );

Returns the invocant after asserting that a code reference argument returns
true.  When the assertion code reference runs, it will have the invocant
object in the C<$_> variable.  If it returns false, an exception will be
thrown.  The assertion code reference may also throw its own exception.

If no assertion is provided, the invocant is returned without error.

Current API available since 0.062.

=head2 basename

    $name = path("foo/bar.txt")->basename;        # bar.txt
    $name = path("foo.txt")->basename('.txt');    # foo
    $name = path("foo.txt")->basename(qr/.txt/);  # foo
    $name = path("foo.txt")->basename(@suffixes);

Returns the file portion or last directory portion of a path.

Given a list of suffixes as strings or regular expressions, any that match at
the end of the file portion or last directory portion will be removed before
the result is returned.

Current API available since 0.054.

=head2 canonpath

    $canonical = path("foo/bar")->canonpath; # foo\bar on Windows

Returns a string with the canonical format of the path name for
the platform.  In particular, this means directory separators
will be C<\> on Windows.

Current API available since 0.001.

=head2 cached_temp

Returns the cached C<File::Temp> or C<File::Temp::Dir> object if the
C<Path::Tiny> object was created with C</tempfile> or C</tempdir>.
If there is no such object, this method throws.

B<WARNING>: Keeping a reference to, or modifying the cached object may
break the behavior documented for temporary files and directories created
with C<Path::Tiny> and is not supported.  Use at your own risk.

Current API available since 0.101.

=head2 child

    $file = path("/tmp")->child("foo.txt"); # "/tmp/foo.txt"
    $file = path("/tmp")->child(@parts);

Returns a new C<Path::Tiny> object relative to the original.  Works
like C<catfile> or C<catdir> from File::Spec, but without caring about
file or directories.

B<WARNING>: because the argument could contain C<..> or refer to symlinks,
there is no guarantee that the new path refers to an actual descendent of
the original.  If this is important to you, transform parent and child with
L</realpath> and check them with L</subsumes>.

Current API available since 0.001.

=head2 children

    @paths = path("/tmp")->children;
    @paths = path("/tmp")->children( qr/\.txt\z/ );

Returns a list of C<Path::Tiny> objects for all files and directories
within a directory.  Excludes "." and ".." automatically.

If an optional C<qr//> argument is provided, it only returns objects for child
names that match the given regular expression.  Only the base name is used
for matching:

    @paths = path("/tmp")->children( qr/^foo/ );
    # matches children like the glob foo*

Current API available since 0.028.

=head2 chmod

    path("foo.txt")->chmod(0777);
    path("foo.txt")->chmod("0755");
    path("foo.txt")->chmod("go-w");
    path("foo.txt")->chmod("a=r,u+wx");

Sets file or directory permissions.  The argument can be a numeric mode, a
octal string beginning with a "0" or a limited subset of the symbolic mode use
by F</bin/chmod>.

The symbolic mode must be a comma-delimited list of mode clauses.  Clauses must
match C<< qr/\A([augo]+)([=+-])([rwx]+)\z/ >>, which defines "who", "op" and
"perms" parameters for each clause.  Unlike F</bin/chmod>, all three parameters
are required for each clause, multiple ops are not allowed and permissions
C<stugoX> are not supported.  (See L<File::chmod> for more complex needs.)

Current API available since 0.053.

=head2 copy

    path("/tmp/foo.txt")->copy("/tmp/bar.txt");

Copies the current path to the given destination using L<File::Copy>'s
C<copy> function. Upon success, returns the C<Path::Tiny> object for the
newly copied file.

Current API available since 0.070.

=head2 digest

    $obj = path("/tmp/foo.txt")->digest;        # SHA-256
    $obj = path("/tmp/foo.txt")->digest("MD5"); # user-selected
    $obj = path("/tmp/foo.txt")->digest( { chunk_size => 1e6 }, "MD5" );

Returns a hexadecimal digest for a file.  An optional hash reference of options may
be given.  The only option is C<chunk_size>.  If C<chunk_size> is given, that many
bytes will be read at a time.  If not provided, the entire file will be slurped
into memory to compute the digest.

Any subsequent arguments are passed to the constructor for L<Digest> to select
an algorithm.  If no arguments are given, the default is SHA-256.

Current API available since 0.056.

=head2 dirname (deprecated)

    $name = path("/tmp/foo.txt")->dirname; # "/tmp/"

Returns the directory portion you would get from calling
C<< File::Spec->splitpath( $path->stringify ) >> or C<"."> for a path without a
parent directory portion.  Because L<File::Spec> is inconsistent, the result
might or might not have a trailing slash.  Because of this, this method is
B<deprecated>.

A better, more consistently approach is likely C<< $path->parent->stringify >>,
which will not have a trailing slash except for a root directory.

Deprecated in 0.056.

=head2 edit, edit_raw, edit_utf8

    path("foo.txt")->edit( \&callback, $options );
    path("foo.txt")->edit_utf8( \&callback );
    path("foo.txt")->edit_raw( \&callback );

These are convenience methods that allow "editing" a file using a single
callback argument. They slurp the file using C<slurp>, place the contents
inside a localized C<$_> variable, call the callback function (without
arguments), and then write C<$_> (presumably mutated) back to the
file with C<spew>.

An optional hash reference may be used to pass options.  The only option is
C<binmode>, which is passed to C<slurp> and C<spew>.

C<edit_utf8> and C<edit_raw> act like their respective C<slurp_*> and
C<spew_*> methods.

Current API available since 0.077.

=head2 edit_lines, edit_lines_utf8, edit_lines_raw

    path("foo.txt")->edit_lines( \&callback, $options );
    path("foo.txt")->edit_lines_utf8( \&callback );
    path("foo.txt")->edit_lines_raw( \&callback );

These are convenience methods that allow "editing" a file's lines using a
single callback argument.  They iterate over the file: for each line, the
line is put into a localized C<$_> variable, the callback function is
executed (without arguments) and then C<$_> is written to a temporary file.
When iteration is finished, the temporary file is atomically renamed over
the original.

An optional hash reference may be used to pass options.  The only option is
C<binmode>, which is passed to the method that open handles for reading and
writing.

C<edit_lines_utf8> and C<edit_lines_raw> act like their respective
C<slurp_*> and C<spew_*> methods.

Current API available since 0.077.

=head2 exists, is_file, is_dir

    if ( path("/tmp")->exists ) { ... }     # -e
    if ( path("/tmp")->is_dir ) { ... }     # -d
    if ( path("/tmp")->is_file ) { ... }    # -e && ! -d

Implements file test operations, this means the file or directory actually has
to exist on the filesystem.  Until then, it's just a path.

B<Note>: C<is_file> is not C<-f> because C<-f> is not the opposite of C<-d>.
C<-f> means "plain file", excluding symlinks, devices, etc. that often can be
read just like files.

Use C<-f> instead if you really mean to check for a plain file.

Current API available since 0.053.

=head2 filehandle

    $fh = path("/tmp/foo.txt")->filehandle($mode, $binmode);
    $fh = path("/tmp/foo.txt")->filehandle({ locked => 1 }, $mode, $binmode);
    $fh = path("/tmp/foo.txt")->filehandle({ exclusive => 1  }, $mode, $binmode);

Returns an open file handle.  The C<$mode> argument must be a Perl-style
read/write mode string ("<" ,">", ">>", etc.).  If a C<$binmode>
is given, it is set during the C<open> call.

An optional hash reference may be used to pass options.

The C<locked> option governs file locking; if true, handles opened for writing,
appending or read-write are locked with C<LOCK_EX>; otherwise, they are
locked with C<LOCK_SH>.  When using C<locked>, ">" or "+>" modes will delay
truncation until after the lock is acquired.

The C<exclusive> option causes the open() call to fail if the file already
exists.  This corresponds to the O_EXCL flag to sysopen / open(2).
C<exclusive> implies C<locked> and will set it for you if you forget it.

See C<openr>, C<openw>, C<openrw>, and C<opena> for sugar.

Current API available since 0.066.

=head2 is_absolute, is_relative

    if ( path("/tmp")->is_absolute ) { ... }
    if ( path("/tmp")->is_relative ) { ... }

Booleans for whether the path appears absolute or relative.

Current API available since 0.001.

=head2 is_rootdir

    while ( ! $path->is_rootdir ) {
        $path = $path->parent;
        ...
    }

Boolean for whether the path is the root directory of the volume.  I.e. the
C<dirname> is C<q[/]> and the C<basename> is C<q[]>.

This works even on C<MSWin32> with drives and UNC volumes:

    path("C:/")->is_rootdir;             # true
    path("//server/share/")->is_rootdir; #true

Current API available since 0.038.

=head2 iterator

    $iter = path("/tmp")->iterator( \%options );

Returns a code reference that walks a directory lazily.  Each invocation
returns a C<Path::Tiny> object or undef when the iterator is exhausted.

    $iter = path("/tmp")->iterator;
    while ( $path = $iter->() ) {
        ...
    }

The current and parent directory entries ("." and "..") will not
be included.

If the C<recurse> option is true, the iterator will walk the directory
recursively, breadth-first.  If the C<follow_symlinks> option is also true,
directory links will be followed recursively.  There is no protection against
loops when following links. If a directory is not readable, it will not be
followed.

The default is the same as:

    $iter = path("/tmp")->iterator( {
        recurse         => 0,
        follow_symlinks => 0,
    } );

For a more powerful, recursive iterator with built-in loop avoidance, see
L<Path::Iterator::Rule>.

See also L</visit>.

Current API available since 0.016.

=head2 lines, lines_raw, lines_utf8

    @contents = path("/tmp/foo.txt")->lines;
    @contents = path("/tmp/foo.txt")->lines(\%options);
    @contents = path("/tmp/foo.txt")->lines_raw;
    @contents = path("/tmp/foo.txt")->lines_utf8;

    @contents = path("/tmp/foo.txt")->lines( { chomp => 1, count => 4 } );

Returns a list of lines from a file.  Optionally takes a hash-reference of
options.  Valid options are C<binmode>, C<count> and C<chomp>.

If C<binmode> is provided, it will be set on the handle prior to reading.

If a positive C<count> is provided, that many lines will be returned from the
start of the file.  If a negative C<count> is provided, the entire file will be
read, but only C<abs(count)> will be kept and returned.  If C<abs(count)>
exceeds the number of lines in the file, all lines will be returned.

If C<chomp> is set, any end-of-line character sequences (C<CR>, C<CRLF>, or
C<LF>) will be removed from the lines returned.

Because the return is a list, C<lines> in scalar context will return the number
of lines (and throw away the data).

    $number_of_lines = path("/tmp/foo.txt")->lines;

C<lines_raw> is like C<lines> with a C<binmode> of C<:raw>.  We use C<:raw>
instead of C<:unix> so PerlIO buffering can manage reading by line.

C<lines_utf8> is like C<lines> with a C<binmode> of C<:raw:encoding(UTF-8)>
(or L<PerlIO::utf8_strict>).  If L<Unicode::UTF8> 0.58+ is installed, a raw
UTF-8 slurp will be done and then the lines will be split.  This is
actually faster than relying on C<:encoding(UTF-8)>, though a bit memory
intensive.  If memory use is a concern, consider C<openr_utf8> and
iterating directly on the handle.

Current API available since 0.065.

=head2 mkpath

    path("foo/bar/baz")->mkpath;
    path("foo/bar/baz")->mkpath( \%options );

Like calling C<make_path> from L<File::Path>.  An optional hash reference
is passed through to C<make_path>.  Errors will be trapped and an exception
thrown.  Returns the list of directories created or an empty list if
the directories already exist, just like C<make_path>.

Current API available since 0.001.

=head2 move

    path("foo.txt")->move("bar.txt");

Move the current path to the given destination path using Perl's
built-in L<rename|perlfunc/rename> function. Returns the result
of the C<rename> function (except it throws an exception if it fails).

Current API available since 0.001.

=head2 openr, openw, openrw, opena

    $fh = path("foo.txt")->openr($binmode);  # read
    $fh = path("foo.txt")->openr_raw;
    $fh = path("foo.txt")->openr_utf8;

    $fh = path("foo.txt")->openw($binmode);  # write
    $fh = path("foo.txt")->openw_raw;
    $fh = path("foo.txt")->openw_utf8;

    $fh = path("foo.txt")->opena($binmode);  # append
    $fh = path("foo.txt")->opena_raw;
    $fh = path("foo.txt")->opena_utf8;

    $fh = path("foo.txt")->openrw($binmode); # read/write
    $fh = path("foo.txt")->openrw_raw;
    $fh = path("foo.txt")->openrw_utf8;

Returns a file handle opened in the specified mode.  The C<openr> style methods
take a single C<binmode> argument.  All of the C<open*> methods have
C<open*_raw> and C<open*_utf8> equivalents that use C<:raw> and
C<:raw:encoding(UTF-8)>, respectively.

An optional hash reference may be used to pass options.  The only option is
C<locked>.  If true, handles opened for writing, appending or read-write are
locked with C<LOCK_EX>; otherwise, they are locked for C<LOCK_SH>.

    $fh = path("foo.txt")->openrw_utf8( { locked => 1 } );

See L</filehandle> for more on locking.

Current API available since 0.011.

=head2 parent

    $parent = path("foo/bar/baz")->parent; # foo/bar
    $parent = path("foo/wibble.txt")->parent; # foo

    $parent = path("foo/bar/baz")->parent(2); # foo

Returns a C<Path::Tiny> object corresponding to the parent directory of the
original directory or file. An optional positive integer argument is the number
of parent directories upwards to return.  C<parent> by itself is equivalent to
C<parent(1)>.

Current API available since 0.014.

=head2 realpath

    $real = path("/baz/foo/../bar")->realpath;
    $real = path("foo/../bar")->realpath;

Returns a new C<Path::Tiny> object with all symbolic links and upward directory
parts resolved using L<Cwd>'s C<realpath>.  Compared to C<absolute>, this is
more expensive as it must actually consult the filesystem.

If the parent path can't be resolved (e.g. if it includes directories that
don't exist), an exception will be thrown:

    $real = path("doesnt_exist/foo")->realpath; # dies

However, if the parent path exists and only the last component (e.g. filename)
doesn't exist, the realpath will be the realpath of the parent plus the
non-existent last component:

    $real = path("./aasdlfasdlf")->realpath; # works

The underlying L<Cwd> module usually worked this way on Unix, but died on
Windows (and some Unixes) if the full path didn't exist.  As of version 0.064,
it's safe to use anywhere.

Current API available since 0.001.

=head2 relative

    $rel = path("/tmp/foo/bar")->relative("/tmp"); # foo/bar

Returns a C<Path::Tiny> object with a path relative to a new base path
given as an argument.  If no argument is given, the current directory will
be used as the new base path.

If either path is already relative, it will be made absolute based on the
current directly before determining the new relative path.

The algorithm is roughly as follows:

=over 4

=item *

If the original and new base path are on different volumes, an exception will be thrown.

=item *

If the original and new base are identical, the relative path is C<".">.

=item *

If the new base subsumes the original, the relative path is the original path with the new base chopped off the front

=item *

If the new base does not subsume the original, a common prefix path is determined (possibly the root directory) and the relative path will consist of updirs (C<"..">) to reach the common prefix, followed by the original path less the common prefix.

=back

Unlike C<File::Spec::abs2rel>, in the last case above, the calculation based
on a common prefix takes into account symlinks that could affect the updir
process.  Given an original path "/A/B" and a new base "/A/C",
(where "A", "B" and "C" could each have multiple path components):

=over 4

=item *

Symlinks in "A" don't change the result unless the last component of A is a symlink and the first component of "C" is an updir.

=item *

Symlinks in "B" don't change the result and will exist in the result as given.

=item *

Symlinks and updirs in "C" must be resolved to actual paths, taking into account the possibility that not all path components might exist on the filesystem.

=back

Current API available since 0.001.  New algorithm (that accounts for
symlinks) available since 0.079.

=head2 remove

    path("foo.txt")->remove;

This is just like C<unlink>, except for its error handling: if the path does
not exist, it returns false; if deleting the file fails, it throws an
exception.

Current API available since 0.012.

=head2 remove_tree

    # directory
    path("foo/bar/baz")->remove_tree;
    path("foo/bar/baz")->remove_tree( \%options );
    path("foo/bar/baz")->remove_tree( { safe => 0 } ); # force remove

Like calling C<remove_tree> from L<File::Path>, but defaults to C<safe> mode.
An optional hash reference is passed through to C<remove_tree>.  Errors will be
trapped and an exception thrown.  Returns the number of directories deleted,
just like C<remove_tree>.

If you want to remove a directory only if it is empty, use the built-in
C<rmdir> function instead.

    rmdir path("foo/bar/baz/");

Current API available since 0.013.

=head2 sibling

    $foo = path("/tmp/foo.txt");
    $sib = $foo->sibling("bar.txt");        # /tmp/bar.txt
    $sib = $foo->sibling("baz", "bam.txt"); # /tmp/baz/bam.txt

Returns a new C<Path::Tiny> object relative to the parent of the original.
This is slightly more efficient than C<< $path->parent->child(...) >>.

Current API available since 0.058.

=head2 slurp, slurp_raw, slurp_utf8

    $data = path("foo.txt")->slurp;
    $data = path("foo.txt")->slurp( {binmode => ":raw"} );
    $data = path("foo.txt")->slurp_raw;
    $data = path("foo.txt")->slurp_utf8;

Reads file contents into a scalar.  Takes an optional hash reference which may
be used to pass options.  The only available option is C<binmode>, which is
passed to C<binmode()> on the handle used for reading.

C<slurp_raw> is like C<slurp> with a C<binmode> of C<:unix> for
a fast, unbuffered, raw read.

C<slurp_utf8> is like C<slurp> with a C<binmode> of
C<:unix:encoding(UTF-8)> (or L<PerlIO::utf8_strict>).  If L<Unicode::UTF8>
0.58+ is installed, a raw slurp will be done instead and the result decoded
with C<Unicode::UTF8>.  This is just as strict and is roughly an order of
magnitude faster than using C<:encoding(UTF-8)>.

B<Note>: C<slurp> and friends lock the filehandle before slurping.  If
you plan to slurp from a file created with L<File::Temp>, be sure to
close other handles or open without locking to avoid a deadlock:

    my $tempfile = File::Temp->new(EXLOCK => 0);
    my $guts = path($tempfile)->slurp;

Current API available since 0.004.

=head2 spew, spew_raw, spew_utf8

    path("foo.txt")->spew(@data);
    path("foo.txt")->spew(\@data);
    path("foo.txt")->spew({binmode => ":raw"}, @data);
    path("foo.txt")->spew_raw(@data);
    path("foo.txt")->spew_utf8(@data);

Writes data to a file atomically.  The file is written to a temporary file in
the same directory, then renamed over the original.  An optional hash reference
may be used to pass options.  The only option is C<binmode>, which is passed to
C<binmode()> on the handle used for writing.

C<spew_raw> is like C<spew> with a C<binmode> of C<:unix> for a fast,
unbuffered, raw write.

C<spew_utf8> is like C<spew> with a C<binmode> of C<:unix:encoding(UTF-8)>
(or L<PerlIO::utf8_strict>).  If L<Unicode::UTF8> 0.58+ is installed, a raw
spew will be done instead on the data encoded with C<Unicode::UTF8>.

B<NOTE>: because the file is written to a temporary file and then renamed, the
new file will wind up with permissions based on your current umask.  This is a
feature to protect you from a race condition that would otherwise give
different permissions than you might expect.  If you really want to keep the
original mode flags, use L</append> with the C<truncate> option.

Current API available since 0.011.

=head2 stat, lstat

    $stat = path("foo.txt")->stat;
    $stat = path("/some/symlink")->lstat;

Like calling C<stat> or C<lstat> from L<File::stat>.

Current API available since 0.001.

=head2 stringify

    $path = path("foo.txt");
    say $path->stringify; # same as "$path"

Returns a string representation of the path.  Unlike C<canonpath>, this method
returns the path standardized with Unix-style C</> directory separators.

Current API available since 0.001.

=head2 subsumes

    path("foo/bar")->subsumes("foo/bar/baz"); # true
    path("/foo/bar")->subsumes("/foo/baz");   # false

Returns true if the first path is a prefix of the second path at a directory
boundary.

This B<does not> resolve parent directory entries (C<..>) or symlinks:

    path("foo/bar")->subsumes("foo/bar/../baz"); # true

If such things are important to you, ensure that both paths are resolved to
the filesystem with C<realpath>:

    my $p1 = path("foo/bar")->realpath;
    my $p2 = path("foo/bar/../baz")->realpath;
    if ( $p1->subsumes($p2) ) { ... }

Current API available since 0.048.

=head2 touch

    path("foo.txt")->touch;
    path("foo.txt")->touch($epoch_secs);

Like the Unix C<touch> utility.  Creates the file if it doesn't exist, or else
changes the modification and access times to the current time.  If the first
argument is the epoch seconds then it will be used.

Returns the path object so it can be easily chained with other methods:

    # won't die if foo.txt doesn't exist
    $content = path("foo.txt")->touch->slurp;

Current API available since 0.015.

=head2 touchpath

    path("bar/baz/foo.txt")->touchpath;

Combines C<mkpath> and C<touch>.  Creates the parent directory if it doesn't exist,
before touching the file.  Returns the path object like C<touch> does.

Current API available since 0.022.

=head2 visit

    path("/tmp")->visit( \&callback, \%options );

Executes a callback for each child of a directory.  It returns a hash
reference with any state accumulated during iteration.

The options are the same as for L</iterator> (which it uses internally):
C<recurse> and C<follow_symlinks>.  Both default to false.

The callback function will receive a C<Path::Tiny> object as the first argument
and a hash reference to accumulate state as the second argument.  For example:

    # collect files sizes
    my $sizes = path("/tmp")->visit(
        sub {
            my ($path, $state) = @_;
            return if $path->is_dir;
            $state->{$path} = -s $path;
        },
        { recurse => 1 }
    );

For convenience, the C<Path::Tiny> object will also be locally aliased as the
C<$_> global variable:

    # print paths matching /foo/
    path("/tmp")->visit( sub { say if /foo/ }, { recurse => 1} );

If the callback returns a B<reference> to a false scalar value, iteration will
terminate.  This is not the same as "pruning" a directory search; this just
stops all iteration and returns the state hash reference.

    # find up to 10 files larger than 100K
    my $files = path("/tmp")->visit(
        sub {
            my ($path, $state) = @_;
            $state->{$path}++ if -s $path > 102400
            return \0 if keys %$state == 10;
        },
        { recurse => 1 }
    );

If you want more flexible iteration, use a module like L<Path::Iterator::Rule>.

Current API available since 0.062.

=head2 volume

    $vol = path("/tmp/foo.txt")->volume;   # ""
    $vol = path("C:/tmp/foo.txt")->volume; # "C:"

Returns the volume portion of the path.  This is equivalent
to what L<File::Spec> would give from C<splitpath> and thus
usually is the empty string on Unix-like operating systems or the
drive letter for an absolute path on C<MSWin32>.

Current API available since 0.001.

=for Pod::Coverage openr_utf8 opena_utf8 openw_utf8 openrw_utf8
openr_raw opena_raw openw_raw openrw_raw
IS_WIN32 FREEZE THAW TO_JSON abs2rel

=head1 EXCEPTION HANDLING

Simple usage errors will generally croak.  Failures of underlying Perl
functions will be thrown as exceptions in the class
C<Path::Tiny::Error>.

A C<Path::Tiny::Error> object will be a hash reference with the following fields:

=over 4

=item *

C<op> — a description of the operation, usually function call and any extra info

=item *

C<file> — the file or directory relating to the error

=item *

C<err> — hold C<$!> at the time the error was thrown

=item *

C<msg> — a string combining the above data and a Carp-like short stack trace

=back

Exception objects will stringify as the C<msg> field.

=head1 ENVIRONMENT

=head2 PERL_PATH_TINY_NO_FLOCK

If the environment variable C<PERL_PATH_TINY_NO_FLOCK> is set to a true
value then flock will NOT be used when accessing files (this is not
recommended).

=head1 CAVEATS

=head2 Subclassing not supported

For speed, this class is implemented as an array based object and uses many
direct function calls internally.  You must not subclass it and expect
things to work properly.

=head2 File locking

If flock is not supported on a platform, it will not be used, even if
locking is requested.

In situations where a platform normally would support locking, but the
flock fails due to a filesystem limitation, Path::Tiny has some heuristics
to detect this and will warn once and continue in an unsafe mode.  If you
want this failure to be fatal, you can fatalize the 'flock' warnings
category:

    use warnings FATAL => 'flock';

See additional caveats below.

=head3 NFS and BSD

On BSD, Perl's flock implementation may not work to lock files on an
NFS filesystem.  If detected, this situation will warn once, as described
above.

=head3 Lustre

The Lustre filesystem does not support flock.  If detected, this situation
will warn once, as described above.

=head3 AIX and locking

AIX requires a write handle for locking.  Therefore, calls that normally
open a read handle and take a shared lock instead will open a read-write
handle and take an exclusive lock.  If the user does not have write
permission, no lock will be used.

=head2 utf8 vs UTF-8

All the C<*_utf8> methods by default use C<:encoding(UTF-8)> -- either as
C<:unix:encoding(UTF-8)> (unbuffered) or C<:raw:encoding(UTF-8)> (buffered) --
which is strict against the Unicode spec and disallows illegal Unicode
codepoints or UTF-8 sequences.

Unfortunately, C<:encoding(UTF-8)> is very, very slow.  If you install
L<Unicode::UTF8> 0.58 or later, that module will be used by some C<*_utf8>
methods to encode or decode data after a raw, binary input/output operation,
which is much faster.  Alternatively, if you install L<PerlIO::utf8_strict>,
that will be used instead of C<:encoding(UTF-8)> and is also very fast.

If you need the performance and can accept the security risk,
C<< slurp({binmode => ":unix:utf8"}) >> will be faster than C<:unix:encoding(UTF-8)>
(but not as fast as C<Unicode::UTF8>).

Note that the C<*_utf8> methods read in B<raw> mode.  There is no CRLF
translation on Windows.  If you must have CRLF translation, use the regular
input/output methods with an appropriate binmode:

  $path->spew_utf8($data);                            # raw
  $path->spew({binmode => ":encoding(UTF-8)"}, $data; # LF -> CRLF

=head2 Default IO layers and the open pragma

If you have Perl 5.10 or later, file input/output methods (C<slurp>, C<spew>,
etc.) and high-level handle opening methods ( C<filehandle>, C<openr>,
C<openw>, etc. ) respect default encodings set by the C<-C> switch or lexical
L<open> settings of the caller.  For UTF-8, this is almost certainly slower
than using the dedicated C<_utf8> methods if you have L<Unicode::UTF8>.

=head1 TYPE CONSTRAINTS AND COERCION

A standard L<MooseX::Types> library is available at
L<MooseX::Types::Path::Tiny>.  A L<Type::Tiny> equivalent is available as
L<Types::Path::Tiny>.

=head1 SEE ALSO

These are other file/path utilities, which may offer a different feature
set than C<Path::Tiny>.

=over 4

=item *

L<File::chmod>

=item *

L<File::Fu>

=item *

L<IO::All>

=item *

L<Path::Class>

=back

These iterators may be slightly faster than the recursive iterator in
C<Path::Tiny>:

=over 4

=item *

L<Path::Iterator::Rule>

=item *

L<File::Next>

=back

There are probably comparable, non-Tiny tools.  Let me know if you want me to
add a module to the list.

This module was featured in the L<2013 Perl Advent Calendar|http://www.perladvent.org/2013/2013-12-18.html>.

=for :stopwords cpan testmatrix url bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan

=head1 SUPPORT

=head2 Bugs / Feature Requests

Please report any bugs or feature requests through the issue tracker
at L<https://github.com/dagolden/Path-Tiny/issues>.
You will be notified automatically of any progress on your issue.

=head2 Source Code

This is open source software.  The code repository is available for
public review and contribution under the terms of the license.

L<https://github.com/dagolden/Path-Tiny>

  git clone https://github.com/dagolden/Path-Tiny.git

=head1 AUTHOR

David Golden <dagolden@cpan.org>

=head1 CONTRIBUTORS

=for stopwords Alex Efros Aristotle Pagaltzis Chris Williams Dan Book Dave Rolsky David Steinbrunner Doug Bell Gabor Szabo Gabriel Andrade George Hartzell Geraud Continsouzas Goro Fuji Graham Knop Ollis Ian Sillitoe James Hunt John Karr Karen Etheridge Mark Ellis Martin H. Sluka Kjeldsen Michael G. Schwern Nigel Gregoire Philippe Bruhat (BooK) Regina Verbae Roy Ivy III Shlomi Fish Smylers Tatsuhiko Miyagawa Toby Inkster Yanick Champoux 김도형 - Keedi Kim

=over 4

=item *

Alex Efros <powerman@powerman.name>

=item *

Aristotle Pagaltzis <pagaltzis@gmx.de>

=item *

Chris Williams <bingos@cpan.org>

=item *

Dan Book <grinnz@grinnz.com>

=item *

Dave Rolsky <autarch@urth.org>

=item *

David Steinbrunner <dsteinbrunner@pobox.com>

=item *

Doug Bell <madcityzen@gmail.com>

=item *

Gabor Szabo <szabgab@cpan.org>

=item *

Gabriel Andrade <gabiruh@gmail.com>

=item *

George Hartzell <hartzell@cpan.org>

=item *

Geraud Continsouzas <geraud@scsi.nc>

=item *

Goro Fuji <gfuji@cpan.org>

=item *

Graham Knop <haarg@haarg.org>

=item *

Graham Ollis <plicease@cpan.org>

=item *

Ian Sillitoe <ian@sillit.com>

=item *

James Hunt <james@niftylogic.com>

=item *

John Karr <brainbuz@brainbuz.org>

=item *

Karen Etheridge <ether@cpan.org>

=item *

Mark Ellis <mark.ellis@cartridgesave.co.uk>

=item *

Martin H. Sluka <fany@cpan.org>

=item *

Martin Kjeldsen <mk@bluepipe.dk>

=item *

Michael G. Schwern <mschwern@cpan.org>

=item *

Nigel Gregoire <nigelgregoire@gmail.com>

=item *

Philippe Bruhat (BooK) <book@cpan.org>

=item *

Regina Verbae <regina-verbae@users.noreply.github.com>

=item *

Roy Ivy III <rivy@cpan.org>

=item *

Shlomi Fish <shlomif@shlomifish.org>

=item *

Smylers <Smylers@stripey.com>

=item *

Tatsuhiko Miyagawa <miyagawa@bulknews.net>

=item *

Toby Inkster <tobyink@cpan.org>

=item *

Yanick Champoux <yanick@babyl.dyndns.org>

=item *

김도형 - Keedi Kim <keedi@cpan.org>

=back

=head1 COPYRIGHT AND LICENSE

This software is Copyright (c) 2014 by David Golden.

This is free software, licensed under:

  The Apache License, Version 2.0, January 2004

=cut
PK       ! ���9Z   Z   #  perl5/auto/Data/Uniqid/autosplit.ixnu ��6�$        # Index created by AutoSplit for blib/lib/Data/Uniqid.pm
#    (file acts as timestamp)
1;
PK       ! �����	  �	    perl5/LWP/Authen/Digest.pmnu ��6�$        package LWP::Authen::Digest;

use strict;
use base 'LWP::Authen::Basic';

our $VERSION = '6.49';

require Digest::MD5;

sub _reauth_requested {
    my ($class, $auth_param, $ua, $request, $auth_header) = @_;
    my $ret = defined($$auth_param{stale}) && lc($$auth_param{stale}) eq 'true';
    if ($ret) {
        my $hdr = $request->header($auth_header);
        $hdr =~ tr/,/;/;    # "," is used to separate auth-params!!
        ($hdr) = HTTP::Headers::Util::split_header_words($hdr);
        my $nonce = {@$hdr}->{nonce};
        delete $$ua{authen_md5_nonce_count}{$nonce};
    }
    return $ret;
}

sub auth_header {
    my($class, $user, $pass, $request, $ua, $h) = @_;

    my $auth_param = $h->{auth_param};

    my $nc = sprintf "%08X", ++$ua->{authen_md5_nonce_count}{$auth_param->{nonce}};
    my $cnonce = sprintf "%8x", time;

    my $uri = $request->uri->path_query;
    $uri = "/" unless length $uri;

    my $md5 = Digest::MD5->new;

    my(@digest);
    $md5->add(join(":", $user, $auth_param->{realm}, $pass));
    push(@digest, $md5->hexdigest);
    $md5->reset;

    push(@digest, $auth_param->{nonce});

    if ($auth_param->{qop}) {
	push(@digest, $nc, $cnonce, ($auth_param->{qop} =~ m|^auth[,;]auth-int$|) ? 'auth' : $auth_param->{qop});
    }

    $md5->add(join(":", $request->method, $uri));
    push(@digest, $md5->hexdigest);
    $md5->reset;

    $md5->add(join(":", @digest));
    my($digest) = $md5->hexdigest;
    $md5->reset;

    my %resp = map { $_ => $auth_param->{$_} } qw(realm nonce opaque);
    @resp{qw(username uri response algorithm)} = ($user, $uri, $digest, "MD5");

    if (($auth_param->{qop} || "") =~ m|^auth([,;]auth-int)?$|) {
	@resp{qw(qop cnonce nc)} = ("auth", $cnonce, $nc);
    }

    my(@order) = qw(username realm qop algorithm uri nonce nc cnonce response);
    if($request->method =~ /^(?:POST|PUT)$/) {
	$md5->add($request->content);
	my $content = $md5->hexdigest;
	$md5->reset;
	$md5->add(join(":", @digest[0..1], $content));
	$md5->reset;
	$resp{"message-digest"} = $md5->hexdigest;
	push(@order, "message-digest");
    }
    push(@order, "opaque");
    my @pairs;
    for (@order) {
	next unless defined $resp{$_};

	# RFC2617 says that qop-value and nc-value should be unquoted.
	if ( $_ eq 'qop' || $_ eq 'nc' ) {
		push(@pairs, "$_=" . $resp{$_});
	}
	else {
		push(@pairs, "$_=" . qq("$resp{$_}"));
	}
    }

    my $auth_value  = "Digest " . join(", ", @pairs);
    return $auth_value;
}

1;
PK       ! �&u��  �    perl5/LWP/Authen/Ntlm.pmnu ��6�$        package LWP::Authen::Ntlm;

use strict;

our $VERSION = '6.49';

use Authen::NTLM "1.02";
use MIME::Base64 "2.12";

sub authenticate {
    my($class, $ua, $proxy, $auth_param, $response,
       $request, $arg, $size) = @_;

    my($user, $pass) = $ua->get_basic_credentials($auth_param->{realm},
                                                  $request->uri, $proxy);

    unless(defined $user and defined $pass) {
		return $response;
	}

	if (!$ua->conn_cache()) {
		warn "The keep_alive option must be enabled for NTLM authentication to work.  NTLM authentication aborted.\n";
		return $response;
	}

	my($domain, $username) = split(/\\/, $user);

	ntlm_domain($domain);
	ntlm_user($username);
	ntlm_password($pass);

    my $auth_header = $proxy ? "Proxy-Authorization" : "Authorization";

	# my ($challenge) = $response->header('WWW-Authenticate');
	my $challenge;
	foreach ($response->header('WWW-Authenticate')) {
		last if /^NTLM/ && ($challenge=$_);
	}

	if ($challenge eq 'NTLM') {
		# First phase, send handshake
	    my $auth_value = "NTLM " . ntlm();
		ntlm_reset();

	    # Need to check this isn't a repeated fail!
	    my $r = $response;
		my $retry_count = 0;
	    while ($r) {
			my $auth = $r->request->header($auth_header);
			++$retry_count if ($auth && $auth eq $auth_value);
			if ($retry_count > 2) {
				    # here we know this failed before
				    $response->header("Client-Warning" =>
						      "Credentials for '$user' failed before");
				    return $response;
			}
			$r = $r->previous;
	    }

	    my $referral = $request->clone;
	    $referral->header($auth_header => $auth_value);
	    return $ua->request($referral, $arg, $size, $response);
	}

	else {
		# Second phase, use the response challenge (unless non-401 code
		#  was returned, in which case, we just send back the response
		#  object, as is
		my $auth_value;
		if ($response->code ne '401') {
			return $response;
		}
		else {
			my $challenge;
			foreach ($response->header('WWW-Authenticate')) {
				last if /^NTLM/ && ($challenge=$_);
			}
			$challenge =~ s/^NTLM //;
			ntlm();
			$auth_value = "NTLM " . ntlm($challenge);
			ntlm_reset();
		}

	    my $referral = $request->clone;
	    $referral->header($auth_header => $auth_value);
	    my $response2 = $ua->request($referral, $arg, $size, $response);
		return $response2;
	}
}

1;
__END__

=pod

=head1 NAME

LWP::Authen::Ntlm - Library for enabling NTLM authentication (Microsoft) in LWP

=head1 SYNOPSIS

 use LWP::UserAgent;
 use HTTP::Request::Common;
 my $url = 'http://www.company.com/protected_page.html';

 # Set up the ntlm client and then the base64 encoded ntlm handshake message
 my $ua = LWP::UserAgent->new(keep_alive=>1);
 $ua->credentials('www.company.com:80', '', "MyDomain\\MyUserCode", 'MyPassword');

 $request = GET $url;
 print "--Performing request now...-----------\n";
 $response = $ua->request($request);
 print "--Done with request-------------------\n";

 if ($response->is_success) {print "It worked!->" . $response->code . "\n"}
 else {print "It didn't work!->" . $response->code . "\n"}

=head1 DESCRIPTION

L<LWP::Authen::Ntlm> allows LWP to authenticate against servers that are using the
NTLM authentication scheme popularized by Microsoft.  This type of authentication is
common on intranets of Microsoft-centric organizations.

The module takes advantage of the Authen::NTLM module by Mark Bush.  Since there
is also another Authen::NTLM module available from CPAN by Yee Man Chan with an
entirely different interface, it is necessary to ensure that you have the correct
NTLM module.

In addition, there have been problems with incompatibilities between different
versions of Mime::Base64, which Bush's Authen::NTLM makes use of.  Therefore, it is
necessary to ensure that your Mime::Base64 module supports exporting of the
encode_base64 and decode_base64 functions.

=head1 USAGE

The module is used indirectly through LWP, rather than including it directly in your
code.  The LWP system will invoke the NTLM authentication when it encounters the
authentication scheme while attempting to retrieve a URL from a server.  In order
for the NTLM authentication to work, you must have a few things set up in your
code prior to attempting to retrieve the URL:

=over 4

=item *

Enable persistent HTTP connections

To do this, pass the "keep_alive=>1" option to the LWP::UserAgent when creating it, like this:

    my $ua = LWP::UserAgent->new(keep_alive=>1);

=item *

Set the credentials on the UserAgent object

The credentials must be set like this:

   $ua->credentials('www.company.com:80', '', "MyDomain\\MyUserCode", 'MyPassword');

Note that you cannot use the HTTP::Request object's authorization_basic() method to set
the credentials.  Note, too, that the 'www.company.com:80' portion only sets credentials
on the specified port AND it is case-sensitive (this is due to the way LWP is coded, and
has nothing to do with LWP::Authen::Ntlm)

=back

=head1 AVAILABILITY

General queries regarding LWP should be made to the LWP Mailing List.

Questions specific to LWP::Authen::Ntlm can be forwarded to jtillman@bigfoot.com

=head1 COPYRIGHT

Copyright (c) 2002 James Tillman. All rights reserved. This
program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=head1 SEE ALSO

L<LWP>, L<LWP::UserAgent>, L<lwpcook>.

=cut
PK       ! �ݵ�<
  <
    perl5/LWP/Authen/Basic.pmnu ��6�$        package LWP::Authen::Basic;

use strict;

our $VERSION = '6.49';

require Encode;
require MIME::Base64;

sub auth_header {
    my($class, $user, $pass, $request, $ua, $h) = @_;

    my $userpass = "$user:$pass";
    # https://tools.ietf.org/html/rfc7617#section-2.1
    my $charset = uc($h->{auth_param}->{charset} || "");
    $userpass = Encode::encode($charset, $userpass)
        if ($charset eq "UTF-8");

    return "Basic " . MIME::Base64::encode($userpass, "");
}

sub _reauth_requested {
    return 0;
}

sub authenticate
{
    my($class, $ua, $proxy, $auth_param, $response,
       $request, $arg, $size) = @_;

    my $realm = $auth_param->{realm} || "";
    my $url = $proxy ? $request->{proxy} : $request->uri_canonical;
    return $response unless $url;
    my $host_port = $url->host_port;
    my $auth_header = $proxy ? "Proxy-Authorization" : "Authorization";

    my @m = $proxy ? (m_proxy => $url) : (m_host_port => $host_port);
    push(@m, realm => $realm);

    my $h = $ua->get_my_handler("request_prepare", @m, sub {
        $_[0]{callback} = sub {
            my($req, $ua, $h) = @_;
            my($user, $pass) = $ua->credentials($host_port, $h->{realm});
	    if (defined $user) {
		my $auth_value = $class->auth_header($user, $pass, $req, $ua, $h);
		$req->header($auth_header => $auth_value);
	    }
        };
    });
    $h->{auth_param} = $auth_param;

    my $reauth_requested
        = $class->_reauth_requested($auth_param, $ua, $request, $auth_header);
    if (   !$proxy
        && (!$request->header($auth_header) || $reauth_requested)
        && $ua->credentials($host_port, $realm))
    {
        # we can make sure this handler applies and retry
        add_path($h, $url->path)
            unless $reauth_requested;  # Do not clobber up path list for retries
        return $ua->request($request->clone, $arg, $size, $response);
    }

    my($user, $pass) = $ua->get_basic_credentials($realm, $url, $proxy);
    unless (defined $user and defined $pass) {
	$ua->set_my_handler("request_prepare", undef, @m);  # delete handler
	return $response;
    }

    # check that the password has changed
    my ($olduser, $oldpass) = $ua->credentials($host_port, $realm);
    return $response if (defined $olduser and defined $oldpass and
                         $user eq $olduser and $pass eq $oldpass);

    $ua->credentials($host_port, $realm, $user, $pass);
    add_path($h, $url->path) unless $proxy;
    return $ua->request($request->clone, $arg, $size, $response);
}

sub add_path {
    my($h, $path) = @_;
    $path =~ s,[^/]+\z,,;
    push(@{$h->{m_path_prefix}}, $path);
}

1;
PK       ! oFD��  �    perl5/LWP/RobotUA.pmnu ��6�$        package LWP::RobotUA;

use base qw(LWP::UserAgent);

our $VERSION = '6.49';

require WWW::RobotRules;
require HTTP::Request;
require HTTP::Response;

use Carp ();
use HTTP::Status ();
use HTTP::Date qw(time2str);
use strict;


#
# Additional attributes in addition to those found in LWP::UserAgent:
#
# $self->{'delay'}    Required delay between request to the same
#                     server in minutes.
#
# $self->{'rules'}     A WWW::RobotRules object
#

sub new
{
    my $class = shift;
    my %cnf;
    if (@_ < 4) {
	# legacy args
	@cnf{qw(agent from rules)} = @_;
    }
    else {
	%cnf = @_;
    }

    Carp::croak('LWP::RobotUA agent required') unless $cnf{agent};
    Carp::croak('LWP::RobotUA from address required')
	unless $cnf{from} && $cnf{from} =~ m/\@/;

    my $delay = delete $cnf{delay} || 1;
    my $use_sleep = delete $cnf{use_sleep};
    $use_sleep = 1 unless defined($use_sleep);
    my $rules = delete $cnf{rules};

    my $self = LWP::UserAgent->new(%cnf);
    $self = bless $self, $class;

    $self->{'delay'} = $delay;   # minutes
    $self->{'use_sleep'} = $use_sleep;

    if ($rules) {
	$rules->agent($cnf{agent});
	$self->{'rules'} = $rules;
    }
    else {
	$self->{'rules'} = WWW::RobotRules->new($cnf{agent});
    }

    $self;
}


sub delay     { shift->_elem('delay',     @_); }
sub use_sleep { shift->_elem('use_sleep', @_); }


sub agent
{
    my $self = shift;
    my $old = $self->SUPER::agent(@_);
    if (@_) {
	# Changing our name means to start fresh
	$self->{'rules'}->agent($self->{'agent'});
    }
    $old;
}


sub rules {
    my $self = shift;
    my $old = $self->_elem('rules', @_);
    $self->{'rules'}->agent($self->{'agent'}) if @_;
    $old;
}


sub no_visits
{
    my($self, $netloc) = @_;
    $self->{'rules'}->no_visits($netloc) || 0;
}

*host_count = \&no_visits;  # backwards compatibility with LWP-5.02


sub host_wait
{
    my($self, $netloc) = @_;
    return undef unless defined $netloc;
    my $last = $self->{'rules'}->last_visit($netloc);
    if ($last) {
	my $wait = int($self->{'delay'} * 60 - (time - $last));
	$wait = 0 if $wait < 0;
	return $wait;
    }
    return 0;
}


sub simple_request
{
    my($self, $request, $arg, $size) = @_;

    # Do we try to access a new server?
    my $allowed = $self->{'rules'}->allowed($request->uri);

    if ($allowed < 0) {
	# Host is not visited before, or robots.txt expired; fetch "robots.txt"
	my $robot_url = $request->uri->clone;
	$robot_url->path("robots.txt");
	$robot_url->query(undef);

	# make access to robot.txt legal since this will be a recursive call
	$self->{'rules'}->parse($robot_url, "");

	my $robot_req = HTTP::Request->new('GET', $robot_url);
	my $parse_head = $self->parse_head(0);
	my $robot_res = $self->request($robot_req);
	$self->parse_head($parse_head);
	my $fresh_until = $robot_res->fresh_until;
	my $content = "";
	if ($robot_res->is_success && $robot_res->content_is_text) {
	    $content = $robot_res->decoded_content;
	    $content = "" unless $content && $content =~ /^\s*Disallow\s*:/mi;
	}
	$self->{'rules'}->parse($robot_url, $content, $fresh_until);

	# recalculate allowed...
	$allowed = $self->{'rules'}->allowed($request->uri);
    }

    # Check rules
    unless ($allowed) {
	my $res = HTTP::Response->new(
	  HTTP::Status::RC_FORBIDDEN, 'Forbidden by robots.txt');
	$res->request( $request ); # bind it to that request
	return $res;
    }

    my $netloc = eval { local $SIG{__DIE__}; $request->uri->host_port; };
    my $wait = $self->host_wait($netloc);

    if ($wait) {
	if ($self->{'use_sleep'}) {
	    sleep($wait)
	}
	else {
	    my $res = HTTP::Response->new(
	      HTTP::Status::RC_SERVICE_UNAVAILABLE, 'Please, slow down');
	    $res->header('Retry-After', time2str(time + $wait));
	    $res->request( $request ); # bind it to that request
	    return $res;
	}
    }

    # Perform the request
    my $res = $self->SUPER::simple_request($request, $arg, $size);

    $self->{'rules'}->visit($netloc);

    $res;
}


sub as_string
{
    my $self = shift;
    my @s;
    push(@s, "Robot: $self->{'agent'} operated by $self->{'from'}  [$self]");
    push(@s, "    Minimum delay: " . int($self->{'delay'}*60) . "s");
    push(@s, "    Will sleep if too early") if $self->{'use_sleep'};
    push(@s, "    Rules = $self->{'rules'}");
    join("\n", @s, '');
}

1;


__END__

=pod

=head1 NAME

LWP::RobotUA - a class for well-behaved Web robots

=head1 SYNOPSIS

  use LWP::RobotUA;
  my $ua = LWP::RobotUA->new('my-robot/0.1', 'me@foo.com');
  $ua->delay(10);  # be very nice -- max one hit every ten minutes!
  ...

  # Then just use it just like a normal LWP::UserAgent:
  my $response = $ua->get('http://whatever.int/...');
  ...

=head1 DESCRIPTION

This class implements a user agent that is suitable for robot
applications.  Robots should be nice to the servers they visit.  They
should consult the F</robots.txt> file to ensure that they are welcomed
and they should not make requests too frequently.

But before you consider writing a robot, take a look at
L<URL:http://www.robotstxt.org/>.

When you use an I<LWP::RobotUA> object as your user agent, then you do not
really have to think about these things yourself; C<robots.txt> files
are automatically consulted and obeyed, the server isn't queried
too rapidly, and so on.  Just send requests
as you do when you are using a normal I<LWP::UserAgent>
object (using C<< $ua->get(...) >>, C<< $ua->head(...) >>,
C<< $ua->request(...) >>, etc.), and this
special agent will make sure you are nice.

=head1 METHODS

The LWP::RobotUA is a sub-class of L<LWP::UserAgent> and implements the
same methods. In addition the following methods are provided:

=head2 new

    my $ua = LWP::RobotUA->new( %options )
    my $ua = LWP::RobotUA->new( $agent, $from )
    my $ua = LWP::RobotUA->new( $agent, $from, $rules )

The LWP::UserAgent options C<agent> and C<from> are mandatory.  The
options C<delay>, C<use_sleep> and C<rules> initialize attributes
private to the RobotUA.  If C<rules> are not provided, then
C<WWW::RobotRules> is instantiated providing an internal database of
F<robots.txt>.

It is also possible to just pass the value of C<agent>, C<from> and
optionally C<rules> as plain positional arguments.

=head2 delay

    my $delay = $ua->delay;
    $ua->delay( $minutes );

Get/set the minimum delay between requests to the same server, in
I<minutes>.  The default is C<1> minute.  Note that this number doesn't
have to be an integer; for example, this sets the delay to C<10> seconds:

    $ua->delay(10/60);

=head2 use_sleep

    my $bool = $ua->use_sleep;
    $ua->use_sleep( $boolean );

Get/set a value indicating whether the UA should L<LWP::RobotUA/sleep> if
requests arrive too fast, defined as C<< $ua->delay >> minutes not passed since
last request to the given server.  The default is true.  If this value is
false then an internal C<SERVICE_UNAVAILABLE> response will be generated.
It will have a C<Retry-After> header that indicates when it is OK to
send another request to this server.

=head2 rules

    my $rules = $ua->rules;
    $ua->rules( $rules );

Set/get which I<WWW::RobotRules> object to use.

=head2 no_visits

    my $num = $ua->no_visits( $netloc )

Returns the number of documents fetched from this server host. Yeah I
know, this method should probably have been named C<num_visits> or
something like that. :-(

=head2 host_wait

    my $num = $ua->host_wait( $netloc )

Returns the number of I<seconds> (from now) you must wait before you can
make a new request to this host.

=head2 as_string

    my $string = $ua->as_string;

Returns a string that describes the state of the UA.
Mainly useful for debugging.

=head1 SEE ALSO

L<LWP::UserAgent>, L<WWW::RobotRules>

=head1 COPYRIGHT

Copyright 1996-2004 Gisle Aas.

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

=cut
PK       ! ӗP7#  7#    perl5/LWP/Protocol.pmnu ��6�$        package LWP::Protocol;

use base 'LWP::MemberMixin';

our $VERSION = '6.49';

use strict;
use Carp ();
use HTTP::Status ();
use HTTP::Response ();
use Try::Tiny qw(try catch);

my %ImplementedBy = (); # scheme => classname

sub new
{
    my($class, $scheme, $ua) = @_;

    my $self = bless {
	scheme => $scheme,
	ua => $ua,

	# historical/redundant
        max_size => $ua->{max_size},
    }, $class;

    $self;
}


sub create
{
    my($scheme, $ua) = @_;
    my $impclass = LWP::Protocol::implementor($scheme) or
	Carp::croak("Protocol scheme '$scheme' is not supported");

    # hand-off to scheme specific implementation sub-class
    my $protocol = $impclass->new($scheme, $ua);

    return $protocol;
}


sub implementor
{
    my($scheme, $impclass) = @_;

    if ($impclass) {
	$ImplementedBy{$scheme} = $impclass;
    }
    my $ic = $ImplementedBy{$scheme};
    return $ic if $ic;

    return '' unless $scheme =~ /^([.+\-\w]+)$/;  # check valid URL schemes
    $scheme = $1; # untaint
    $scheme =~ tr/.+-/_/;  # make it a legal module name

    # scheme not yet known, look for a 'use'd implementation
    $ic = "LWP::Protocol::$scheme";  # default location
    $ic = "LWP::Protocol::nntp" if $scheme eq 'news'; #XXX ugly hack
    no strict 'refs';
    # check we actually have one for the scheme:
    unless (@{"${ic}::ISA"}) {
        # try to autoload it
        try {
            (my $class = $ic) =~ s{::}{/}g;
            $class .= '.pm' unless $class =~ /\.pm$/;
            require $class;
        }
        catch {
            my $error = $_;
            if ($error =~ /Can't locate/) {
                $ic = '';
            }
            else {
                die "$error\n";
            }
        };
    }
    $ImplementedBy{$scheme} = $ic if $ic;
    $ic;
}


sub request
{
    my($self, $request, $proxy, $arg, $size, $timeout) = @_;
    Carp::croak('LWP::Protocol::request() needs to be overridden in subclasses');
}


# legacy
sub timeout    { shift->_elem('timeout',    @_); }
sub max_size   { shift->_elem('max_size',   @_); }


sub collect
{
    my ($self, $arg, $response, $collector) = @_;
    my $content;
    my($ua, $max_size) = @{$self}{qw(ua max_size)};

    # This can't be moved to Try::Tiny due to the closures within causing
    # leaks on any version of Perl prior to 5.18.
    # https://perl5.git.perl.org/perl.git/commitdiff/a0d2bbd5c
    my $error = do { #catch
        local $@;
        local $\; # protect the print below from surprises
        eval { # try
            if (!defined($arg) || !$response->is_success) {
                $response->{default_add_content} = 1;
            }
            elsif (!ref($arg) && length($arg)) {
                open(my $fh, ">", $arg) or die "Can't write to '$arg': $!";
                binmode($fh);
                push(@{$response->{handlers}{response_data}}, {
                    callback => sub {
                        print $fh $_[3] or die "Can't write to '$arg': $!";
                        1;
                    },
                });
                push(@{$response->{handlers}{response_done}}, {
                    callback => sub {
                        close($fh) or die "Can't write to '$arg': $!";
                        undef($fh);
                    },
                });
            }
            elsif (ref($arg) eq 'CODE') {
                push(@{$response->{handlers}{response_data}}, {
                    callback => sub {
                        &$arg($_[3], $_[0], $self);
                        1;
                    },
                });
            }
            else {
                die "Unexpected collect argument '$arg'";
            }

            $ua->run_handlers("response_header", $response);

            if (delete $response->{default_add_content}) {
                push(@{$response->{handlers}{response_data}}, {
                    callback => sub {
                        $_[0]->add_content($_[3]);
                        1;
                    },
                });
            }


            my $content_size = 0;
            my $length = $response->content_length;
            my %skip_h;

            while ($content = &$collector, length $$content) {
                for my $h ($ua->handlers("response_data", $response)) {
                    next if $skip_h{$h};
                    unless ($h->{callback}->($response, $ua, $h, $$content)) {
                        # XXX remove from $response->{handlers}{response_data} if present
                        $skip_h{$h}++;
                    }
                }
                $content_size += length($$content);
                $ua->progress(($length ? ($content_size / $length) : "tick"), $response);
                if (defined($max_size) && $content_size > $max_size) {
                    $response->push_header("Client-Aborted", "max_size");
                    last;
                }
            }
            1;
        };
        $@;
    };

    if ($error) {
        chomp($error);
        $response->push_header('X-Died' => $error);
        $response->push_header("Client-Aborted", "die");
    };
    delete $response->{handlers}{response_data};
    delete $response->{handlers} unless %{$response->{handlers}};
    return $response;
}


sub collect_once
{
    my($self, $arg, $response) = @_;
    my $content = \ $_[3];
    my $first = 1;
    $self->collect($arg, $response, sub {
	return $content if $first--;
	return \ "";
    });
}

1;


__END__

=pod

=head1 NAME

LWP::Protocol - Base class for LWP protocols

=head1 SYNOPSIS

 package LWP::Protocol::foo;
 use base qw(LWP::Protocol);

=head1 DESCRIPTION

This class is used as the base class for all protocol implementations
supported by the LWP library.

When creating an instance of this class using
C<LWP::Protocol::create($url)>, and you get an initialized subclass
appropriate for that access method. In other words, the
L<LWP::Protocol/create> function calls the constructor for one of its
subclasses.

All derived C<LWP::Protocol> classes need to override the request()
method which is used to service a request. The overridden method can
make use of the collect() function to collect together chunks of data
as it is received.

=head1 METHODS

The following methods and functions are provided:

=head2 new

    my $prot = LWP::Protocol->new();

The LWP::Protocol constructor is inherited by subclasses. As this is a
virtual base class this method should B<not> be called directly.

=head2 create

    my $prot = LWP::Protocol::create($scheme)

Create an object of the class implementing the protocol to handle the
given scheme. This is a function, not a method. It is more an object
factory than a constructor. This is the function user agents should
use to access protocols.

=head2 implementor

    my $class = LWP::Protocol::implementor($scheme, [$class])

Get and/or set implementor class for a scheme.  Returns C<''> if the
specified scheme is not supported.

=head2 request

    $response = $protocol->request($request, $proxy, undef);
    $response = $protocol->request($request, $proxy, '/tmp/sss');
    $response = $protocol->request($request, $proxy, \&callback, 1024);

Dispatches a request over the protocol, and returns a response
object. This method needs to be overridden in subclasses.  Refer to
L<LWP::UserAgent> for description of the arguments.

=head2 collect

    my $res = $prot->collect(undef, $response, $collector); # stored in $response
    my $res = $prot->collect($filename, $response, $collector);
    my $res = $prot->collect(sub { ... }, $response, $collector);

Collect the content of a request, and process it appropriately into a scalar,
file, or by calling a callback. If the first parameter is undefined, then the
content is stored within the C<$response>. If it's a simple scalar, then it's
interpreted as a file name and the content is written to this file.  If it's a
code reference, then content is passed to this routine.

The collector is a routine that will be called and which is
responsible for returning pieces (as ref to scalar) of the content to
process.  The C<$collector> signals C<EOF> by returning a reference to an
empty string.

The return value is the L<HTTP::Response> object reference.

B<Note:> We will only use the callback or file argument if
C<< $response->is_success() >>.  This avoids sending content data for
redirects and authentication responses to the callback which would be
confusing.

=head2 collect_once

    $prot->collect_once($arg, $response, $content)

Can be called when the whole response content is available as content. This
will invoke L<LWP::Protocol/collect> with a collector callback that
returns a reference to C<$content> the first time and an empty string the
next.

=head1 SEE ALSO

Inspect the F<LWP/Protocol/file.pm> and F<LWP/Protocol/http.pm> files
for examples of usage.

=head1 COPYRIGHT

Copyright 1995-2001 Gisle Aas.

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

=cut
PK       ! ��#"  #"    perl5/LWP/ConnCache.pmnu ��6�$        package LWP::ConnCache;

use strict;

our $VERSION = '6.49';
our $DEBUG;

sub new {
    my($class, %cnf) = @_;

    my $total_capacity = 1;
    if (exists $cnf{total_capacity}) {
        $total_capacity = delete $cnf{total_capacity};
    }
    if (%cnf && $^W) {
	require Carp;
	Carp::carp("Unrecognised options: @{[sort keys %cnf]}")
    }
    my $self = bless { cc_conns => [] }, $class;
    $self->total_capacity($total_capacity);
    $self;
}


sub deposit {
    my($self, $type, $key, $conn) = @_;
    push(@{$self->{cc_conns}}, [$conn, $type, $key, time]);
    $self->enforce_limits($type);
    return;
}


sub withdraw {
    my($self, $type, $key) = @_;
    my $conns = $self->{cc_conns};
    for my $i (0 .. @$conns - 1) {
	my $c = $conns->[$i];
	next unless $c->[1] eq $type && $c->[2] eq $key;
	splice(@$conns, $i, 1);  # remove it
	return $c->[0];
    }
    return undef;
}


sub total_capacity {
    my $self = shift;
    my $old = $self->{cc_limit_total};
    if (@_) {
	$self->{cc_limit_total} = shift;
	$self->enforce_limits;
    }
    $old;
}


sub capacity {
    my $self = shift;
    my $type = shift;
    my $old = $self->{cc_limit}{$type};
    if (@_) {
	$self->{cc_limit}{$type} = shift;
	$self->enforce_limits($type);
    }
    $old;
}


sub enforce_limits {
    my($self, $type) = @_;
    my $conns = $self->{cc_conns};

    my @types = $type ? ($type) : ($self->get_types);
    for $type (@types) {
	next unless $self->{cc_limit};
	my $limit = $self->{cc_limit}{$type};
	next unless defined $limit;
	for my $i (reverse 0 .. @$conns - 1) {
	    next unless $conns->[$i][1] eq $type;
	    if (--$limit < 0) {
		$self->dropping(splice(@$conns, $i, 1), "$type capacity exceeded");
	    }
	}
    }

    if (defined(my $total = $self->{cc_limit_total})) {
	while (@$conns > $total) {
	    $self->dropping(shift(@$conns), "Total capacity exceeded");
	}
    }
}


sub dropping {
    my($self, $c, $reason) = @_;
    print "DROPPING @$c [$reason]\n" if $DEBUG;
}


sub drop {
    my($self, $checker, $reason) = @_;
    if (ref($checker) ne "CODE") {
	# make it so
	if (!defined $checker) {
	    $checker = sub { 1 };  # drop all of them
	}
	elsif (_looks_like_number($checker)) {
	    my $age_limit = $checker;
	    my $time_limit = time - $age_limit;
	    $reason ||= "older than $age_limit";
	    $checker = sub { $_[3] < $time_limit };
	}
	else {
	    my $type = $checker;
	    $reason ||= "drop $type";
	    $checker = sub { $_[1] eq $type };  # match on type
	}
    }
    $reason ||= "drop";

    local $SIG{__DIE__};  # don't interfere with eval below
    local $@;
    my @c;
    for (@{$self->{cc_conns}}) {
	my $drop;
	eval {
	    if (&$checker(@$_)) {
		$self->dropping($_, $reason);
		$drop++;
	    }
	};
	push(@c, $_) unless $drop;
    }
    @{$self->{cc_conns}} = @c;
}


sub prune {
    my $self = shift;
    $self->drop(sub { !shift->ping }, "ping");
}


sub get_types {
    my $self = shift;
    my %t;
    $t{$_->[1]}++ for @{$self->{cc_conns}};
    return keys %t;
}


sub get_connections {
    my($self, $type) = @_;
    my @c;
    for (@{$self->{cc_conns}}) {
	push(@c, $_->[0]) if !$type || ($type && $type eq $_->[1]);
    }
    @c;
}


sub _looks_like_number {
    $_[0] =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/;
}

1;


__END__

=pod

=head1 NAME

LWP::ConnCache - Connection cache manager

=head1 NOTE

This module is experimental.  Details of its interface is likely to
change in the future.

=head1 SYNOPSIS

 use LWP::ConnCache;
 my $cache = LWP::ConnCache->new;
 $cache->deposit($type, $key, $sock);
 $sock = $cache->withdraw($type, $key);

=head1 DESCRIPTION

The C<LWP::ConnCache> class is the standard connection cache manager
for L<LWP::UserAgent>.

=head1 METHODS

The following basic methods are provided:

=head2 new

    my $cache = LWP::ConnCache->new( %options )

This method constructs a new L<LWP::ConnCache> object.  The only
option currently accepted is C<total_capacity>.  If specified it
initializes the L<LWP::ConnCache/total_capacity> option. It defaults to C<1>.

=head2 total_capacity

    my $cap = $cache->total_capacity;
    $cache->total_capacity(0); # drop all immediately
    $cache->total_capacity(undef); # no limit
    $cache->total_capacity($number);

Get/sets the number of connection that will be cached.  Connections
will start to be dropped when this limit is reached.  If set to C<0>,
then all connections are immediately dropped.  If set to C<undef>,
then there is no limit.

=head2 capacity

    my $http_capacity = $cache->capacity('http');
    $cache->capacity('http', 2 );

Get/set a limit for the number of connections of the specified type
that can be cached.  The first parameter is a short string like
"http" or "ftp".

=head2 drop

    $cache->drop(); # Drop ALL connections
    # which is just a synonym for:
    $cache->drop(sub{1}); # Drop ALL connections
    # drop all connections older than 22 seconds and add a reason for it!
    $cache->drop(22, "Older than 22 secs dropped");
    # which is just a synonym for:
    $cache->drop(sub {
        my ($conn, $type, $key, $deposit_time) = @_;
        if ($deposit_time < 22) {
            # true values drop the connection
            return 1;
        }
        # false values don't drop the connection
        return 0;
    }, "Older than 22 secs dropped" );

Drop connections by some criteria.  The $checker argument is a
subroutine that is called for each connection.  If the routine returns
a TRUE value then the connection is dropped.  The routine is called
with ($conn, $type, $key, $deposit_time) as arguments.

Shortcuts: If the $checker argument is absent (or C<undef>) all cached
connections are dropped.  If the $checker is a number then all
connections untouched that the given number of seconds or more are
dropped.  If $checker is a string then all connections of the given
type are dropped.

The C<reason> is passed on to the L<LWP::ConnCache/dropped> method.

=head2 prune

    $cache->prune();

Calling this method will drop all connections that are dead.  This is
tested by calling the L<LWP::ConnCache/ping> method on the connections. If
the L<LWP::ConnCache/ping> method exists and returns a false value, then the
connection is dropped.

=head2 get_types

    my @types = $cache->get_types();

This returns all the C<type> fields used for the currently cached
connections.

=head2 get_connections

    my @conns = $cache->get_connections(); # all connections
    my @conns = $cache->get_connections('http'); # connections for http

This returns all connection objects of the specified type.  If no type
is specified then all connections are returned.  In scalar context the
number of cached connections of the specified type is returned.

=head1 PROTOCOL METHODS

The following methods are called by low-level protocol modules to
try to save away connections and to get them back.

=head2 deposit

    $cache->deposit($type, $key, $conn);

This method adds a new connection to the cache.  As a result, other
already cached connections might be dropped.  Multiple connections with
the same type/key might be added.

=head2 withdraw

    my $conn = $cache->withdraw($type, $key);

This method tries to fetch back a connection that was previously
deposited.  If no cached connection with the specified $type/$key is
found, then C<undef> is returned.  There is not guarantee that a
deposited connection can be withdrawn, as the cache manger is free to
drop connections at any time.

=head1 INTERNAL METHODS

The following methods are called internally.  Subclasses might want to
override them.

=head2 enforce_limits

    $conn->enforce_limits([$type])

This method is called with after a new connection is added (deposited)
in the cache or capacity limits are adjusted.  The default
implementation drops connections until the specified capacity limits
are not exceeded.

=head2 dropping

    $conn->dropping($conn_record, $reason)

This method is called when a connection is dropped.  The record
belonging to the dropped connection is passed as the first argument
and a string describing the reason for the drop is passed as the
second argument.  The default implementation makes some noise if the
C<$LWP::ConnCache::DEBUG> variable is set and nothing more.

=head1 SUBCLASSING

For specialized cache policy it makes sense to subclass
C<LWP::ConnCache> and perhaps override the L<LWP::ConnCache/deposit>,
L<LWP::ConnCache/enforce_limits>, and L<LWP::ConnCache/dropping> methods.

The object itself is a hash.  Keys prefixed with C<cc_> are reserved
for the base class.

=head1 SEE ALSO

L<LWP::UserAgent>

=head1 COPYRIGHT

Copyright 2001 Gisle Aas.

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

=cut
PK       ! 5*3�  �    perl5/LWP/Simple.pmnu ��6�$        package LWP::Simple;

use strict;

our $VERSION = '6.49';

require Exporter;

our @EXPORT = qw(get head getprint getstore mirror);
our @EXPORT_OK = qw($ua);

# I really hate this.  It was a bad idea to do it in the first place.
# Wonder how to get rid of it???  (It even makes LWP::Simple 7% slower
# for trivial tests)
use HTTP::Status;
push(@EXPORT, @HTTP::Status::EXPORT);

sub import
{
    my $pkg = shift;
    my $callpkg = caller;
    Exporter::export($pkg, $callpkg, @_);
}

use LWP::UserAgent ();
use HTTP::Date ();

our $ua = LWP::UserAgent->new;  # we create a global UserAgent object
$ua->agent("LWP::Simple/$VERSION ");
$ua->env_proxy;

sub get ($)
{
    my $response = $ua->get(shift);
    return $response->decoded_content if $response->is_success;
    return undef;
}


sub head ($)
{
    my($url) = @_;
    my $request = HTTP::Request->new(HEAD => $url);
    my $response = $ua->request($request);

    if ($response->is_success) {
	return $response unless wantarray;
	return (scalar $response->header('Content-Type'),
		scalar $response->header('Content-Length'),
		HTTP::Date::str2time($response->header('Last-Modified')),
		HTTP::Date::str2time($response->header('Expires')),
		scalar $response->header('Server'),
	       );
    }
    return;
}


sub getprint ($)
{
    my($url) = @_;
    my $request = HTTP::Request->new(GET => $url);
    local($\) = ""; # ensure standard $OUTPUT_RECORD_SEPARATOR
    my $callback = sub { print $_[0] };
    if ($^O eq "MacOS") {
	$callback = sub { $_[0] =~ s/\015?\012/\n/g; print $_[0] }
    }
    my $response = $ua->request($request, $callback);
    unless ($response->is_success) {
	print STDERR $response->status_line, " <URL:$url>\n";
    }
    $response->code;
}


sub getstore ($$)
{
    my($url, $file) = @_;
    my $request = HTTP::Request->new(GET => $url);
    my $response = $ua->request($request, $file);

    $response->code;
}


sub mirror ($$)
{
    my($url, $file) = @_;
    my $response = $ua->mirror($url, $file);
    $response->code;
}


1;

__END__

=pod

=head1 NAME

LWP::Simple - simple procedural interface to LWP

=head1 SYNOPSIS

 perl -MLWP::Simple -e 'getprint "http://www.sn.no"'

 use LWP::Simple;
 $content = get("http://www.sn.no/");
 die "Couldn't get it!" unless defined $content;

 if (mirror("http://www.sn.no/", "foo") == RC_NOT_MODIFIED) {
     ...
 }

 if (is_success(getprint("http://www.sn.no/"))) {
     ...
 }

=head1 DESCRIPTION

This module is meant for people who want a simplified view of the
libwww-perl library.  It should also be suitable for one-liners.  If
you need more control or access to the header fields in the requests
sent and responses received, then you should use the full object-oriented
interface provided by the L<LWP::UserAgent> module.

The module will also export the L<LWP::UserAgent> object as C<$ua> if you
ask for it explicitly.

The user agent created by this module will identify itself as
C<LWP::Simple/#.##>
and will initialize its proxy defaults from the environment (by
calling C<< $ua->env_proxy >>).

=head1 FUNCTIONS

The following functions are provided (and exported) by this module:

=head2 get

    my $res = get($url);

The get() function will fetch the document identified by the given URL
and return it.  It returns C<undef> if it fails.  The C<$url> argument can
be either a string or a reference to a L<URI> object.

You will not be able to examine the response code or response headers
(like C<Content-Type>) when you are accessing the web using this
function.  If you need that information you should use the full OO
interface (see L<LWP::UserAgent>).

=head2 head

    my $res = head($url);

Get document headers. Returns the following 5 values if successful:
($content_type, $document_length, $modified_time, $expires, $server)

Returns an empty list if it fails.  In scalar context returns TRUE if
successful.

=head2 getprint

    my $code = getprint($url);

Get and print a document identified by a URL. The document is printed
to the selected default filehandle for output (normally STDOUT) as
data is received from the network.  If the request fails, then the
status code and message are printed on STDERR.  The return value is
the HTTP response code.

=head2 getstore

    my $code = getstore($url, $file)

Gets a document identified by a URL and stores it in the file. The
return value is the HTTP response code.

=head2 mirror

    my $code = mirror($url, $file);

Get and store a document identified by a URL, using
I<If-modified-since>, and checking the I<Content-Length>.  Returns
the HTTP response code.

=head1 STATUS CONSTANTS

This module also exports the L<HTTP::Status> constants and procedures.
You can use them when you check the response code from L<LWP::Simple/getprint>,
L<LWP::Simple/getstore> or L<LWP::Simple/mirror>.  The constants are:

   RC_CONTINUE
   RC_SWITCHING_PROTOCOLS
   RC_OK
   RC_CREATED
   RC_ACCEPTED
   RC_NON_AUTHORITATIVE_INFORMATION
   RC_NO_CONTENT
   RC_RESET_CONTENT
   RC_PARTIAL_CONTENT
   RC_MULTIPLE_CHOICES
   RC_MOVED_PERMANENTLY
   RC_MOVED_TEMPORARILY
   RC_SEE_OTHER
   RC_NOT_MODIFIED
   RC_USE_PROXY
   RC_BAD_REQUEST
   RC_UNAUTHORIZED
   RC_PAYMENT_REQUIRED
   RC_FORBIDDEN
   RC_NOT_FOUND
   RC_METHOD_NOT_ALLOWED
   RC_NOT_ACCEPTABLE
   RC_PROXY_AUTHENTICATION_REQUIRED
   RC_REQUEST_TIMEOUT
   RC_CONFLICT
   RC_GONE
   RC_LENGTH_REQUIRED
   RC_PRECONDITION_FAILED
   RC_REQUEST_ENTITY_TOO_LARGE
   RC_REQUEST_URI_TOO_LARGE
   RC_UNSUPPORTED_MEDIA_TYPE
   RC_INTERNAL_SERVER_ERROR
   RC_NOT_IMPLEMENTED
   RC_BAD_GATEWAY
   RC_SERVICE_UNAVAILABLE
   RC_GATEWAY_TIMEOUT
   RC_HTTP_VERSION_NOT_SUPPORTED

=head1 CLASSIFICATION FUNCTIONS

The L<HTTP::Status> classification functions are:

=head2 is_success

    my $bool = is_success($rc);

True if response code indicated a successful request.

=head2 is_error

    my $bool = is_error($rc)

True if response code indicated that an error occurred.

=head1 CAVEAT

Note that if you are using both LWP::Simple and the very popular L<CGI>
module, you may be importing a C<head> function from each module,
producing a warning like C<Prototype mismatch: sub main::head ($) vs none>.
Get around this problem by just not importing LWP::Simple's
C<head> function, like so:

        use LWP::Simple qw(!head);
        use CGI qw(:standard);  # then only CGI.pm defines a head()

Then if you do need LWP::Simple's C<head> function, you can just call
it as C<LWP::Simple::head($url)>.

=head1 SEE ALSO

L<LWP>, L<lwpcook>, L<LWP::UserAgent>, L<HTTP::Status>, L<lwp-request>,
L<lwp-mirror>

=cut
PK       ! C\�;W  W    perl5/LWP/Debug/TraceHTTP.pmnu ��6�$        package LWP::Debug::TraceHTTP;

# Just call:
#
#   require LWP::Debug::TraceHTTP;
#   LWP::Protocol::implementor('http', 'LWP::Debug::TraceHTTP');
#
# to use this module to trace all calls to the HTTP socket object in
# programs that use LWP.

use strict;
use base 'LWP::Protocol::http';

our $VERSION = '6.49';

package # hide from PAUSE
    LWP::Debug::TraceHTTP::Socket;

use Data::Dump 1.13;
use Data::Dump::Trace qw(autowrap mcall);

autowrap("LWP::Protocol::http::Socket" => "sock");

sub new {
    my $class = shift;
    return mcall("LWP::Protocol::http::Socket" => "new", undef, @_);
}

1;
PK       ! ݴ��C   C     perl5/LWP/DebugFile.pmnu ��6�$        package LWP::DebugFile;

our $VERSION = '6.49';

# legacy stub

1;
PK       ! ^7�	k  k    perl5/LWP/MemberMixin.pmnu ��6�$        package LWP::MemberMixin;

our $VERSION = '6.49';

sub _elem {
    my $self = shift;
    my $elem = shift;
    my $old  = $self->{$elem};
    $self->{$elem} = shift if @_;
    return $old;
}

1;

__END__

=pod

=head1 NAME

LWP::MemberMixin - Member access mixin class

=head1 SYNOPSIS

 package Foo;
 use base qw(LWP::MemberMixin);

=head1 DESCRIPTION

A mixin class to get methods that provide easy access to member
variables in the C<%$self>.
Ideally there should be better Perl language support for this.

=head1 METHODS

There is only one method provided:

=head2 _elem

    _elem($elem [, $val])

Internal method to get/set the value of member variable
C<$elem>. If C<$val> is present it is used as the new value
for the member variable.  If it is not present the current
value is not touched. In both cases the previous value of
the member variable is returned.

=cut
PK       ! �s)b  b    perl5/LWP/Debug.pmnu ��6�$        package LWP::Debug;    # legacy

our $VERSION = '6.49';

require Exporter;
our @ISA       = qw(Exporter);
our @EXPORT_OK = qw(level trace debug conns);

use Carp ();

my @levels = qw(trace debug conns);
our %current_level = ();

sub import {
    my $pack    = shift;
    my $callpkg = caller(0);
    my @symbols = ();
    my @levels  = ();
    for (@_) {
        if (/^[-+]/) {
            push(@levels, $_);
        }
        else {
            push(@symbols, $_);
        }
    }
    Exporter::export($pack, $callpkg, @symbols);
    level(@levels);
}

sub level {
    for (@_) {
        if ($_ eq '+') {    # all on
                            # switch on all levels
            %current_level = map { $_ => 1 } @levels;
        }
        elsif ($_ eq '-') {    # all off
            %current_level = ();
        }
        elsif (/^([-+])(\w+)$/) {
            $current_level{$2} = $1 eq '+';
        }
        else {
            Carp::croak("Illegal level format $_");
        }
    }
}

sub trace { _log(@_) if $current_level{'trace'}; }
sub debug { _log(@_) if $current_level{'debug'}; }
sub conns { _log(@_) if $current_level{'conns'}; }

sub _log {
    my $msg = shift;
    $msg .= "\n" unless $msg =~ /\n$/;    # ensure trailing "\n"

    my ($package, $filename, $line, $sub) = caller(2);
    print STDERR "$sub: $msg";
}

1;

__END__

=pod

=head1 NAME

LWP::Debug - deprecated

=head1 DESCRIPTION

This module has been deprecated.  Please see L<LWP::ConsoleLogger> for your
debugging needs.

LWP::Debug is used to provide tracing facilities, but these are not used
by LWP any more.  The code in this module is kept around
(undocumented) so that 3rd party code that happens to use the old
interfaces continue to run.

One useful feature that LWP::Debug provided (in an imprecise and
troublesome way) was network traffic monitoring.  The following
section provides some hints about recommended replacements.

=head2 Network traffic monitoring

The best way to monitor the network traffic that LWP generates is to
use an external TCP monitoring program.  The
L<WireShark|http://www.wireshark.org/> program is highly recommended for this.

Another approach it to use a debugging HTTP proxy server and make
LWP direct all its traffic via this one.  Call C<< $ua->proxy >> to
set it up and then just use LWP as before.

For less precise monitoring needs just setting up a few simple
handlers might do.  The following example sets up handlers to dump the
request and response objects that pass through LWP:

  use LWP::UserAgent;
  $ua = LWP::UserAgent->new;
  $ua->default_header('Accept-Encoding' => scalar HTTP::Message::decodable());

  $ua->add_handler("request_send",  sub { shift->dump; return });
  $ua->add_handler("response_done", sub { shift->dump; return });

  $ua->get("http://www.example.com");

=head1 SEE ALSO

L<LWP::ConsoleLogger>, L<LWP::ConsoleLogger::Everywhere>, L<LWP::UserAgent>

=cut
PK       ! n�[��  �    perl5/LWP/Protocol/data.pmnu ��6�$        package LWP::Protocol::data;

# Implements access to data:-URLs as specified in RFC 2397

use strict;

our $VERSION = '6.49';

require HTTP::Response;
require HTTP::Status;

use base qw(LWP::Protocol);

use HTTP::Date qw(time2str);
require LWP;  # needs version number

sub request
{
    my($self, $request, $proxy, $arg, $size) = @_;

    # check proxy
    if (defined $proxy)
    {
	return HTTP::Response->new( HTTP::Status::RC_BAD_REQUEST,
				  'You can not proxy with data');
    }

    # check method
    my $method = $request->method;
    unless ($method eq 'GET' || $method eq 'HEAD') {
	return HTTP::Response->new( HTTP::Status::RC_BAD_REQUEST,
				  'Library does not allow method ' .
				  "$method for 'data:' URLs");
    }

    my $url = $request->uri;
    my $response = HTTP::Response->new( HTTP::Status::RC_OK, "Document follows");

    my $media_type = $url->media_type;

    my $data = $url->data;
    $response->header('Content-Type'   => $media_type,
		      'Content-Length' => length($data),
		      'Date'           => time2str(time),
		      'Server'         => "libwww-perl-internal/$LWP::VERSION"
		     );

    $data = "" if $method eq "HEAD";
    return $self->collect_once($arg, $response, $data);
}

1;
PK       ! A��3b  b    perl5/LWP/Protocol/nogo.pmnu ��6�$        package LWP::Protocol::nogo;
# If you want to disable access to a particular scheme, use this
# class and then call
#   LWP::Protocol::implementor(that_scheme, 'LWP::Protocol::nogo');
# For then on, attempts to access URLs with that scheme will generate
# a 500 error.

use strict;

our $VERSION = '6.49';

require HTTP::Response;
require HTTP::Status;
use base qw(LWP::Protocol);

sub request {
    my($self, $request) = @_;
    my $scheme = $request->uri->scheme;

    return HTTP::Response->new(
      HTTP::Status::RC_INTERNAL_SERVER_ERROR,
      "Access to \'$scheme\' URIs has been disabled"
    );
}
1;
PK       ! ���f6  6    perl5/LWP/Protocol/mailto.pmnu ��6�$        package LWP::Protocol::mailto;

# This module implements the mailto protocol.  It is just a simple
# frontend to the Unix sendmail program except on MacOS, where it uses
# Mail::Internet.

require HTTP::Request;
require HTTP::Response;
require HTTP::Status;

use Carp;
use strict;

our $VERSION = '6.49';

use base qw(LWP::Protocol);
our $SENDMAIL;

unless ($SENDMAIL = $ENV{SENDMAIL}) {
    for my $sm (qw(/usr/sbin/sendmail
		   /usr/lib/sendmail
		   /usr/ucblib/sendmail
		  ))
    {
	if (-x $sm) {
	    $SENDMAIL = $sm;
	    last;
	}
    }
    die "Can't find the 'sendmail' program" unless $SENDMAIL;
}

sub request
{
    my($self, $request, $proxy, $arg, $size) = @_;

    my ($mail, $addr) if $^O eq "MacOS";
    my @text = () if $^O eq "MacOS";

    # check proxy
    if (defined $proxy)
    {
	return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
				  'You can not proxy with mail');
    }

    # check method
    my $method = $request->method;

    if ($method ne 'POST') {
	return HTTP::Response->new( HTTP::Status::RC_BAD_REQUEST,
				  'Library does not allow method ' .
				  "$method for 'mailto:' URLs");
    }

    # check url
    my $url = $request->uri;

    my $scheme = $url->scheme;
    if ($scheme ne 'mailto') {
	return HTTP::Response->new( HTTP::Status::RC_INTERNAL_SERVER_ERROR,
			 "LWP::Protocol::mailto::request called for '$scheme'");
    }
    if ($^O eq "MacOS") {
	eval {
	    require Mail::Internet;
	};
	if($@) {
	    return HTTP::Response->new( HTTP::Status::RC_INTERNAL_SERVER_ERROR,
	               "You don't have MailTools installed");
	}
	unless ($ENV{SMTPHOSTS}) {
	    return HTTP::Response->new( HTTP::Status::RC_INTERNAL_SERVER_ERROR,
	               "You don't have SMTPHOSTS defined");
	}
    }
    else {
	unless (-x $SENDMAIL) {
	    return HTTP::Response->new( HTTP::Status::RC_INTERNAL_SERVER_ERROR,
	               "You don't have $SENDMAIL");
    }
    }
    if ($^O eq "MacOS") {
	    $mail = Mail::Internet->new or
	    return HTTP::Response->new( HTTP::Status::RC_INTERNAL_SERVER_ERROR,
	    "Can't get a Mail::Internet object");
    }
    else {
	open(SENDMAIL, "| $SENDMAIL -oi -t") or
	    return HTTP::Response->new( HTTP::Status::RC_INTERNAL_SERVER_ERROR,
	               "Can't run $SENDMAIL: $!");
    }
    if ($^O eq "MacOS") {
	$addr = $url->encoded822addr;
    }
    else {
	$request = $request->clone;  # we modify a copy
	my @h = $url->headers;  # URL headers override those in the request
	while (@h) {
	    my $k = shift @h;
	    my $v = shift @h;
	    next unless defined $v;
	    if (lc($k) eq "body") {
		$request->content($v);
	    }
	    else {
		$request->push_header($k => $v);
	    }
	}
    }
    if ($^O eq "MacOS") {
	$mail->add(To => $addr);
	$mail->add(split(/[:\n]/,$request->headers_as_string));
    }
    else {
	print SENDMAIL $request->headers_as_string;
	print SENDMAIL "\n";
    }
    my $content = $request->content;
    if (defined $content) {
	my $contRef = ref($content) ? $content : \$content;
	if (ref($contRef) eq 'SCALAR') {
	    if ($^O eq "MacOS") {
		@text = split("\n",$$contRef);
		foreach (@text) {
		    $_ .= "\n";
		}
	    }
	    else {
	    print SENDMAIL $$contRef;
	    }

	}
	elsif (ref($contRef) eq 'CODE') {
	    # Callback provides data
	    my $d;
	    if ($^O eq "MacOS") {
		my $stuff = "";
		while (length($d = &$contRef)) {
		    $stuff .= $d;
		}
		@text = split("\n",$stuff);
		foreach (@text) {
		    $_ .= "\n";
		}
	    }
	    else {
		print SENDMAIL $d;
	    }
	}
    }
    if ($^O eq "MacOS") {
	$mail->body(\@text);
	unless ($mail->smtpsend) {
	    return HTTP::Response->new(HTTP::Status::RC_INTERNAL_SERVER_ERROR,
				       "Mail::Internet->smtpsend unable to send message to <$addr>");
	}
    }
    else {
	unless (close(SENDMAIL)) {
	    my $err = $! ? "$!" : "Exit status $?";
	    return HTTP::Response->new(HTTP::Status::RC_INTERNAL_SERVER_ERROR,
				       "$SENDMAIL: $err");
	}
    }


    my $response = HTTP::Response->new(HTTP::Status::RC_ACCEPTED,
				       "Mail accepted");
    $response->header('Content-Type', 'text/plain');
    if ($^O eq "MacOS") {
	$response->header('Server' => "Mail::Internet $Mail::Internet::VERSION");
	$response->content("Message sent to <$addr>\n");
    }
    else {
	$response->header('Server' => $SENDMAIL);
	my $to = $request->header("To");
	$response->content("Message sent to <$to>\n");
    }

    return $response;
}

1;
PK       ! �eQ  Q    perl5/LWP/Protocol/cpan.pmnu ��6�$        package LWP::Protocol::cpan;

use strict;

use base qw(LWP::Protocol);

our $VERSION = '6.49';

require URI;
require HTTP::Status;
require HTTP::Response;

our $CPAN;

unless ($CPAN) {
    # Try to find local CPAN mirror via $CPAN::Config
    eval {
	require CPAN::Config;
	if($CPAN::Config) {
	    my $urls = $CPAN::Config->{urllist};
	    if (ref($urls) eq "ARRAY") {
		my $file;
		for (@$urls) {
		    if (/^file:/) {
			$file = $_;
			last;
		    }
		}

		if ($file) {
		    $CPAN = $file;
		}
		else {
		    $CPAN = $urls->[0];
		}
	    }
	}
    };

    $CPAN ||= "http://cpan.org/";  # last resort
}

# ensure that we don't chop of last part
$CPAN .= "/" unless $CPAN =~ m,/$,;


sub request {
    my($self, $request, $proxy, $arg, $size) = @_;
    # check proxy
    if (defined $proxy)
    {
	return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
				   'You can not proxy with cpan');
    }

    # check method
    my $method = $request->method;
    unless ($method eq 'GET' || $method eq 'HEAD') {
	return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
				   'Library does not allow method ' .
				   "$method for 'cpan:' URLs");
    }

    my $path = $request->uri->path;
    $path =~ s,^/,,;

    my $response = HTTP::Response->new(HTTP::Status::RC_FOUND);
    $response->header("Location" => URI->new_abs($path, $CPAN));
    $response;
}

1;
PK       ! ���QJ  J    perl5/LWP/Protocol/loopback.pmnu ��6�$        package LWP::Protocol::loopback;

use strict;

our $VERSION = '6.49';

require HTTP::Response;

use base qw(LWP::Protocol);

sub request {
    my($self, $request, $proxy, $arg, $size, $timeout) = @_;

    my $response = HTTP::Response->new(200, "OK");
    $response->content_type("message/http; msgtype=request");

    $response->header("Via", "loopback/1.0 $proxy")
	if $proxy;

    $response->header("X-Arg", $arg);
    $response->header("X-Read-Size", $size);
    $response->header("X-Timeout", $timeout);

    return $self->collect_once($arg, $response, $request->as_string);
}

1;
PK       ! ���`  `    perl5/LWP/Protocol/gopher.pmnu ��6�$        package LWP::Protocol::gopher;

# Implementation of the gopher protocol (RFC 1436)
#
# This code is based on 'wwwgopher.pl,v 0.10 1994/10/17 18:12:34 shelden'
# which in turn is a vastly modified version of Oscar's http'get()
# dated 28/3/94 in <ftp://cui.unige.ch/PUBLIC/oscar/scripts/http.pl>
# including contributions from Marc van Heyningen and Martijn Koster.

use strict;

our $VERSION = '6.49';

require HTTP::Response;
require HTTP::Status;
require IO::Socket;
require IO::Select;

use base qw(LWP::Protocol);


my %gopher2mimetype = (
    '0' => 'text/plain',                # 0 file
    '1' => 'text/html',                 # 1 menu
					# 2 CSO phone-book server
					# 3 Error
    '4' => 'application/mac-binhex40',  # 4 BinHexed Macintosh file
    '5' => 'application/zip',           # 5 DOS binary archive of some sort
    '6' => 'application/octet-stream',  # 6 UNIX uuencoded file.
    '7' => 'text/html',                 # 7 Index-Search server
					# 8 telnet session
    '9' => 'application/octet-stream',  # 9 binary file
    'h' => 'text/html',                 # html
    'g' => 'image/gif',                 # gif
    'I' => 'image/*',                   # some kind of image
);

my %gopher2encoding = (
    '6' => 'x_uuencode',                # 6 UNIX uuencoded file.
);

sub request
{
    my($self, $request, $proxy, $arg, $size, $timeout) = @_;

    $size = 4096 unless $size;

    # check proxy
    if (defined $proxy) {
	return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
				   'You can not proxy through the gopher');
    }

    my $url = $request->uri;
    die "bad scheme" if $url->scheme ne 'gopher';


    my $method = $request->method;
    unless ($method eq 'GET' || $method eq 'HEAD') {
	return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
				   'Library does not allow method ' .
				   "$method for 'gopher:' URLs");
    }

    my $gophertype = $url->gopher_type;
    unless (exists $gopher2mimetype{$gophertype}) {
	return HTTP::Response->new(HTTP::Status::RC_NOT_IMPLEMENTED,
				   'Library does not support gophertype ' .
				   $gophertype);
    }

    my $response = HTTP::Response->new(HTTP::Status::RC_OK, "OK");
    $response->header('Content-type' => $gopher2mimetype{$gophertype}
					|| 'text/plain');
    $response->header('Content-Encoding' => $gopher2encoding{$gophertype})
	if exists $gopher2encoding{$gophertype};

    if ($method eq 'HEAD') {
	# XXX: don't even try it so we set this header
	$response->header('Client-Warning' => 'Client answer only');
	return $response;
    }

    if ($gophertype eq '7' && ! $url->search) {
      # the url is the prompt for a gopher search; supply boiler-plate
      return $self->collect_once($arg, $response, <<"EOT");
<HEAD>
<TITLE>Gopher Index</TITLE>
<ISINDEX>
</HEAD>
<BODY>
<H1>$url<BR>Gopher Search</H1>
This is a searchable Gopher index.
Use the search function of your browser to enter search terms.
</BODY>
EOT
    }

    my $host = $url->host;
    my $port = $url->port;

    my $requestLine = "";

    my $selector = $url->selector;
    if (defined $selector) {
	$requestLine .= $selector;
	my $search = $url->search;
	if (defined $search) {
	    $requestLine .= "\t$search";
	    my $string = $url->string;
	    if (defined $string) {
		$requestLine .= "\t$string";
	    }
	}
    }
    $requestLine .= "\015\012";

    # potential request headers are just ignored

    # Ok, lets make the request
    my $socket = IO::Socket::INET->new(PeerAddr => $host,
				       PeerPort => $port,
				       LocalAddr => $self->{ua}{local_address},
				       Proto    => 'tcp',
				       Timeout  => $timeout);
    die "Can't connect to $host:$port" unless $socket;
    my $sel = IO::Select->new($socket);

    {
	die "write timeout" if $timeout && !$sel->can_write($timeout);
	my $n = syswrite($socket, $requestLine, length($requestLine));
	die $! unless defined($n);
	die "short write" if $n != length($requestLine);
    }

    my $user_arg = $arg;

    # must handle menus in a special way since they are to be
    # converted to HTML.  Undefing $arg ensures that the user does
    # not see the data before we get a change to convert it.
    $arg = undef if $gophertype eq '1' || $gophertype eq '7';

    # collect response
    my $buf = '';
    $response = $self->collect($arg, $response, sub {
	die "read timeout" if $timeout && !$sel->can_read($timeout);
        my $n = sysread($socket, $buf, $size);
	die $! unless defined($n);
	return \$buf;
      } );

    # Convert menu to HTML and return data to user.
    if ($gophertype eq '1' || $gophertype eq '7') {
	my $content = menu2html($response->content);
	if (defined $user_arg) {
	    $response = $self->collect_once($user_arg, $response, $content);
	}
	else {
	    $response->content($content);
	}
    }

    $response;
}


sub gopher2url
{
    my($gophertype, $path, $host, $port) = @_;

    my $url;

    if ($gophertype eq '8' || $gophertype eq 'T') {
	# telnet session
	$url = $HTTP::URI_CLASS->new($gophertype eq '8' ? 'telnet:':'tn3270:');
	$url->user($path) if defined $path;
    }
    else {
	$path = URI::Escape::uri_escape($path);
	$url = $HTTP::URI_CLASS->new("gopher:/$gophertype$path");
    }
    $url->host($host);
    $url->port($port);
    $url;
}

sub menu2html {
    my($menu) = @_;

    $menu =~ tr/\015//d;  # remove carriage return
    my $tmp = <<"EOT";
<HTML>
<HEAD>
   <TITLE>Gopher menu</TITLE>
</HEAD>
<BODY>
<H1>Gopher menu</H1>
EOT
    for (split("\n", $menu)) {
	last if /^\./;
	my($pretty, $path, $host, $port) = split("\t");

	$pretty =~ s/^(.)//;
	my $type = $1;

	my $url = gopher2url($type, $path, $host, $port)->as_string;
	$tmp .= qq{<A HREF="$url">$pretty</A><BR>\n};
    }
    $tmp .= "</BODY>\n</HTML>\n";
    $tmp;
}

1;
PK       ! � �;  ;    perl5/LWP/Protocol/http.pmnu ��6�$        package LWP::Protocol::http;

use strict;

our $VERSION = '6.49';

require HTTP::Response;
require HTTP::Status;
require Net::HTTP;

use base qw(LWP::Protocol);

our @EXTRA_SOCK_OPTS;
my $CRLF = "\015\012";

sub _new_socket
{
    my($self, $host, $port, $timeout) = @_;

    # IPv6 literal IP address should be [bracketed] to remove
    # ambiguity between ip address and port number.
    if ( ($host =~ /:/) && ($host !~ /^\[/) ) {
      $host = "[$host]";
    }

    local($^W) = 0;  # IO::Socket::INET can be noisy
    my $sock = $self->socket_class->new(PeerAddr => $host,
					PeerPort => $port,
					LocalAddr => $self->{ua}{local_address},
					Proto    => 'tcp',
					Timeout  => $timeout,
					KeepAlive => !!$self->{ua}{conn_cache},
					SendTE    => $self->{ua}{send_te},
					$self->_extra_sock_opts($host, $port),
				       );

    unless ($sock) {
	# IO::Socket::INET leaves additional error messages in $@
	my $status = "Can't connect to $host:$port";
	if ($@ =~ /\bconnect: (.*)/ ||
	    $@ =~ /\b(Bad hostname)\b/ ||
	    $@ =~ /\b(nodename nor servname provided, or not known)\b/ ||
	    $@ =~ /\b(certificate verify failed)\b/ ||
	    $@ =~ /\b(Crypt-SSLeay can't verify hostnames)\b/
	) {
	    $status .= " ($1)";
	} elsif ($@) {
	    $status .= " ($@)";
	}
	die "$status\n\n$@";
    }

    # perl 5.005's IO::Socket does not have the blocking method.
    eval { $sock->blocking(0); };

    $sock;
}

sub socket_type
{
    return "http";
}

sub socket_class
{
    my $self = shift;
    (ref($self) || $self) . "::Socket";
}

sub _extra_sock_opts  # to be overridden by subclass
{
    return @EXTRA_SOCK_OPTS;
}

sub _check_sock
{
    #my($self, $req, $sock) = @_;
}

sub _get_sock_info
{
    my($self, $res, $sock) = @_;
    if (defined(my $peerhost = $sock->peerhost)) {
        $res->header("Client-Peer" => "$peerhost:" . $sock->peerport);
    }
}

sub _fixup_header
{
    my($self, $h, $url, $proxy) = @_;

    # Extract 'Host' header
    my $hhost = $url->authority;
    if ($hhost =~ s/^([^\@]*)\@//) {  # get rid of potential "user:pass@"
	# add authorization header if we need them.  HTTP URLs do
	# not really support specification of user and password, but
	# we allow it.
	if (defined($1) && not $h->header('Authorization')) {
	    require URI::Escape;
	    $h->authorization_basic(map URI::Escape::uri_unescape($_),
				    split(":", $1, 2));
	}
    }
    $h->init_header('Host' => $hhost);

    if ($proxy && $url->scheme ne 'https') {
	# Check the proxy URI's userinfo() for proxy credentials
	# export http_proxy="http://proxyuser:proxypass@proxyhost:port".
	# For https only the initial CONNECT requests needs authorization.
	my $p_auth = $proxy->userinfo();
	if(defined $p_auth) {
	    require URI::Escape;
	    $h->proxy_authorization_basic(map URI::Escape::uri_unescape($_),
					  split(":", $p_auth, 2))
	}
    }
}

sub hlist_remove {
    my($hlist, $k) = @_;
    $k = lc $k;
    for (my $i = @$hlist - 2; $i >= 0; $i -= 2) {
	next unless lc($hlist->[$i]) eq $k;
	splice(@$hlist, $i, 2);
    }
}

sub request
{
    my($self, $request, $proxy, $arg, $size, $timeout) = @_;

    $size ||= 4096;

    # check method
    my $method = $request->method;
    unless ($method =~ /^[A-Za-z0-9_!\#\$%&\'*+\-.^\`|~]+$/) {  # HTTP token
	return HTTP::Response->new( HTTP::Status::RC_BAD_REQUEST,
				  'Library does not allow method ' .
				  "$method for 'http:' URLs");
    }

    my $url = $request->uri;

    # Proxying SSL with a http proxy needs issues a CONNECT request to build a
    # tunnel and then upgrades the tunnel to SSL. But when doing keep-alive the
    # https request does not need to be the first request in the connection, so
    # we need to distinguish between
    # - not yet connected (create socket and ssl upgrade)
    # - connected but not inside ssl tunnel (ssl upgrade)
    # - inside ssl tunnel to the target - once we are in the tunnel to the
    #   target we cannot only reuse the tunnel for more https requests with the
    #   same target

    my $ssl_tunnel = $proxy && $url->scheme eq 'https'
	&& $url->host.":".$url->port;

    my ($host,$port) = $proxy
	? ($proxy->host,$proxy->port)
	: ($url->host,$url->port);
    my $fullpath =
	$method eq 'CONNECT' ? $url->host . ":" . $url->port :
	$proxy && ! $ssl_tunnel ? $url->as_string :
	do {
	    my $path = $url->path_query;
	    $path = "/$path" if $path !~m{^/};
	    $path
	};

    my $socket;
    my $conn_cache = $self->{ua}{conn_cache};
    my $cache_key;
    if ( $conn_cache ) {
	$cache_key = "$host:$port";
	# For https we reuse the socket immediately only if it has an established
	# tunnel to the target. Otherwise a CONNECT request followed by an SSL
	# upgrade need to be done first. The request itself might reuse an
	# existing non-ssl connection to the proxy
	$cache_key .= "!".$ssl_tunnel if $ssl_tunnel;
	if ( $socket = $conn_cache->withdraw($self->socket_type,$cache_key)) {
	    if ($socket->can_read(0)) {
		# if the socket is readable, then either the peer has closed the
		# connection or there are some garbage bytes on it.  In either
		# case we abandon it.
		$socket->close;
		$socket = undef;
	    } # else use $socket
	    else {
		$socket->timeout($timeout);
	    }
	}
    }

    if ( ! $socket && $ssl_tunnel ) {
	my $proto_https = LWP::Protocol::create('https',$self->{ua})
	    or die "no support for scheme https found";

	# only if ssl socket class is IO::Socket::SSL we can upgrade
	# a plain socket to SSL. In case of Net::SSL we fall back to
	# the old version
	if ( my $upgrade_sub = $proto_https->can('_upgrade_sock')) {
	    my $response = $self->request(
		HTTP::Request->new('CONNECT',"http://$ssl_tunnel"),
		$proxy,
		undef,$size,$timeout
	    );
	    $response->is_success or die
		"establishing SSL tunnel failed: ".$response->status_line;
	    $socket = $upgrade_sub->($proto_https,
		$response->{client_socket},$url)
		or die "SSL upgrade failed: $@";
	} else {
	    $socket = $proto_https->_new_socket($url->host,$url->port,$timeout);
	}
    }

    if ( ! $socket ) {
	# connect to remote site w/o reusing established socket
	$socket = $self->_new_socket($host, $port, $timeout );
    }

    my $http_version = "";
    if (my $proto = $request->protocol) {
	if ($proto =~ /^(?:HTTP\/)?(1.\d+)$/) {
	    $http_version = $1;
	    $socket->http_version($http_version);
	    $socket->send_te(0) if $http_version eq "1.0";
	}
    }

    $self->_check_sock($request, $socket);

    my @h;
    my $request_headers = $request->headers->clone;
    $self->_fixup_header($request_headers, $url, $proxy);

    $request_headers->scan(sub {
			       my($k, $v) = @_;
			       $k =~ s/^://;
			       $v =~ tr/\n/ /;
			       push(@h, $k, $v);
			   });

    my $content_ref = $request->content_ref;
    $content_ref = $$content_ref if ref($$content_ref);
    my $chunked;
    my $has_content;

    if (ref($content_ref) eq 'CODE') {
	my $clen = $request_headers->header('Content-Length');
	$has_content++ if $clen;
	unless (defined $clen) {
	    push(@h, "Transfer-Encoding" => "chunked");
	    $has_content++;
	    $chunked++;
	}
    }
    else {
	# Set (or override) Content-Length header
	my $clen = $request_headers->header('Content-Length');
	if (defined($$content_ref) && length($$content_ref)) {
	    $has_content = length($$content_ref);
	    if (!defined($clen) || $clen ne $has_content) {
		if (defined $clen) {
		    warn "Content-Length header value was wrong, fixed";
		    hlist_remove(\@h, 'Content-Length');
		}
		push(@h, 'Content-Length' => $has_content);
	    }
	}
	elsif ($clen) {
	    warn "Content-Length set when there is no content, fixed";
	    hlist_remove(\@h, 'Content-Length');
	}
    }

    my $write_wait = 0;
    $write_wait = 2
	if ($request_headers->header("Expect") || "") =~ /100-continue/;

    my $req_buf = $socket->format_request($method, $fullpath, @h);
    #print "------\n$req_buf\n------\n";

    if (!$has_content || $write_wait || $has_content > 8*1024) {
      WRITE:
        {
            # Since this just writes out the header block it should almost
            # always succeed to send the whole buffer in a single write call.
            my $n = $socket->syswrite($req_buf, length($req_buf));
            unless (defined $n) {
                redo WRITE if $!{EINTR};
                if ($!{EWOULDBLOCK} || $!{EAGAIN}) {
                    select(undef, undef, undef, 0.1);
                    redo WRITE;
                }
                die "write failed: $!";
            }
            if ($n) {
                substr($req_buf, 0, $n, "");
            }
            else {
                select(undef, undef, undef, 0.5);
            }
            redo WRITE if length $req_buf;
        }
    }

    my($code, $mess, @junk);
    my $drop_connection;

    if ($has_content) {
	my $eof;
	my $wbuf;
	my $woffset = 0;
      INITIAL_READ:
	if ($write_wait) {
	    # skip filling $wbuf when waiting for 100-continue
	    # because if the response is a redirect or auth required
	    # the request will be cloned and there is no way
	    # to reset the input stream
	    # return here via the label after the 100-continue is read
	}
	elsif (ref($content_ref) eq 'CODE') {
	    my $buf = &$content_ref();
	    $buf = "" unless defined($buf);
	    $buf = sprintf "%x%s%s%s", length($buf), $CRLF, $buf, $CRLF
		if $chunked;
	    substr($buf, 0, 0) = $req_buf if $req_buf;
	    $wbuf = \$buf;
	}
	else {
	    if ($req_buf) {
		my $buf = $req_buf . $$content_ref;
		$wbuf = \$buf;
	    }
	    else {
		$wbuf = $content_ref;
	    }
	    $eof = 1;
	}

	my $fbits = '';
	vec($fbits, fileno($socket), 1) = 1;

      WRITE:
	while ($write_wait || $woffset < length($$wbuf)) {

	    my $sel_timeout = $timeout;
	    if ($write_wait) {
		$sel_timeout = $write_wait if $write_wait < $sel_timeout;
	    }
	    my $time_before;
            $time_before = time if $sel_timeout;

	    my $rbits = $fbits;
	    my $wbits = $write_wait ? undef : $fbits;
            my $sel_timeout_before = $sel_timeout;
          SELECT:
            {
                my $nfound = select($rbits, $wbits, undef, $sel_timeout);
                if ($nfound < 0) {
                    if ($!{EINTR} || $!{EWOULDBLOCK} || $!{EAGAIN}) {
                        if ($time_before) {
                            $sel_timeout = $sel_timeout_before - (time - $time_before);
                            $sel_timeout = 0 if $sel_timeout < 0;
                        }
                        redo SELECT;
                    }
                    die "select failed: $!";
                }
	    }

	    if ($write_wait) {
		$write_wait -= time - $time_before;
		$write_wait = 0 if $write_wait < 0;
	    }

	    if (defined($rbits) && $rbits =~ /[^\0]/) {
		# readable
		my $buf = $socket->_rbuf;
		my $n = $socket->sysread($buf, 1024, length($buf));
                unless (defined $n) {
                    die "read failed: $!" unless  $!{EINTR} || $!{EWOULDBLOCK} || $!{EAGAIN};
                    # if we get here the rest of the block will do nothing
                    # and we will retry the read on the next round
                }
		elsif ($n == 0) {
                    # the server closed the connection before we finished
                    # writing all the request content.  No need to write any more.
                    $drop_connection++;
                    last WRITE;
		}
		$socket->_rbuf($buf);
		if (!$code && $buf =~ /\015?\012\015?\012/) {
		    # a whole response header is present, so we can read it without blocking
		    ($code, $mess, @h) = $socket->read_response_headers(laxed => 1,
									junk_out => \@junk,
								       );
		    if ($code eq "100") {
			$write_wait = 0;
			undef($code);
			goto INITIAL_READ;
		    }
		    else {
			$drop_connection++;
			last WRITE;
			# XXX should perhaps try to abort write in a nice way too
		    }
		}
	    }
	    if (defined($wbits) && $wbits =~ /[^\0]/) {
		my $n = $socket->syswrite($$wbuf, length($$wbuf), $woffset);
                unless (defined $n) {
                    die "write failed: $!" unless $!{EINTR} || $!{EWOULDBLOCK} || $!{EAGAIN};
                    $n = 0;  # will retry write on the next round
                }
                elsif ($n == 0) {
		    die "write failed: no bytes written";
		}
		$woffset += $n;

		if (!$eof && $woffset >= length($$wbuf)) {
		    # need to refill buffer from $content_ref code
		    my $buf = &$content_ref();
		    $buf = "" unless defined($buf);
		    $eof++ unless length($buf);
		    $buf = sprintf "%x%s%s%s", length($buf), $CRLF, $buf, $CRLF
			if $chunked;
		    $wbuf = \$buf;
		    $woffset = 0;
		}
	    }
	} # WRITE
    }

    ($code, $mess, @h) = $socket->read_response_headers(laxed => 1, junk_out => \@junk)
	unless $code;
    ($code, $mess, @h) = $socket->read_response_headers(laxed => 1, junk_out => \@junk)
	if $code eq "100";

    my $response = HTTP::Response->new($code, $mess);
    my $peer_http_version = $socket->peer_http_version;
    $response->protocol("HTTP/$peer_http_version");
    {
	local $HTTP::Headers::TRANSLATE_UNDERSCORE;
	$response->push_header(@h);
    }
    $response->push_header("Client-Junk" => \@junk) if @junk;

    $response->request($request);
    $self->_get_sock_info($response, $socket);

    if ($method eq "CONNECT") {
	$response->{client_socket} = $socket;  # so it can be picked up
	return $response;
    }

    if (my @te = $response->remove_header('Transfer-Encoding')) {
	$response->push_header('Client-Transfer-Encoding', \@te);
    }
    $response->push_header('Client-Response-Num', scalar $socket->increment_response_count);

    my $complete;
    $response = $self->collect($arg, $response, sub {
	my $buf = ""; #prevent use of uninitialized value in SSLeay.xs
	my $n;
      READ:
	{
	    $n = $socket->read_entity_body($buf, $size);
            unless (defined $n) {
                redo READ if $!{EINTR} || $!{EWOULDBLOCK} || $!{EAGAIN} || $!{ENOTTY};
                die "read failed: $!";
            }
	    redo READ if $n == -1;
	}
	$complete++ if !$n;
        return \$buf;
    } );
    $drop_connection++ unless $complete;

    @h = $socket->get_trailers;
    if (@h) {
	local $HTTP::Headers::TRANSLATE_UNDERSCORE;
	$response->push_header(@h);
    }

    # keep-alive support
    unless ($drop_connection) {
	if ($cache_key) {
	    my %connection = map { (lc($_) => 1) }
		             split(/\s*,\s*/, ($response->header("Connection") || ""));
	    if (($peer_http_version eq "1.1" && !$connection{close}) ||
		$connection{"keep-alive"})
	    {
		$conn_cache->deposit($self->socket_type, $cache_key, $socket);
	    }
	}
    }

    $response;
}


#-----------------------------------------------------------
package # hide from PAUSE
    LWP::Protocol::http::SocketMethods;

sub ping {
    my $self = shift;
    !$self->can_read(0);
}

sub increment_response_count {
    my $self = shift;
    return ++${*$self}{'myhttp_response_count'};
}

#-----------------------------------------------------------
package # hide from PAUSE
    LWP::Protocol::http::Socket;

use parent -norequire, qw(LWP::Protocol::http::SocketMethods Net::HTTP);

1;
PK       ! ��>�d  d    perl5/LWP/Protocol/nntp.pmnu ��6�$        package LWP::Protocol::nntp;

# Implementation of the Network News Transfer Protocol (RFC 977)

use base qw(LWP::Protocol);

our $VERSION = '6.49';

require HTTP::Response;
require HTTP::Status;
require Net::NNTP;

use strict;


sub request {
    my ($self, $request, $proxy, $arg, $size, $timeout) = @_;

    $size = 4096 unless $size;

    # Check for proxy
    if (defined $proxy) {
        return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
            'You can not proxy through NNTP');
    }

    # Check that the scheme is as expected
    my $url    = $request->uri;
    my $scheme = $url->scheme;
    unless ($scheme eq 'news' || $scheme eq 'nntp') {
        return HTTP::Response->new(HTTP::Status::RC_INTERNAL_SERVER_ERROR,
            "LWP::Protocol::nntp::request called for '$scheme'");
    }

    # check for a valid method
    my $method = $request->method;
    unless ($method eq 'GET' || $method eq 'HEAD' || $method eq 'POST') {
        return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
            'Library does not allow method ' . "$method for '$scheme:' URLs");
    }

    # extract the identifier and check against posting to an article
    my $groupart = $url->_group;
    my $is_art   = $groupart =~ /@/;

    if ($is_art && $method eq 'POST') {
        return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
            "Can't post to an article <$groupart>");
    }

    my $nntp = Net::NNTP->new(
        $url->host,

        #Port    => 18574,
        Timeout => $timeout,

        #Debug   => 1,
    );
    die "Can't connect to nntp server" unless $nntp;

    # Check the initial welcome message from the NNTP server
    if ($nntp->status != 2) {
        return HTTP::Response->new(HTTP::Status::RC_SERVICE_UNAVAILABLE,
            $nntp->message);
    }
    my $response = HTTP::Response->new(HTTP::Status::RC_OK, "OK");

    my $mess = $nntp->message;

    # Try to extract server name from greeting message.
    # Don't know if this works well for a large class of servers, but
    # this works for our server.
    $mess =~ s/\s+ready\b.*//;
    $mess =~ s/^\S+\s+//;
    $response->header(Server => $mess);

    # First we handle posting of articles
    if ($method eq 'POST') {
        $nntp->quit;
        $nntp = undef;
        $response->code(HTTP::Status::RC_NOT_IMPLEMENTED);
        $response->message("POST not implemented yet");
        return $response;
    }

    # The method must be "GET" or "HEAD" by now
    if (!$is_art) {
        if (!$nntp->group($groupart)) {
            $response->code(HTTP::Status::RC_NOT_FOUND);
            $response->message($nntp->message);
        }
        $nntp->quit;
        $nntp = undef;

        # HEAD: just check if the group exists
        if ($method eq 'GET' && $response->is_success) {
            $response->code(HTTP::Status::RC_NOT_IMPLEMENTED);
            $response->message("GET newsgroup not implemented yet");
        }
        return $response;
    }

    # Send command to server to retrieve an article (or just the headers)
    my $get = $method eq 'HEAD' ? "head" : "article";
    my $art = $nntp->$get("<$groupart>");
    unless ($art) {
        $nntp->quit;
        $response->code(HTTP::Status::RC_NOT_FOUND);
        $response->message($nntp->message);
        $nntp = undef;
        return $response;
    }

    # Parse headers
    my ($key, $val);
    local $_;
    while ($_ = shift @$art) {
        if (/^\s+$/) {
            last;    # end of headers
        }
        elsif (/^(\S+):\s*(.*)/) {
            $response->push_header($key, $val) if $key;
            ($key, $val) = ($1, $2);
        }
        elsif (/^\s+(.*)/) {
            next unless $key;
            $val .= $1;
        }
        else {
            unshift(@$art, $_);
            last;
        }
    }
    $response->push_header($key, $val) if $key;

    # Ensure that there is a Content-Type header
    $response->header("Content-Type", "text/plain")
        unless $response->header("Content-Type");

    # Collect the body
    $response = $self->collect_once($arg, $response, join("", @$art)) if @$art;

    # Say goodbye to the server
    $nntp->quit;
    $nntp = undef;

    $response;
}

1;
PK       ! �o8�J  �J    perl5/LWP/Protocol/ftp.pmnu ��6�$        package LWP::Protocol::ftp;

# Implementation of the ftp protocol (RFC 959). We let the Net::FTP
# package do all the dirty work.
use base qw(LWP::Protocol);
use strict;

our $VERSION = '6.49';

use Carp            ();
use HTTP::Status    ();
use HTTP::Negotiate ();
use HTTP::Response  ();
use LWP::MediaTypes ();
use File::Listing   ();


{

    package # hide from PAUSE
        LWP::Protocol::MyFTP;

    use strict;
    use base qw(Net::FTP);

    sub new {
        my $class = shift;

        my $self = $class->SUPER::new(@_) || return undef;

        my $mess = $self->message;    # welcome message
        $mess =~ s|\n.*||s;           # only first line left
        $mess =~ s|\s*ready\.?$||;

        # Make the version number more HTTP like
        $mess =~ s|\s*\(Version\s*|/| and $mess =~ s|\)$||;
        ${*$self}{myftp_server} = $mess;

        #$response->header("Server", $mess);

        $self;
    }

    sub http_server {
        my $self = shift;
        ${*$self}{myftp_server};
    }

    sub home {
        my $self = shift;
        my $old  = ${*$self}{myftp_home};
        if (@_) {
            ${*$self}{myftp_home} = shift;
        }
        $old;
    }

    sub go_home {
        my $self = shift;
        $self->cwd(${*$self}{myftp_home});
    }

    sub request_count {
        my $self = shift;
        ++${*$self}{myftp_reqcount};
    }

    sub ping {
        my $self = shift;
        return $self->go_home;
    }
}

sub _connect {
    my ($self, $host, $port, $user, $account, $password, $timeout) = @_;

    my $key;
    my $conn_cache = $self->{ua}{conn_cache};
    if ($conn_cache) {
        $key = "$host:$port:$user";
        $key .= ":$account" if defined($account);
        if (my $ftp = $conn_cache->withdraw("ftp", $key)) {
            if ($ftp->ping) {

                # save it again
                $conn_cache->deposit("ftp", $key, $ftp);
                return $ftp;
            }
        }
    }

    # try to make a connection
    my $ftp = LWP::Protocol::MyFTP->new(
        $host,
        Port      => $port,
        Timeout   => $timeout,
        LocalAddr => $self->{ua}{local_address},
    );

    # XXX Should be some what to pass on 'Passive' (header??)
    unless ($ftp) {
        $@ =~ s/^Net::FTP: //;
        return HTTP::Response->new(HTTP::Status::RC_INTERNAL_SERVER_ERROR, $@);
    }

    unless ($ftp->login($user, $password, $account)) {

        # Unauthorized.  Let's fake a RC_UNAUTHORIZED response
        my $mess = scalar($ftp->message);
        $mess =~ s/\n$//;
        my $res = HTTP::Response->new(HTTP::Status::RC_UNAUTHORIZED, $mess);
        $res->header("Server",           $ftp->http_server);
        $res->header("WWW-Authenticate", qq(Basic Realm="FTP login"));
        return $res;
    }

    my $home = $ftp->pwd;
    $ftp->home($home);

    $conn_cache->deposit("ftp", $key, $ftp) if $conn_cache;

    return $ftp;
}


sub request {
    my ($self, $request, $proxy, $arg, $size, $timeout) = @_;

    $size = 4096 unless $size;

    # check proxy
    if (defined $proxy) {
        return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
            'You can not proxy through the ftp');
    }

    my $url = $request->uri;
    if ($url->scheme ne 'ftp') {
        my $scheme = $url->scheme;
        return HTTP::Response->new(HTTP::Status::RC_INTERNAL_SERVER_ERROR,
            "LWP::Protocol::ftp::request called for '$scheme'");
    }

    # check method
    my $method = $request->method;

    unless ($method eq 'GET' || $method eq 'HEAD' || $method eq 'PUT') {
        return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
            'Library does not allow method ' . "$method for 'ftp:' URLs");
    }

    my $host     = $url->host;
    my $port     = $url->port;
    my $user     = $url->user;
    my $password = $url->password;

    # If a basic authorization header is present than we prefer these over
    # the username/password specified in the URL.
    {
        my ($u, $p) = $request->authorization_basic;
        if (defined $u) {
            $user     = $u;
            $password = $p;
        }
    }

    # We allow the account to be specified in the "Account" header
    my $account = $request->header('Account');

    my $ftp
        = $self->_connect($host, $port, $user, $account, $password, $timeout);
    return $ftp if ref($ftp) eq "HTTP::Response";    # ugh!

    # Create an initial response object
    my $response = HTTP::Response->new(HTTP::Status::RC_OK, "OK");
    $response->header(Server               => $ftp->http_server);
    $response->header('Client-Request-Num' => $ftp->request_count);
    $response->request($request);

    # Get & fix the path
    my @path = grep {length} $url->path_segments;
    my $remote_file = pop(@path);
    $remote_file = '' unless defined $remote_file;

    my $type;
    if (ref $remote_file) {
        my @params;
        ($remote_file, @params) = @$remote_file;
        for (@params) {
            $type = $_ if s/^type=//;
        }
    }

    if ($type && $type eq 'a') {
        $ftp->ascii;
    }
    else {
        $ftp->binary;
    }

    for (@path) {
        unless ($ftp->cwd($_)) {
            return HTTP::Response->new(HTTP::Status::RC_NOT_FOUND,
                "Can't chdir to $_");
        }
    }

    if ($method eq 'GET' || $method eq 'HEAD') {
        if (my $mod_time = $ftp->mdtm($remote_file)) {
            $response->last_modified($mod_time);
            if (my $ims = $request->if_modified_since) {
                if ($mod_time <= $ims) {
                    $response->code(HTTP::Status::RC_NOT_MODIFIED);
                    $response->message("Not modified");
                    return $response;
                }
            }
        }

        # We'll use this later to abort the transfer if necessary.
        # if $max_size is defined, we need to abort early. Otherwise, it's
        # a normal transfer
        my $max_size = undef;

        # Set resume location, if the client requested it
        if ($request->header('Range') && $ftp->supported('REST')) {
            my $range_info = $request->header('Range');

            # Change bytes=2772992-6781209 to just 2772992
            my ($start_byte, $end_byte) = $range_info =~ /.*=\s*(\d+)-(\d+)?/;
            if (defined $start_byte && !defined $end_byte) {

                # open range -- only the start is specified

                $ftp->restart($start_byte);

                # don't define $max_size, we don't want to abort early
            }
            elsif (defined $start_byte
                && defined $end_byte
                && $start_byte >= 0
                && $end_byte >= $start_byte)
            {

                $ftp->restart($start_byte);
                $max_size = $end_byte - $start_byte;
            }
            else {

                return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
                    'Incorrect syntax for Range request');
            }
        }
        elsif ($request->header('Range') && !$ftp->supported('REST')) {
            return HTTP::Response->new(HTTP::Status::RC_NOT_IMPLEMENTED,
                "Server does not support resume."
            );
        }

        my $data;    # the data handle
        if (length($remote_file) and $data = $ftp->retr($remote_file)) {
            my ($type, @enc) = LWP::MediaTypes::guess_media_type($remote_file);
            $response->header('Content-Type', $type) if $type;
            for (@enc) {
                $response->push_header('Content-Encoding', $_);
            }
            my $mess = $ftp->message;
            if ($mess =~ /\((\d+)\s+bytes\)/) {
                $response->header('Content-Length', "$1");
            }

            if ($method ne 'HEAD') {

                # Read data from server
                $response = $self->collect(
                    $arg,
                    $response,
                    sub {
                        my $content = '';
                        my $result = $data->read($content, $size);

                        # Stop early if we need to.
                        if (defined $max_size) {

                        # We need an interface to Net::FTP::dataconn for getting
                        # the number of bytes already read
                            my $bytes_received = $data->bytes_read();

                           # We were already over the limit. (Should only happen
                           # once at the end.)
                            if ($bytes_received - length($content) > $max_size)
                            {
                                $content = '';
                            }

                            # We just went over the limit
                            elsif ($bytes_received > $max_size) {

                                # Trim content
                                $content = substr($content, 0,
                                    $max_size
                                        - ($bytes_received - length($content)));
                            }

                            # We're under the limit
                            else {
                            }
                        }

                        return \$content;
                    }
                );
            }

            # abort is needed for HEAD, it's == close if the transfer has
            # already completed.
            unless ($data->abort) {

                # Something did not work too well.  Note that we treat
                # responses to abort() with code 0 in case of HEAD as ok
                # (at least wu-ftpd 2.6.1(1) does that).
                if ($method ne 'HEAD' || $ftp->code != 0) {
                    $response->code(HTTP::Status::RC_INTERNAL_SERVER_ERROR);
                    $response->message("FTP close response: "
                            . $ftp->code . " "
                            . $ftp->message);
                }
            }
        }
        elsif (!length($remote_file) || ($ftp->code >= 400 && $ftp->code < 600))
        {
            # not a plain file, try to list instead
            if (length($remote_file) && !$ftp->cwd($remote_file)) {
                return HTTP::Response->new(HTTP::Status::RC_NOT_FOUND,
                    "File '$remote_file' not found"
                );
            }

            # It should now be safe to try to list the directory
            my @lsl = $ftp->dir;

            # Try to figure out if the user want us to convert the
            # directory listing to HTML.
            my @variants = (
                ['html', 0.60, 'text/html'],
                ['dir',  1.00, 'text/ftp-dir-listing']
            );

            #$HTTP::Negotiate::DEBUG=1;
            my $prefer = HTTP::Negotiate::choose(\@variants, $request);

            my $content = '';

            if (!defined($prefer)) {
                return HTTP::Response->new(HTTP::Status::RC_NOT_ACCEPTABLE,
                    "Neither HTML nor directory listing wanted");
            }
            elsif ($prefer eq 'html') {
                $response->header('Content-Type' => 'text/html');
                $content = "<HEAD><TITLE>File Listing</TITLE>\n";
                my $base = $request->uri->clone;
                my $path = $base->path;
                $base->path("$path/") unless $path =~ m|/$|;
                $content .= qq(<BASE HREF="$base">\n</HEAD>\n);
                $content .= "<BODY>\n<UL>\n";
                for (File::Listing::parse_dir(\@lsl, 'GMT')) {
                    my ($name, $type, $size, $mtime, $mode) = @$_;
                    $content .= qq(  <LI> <a href="$name">$name</a>);
                    $content .= " $size bytes" if $type eq 'f';
                    $content .= "\n";
                }
                $content .= "</UL></body>\n";
            }
            else {
                $response->header('Content-Type', 'text/ftp-dir-listing');
                $content = join("\n", @lsl, '');
            }

            $response->header('Content-Length', length($content));

            if ($method ne 'HEAD') {
                $response = $self->collect_once($arg, $response, $content);
            }
        }
        else {
            my $res = HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
                "FTP return code " . $ftp->code);
            $res->content_type("text/plain");
            $res->content($ftp->message);
            return $res;
        }
    }
    elsif ($method eq 'PUT') {

        # method must be PUT
        unless (length($remote_file)) {
            return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
                "Must have a file name to PUT to"
            );
        }
        my $data;
        if ($data = $ftp->stor($remote_file)) {
            my $content = $request->content;
            my $bytes   = 0;
            if (defined $content) {
                if (ref($content) eq 'SCALAR') {
                    $bytes = $data->write($$content, length($$content));
                }
                elsif (ref($content) eq 'CODE') {
                    my ($buf, $n);
                    while (length($buf = &$content)) {
                        $n = $data->write($buf, length($buf));
                        last unless $n;
                        $bytes += $n;
                    }
                }
                elsif (!ref($content)) {
                    if (defined $content && length($content)) {
                        $bytes = $data->write($content, length($content));
                    }
                }
                else {
                    die "Bad content";
                }
            }
            $data->close;

            $response->code(HTTP::Status::RC_CREATED);
            $response->header('Content-Type', 'text/plain');
            $response->content("$bytes bytes stored as $remote_file on $host\n")

        }
        else {
            my $res = HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
                "FTP return code " . $ftp->code);
            $res->content_type("text/plain");
            $res->content($ftp->message);
            return $res;
        }
    }
    else {
        return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
            "Illegal method $method");
    }

    $response;
}

1;

__END__

# This is what RFC 1738 has to say about FTP access:
# --------------------------------------------------
#
# 3.2. FTP
#
#    The FTP URL scheme is used to designate files and directories on
#    Internet hosts accessible using the FTP protocol (RFC959).
#
#    A FTP URL follow the syntax described in Section 3.1.  If :<port> is
#    omitted, the port defaults to 21.
#
# 3.2.1. FTP Name and Password
#
#    A user name and password may be supplied; they are used in the ftp
#    "USER" and "PASS" commands after first making the connection to the
#    FTP server.  If no user name or password is supplied and one is
#    requested by the FTP server, the conventions for "anonymous" FTP are
#    to be used, as follows:
#
#         The user name "anonymous" is supplied.
#
#         The password is supplied as the Internet e-mail address
#         of the end user accessing the resource.
#
#    If the URL supplies a user name but no password, and the remote
#    server requests a password, the program interpreting the FTP URL
#    should request one from the user.
#
# 3.2.2. FTP url-path
#
#    The url-path of a FTP URL has the following syntax:
#
#         <cwd1>/<cwd2>/.../<cwdN>/<name>;type=<typecode>
#
#    Where <cwd1> through <cwdN> and <name> are (possibly encoded) strings
#    and <typecode> is one of the characters "a", "i", or "d".  The part
#    ";type=<typecode>" may be omitted. The <cwdx> and <name> parts may be
#    empty. The whole url-path may be omitted, including the "/"
#    delimiting it from the prefix containing user, password, host, and
#    port.
#
#    The url-path is interpreted as a series of FTP commands as follows:
#
#       Each of the <cwd> elements is to be supplied, sequentially, as the
#       argument to a CWD (change working directory) command.
#
#       If the typecode is "d", perform a NLST (name list) command with
#       <name> as the argument, and interpret the results as a file
#       directory listing.
#
#       Otherwise, perform a TYPE command with <typecode> as the argument,
#       and then access the file whose name is <name> (for example, using
#       the RETR command.)
#
#    Within a name or CWD component, the characters "/" and ";" are
#    reserved and must be encoded. The components are decoded prior to
#    their use in the FTP protocol.  In particular, if the appropriate FTP
#    sequence to access a particular file requires supplying a string
#    containing a "/" as an argument to a CWD or RETR command, it is
#    necessary to encode each "/".
#
#    For example, the URL <URL:ftp://myname@host.dom/%2Fetc/motd> is
#    interpreted by FTP-ing to "host.dom", logging in as "myname"
#    (prompting for a password if it is asked for), and then executing
#    "CWD /etc" and then "RETR motd". This has a different meaning from
#    <URL:ftp://myname@host.dom/etc/motd> which would "CWD etc" and then
#    "RETR motd"; the initial "CWD" might be executed relative to the
#    default directory for "myname". On the other hand,
#    <URL:ftp://myname@host.dom//etc/motd>, would "CWD " with a null
#    argument, then "CWD etc", and then "RETR motd".
#
#    FTP URLs may also be used for other operations; for example, it is
#    possible to update a file on a remote file server, or infer
#    information about it from the directory listings. The mechanism for
#    doing so is not spelled out here.
#
# 3.2.3. FTP Typecode is Optional
#
#    The entire ;type=<typecode> part of a FTP URL is optional. If it is
#    omitted, the client program interpreting the URL must guess the
#    appropriate mode to use. In general, the data content type of a file
#    can only be guessed from the name, e.g., from the suffix of the name;
#    the appropriate type code to be used for transfer of the file can
#    then be deduced from the data content of the file.
#
# 3.2.4 Hierarchy
#
#    For some file systems, the "/" used to denote the hierarchical
#    structure of the URL corresponds to the delimiter used to construct a
#    file name hierarchy, and thus, the filename will look similar to the
#    URL path. This does NOT mean that the URL is a Unix filename.
#
# 3.2.5. Optimization
#
#    Clients accessing resources via FTP may employ additional heuristics
#    to optimize the interaction. For some FTP servers, for example, it
#    may be reasonable to keep the control connection open while accessing
#    multiple URLs from the same server. However, there is no common
#    hierarchical model to the FTP protocol, so if a directory change
#    command has been given, it is impossible in general to deduce what
#    sequence should be given to navigate to another directory for a
#    second retrieval, if the paths are different.  The only reliable
#    algorithm is to disconnect and reestablish the control connection.
PK       ! �z'$      perl5/LWP/Protocol/file.pmnu ��6�$        package LWP::Protocol::file;

use base qw(LWP::Protocol);

use strict;

our $VERSION = '6.49';

require LWP::MediaTypes;
require HTTP::Request;
require HTTP::Response;
require HTTP::Status;
require HTTP::Date;


sub request
{
    my($self, $request, $proxy, $arg, $size) = @_;

    $size = 4096 unless defined $size and $size > 0;

    # check proxy
    if (defined $proxy)
    {
	return HTTP::Response->new( HTTP::Status::RC_BAD_REQUEST,
				  'You can not proxy through the filesystem');
    }

    # check method
    my $method = $request->method;
    unless ($method eq 'GET' || $method eq 'HEAD') {
	return HTTP::Response->new( HTTP::Status::RC_BAD_REQUEST,
				  'Library does not allow method ' .
				  "$method for 'file:' URLs");
    }

    # check url
    my $url = $request->uri;

    my $scheme = $url->scheme;
    if ($scheme ne 'file') {
	return HTTP::Response->new( HTTP::Status::RC_INTERNAL_SERVER_ERROR,
			   "LWP::Protocol::file::request called for '$scheme'");
    }

    # URL OK, look at file
    my $path  = $url->file;

    # test file exists and is readable
    unless (-e $path) {
	return HTTP::Response->new( HTTP::Status::RC_NOT_FOUND,
				  "File `$path' does not exist");
    }
    unless (-r _) {
	return HTTP::Response->new( HTTP::Status::RC_FORBIDDEN,
				  'User does not have read permission');
    }

    # looks like file exists
    my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$filesize,
       $atime,$mtime,$ctime,$blksize,$blocks)
	    = stat(_);

    # XXX should check Accept headers?

    # check if-modified-since
    my $ims = $request->header('If-Modified-Since');
    if (defined $ims) {
	my $time = HTTP::Date::str2time($ims);
	if (defined $time and $time >= $mtime) {
	    return HTTP::Response->new( HTTP::Status::RC_NOT_MODIFIED,
				      "$method $path");
	}
    }

    # Ok, should be an OK response by now...
    my $response = HTTP::Response->new( HTTP::Status::RC_OK );

    # fill in response headers
    $response->header('Last-Modified', HTTP::Date::time2str($mtime));

    if (-d _) {         # If the path is a directory, process it
	# generate the HTML for directory
	opendir(D, $path) or
	   return HTTP::Response->new( HTTP::Status::RC_INTERNAL_SERVER_ERROR,
				     "Cannot read directory '$path': $!");
	my(@files) = sort readdir(D);
	closedir(D);

	# Make directory listing
	require URI::Escape;
	require HTML::Entities;
        my $pathe = $path . ( $^O eq 'MacOS' ? ':' : '/');
	for (@files) {
	    my $furl = URI::Escape::uri_escape($_);
            if ( -d "$pathe$_" ) {
                $furl .= '/';
                $_ .= '/';
            }
	    my $desc = HTML::Entities::encode($_);
	    $_ = qq{<LI><A HREF="$furl">$desc</A>};
	}
	# Ensure that the base URL is "/" terminated
	my $base = $url->clone;
	unless ($base->path =~ m|/$|) {
	    $base->path($base->path . "/");
	}
	my $html = join("\n",
			"<HTML>\n<HEAD>",
			"<TITLE>Directory $path</TITLE>",
			"<BASE HREF=\"$base\">",
			"</HEAD>\n<BODY>",
			"<H1>Directory listing of $path</H1>",
			"<UL>", @files, "</UL>",
			"</BODY>\n</HTML>\n");

	$response->header('Content-Type',   'text/html');
	$response->header('Content-Length', length $html);
	$html = "" if $method eq "HEAD";

	return $self->collect_once($arg, $response, $html);

    }

    # path is a regular file
    $response->header('Content-Length', $filesize);
    LWP::MediaTypes::guess_media_type($path, $response);

    # read the file
    if ($method ne "HEAD") {
	open(my $fh, '<', $path) or return new
	    HTTP::Response(HTTP::Status::RC_INTERNAL_SERVER_ERROR,
			   "Cannot read file '$path': $!");
	binmode($fh);
	$response =  $self->collect($arg, $response, sub {
	    my $content = "";
	    my $bytes = sysread($fh, $content, $size);
	    return \$content if $bytes > 0;
	    return \ "";
	});
	close($fh);
    }

    $response;
}

1;
PK       ! ��� �   perl5/LWP/UserAgent.pmnu ��6�$        package LWP::UserAgent;

use strict;

use base qw(LWP::MemberMixin);

use Carp ();
use HTTP::Request ();
use HTTP::Response ();
use HTTP::Date ();

use LWP ();
use LWP::Protocol ();

use Scalar::Util qw(blessed);
use Try::Tiny qw(try catch);

our $VERSION = '6.49';

sub new
{
    # Check for common user mistake
    Carp::croak("Options to LWP::UserAgent should be key/value pairs, not hash reference")
        if ref($_[1]) eq 'HASH';

    my($class, %cnf) = @_;

    my $agent = delete $cnf{agent};
    my $from  = delete $cnf{from};
    my $def_headers = delete $cnf{default_headers};
    my $timeout = delete $cnf{timeout};
    $timeout = 3*60 unless defined $timeout;
    my $local_address = delete $cnf{local_address};
    my $ssl_opts = delete $cnf{ssl_opts} || {};
    unless (exists $ssl_opts->{verify_hostname}) {
	# The processing of HTTPS_CA_* below is for compatibility with Crypt::SSLeay
	if (exists $ENV{PERL_LWP_SSL_VERIFY_HOSTNAME}) {
	    $ssl_opts->{verify_hostname} = $ENV{PERL_LWP_SSL_VERIFY_HOSTNAME};
	}
	elsif ($ENV{HTTPS_CA_FILE} || $ENV{HTTPS_CA_DIR}) {
	    # Crypt-SSLeay compatibility (verify peer certificate; but not the hostname)
	    $ssl_opts->{verify_hostname} = 0;
	    $ssl_opts->{SSL_verify_mode} = 1;
	}
	else {
	    $ssl_opts->{verify_hostname} = 1;
	}
    }
    unless (exists $ssl_opts->{SSL_ca_file}) {
	if (my $ca_file = $ENV{PERL_LWP_SSL_CA_FILE} || $ENV{HTTPS_CA_FILE}) {
	    $ssl_opts->{SSL_ca_file} = $ca_file;
	}
    }
    unless (exists $ssl_opts->{SSL_ca_path}) {
	if (my $ca_path = $ENV{PERL_LWP_SSL_CA_PATH} || $ENV{HTTPS_CA_DIR}) {
	    $ssl_opts->{SSL_ca_path} = $ca_path;
	}
    }
    my $use_eval = delete $cnf{use_eval};
    $use_eval = 1 unless defined $use_eval;
    my $parse_head = delete $cnf{parse_head};
    $parse_head = 1 unless defined $parse_head;
    my $send_te = delete $cnf{send_te};
    $send_te = 1 unless defined $send_te;
    my $show_progress = delete $cnf{show_progress};
    my $max_size = delete $cnf{max_size};
    my $max_redirect = delete $cnf{max_redirect};
    $max_redirect = 7 unless defined $max_redirect;
    my $env_proxy = exists $cnf{env_proxy} ? delete $cnf{env_proxy} : $ENV{PERL_LWP_ENV_PROXY};
    my $no_proxy = exists $cnf{no_proxy} ? delete $cnf{no_proxy} : [];
    Carp::croak(qq{no_proxy must be an arrayref, not $no_proxy!}) if ref $no_proxy ne 'ARRAY';

    my $cookie_jar = delete $cnf{cookie_jar};
    my $conn_cache = delete $cnf{conn_cache};
    my $keep_alive = delete $cnf{keep_alive};

    Carp::croak("Can't mix conn_cache and keep_alive")
	  if $conn_cache && $keep_alive;

    my $protocols_allowed   = delete $cnf{protocols_allowed};
    my $protocols_forbidden = delete $cnf{protocols_forbidden};

    my $requests_redirectable = delete $cnf{requests_redirectable};
    $requests_redirectable = ['GET', 'HEAD']
      unless defined $requests_redirectable;

    # Actually ""s are just as good as 0's, but for concision we'll just say:
    Carp::croak("protocols_allowed has to be an arrayref or 0, not \"$protocols_allowed\"!")
      if $protocols_allowed and ref($protocols_allowed) ne 'ARRAY';
    Carp::croak("protocols_forbidden has to be an arrayref or 0, not \"$protocols_forbidden\"!")
      if $protocols_forbidden and ref($protocols_forbidden) ne 'ARRAY';
    Carp::croak("requests_redirectable has to be an arrayref or 0, not \"$requests_redirectable\"!")
      if $requests_redirectable and ref($requests_redirectable) ne 'ARRAY';

    if (%cnf && $^W) {
	Carp::carp("Unrecognized LWP::UserAgent options: @{[sort keys %cnf]}");
    }

    my $self = bless {
        def_headers           => $def_headers,
        timeout               => $timeout,
        local_address         => $local_address,
        ssl_opts              => $ssl_opts,
        use_eval              => $use_eval,
        show_progress         => $show_progress,
        max_size              => $max_size,
        max_redirect          => $max_redirect,
        # We set proxy later as we do validation on the values
        proxy                 => {},
        no_proxy              => [ @{ $no_proxy } ],
        protocols_allowed     => $protocols_allowed,
        protocols_forbidden   => $protocols_forbidden,
        requests_redirectable => $requests_redirectable,
        send_te               => $send_te,
    }, $class;

    $self->agent(defined($agent) ? $agent : $class->_agent)
        if defined($agent) || !$def_headers || !$def_headers->header("User-Agent");
    $self->from($from) if $from;
    $self->cookie_jar($cookie_jar) if $cookie_jar;
    $self->parse_head($parse_head);
    $self->env_proxy if $env_proxy;

    if (exists $cnf{proxy}) {
        Carp::croak(qq{proxy must be an arrayref, not $cnf{proxy}!})
            if ref $cnf{proxy} ne 'ARRAY';
        $self->proxy($cnf{proxy});
    }

    $self->protocols_allowed(  $protocols_allowed  ) if $protocols_allowed;
    $self->protocols_forbidden($protocols_forbidden) if $protocols_forbidden;

    if ($keep_alive) {
	$conn_cache ||= { total_capacity => $keep_alive };
    }
    $self->conn_cache($conn_cache) if $conn_cache;

    return $self;
}


sub send_request
{
    my($self, $request, $arg, $size) = @_;
    my($method, $url) = ($request->method, $request->uri);
    my $scheme = $url->scheme;

    local($SIG{__DIE__});  # protect against user defined die handlers

    $self->progress("begin", $request);

    my $response = $self->run_handlers("request_send", $request);

    unless ($response) {
        my $protocol;

        {
            # Honor object-specific restrictions by forcing protocol objects
            #  into class LWP::Protocol::nogo.
            my $x;
            if($x = $self->protocols_allowed) {
                if (grep lc($_) eq $scheme, @$x) {
                }
                else {
                    require LWP::Protocol::nogo;
                    $protocol = LWP::Protocol::nogo->new;
                }
            }
            elsif ($x = $self->protocols_forbidden) {
                if(grep lc($_) eq $scheme, @$x) {
                    require LWP::Protocol::nogo;
                    $protocol = LWP::Protocol::nogo->new;
                }
            }
            # else fall thru and create the protocol object normally
        }

        # Locate protocol to use
        my $proxy = $request->{proxy};
        if ($proxy) {
            $scheme = $proxy->scheme;
        }

        unless ($protocol) {
            try {
                $protocol = LWP::Protocol::create($scheme, $self);
            }
            catch {
                my $error = $_;
                $error =~ s/ at .* line \d+.*//s;  # remove file/line number
                $response =  _new_response($request, HTTP::Status::RC_NOT_IMPLEMENTED, $error);
                if ($scheme eq "https") {
                    $response->message($response->message . " (LWP::Protocol::https not installed)");
                    $response->content_type("text/plain");
                    $response->content(<<EOT);
LWP will support https URLs if the LWP::Protocol::https module
is installed.
EOT
                }
            };
        }

        if (!$response && $self->{use_eval}) {
            # we eval, and turn dies into responses below
            try {
                $response = $protocol->request($request, $proxy, $arg, $size, $self->{timeout}) || die "No response returned by $protocol";
            }
            catch {
                my $error = $_;
                if (blessed($error) && $error->isa("HTTP::Response")) {
                    $response = $error;
                    $response->request($request);
                }
                else {
                    my $full = $error;
                    (my $status = $error) =~ s/\n.*//s;
                    $status =~ s/ at .* line \d+.*//s;  # remove file/line number
                    my $code = ($status =~ s/^(\d\d\d)\s+//) ? $1 : HTTP::Status::RC_INTERNAL_SERVER_ERROR;
                    $response = _new_response($request, $code, $status, $full);
                }
            };
        }
        elsif (!$response) {
            $response = $protocol->request($request, $proxy,
                                           $arg, $size, $self->{timeout});
            # XXX: Should we die unless $response->is_success ???
        }
    }

    $response->request($request);  # record request for reference
    $response->header("Client-Date" => HTTP::Date::time2str(time));

    $self->run_handlers("response_done", $response);

    $self->progress("end", $response);
    return $response;
}


sub prepare_request
{
    my($self, $request) = @_;
    die "Method missing" unless $request->method;
    my $url = $request->uri;
    die "URL missing" unless $url;
    die "URL must be absolute" unless $url->scheme;

    $self->run_handlers("request_preprepare", $request);

    if (my $def_headers = $self->{def_headers}) {
	for my $h ($def_headers->header_field_names) {
	    $request->init_header($h => [$def_headers->header($h)]);
	}
    }

    $self->run_handlers("request_prepare", $request);

    return $request;
}


sub simple_request
{
    my($self, $request, $arg, $size) = @_;

    # sanity check the request passed in
    if (defined $request) {
	if (ref $request) {
	    Carp::croak("You need a request object, not a " . ref($request) . " object")
	      if ref($request) eq 'ARRAY' or ref($request) eq 'HASH' or
		 !$request->can('method') or !$request->can('uri');
	}
	else {
	    Carp::croak("You need a request object, not '$request'");
	}
    }
    else {
        Carp::croak("No request object passed in");
    }

    my $error;
    try {
        $request = $self->prepare_request($request);
    }
    catch {
        $error = $_;
        $error =~ s/ at .* line \d+.*//s;  # remove file/line number
    };

    if ($error) {
        return _new_response($request, HTTP::Status::RC_BAD_REQUEST, $error);
    }
    return $self->send_request($request, $arg, $size);
}


sub request {
    my ($self, $request, $arg, $size, $previous) = @_;

    my $response = $self->simple_request($request, $arg, $size);
    $response->previous($previous) if $previous;

    if ($response->redirects >= $self->{max_redirect}) {
        if ($response->header('Location')) {
            $response->header("Client-Warning" =>
                "Redirect loop detected (max_redirect = $self->{max_redirect})"
            );
        }
        return $response;
    }

    if (my $req = $self->run_handlers("response_redirect", $response)) {
        return $self->request($req, $arg, $size, $response);
    }

    my $code = $response->code;

    if (   $code == HTTP::Status::RC_MOVED_PERMANENTLY
        or $code == HTTP::Status::RC_FOUND
        or $code == HTTP::Status::RC_SEE_OTHER
        or $code == HTTP::Status::RC_TEMPORARY_REDIRECT
        or $code == HTTP::Status::RC_PERMANENT_REDIRECT)
    {
        my $referral = $request->clone;

        # These headers should never be forwarded
        $referral->remove_header('Host', 'Cookie');

        if (   $referral->header('Referer')
            && $request->uri->scheme eq 'https'
            && $referral->uri->scheme eq 'http')
        {
            # RFC 2616, section 15.1.3.
            # https -> http redirect, suppressing Referer
            $referral->remove_header('Referer');
        }

        if (   $code == HTTP::Status::RC_SEE_OTHER
            || $code == HTTP::Status::RC_FOUND)
        {
            my $method = uc($referral->method);
            unless ($method eq "GET" || $method eq "HEAD") {
                $referral->method("GET");
                $referral->content("");
                $referral->remove_content_headers;
            }
        }

        # And then we update the URL based on the Location:-header.
        my $referral_uri = $response->header('Location');
        {
            # Some servers erroneously return a relative URL for redirects,
            # so make it absolute if it not already is.
            local $URI::ABS_ALLOW_RELATIVE_SCHEME = 1;
            my $base = $response->base;
            $referral_uri = "" unless defined $referral_uri;
            $referral_uri
                = $HTTP::URI_CLASS->new($referral_uri, $base)->abs($base);
        }
        $referral->uri($referral_uri);

        return $response unless $self->redirect_ok($referral, $response);
        return $self->request($referral, $arg, $size, $response);

    }
    elsif ($code == HTTP::Status::RC_UNAUTHORIZED
        || $code == HTTP::Status::RC_PROXY_AUTHENTICATION_REQUIRED)
    {
        my $proxy = ($code == HTTP::Status::RC_PROXY_AUTHENTICATION_REQUIRED);
        my $ch_header
            = $proxy || $request->method eq 'CONNECT'
            ? "Proxy-Authenticate"
            : "WWW-Authenticate";
        my @challenges = $response->header($ch_header);
        unless (@challenges) {
            $response->header(
                "Client-Warning" => "Missing Authenticate header");
            return $response;
        }

        require HTTP::Headers::Util;
        CHALLENGE: for my $challenge (@challenges) {
            $challenge =~ tr/,/;/;    # "," is used to separate auth-params!!
            ($challenge) = HTTP::Headers::Util::split_header_words($challenge);
            my $scheme = shift(@$challenge);
            shift(@$challenge);       # no value
            $challenge = {@$challenge};    # make rest into a hash

            unless ($scheme =~ /^([a-z]+(?:-[a-z]+)*)$/) {
                $response->header(
                    "Client-Warning" => "Bad authentication scheme '$scheme'");
                return $response;
            }
            $scheme = $1;                  # untainted now
            my $class = "LWP::Authen::\u$scheme";
            $class =~ tr/-/_/;

            no strict 'refs';
            unless (%{"$class\::"}) {
                # try to load it
                my $error;
                try {
                    (my $req = $class) =~ s{::}{/}g;
                    $req .= '.pm' unless $req =~ /\.pm$/;
                    require $req;
                }
                catch {
                    $error = $_;
                };
                if ($error) {
                    if ($error =~ /^Can\'t locate/) {
                        $response->header("Client-Warning" =>
                                "Unsupported authentication scheme '$scheme'");
                    }
                    else {
                        $response->header("Client-Warning" => $error);
                    }
                    next CHALLENGE;
                }
            }
            unless ($class->can("authenticate")) {
                $response->header("Client-Warning" =>
                        "Unsupported authentication scheme '$scheme'");
                next CHALLENGE;
            }
            my $re = $class->authenticate($self, $proxy, $challenge, $response,
                $request, $arg, $size);

            next CHALLENGE if $re->code == HTTP::Status::RC_UNAUTHORIZED;
            return $re;
        }
        return $response;
    }
    return $response;
}

#
# Now the shortcuts...
#
sub get {
    require HTTP::Request::Common;
    my($self, @parameters) = @_;
    my @suff = $self->_process_colonic_headers(\@parameters,1);
    return $self->request( HTTP::Request::Common::GET( @parameters ), @suff );
}

sub _has_raw_content {
    my $self = shift;
    shift; # drop url

    # taken from HTTP::Request::Common::request_type_with_data
    my $content;
    $content = shift if @_ and ref $_[0];
    my($k, $v);
    while (($k,$v) = splice(@_, 0, 2)) {
        if (lc($k) eq 'content') {
            $content = $v;
        }
    }

    # We were given Content => 'string' ...
    if (defined $content && ! ref ($content)) {
        return 1;
    }

    return;
}

sub _maybe_copy_default_content_type {
    my ($self, $req, @parameters) = @_;

    # If we have a default Content-Type and someone passes in a POST/PUT
    # with Content => 'some-string-value', use that Content-Type instead
    # of x-www-form-urlencoded
    my $ct = $self->default_header('Content-Type');
    return unless defined $ct && $self->_has_raw_content(@parameters);

    $req->header('Content-Type' => $ct);
}

sub post {
    require HTTP::Request::Common;
    my($self, @parameters) = @_;
    my @suff = $self->_process_colonic_headers(\@parameters, (ref($parameters[1]) ? 2 : 1));
    my $req = HTTP::Request::Common::POST(@parameters);
    $self->_maybe_copy_default_content_type($req, @parameters);
    return $self->request($req, @suff);
}


sub head {
    require HTTP::Request::Common;
    my($self, @parameters) = @_;
    my @suff = $self->_process_colonic_headers(\@parameters,1);
    return $self->request( HTTP::Request::Common::HEAD( @parameters ), @suff );
}

sub patch {
    require HTTP::Request::Common;
    my($self, @parameters) = @_;
    my @suff = $self->_process_colonic_headers(\@parameters, (ref($parameters[1]) ? 2 : 1));

    # this work-around is in place as HTTP::Request::Common
    # did not implement a patch convenience method until
    # version 6.12. Once we can bump the prereq to at least
    # that version, we can use ::PATCH instead of this hack
    my $req = HTTP::Request::Common::PUT(@parameters);
    $req->method('PATCH');

    $self->_maybe_copy_default_content_type($req, @parameters);
    return $self->request($req, @suff);
}

sub put {
    require HTTP::Request::Common;
    my($self, @parameters) = @_;
    my @suff = $self->_process_colonic_headers(\@parameters, (ref($parameters[1]) ? 2 : 1));
    my $req = HTTP::Request::Common::PUT(@parameters);
    $self->_maybe_copy_default_content_type($req, @parameters);
    return $self->request($req, @suff);
}


sub delete {
    require HTTP::Request::Common;
    my($self, @parameters) = @_;
    my @suff = $self->_process_colonic_headers(\@parameters,1);
    return $self->request( HTTP::Request::Common::DELETE( @parameters ), @suff );
}


sub _process_colonic_headers {
    # Process :content_cb / :content_file / :read_size_hint headers.
    my($self, $args, $start_index) = @_;

    my($arg, $size);
    for(my $i = $start_index; $i < @$args; $i += 2) {
	next unless defined $args->[$i];

	#printf "Considering %s => %s\n", $args->[$i], $args->[$i + 1];

	if($args->[$i] eq ':content_cb') {
	    # Some sanity-checking...
	    $arg = $args->[$i + 1];
	    Carp::croak("A :content_cb value can't be undef") unless defined $arg;
	    Carp::croak("A :content_cb value must be a coderef")
		unless ref $arg and UNIVERSAL::isa($arg, 'CODE');

	}
	elsif ($args->[$i] eq ':content_file') {
	    $arg = $args->[$i + 1];

	    # Some sanity-checking...
	    Carp::croak("A :content_file value can't be undef")
		unless defined $arg;
	    Carp::croak("A :content_file value can't be a reference")
		if ref $arg;
	    Carp::croak("A :content_file value can't be \"\"")
		unless length $arg;

	}
	elsif ($args->[$i] eq ':read_size_hint') {
	    $size = $args->[$i + 1];
	    # Bother checking it?

	}
	else {
	    next;
	}
	splice @$args, $i, 2;
	$i -= 2;
    }

    # And return a suitable suffix-list for request(REQ,...)

    return             unless defined $arg;
    return $arg, $size if     defined $size;
    return $arg;
}


sub is_online {
    my $self = shift;
    return 1 if $self->get("http://www.msftncsi.com/ncsi.txt")->content eq "Microsoft NCSI";
    return 1 if $self->get("http://www.apple.com")->content =~ m,<title>Apple</title>,;
    return 0;
}


my @ANI = qw(- \ | /);

sub progress {
    my($self, $status, $m) = @_;
    return unless $self->{show_progress};

    local($,, $\);
    if ($status eq "begin") {
        print STDERR "** ", $m->method, " ", $m->uri, " ==> ";
        $self->{progress_start} = time;
        $self->{progress_lastp} = "";
        $self->{progress_ani} = 0;
    }
    elsif ($status eq "end") {
        delete $self->{progress_lastp};
        delete $self->{progress_ani};
        print STDERR $m->status_line;
        my $t = time - delete $self->{progress_start};
        print STDERR " (${t}s)" if $t;
        print STDERR "\n";
    }
    elsif ($status eq "tick") {
        print STDERR "$ANI[$self->{progress_ani}++]\b";
        $self->{progress_ani} %= @ANI;
    }
    else {
        my $p = sprintf "%3.0f%%", $status * 100;
        return if $p eq $self->{progress_lastp};
        print STDERR "$p\b\b\b\b";
        $self->{progress_lastp} = $p;
    }
    STDERR->flush;
}


#
# This whole allow/forbid thing is based on man 1 at's way of doing things.
#
sub is_protocol_supported
{
    my($self, $scheme) = @_;
    if (ref $scheme) {
	# assume we got a reference to an URI object
	$scheme = $scheme->scheme;
    }
    else {
	Carp::croak("Illegal scheme '$scheme' passed to is_protocol_supported")
	    if $scheme =~ /\W/;
	$scheme = lc $scheme;
    }

    my $x;
    if(ref($self) and $x       = $self->protocols_allowed) {
      return 0 unless grep lc($_) eq $scheme, @$x;
    }
    elsif (ref($self) and $x = $self->protocols_forbidden) {
      return 0 if grep lc($_) eq $scheme, @$x;
    }

    local($SIG{__DIE__});  # protect against user defined die handlers
    $x = LWP::Protocol::implementor($scheme);
    return 1 if $x and $x ne 'LWP::Protocol::nogo';
    return 0;
}


sub protocols_allowed      { shift->_elem('protocols_allowed'    , @_) }
sub protocols_forbidden    { shift->_elem('protocols_forbidden'  , @_) }
sub requests_redirectable  { shift->_elem('requests_redirectable', @_) }


sub redirect_ok
{
    # RFC 2616, section 10.3.2 and 10.3.3 say:
    #  If the 30[12] status code is received in response to a request other
    #  than GET or HEAD, the user agent MUST NOT automatically redirect the
    #  request unless it can be confirmed by the user, since this might
    #  change the conditions under which the request was issued.

    # Note that this routine used to be just:
    #  return 0 if $_[1]->method eq "POST";  return 1;

    my($self, $new_request, $response) = @_;
    my $method = $response->request->method;
    return 0 unless grep $_ eq $method,
      @{ $self->requests_redirectable || [] };

    if ($new_request->uri->scheme eq 'file') {
      $response->header("Client-Warning" =>
			"Can't redirect to a file:// URL!");
      return 0;
    }

    # Otherwise it's apparently okay...
    return 1;
}

sub credentials {
    my $self   = shift;
    my $netloc = lc(shift || '');
    my $realm  = shift || "";
    my $old    = $self->{basic_authentication}{$netloc}{$realm};
    if (@_) {
        $self->{basic_authentication}{$netloc}{$realm} = [@_];
    }
    return unless $old;
    return @$old if wantarray;
    return join(":", @$old);
}

sub get_basic_credentials
{
    my($self, $realm, $uri, $proxy) = @_;
    return if $proxy;
    return $self->credentials($uri->host_port, $realm);
}


sub timeout      { shift->_elem('timeout',      @_); }
sub local_address{ shift->_elem('local_address',@_); }
sub max_size     { shift->_elem('max_size',     @_); }
sub max_redirect { shift->_elem('max_redirect', @_); }
sub show_progress{ shift->_elem('show_progress', @_); }
sub send_te      { shift->_elem('send_te',      @_); }

sub ssl_opts {
    my $self = shift;
    if (@_ == 1) {
	my $k = shift;
	return $self->{ssl_opts}{$k};
    }
    if (@_) {
	my $old;
	while (@_) {
	    my($k, $v) = splice(@_, 0, 2);
	    $old = $self->{ssl_opts}{$k} unless @_;
	    if (defined $v) {
		$self->{ssl_opts}{$k} = $v;
	    }
	    else {
		delete $self->{ssl_opts}{$k};
	    }
	}
	%{$self->{ssl_opts}} = (%{$self->{ssl_opts}}, @_);
	return $old;
    }

    return keys %{$self->{ssl_opts}};
}

sub parse_head {
    my $self = shift;
    if (@_) {
        my $flag = shift;
        my $parser;
        my $old = $self->set_my_handler("response_header", $flag ? sub {
               my($response, $ua) = @_;
               require HTML::HeadParser;
               $parser = HTML::HeadParser->new;
               $parser->xml_mode(1) if $response->content_is_xhtml;
               $parser->utf8_mode(1) if $] >= 5.008 && $HTML::Parser::VERSION >= 3.40;

               push(@{$response->{handlers}{response_data}}, {
		   callback => sub {
		       return unless $parser;
		       unless ($parser->parse($_[3])) {
			   my $h = $parser->header;
			   my $r = $_[0];
			   for my $f ($h->header_field_names) {
			       $r->init_header($f, [$h->header($f)]);
			   }
			   undef($parser);
		       }
		   },
	       });

            } : undef,
            m_media_type => "html",
        );
        return !!$old;
    }
    else {
        return !!$self->get_my_handler("response_header");
    }
}

sub cookie_jar {
    my $self = shift;
    my $old = $self->{cookie_jar};
    if (@_) {
	my $jar = shift;
	if (ref($jar) eq "HASH") {
	    require HTTP::Cookies;
	    $jar = HTTP::Cookies->new(%$jar);
	}
	$self->{cookie_jar} = $jar;
        $self->set_my_handler("request_prepare",
            $jar ? sub {
                return if $_[0]->header("Cookie");
                $jar->add_cookie_header($_[0]);
            } : undef,
        );
        $self->set_my_handler("response_done",
            $jar ? sub { $jar->extract_cookies($_[0]); } : undef,
        );
    }
    $old;
}

sub default_headers {
    my $self = shift;
    my $old = $self->{def_headers} ||= HTTP::Headers->new;
    if (@_) {
	Carp::croak("default_headers not set to HTTP::Headers compatible object")
	    unless @_ == 1 && $_[0]->can("header_field_names");
	$self->{def_headers} = shift;
    }
    return $old;
}

sub default_header {
    my $self = shift;
    return $self->default_headers->header(@_);
}

sub _agent { "libwww-perl/$VERSION" }

sub agent {
    my $self = shift;
    if (@_) {
	my $agent = shift;
        if ($agent) {
            $agent .= $self->_agent if $agent =~ /\s+$/;
        }
        else {
            undef($agent)
        }
        return $self->default_header("User-Agent", $agent);
    }
    return $self->default_header("User-Agent");
}

sub from {  # legacy
    my $self = shift;
    return $self->default_header("From", @_);
}


sub conn_cache {
    my $self = shift;
    my $old = $self->{conn_cache};
    if (@_) {
	my $cache = shift;
	if (ref($cache) eq "HASH") {
	    require LWP::ConnCache;
	    $cache = LWP::ConnCache->new(%$cache);
	}
	$self->{conn_cache} = $cache;
    }
    $old;
}


sub add_handler {
    my($self, $phase, $cb, %spec) = @_;
    $spec{line} ||= join(":", (caller)[1,2]);
    my $conf = $self->{handlers}{$phase} ||= do {
        require HTTP::Config;
        HTTP::Config->new;
    };
    $conf->add(%spec, callback => $cb);
}

sub set_my_handler {
    my($self, $phase, $cb, %spec) = @_;
    $spec{owner} = (caller(1))[3] unless exists $spec{owner};
    $self->remove_handler($phase, %spec);
    $spec{line} ||= join(":", (caller)[1,2]);
    $self->add_handler($phase, $cb, %spec) if $cb;
}

sub get_my_handler {
    my $self = shift;
    my $phase = shift;
    my $init = pop if @_ % 2;
    my %spec = @_;
    my $conf = $self->{handlers}{$phase};
    unless ($conf) {
        return unless $init;
        require HTTP::Config;
        $conf = $self->{handlers}{$phase} = HTTP::Config->new;
    }
    $spec{owner} = (caller(1))[3] unless exists $spec{owner};
    my @h = $conf->find(%spec);
    if (!@h && $init) {
        if (ref($init) eq "CODE") {
            $init->(\%spec);
        }
        elsif (ref($init) eq "HASH") {
            while (my($k, $v) = each %$init) {
                $spec{$k} = $v;
            }
        }
        $spec{callback} ||= sub {};
        $spec{line} ||= join(":", (caller)[1,2]);
        $conf->add(\%spec);
        return \%spec;
    }
    return wantarray ? @h : $h[0];
}

sub remove_handler {
    my($self, $phase, %spec) = @_;
    if ($phase) {
        my $conf = $self->{handlers}{$phase} || return;
        my @h = $conf->remove(%spec);
        delete $self->{handlers}{$phase} if $conf->empty;
        return @h;
    }

    return unless $self->{handlers};
    return map $self->remove_handler($_), sort keys %{$self->{handlers}};
}

sub handlers {
    my($self, $phase, $o) = @_;
    my @h;
    if ($o->{handlers} && $o->{handlers}{$phase}) {
        push(@h, @{$o->{handlers}{$phase}});
    }
    if (my $conf = $self->{handlers}{$phase}) {
        push(@h, $conf->matching($o));
    }
    return @h;
}

sub run_handlers {
    my($self, $phase, $o) = @_;

    # here we pass $_[2] to the callbacks, instead of $o, so that they
    # can assign to it; e.g. request_prepare is documented to allow
    # that
    if (defined(wantarray)) {
        for my $h ($self->handlers($phase, $o)) {
            my $ret = $h->{callback}->($_[2], $self, $h);
            return $ret if $ret;
        }
        return undef;
    }

    for my $h ($self->handlers($phase, $o)) {
        $h->{callback}->($_[2], $self, $h);
    }
}


# deprecated
sub use_eval   { shift->_elem('use_eval',  @_); }
sub use_alarm
{
    Carp::carp("LWP::UserAgent->use_alarm(BOOL) is a no-op")
	if @_ > 1 && $^W;
    "";
}


sub clone
{
    my $self = shift;
    my $copy = bless { %$self }, ref $self;  # copy most fields

    delete $copy->{handlers};
    delete $copy->{conn_cache};

    # copy any plain arrays and hashes; known not to need recursive copy
    for my $k (qw(proxy no_proxy requests_redirectable ssl_opts)) {
        next unless $copy->{$k};
        if (ref($copy->{$k}) eq "ARRAY") {
            $copy->{$k} = [ @{$copy->{$k}} ];
        }
        elsif (ref($copy->{$k}) eq "HASH") {
            $copy->{$k} = { %{$copy->{$k}} };
        }
    }

    if ($self->{def_headers}) {
        $copy->{def_headers} = $self->{def_headers}->clone;
    }

    # re-enable standard handlers
    $copy->parse_head($self->parse_head);

    # no easy way to clone the cookie jar; so let's just remove it for now
    $copy->cookie_jar(undef);

    $copy;
}


sub mirror
{
    my($self, $url, $file) = @_;

    die "Local file name is missing" unless defined $file && length $file;

    my $request = HTTP::Request->new('GET', $url);

    # If the file exists, add a cache-related header
    if ( -e $file ) {
        my ($mtime) = ( stat($file) )[9];
        if ($mtime) {
            $request->header( 'If-Modified-Since' => HTTP::Date::time2str($mtime) );
        }
    }
    my $tmpfile = "$file-$$";

    my $response = $self->request($request, $tmpfile);
    if ( $response->header('X-Died') ) {
        die $response->header('X-Died');
    }

    # Only fetching a fresh copy of the file would be considered success.
    # If the file was not modified, "304" would returned, which
    # is considered by HTTP::Status to be a "redirect", /not/ "success"
    if ( $response->is_success ) {
        my @stat        = stat($tmpfile) or die "Could not stat tmpfile '$tmpfile': $!";
        my $file_length = $stat[7];
        my ($content_length) = $response->header('Content-length');

        if ( defined $content_length and $file_length < $content_length ) {
            unlink($tmpfile);
            die "Transfer truncated: " . "only $file_length out of $content_length bytes received\n";
        }
        elsif ( defined $content_length and $file_length > $content_length ) {
            unlink($tmpfile);
            die "Content-length mismatch: " . "expected $content_length bytes, got $file_length\n";
        }
        # The file was the expected length.
        else {
            # Replace the stale file with a fresh copy
            if ( -e $file ) {
                # Some DOSish systems fail to rename if the target exists
                chmod 0777, $file;
                unlink $file;
            }
            rename( $tmpfile, $file )
                or die "Cannot rename '$tmpfile' to '$file': $!\n";

            # make sure the file has the same last modification time
            if ( my $lm = $response->last_modified ) {
                utime $lm, $lm, $file;
            }
        }
    }
    # The local copy is fresh enough, so just delete the temp file
    else {
        unlink($tmpfile);
    }
    return $response;
}


sub _need_proxy {
    my($req, $ua) = @_;
    return if exists $req->{proxy};
    my $proxy = $ua->{proxy}{$req->uri->scheme} || return;
    if ($ua->{no_proxy}) {
        if (my $host = eval { $req->uri->host }) {
            for my $domain (@{$ua->{no_proxy}}) {
                if ($host =~ /\Q$domain\E$/) {
                    return;
                }
            }
        }
    }
    $req->{proxy} = $HTTP::URI_CLASS->new($proxy);
}


sub proxy {
    my $self = shift;
    my $key  = shift;
    if (!@_ && ref $key eq 'ARRAY') {
        die 'odd number of items in proxy arrayref!' unless @{$key} % 2 == 0;

        # This map reads the elements of $key 2 at a time
        return
            map { $self->proxy($key->[2 * $_], $key->[2 * $_ + 1]) }
            (0 .. @{$key} / 2 - 1);
    }
    return map { $self->proxy($_, @_) } @$key if ref $key;

    Carp::croak("'$key' is not a valid URI scheme") unless $key =~ /^$URI::scheme_re\z/;
    my $old = $self->{'proxy'}{$key};
    if (@_) {
        my $url = shift;
        if (defined($url) && length($url)) {
            Carp::croak("Proxy must be specified as absolute URI; '$url' is not") unless $url =~ /^$URI::scheme_re:/;
            Carp::croak("Bad http proxy specification '$url'") if $url =~ /^https?:/ && $url !~ m,^https?://[\w[],;
        }
        $self->{proxy}{$key} = $url;
        $self->set_my_handler("request_preprepare", \&_need_proxy)
    }
    return $old;
}


sub env_proxy {
    my ($self) = @_;
    require Encode;
    require Encode::Locale;
    my($k,$v);
    while(($k, $v) = each %ENV) {
	if ($ENV{REQUEST_METHOD}) {
	    # Need to be careful when called in the CGI environment, as
	    # the HTTP_PROXY variable is under control of that other guy.
	    next if $k =~ /^HTTP_/;
	    $k = "HTTP_PROXY" if $k eq "CGI_HTTP_PROXY";
	}
	$k = lc($k);
	next unless $k =~ /^(.*)_proxy$/;
	$k = $1;
	if ($k eq 'no') {
	    $self->no_proxy(split(/\s*,\s*/, $v));
	}
	else {
            # Ignore random _proxy variables, allow only valid schemes
            next unless $k =~ /^$URI::scheme_re\z/;
            # Ignore xxx_proxy variables if xxx isn't a supported protocol
            next unless LWP::Protocol::implementor($k);
	    $self->proxy($k, Encode::decode(locale => $v));
	}
    }
}


sub no_proxy {
    my($self, @no) = @_;
    if (@no) {
	push(@{ $self->{'no_proxy'} }, @no);
    }
    else {
	$self->{'no_proxy'} = [];
    }
}


sub _new_response {
    my($request, $code, $message, $content) = @_;
    $message ||= HTTP::Status::status_message($code);
    my $response = HTTP::Response->new($code, $message);
    $response->request($request);
    $response->header("Client-Date" => HTTP::Date::time2str(time));
    $response->header("Client-Warning" => "Internal response");
    $response->header("Content-Type" => "text/plain");
    $response->content($content || "$code $message\n");
    return $response;
}


1;

__END__

=pod

=head1 NAME

LWP::UserAgent - Web user agent class

=head1 SYNOPSIS

    use strict;
    use warnings;

    use LWP::UserAgent ();

    my $ua = LWP::UserAgent->new(timeout => 10);
    $ua->env_proxy;

    my $response = $ua->get('http://example.com');

    if ($response->is_success) {
        print $response->decoded_content;
    }
    else {
        die $response->status_line;
    }

Extra layers of security (note the C<cookie_jar> and C<protocols_allowed>):

    use strict;
    use warnings;

    use HTTP::CookieJar::LWP ();
    use LWP::UserAgent       ();

    my $jar = HTTP::CookieJar::LWP->new;
    my $ua  = LWP::UserAgent->new(
        cookie_jar        => $jar,
        protocols_allowed => ['http', 'https'],
        timeout           => 10,
    );

    $ua->env_proxy;

    my $response = $ua->get('http://example.com');

    if ($response->is_success) {
        print $response->decoded_content;
    }
    else {
        die $response->status_line;
    }

=head1 DESCRIPTION

The L<LWP::UserAgent> is a class implementing a web user agent.
L<LWP::UserAgent> objects can be used to dispatch web requests.

In normal use the application creates an L<LWP::UserAgent> object, and
then configures it with values for timeouts, proxies, name, etc. It
then creates an instance of L<HTTP::Request> for the request that
needs to be performed. This request is then passed to one of the
request method the UserAgent, which dispatches it using the relevant
protocol, and returns a L<HTTP::Response> object.  There are
convenience methods for sending the most common request types:
L<LWP::UserAgent/get>, L<LWP::UserAgent/head>, L<LWP::UserAgent/post>,
L<LWP::UserAgent/put> and L<LWP::UserAgent/delete>.  When using these
methods, the creation of the request object is hidden as shown in the
synopsis above.

The basic approach of the library is to use HTTP-style communication
for all protocol schemes.  This means that you will construct
L<HTTP::Request> objects and receive L<HTTP::Response> objects even
for non-HTTP resources like I<gopher> and I<ftp>.  In order to achieve
even more similarity to HTTP-style communications, I<gopher> menus and
file directories are converted to HTML documents.

=head1 CONSTRUCTOR METHODS

The following constructor methods are available:

=head2 clone

    my $ua2 = $ua->clone;

Returns a copy of the L<LWP::UserAgent> object.

B<CAVEAT>: Please be aware that the clone method does not copy or clone your
C<cookie_jar> attribute. Due to the limited restrictions on what can be used
for your cookie jar, there is no way to clone the attribute. The C<cookie_jar>
attribute will be C<undef> in the new object instance.

=head2 new

    my $ua = LWP::UserAgent->new( %options )

This method constructs a new L<LWP::UserAgent> object and returns it.
Key/value pair arguments may be provided to set up the initial state.
The following options correspond to attribute methods described below:

   KEY                     DEFAULT
   -----------             --------------------
   agent                   "libwww-perl/#.###"
   from                    undef
   conn_cache              undef
   cookie_jar              undef
   default_headers         HTTP::Headers->new
   local_address           undef
   ssl_opts                { verify_hostname => 1 }
   max_size                undef
   max_redirect            7
   parse_head              1
   protocols_allowed       undef
   protocols_forbidden     undef
   requests_redirectable   ['GET', 'HEAD']
   timeout                 180
   proxy                   undef
   no_proxy                []

The following additional options are also accepted: If the C<env_proxy> option
is passed in with a true value, then proxy settings are read from environment
variables (see L<LWP::UserAgent/env_proxy>). If C<env_proxy> isn't provided, the
C<PERL_LWP_ENV_PROXY> environment variable controls if
L<LWP::UserAgent/env_proxy> is called during initialization.  If the
C<keep_alive> option value is defined and non-zero, then an C<LWP::ConnCache> is set up (see
L<LWP::UserAgent/conn_cache>).  The C<keep_alive> value is passed on as the
C<total_capacity> for the connection cache.

C<proxy> must be set as an arrayref of key/value pairs. C<no_proxy> takes an
arrayref of domains.

=head1 ATTRIBUTES

The settings of the configuration attributes modify the behaviour of the
L<LWP::UserAgent> when it dispatches requests.  Most of these can also
be initialized by options passed to the constructor method.

The following attribute methods are provided.  The attribute value is
left unchanged if no argument is given.  The return value from each
method is the old attribute value.

=head2 agent

    my $agent = $ua->agent;
    $ua->agent('Checkbot/0.4 ');    # append the default to the end
    $ua->agent('Mozilla/5.0');
    $ua->agent("");                 # don't identify

Get/set the product token that is used to identify the user agent on
the network. The agent value is sent as the C<User-Agent> header in
the requests.

The default is a string of the form C<libwww-perl/#.###>, where C<#.###> is
substituted with the version number of this library.

If the provided string ends with space, the default C<libwww-perl/#.###>
string is appended to it.

The user agent string should be one or more simple product identifiers
with an optional version number separated by the C</> character.

=head2 conn_cache

    my $cache_obj = $ua->conn_cache;
    $ua->conn_cache( $cache_obj );

Get/set the L<LWP::ConnCache> object to use.  See L<LWP::ConnCache>
for details.

=head2 cookie_jar

    my $jar = $ua->cookie_jar;
    $ua->cookie_jar( $cookie_jar_obj );

Get/set the cookie jar object to use.  The only requirement is that
the cookie jar object must implement the C<extract_cookies($response)> and
C<add_cookie_header($request)> methods.  These methods will then be
invoked by the user agent as requests are sent and responses are
received.  Normally this will be a L<HTTP::Cookies> object or some
subclass.  You are, however, encouraged to use L<HTTP::CookieJar::LWP>
instead.  See L</"BEST PRACTICES"> for more information.

    use HTTP::CookieJar::LWP ();

    my $jar = HTTP::CookieJar::LWP->new;
    my $ua = LWP::UserAgent->new( cookie_jar => $jar );

    # or after object creation
    $ua->cookie_jar( $cookie_jar );

The default is to have no cookie jar, i.e. never automatically add
C<Cookie> headers to the requests.

Shortcut: If a reference to a plain hash is passed in, it is replaced with an
instance of L<HTTP::Cookies> that is initialized based on the hash. This form
also automatically loads the L<HTTP::Cookies> module.  It means that:

  $ua->cookie_jar({ file => "$ENV{HOME}/.cookies.txt" });

is really just a shortcut for:

  require HTTP::Cookies;
  $ua->cookie_jar(HTTP::Cookies->new(file => "$ENV{HOME}/.cookies.txt"));

=head2 credentials

    my $creds = $ua->credentials();
    $ua->credentials( $netloc, $realm );
    $ua->credentials( $netloc, $realm, $uname, $pass );
    $ua->credentials("www.example.com:80", "Some Realm", "foo", "secret");

Get/set the user name and password to be used for a realm.

The C<$netloc> is a string of the form C<< <host>:<port> >>.  The username and
password will only be passed to this server.

=head2 default_header

    $ua->default_header( $field );
    $ua->default_header( $field => $value );
    $ua->default_header('Accept-Encoding' => scalar HTTP::Message::decodable());
    $ua->default_header('Accept-Language' => "no, en");

This is just a shortcut for
C<< $ua->default_headers->header( $field => $value ) >>.

=head2 default_headers

    my $headers = $ua->default_headers;
    $ua->default_headers( $headers_obj );

Get/set the headers object that will provide default header values for
any requests sent.  By default this will be an empty L<HTTP::Headers>
object.

=head2 from

    my $from = $ua->from;
    $ua->from('foo@bar.com');

Get/set the email address for the human user who controls
the requesting user agent.  The address should be machine-usable, as
defined in L<RFC2822|https://tools.ietf.org/html/rfc2822>. The C<from> value
is sent as the C<From> header in the requests.

The default is to not send a C<From> header.  See
L<LWP::UserAgent/default_headers> for the more general interface that allow
any header to be defaulted.


=head2 local_address

    my $address = $ua->local_address;
    $ua->local_address( $address );

Get/set the local interface to bind to for network connections.  The interface
can be specified as a hostname or an IP address.  This value is passed as the
C<LocalAddr> argument to L<IO::Socket::INET>.

=head2 max_redirect

    my $max = $ua->max_redirect;
    $ua->max_redirect( $n );

This reads or sets the object's limit of how many times it will obey
redirection responses in a given request cycle.

By default, the value is C<7>. This means that if you call L<LWP::UserAgent/request>
and the response is a redirect elsewhere which is in turn a
redirect, and so on seven times, then LWP gives up after that seventh
request.

=head2 max_size

    my $size = $ua->max_size;
    $ua->max_size( $bytes );

Get/set the size limit for response content.  The default is C<undef>,
which means that there is no limit.  If the returned response content
is only partial, because the size limit was exceeded, then a
C<Client-Aborted> header will be added to the response.  The content
might end up longer than C<max_size> as we abort once appending a
chunk of data makes the length exceed the limit.  The C<Content-Length>
header, if present, will indicate the length of the full content and
will normally not be the same as C<< length($res->content) >>.

=head2 parse_head

    my $bool = $ua->parse_head;
    $ua->parse_head( $boolean );

Get/set a value indicating whether we should initialize response
headers from the E<lt>head> section of HTML documents. The default is
true. I<Do not turn this off> unless you know what you are doing.

=head2 protocols_allowed

    my $aref = $ua->protocols_allowed;      # get allowed protocols
    $ua->protocols_allowed( \@protocols );  # allow ONLY these
    $ua->protocols_allowed(undef);          # delete the list
    $ua->protocols_allowed(['http',]);      # ONLY allow http

By default, an object has neither a C<protocols_allowed> list, nor a
L<LWP::UserAgent/protocols_forbidden> list.

This reads (or sets) this user agent's list of protocols that the
request methods will exclusively allow.  The protocol names are case
insensitive.

For example: C<< $ua->protocols_allowed( [ 'http', 'https'] ); >>
means that this user agent will I<allow only> those protocols,
and attempts to use this user agent to access URLs with any other
schemes (like C<ftp://...>) will result in a 500 error.

Note that having a C<protocols_allowed> list causes any
L<LWP::UserAgent/protocols_forbidden> list to be ignored.

=head2 protocols_forbidden

    my $aref = $ua->protocols_forbidden;    # get the forbidden list
    $ua->protocols_forbidden(\@protocols);  # do not allow these
    $ua->protocols_forbidden(['http',]);    # All http reqs get a 500
    $ua->protocols_forbidden(undef);        # delete the list

This reads (or sets) this user agent's list of protocols that the
request method will I<not> allow. The protocol names are case
insensitive.

For example: C<< $ua->protocols_forbidden( [ 'file', 'mailto'] ); >>
means that this user agent will I<not> allow those protocols, and
attempts to use this user agent to access URLs with those schemes
will result in a 500 error.

=head2 requests_redirectable

    my $aref = $ua->requests_redirectable;
    $ua->requests_redirectable( \@requests );
    $ua->requests_redirectable(['GET', 'HEAD',]); # the default

This reads or sets the object's list of request names that
L<LWP::UserAgent/redirect_ok> will allow redirection for. By default, this
is C<['GET', 'HEAD']>, as per L<RFC 2616|https://tools.ietf.org/html/rfc2616>.
To change to include C<POST>, consider:

   push @{ $ua->requests_redirectable }, 'POST';

=head2 send_te

    my $bool = $ua->send_te;
    $ua->send_te( $boolean );

If true, will send a C<TE> header along with the request. The default is
true. Set it to false to disable the C<TE> header for systems who can't
handle it.

=head2 show_progress

    my $bool = $ua->show_progress;
    $ua->show_progress( $boolean );

Get/set a value indicating whether a progress bar should be displayed
on the terminal as requests are processed. The default is false.

=head2 ssl_opts

    my @keys = $ua->ssl_opts;
    my $val = $ua->ssl_opts( $key );
    $ua->ssl_opts( $key => $value );

Get/set the options for SSL connections.  Without argument return the list
of options keys currently set.  With a single argument return the current
value for the given option.  With 2 arguments set the option value and return
the old.  Setting an option to the value C<undef> removes this option.

The options that LWP relates to are:

=over

=item C<verify_hostname> => $bool

When TRUE LWP will for secure protocol schemes ensure it connects to servers
that have a valid certificate matching the expected hostname.  If FALSE no
checks are made and you can't be sure that you communicate with the expected peer.
The no checks behaviour was the default for libwww-perl-5.837 and earlier releases.

This option is initialized from the C<PERL_LWP_SSL_VERIFY_HOSTNAME> environment
variable.  If this environment variable isn't set; then C<verify_hostname>
defaults to 1.

=item C<SSL_ca_file> => $path

The path to a file containing Certificate Authority certificates.
A default setting for this option is provided by checking the environment
variables C<PERL_LWP_SSL_CA_FILE> and C<HTTPS_CA_FILE> in order.

=item C<SSL_ca_path> => $path

The path to a directory containing files containing Certificate Authority
certificates.
A default setting for this option is provided by checking the environment
variables C<PERL_LWP_SSL_CA_PATH> and C<HTTPS_CA_DIR> in order.

=back

Other options can be set and are processed directly by the SSL Socket implementation
in use.  See L<IO::Socket::SSL> or L<Net::SSL> for details.

The libwww-perl core no longer bundles protocol plugins for SSL.  You will need
to install L<LWP::Protocol::https> separately to enable support for processing
https-URLs.

=head2 timeout

    my $secs = $ua->timeout;
    $ua->timeout( $secs );

Get/set the timeout value in seconds. The default value is
180 seconds, i.e. 3 minutes.

The request is aborted if no activity on the connection to the server
is observed for C<timeout> seconds.  This means that the time it takes
for the complete transaction and the L<LWP::UserAgent/request> method to
actually return might be longer.

When a request times out, a response object is still returned.  The response
will have a standard HTTP Status Code (500).  This response will have the
"Client-Warning" header set to the value of "Internal response".  See the
L<LWP::UserAgent/get> method description below for further details.

=head1 PROXY ATTRIBUTES

The following methods set up when requests should be passed via a
proxy server.

=head2 env_proxy

    $ua->env_proxy;

Load proxy settings from C<*_proxy> environment variables.  You might
specify proxies like this (sh-syntax):

  gopher_proxy=http://proxy.my.place/
  wais_proxy=http://proxy.my.place/
  no_proxy="localhost,example.com"
  export gopher_proxy wais_proxy no_proxy

csh or tcsh users should use the C<setenv> command to define these
environment variables.

On systems with case insensitive environment variables there exists a
name clash between the CGI environment variables and the C<HTTP_PROXY>
environment variable normally picked up by C<env_proxy>.  Because of
this C<HTTP_PROXY> is not honored for CGI scripts.  The
C<CGI_HTTP_PROXY> environment variable can be used instead.

=head2 no_proxy

    $ua->no_proxy( @domains );
    $ua->no_proxy('localhost', 'example.com');
    $ua->no_proxy(); # clear the list

Do not proxy requests to the given domains.  Calling C<no_proxy> without
any domains clears the list of domains.

=head2 proxy

    $ua->proxy(\@schemes, $proxy_url)
    $ua->proxy(['http', 'ftp'], 'http://proxy.sn.no:8001/');

    # For a single scheme:
    $ua->proxy($scheme, $proxy_url)
    $ua->proxy('gopher', 'http://proxy.sn.no:8001/');

    # To set multiple proxies at once:
    $ua->proxy([
        ftp => 'http://ftp.example.com:8001/',
        [ 'http', 'https' ] => 'http://http.example.com:8001/',
    ]);

Set/retrieve proxy URL for a scheme.

The first form specifies that the URL is to be used as a proxy for
access methods listed in the list in the first method argument,
i.e. C<http> and C<ftp>.

The second form shows a shorthand form for specifying
proxy URL for a single access scheme.

The third form demonstrates setting multiple proxies at once. This is also
the only form accepted by the constructor.

=head1 HANDLERS

Handlers are code that injected at various phases during the
processing of requests.  The following methods are provided to manage
the active handlers:

=head2 add_handler

    $ua->add_handler( $phase => \&cb, %matchspec )

Add handler to be invoked in the given processing phase.  For how to
specify C<%matchspec> see L<HTTP::Config/"Matching">.

The possible values C<$phase> and the corresponding callback signatures are as
follows.  Note that the handlers are documented in the order in which they will
be run, which is:

    request_preprepare
    request_prepare
    request_send
    response_header
    response_data
    response_done
    response_redirect

=over

=item request_preprepare => sub { my($request, $ua, $handler) = @_; ... }

The handler is called before the C<request_prepare> and other standard
initialization of the request.  This can be used to set up headers
and attributes that the C<request_prepare> handler depends on.  Proxy
initialization should take place here; but in general don't register
handlers for this phase.

=item request_prepare => sub { my($request, $ua, $handler) = @_; ... }

The handler is called before the request is sent and can modify the
request any way it see fit.  This can for instance be used to add
certain headers to specific requests.

The method can assign a new request object to C<$_[0]> to replace the
request that is sent fully.

The return value from the callback is ignored.  If an exception is
raised it will abort the request and make the request method return a
"400 Bad request" response.

=item request_send => sub { my($request, $ua, $handler) = @_; ... }

This handler gets a chance of handling requests before they're sent to the
protocol handlers.  It should return an L<HTTP::Response> object if it
wishes to terminate the processing; otherwise it should return nothing.

The C<response_header> and C<response_data> handlers will not be
invoked for this response, but the C<response_done> will be.

=item response_header => sub { my($response, $ua, $handler) = @_; ... }

This handler is called right after the response headers have been
received, but before any content data.  The handler might set up
handlers for data and might croak to abort the request.

The handler might set the C<< $response->{default_add_content} >> value to
control if any received data should be added to the response object
directly.  This will initially be false if the C<< $ua->request() >> method
was called with a C<$content_file> or C<$content_cb argument>; otherwise true.

=item response_data => sub { my($response, $ua, $handler, $data) = @_; ... }

This handler is called for each chunk of data received for the
response.  The handler might croak to abort the request.

This handler needs to return a TRUE value to be called again for
subsequent chunks for the same request.

=item response_done => sub { my($response, $ua, $handler) = @_; ... }

The handler is called after the response has been fully received, but
before any redirect handling is attempted.  The handler can be used to
extract information or modify the response.

=item response_redirect => sub { my($response, $ua, $handler) = @_; ... }

The handler is called in C<< $ua->request >> after C<response_done>.  If the
handler returns an L<HTTP::Request> object we'll start over with processing
this request instead.

=back

For all of these, C<$handler> is a code reference to the handler that
is currently being run.

=head2 get_my_handler

    $ua->get_my_handler( $phase, %matchspec );
    $ua->get_my_handler( $phase, %matchspec, $init );

Will retrieve the matching handler as hash ref.

If C<$init> is passed as a true value, create and add the
handler if it's not found.  If C<$init> is a subroutine reference, then
it's called with the created handler hash as argument.  This sub might
populate the hash with extra fields; especially the callback.  If
C<$init> is a hash reference, merge the hashes.

=head2 handlers

    $ua->handlers( $phase, $request )
    $ua->handlers( $phase, $response )

Returns the handlers that apply to the given request or response at
the given processing phase.

=head2 remove_handler

    $ua->remove_handler( undef, %matchspec );
    $ua->remove_handler( $phase, %matchspec );
    $ua->remove_handler(); # REMOVE ALL HANDLERS IN ALL PHASES

Remove handlers that match the given C<%matchspec>.  If C<$phase> is not
provided, remove handlers from all phases.

Be careful as calling this function with C<%matchspec> that is not
specific enough can remove handlers not owned by you.  It's probably
better to use the L<LWP::UserAgent/set_my_handler> method instead.

The removed handlers are returned.

=head2 set_my_handler

    $ua->set_my_handler( $phase, $cb, %matchspec );
    $ua->set_my_handler($phase, undef); # remove handler for phase

Set handlers private to the executing subroutine.  Works by defaulting
an C<owner> field to the C<%matchspec> that holds the name of the called
subroutine.  You might pass an explicit C<owner> to override this.

If $cb is passed as C<undef>, remove the handler.

=head1 REQUEST METHODS

The methods described in this section are used to dispatch requests
via the user agent.  The following request methods are provided:

=head2 delete

    my $res = $ua->delete( $url );
    my $res = $ua->delete( $url, $field_name => $value, ... );

This method will dispatch a C<DELETE> request on the given URL.  Additional
headers and content options are the same as for the L<LWP::UserAgent/get>
method.

This method will use the DELETE() function from L<HTTP::Request::Common>
to build the request.  See L<HTTP::Request::Common> for a details on
how to pass form content and other advanced features.

=head2 get

    my $res = $ua->get( $url );
    my $res = $ua->get( $url , $field_name => $value, ... );

This method will dispatch a C<GET> request on the given URL.  Further
arguments can be given to initialize the headers of the request. These
are given as separate name/value pairs.  The return value is a
response object.  See L<HTTP::Response> for a description of the
interface it provides.

There will still be a response object returned when LWP can't connect to the
server specified in the URL or when other failures in protocol handlers occur.
These internal responses use the standard HTTP status codes, so the responses
can't be differentiated by testing the response status code alone.  Error
responses that LWP generates internally will have the "Client-Warning" header
set to the value "Internal response".  If you need to differentiate these
internal responses from responses that a remote server actually generates, you
need to test this header value.

Fields names that start with ":" are special.  These will not
initialize headers of the request but will determine how the response
content is treated.  The following special field names are recognized:

    ':content_file'   => $filename
    ':content_cb'     => \&callback
    ':read_size_hint' => $bytes

If a $filename is provided with the C<:content_file> option, then the
response content will be saved here instead of in the response
object.  If a callback is provided with the C<:content_cb> option then
this function will be called for each chunk of the response content as
it is received from the server.  If neither of these options are
given, then the response content will accumulate in the response
object itself.  This might not be suitable for very large response
bodies.  Only one of C<:content_file> or C<:content_cb> can be
specified.  The content of unsuccessful responses will always
accumulate in the response object itself, regardless of the
C<:content_file> or C<:content_cb> options passed in.  Note that errors
writing to the content file (for example due to permission denied
or the filesystem being full) will be reported via the C<Client-Aborted>
or C<X-Died> response headers, and not the C<is_success> method.

The C<:read_size_hint> option is passed to the protocol module which
will try to read data from the server in chunks of this size.  A
smaller value for the C<:read_size_hint> will result in a higher
number of callback invocations.

The callback function is called with 3 arguments: a chunk of data, a
reference to the response object, and a reference to the protocol
object.  The callback can abort the request by invoking die().  The
exception message will show up as the "X-Died" header field in the
response returned by the get() function.

=head2 head

    my $res = $ua->head( $url );
    my $res = $ua->head( $url , $field_name => $value, ... );

This method will dispatch a C<HEAD> request on the given URL.
Otherwise it works like the L<LWP::UserAgent/get> method described above.

=head2 is_protocol_supported

    my $bool = $ua->is_protocol_supported( $scheme );

You can use this method to test whether this user agent object supports the
specified C<scheme>.  (The C<scheme> might be a string (like C<http> or
C<ftp>) or it might be an L<URI> object reference.)

Whether a scheme is supported is determined by the user agent's
C<protocols_allowed> or C<protocols_forbidden> lists (if any), and by
the capabilities of LWP.  I.e., this will return true only if LWP
supports this protocol I<and> it's permitted for this particular
object.

=head2 is_online

    my $bool = $ua->is_online;

Tries to determine if you have access to the Internet. Returns C<1> (true)
if the built-in heuristics determine that the user agent is
able to access the Internet (over HTTP) or C<0> (false).

See also L<LWP::Online>.

=head2 mirror

    my $res = $ua->mirror( $url, $filename );

This method will get the document identified by URL and store it in
file called C<$filename>.  If the file already exists, then the request
will contain an C<If-Modified-Since> header matching the modification
time of the file.  If the document on the server has not changed since
this time, then nothing happens.  If the document has been updated, it
will be downloaded again.  The modification time of the file will be
forced to match that of the server.

The return value is an L<HTTP::Response> object.

=head2 patch

    # Any version of HTTP::Message works with this form:
    my $res = $ua->patch( $url, $field_name => $value, Content => $content );

    # Using hash or array references requires HTTP::Message >= 6.12
    use HTTP::Request 6.12;
    my $res = $ua->patch( $url, \%form );
    my $res = $ua->patch( $url, \@form );
    my $res = $ua->patch( $url, \%form, $field_name => $value, ... );
    my $res = $ua->patch( $url, $field_name => $value, Content => \%form );
    my $res = $ua->patch( $url, $field_name => $value, Content => \@form );

This method will dispatch a C<PATCH> request on the given URL, with
C<%form> or C<@form> providing the key/value pairs for the fill-in form
content. Additional headers and content options are the same as for
the L<LWP::UserAgent/get> method.

CAVEAT:

This method can only accept content that is in key-value pairs when using
L<HTTP::Request::Common> prior to version C<6.12>. Any use of hash or array
references will result in an error prior to version C<6.12>.

This method will use the C<PATCH> function from L<HTTP::Request::Common>
to build the request.  See L<HTTP::Request::Common> for a details on
how to pass form content and other advanced features.

=head2 post

    my $res = $ua->post( $url, \%form );
    my $res = $ua->post( $url, \@form );
    my $res = $ua->post( $url, \%form, $field_name => $value, ... );
    my $res = $ua->post( $url, $field_name => $value, Content => \%form );
    my $res = $ua->post( $url, $field_name => $value, Content => \@form );
    my $res = $ua->post( $url, $field_name => $value, Content => $content );

This method will dispatch a C<POST> request on the given URL, with
C<%form> or C<@form> providing the key/value pairs for the fill-in form
content. Additional headers and content options are the same as for
the L<LWP::UserAgent/get> method.

This method will use the C<POST> function from L<HTTP::Request::Common>
to build the request.  See L<HTTP::Request::Common> for a details on
how to pass form content and other advanced features.

=head2 put

    # Any version of HTTP::Message works with this form:
    my $res = $ua->put( $url, $field_name => $value, Content => $content );

    # Using hash or array references requires HTTP::Message >= 6.07
    use HTTP::Request 6.07;
    my $res = $ua->put( $url, \%form );
    my $res = $ua->put( $url, \@form );
    my $res = $ua->put( $url, \%form, $field_name => $value, ... );
    my $res = $ua->put( $url, $field_name => $value, Content => \%form );
    my $res = $ua->put( $url, $field_name => $value, Content => \@form );

This method will dispatch a C<PUT> request on the given URL, with
C<%form> or C<@form> providing the key/value pairs for the fill-in form
content. Additional headers and content options are the same as for
the L<LWP::UserAgent/get> method.

CAVEAT:

This method can only accept content that is in key-value pairs when using
L<HTTP::Request::Common> prior to version C<6.07>. Any use of hash or array
references will result in an error prior to version C<6.07>.

This method will use the C<PUT> function from L<HTTP::Request::Common>
to build the request.  See L<HTTP::Request::Common> for a details on
how to pass form content and other advanced features.

=head2 request

    my $res = $ua->request( $request );
    my $res = $ua->request( $request, $content_file );
    my $res = $ua->request( $request, $content_cb );
    my $res = $ua->request( $request, $content_cb, $read_size_hint );

This method will dispatch the given C<$request> object. Normally this
will be an instance of the L<HTTP::Request> class, but any object with
a similar interface will do. The return value is an L<HTTP::Response> object.

The C<request> method will process redirects and authentication
responses transparently. This means that it may actually send several
simple requests via the L<LWP::UserAgent/simple_request> method described below.

The request methods described above; L<LWP::UserAgent/get>, L<LWP::UserAgent/head>,
L<LWP::UserAgent/post> and L<LWP::UserAgent/mirror> will all dispatch the request
they build via this method. They are convenience methods that simply hide the
creation of the request object for you.

The C<$content_file>, C<$content_cb> and C<$read_size_hint> all correspond to
options described with the L<LWP::UserAgent/get> method above. Note that errors
writing to the content file (for example due to permission denied
or the filesystem being full) will be reported via the C<Client-Aborted>
or C<X-Died> response headers, and not the C<is_success> method.

You are allowed to use a CODE reference as C<content> in the request
object passed in.  The C<content> function should return the content
when called.  The content can be returned in chunks.  The content
function will be invoked repeatedly until it return an empty string to
signal that there is no more content.

=head2 simple_request

    my $request = HTTP::Request->new( ... );
    my $res = $ua->simple_request( $request );
    my $res = $ua->simple_request( $request, $content_file );
    my $res = $ua->simple_request( $request, $content_cb );
    my $res = $ua->simple_request( $request, $content_cb, $read_size_hint );

This method dispatches a single request and returns the response
received.  Arguments are the same as for the L<LWP::UserAgent/request> described above.

The difference from L<LWP::UserAgent/request> is that C<simple_request> will not try to
handle redirects or authentication responses.  The L<LWP::UserAgent/request> method
will, in fact, invoke this method for each simple request it sends.

=head1 CALLBACK METHODS

The following methods will be invoked as requests are processed. These
methods are documented here because subclasses of L<LWP::UserAgent>
might want to override their behaviour.

=head2 get_basic_credentials

    # This checks wantarray and can either return an array:
    my ($user, $pass) = $ua->get_basic_credentials( $realm, $uri, $isproxy );
    # or a string that looks like "user:pass"
    my $creds = $ua->get_basic_credentials($realm, $uri, $isproxy);

This is called by L<LWP::UserAgent/request> to retrieve credentials for documents
protected by Basic or Digest Authentication.  The arguments passed in
is the C<$realm> provided by the server, the C<$uri> requested and a
C<boolean flag> to indicate if this is authentication against a proxy server.

The method should return a username and password.  It should return an
empty list to abort the authentication resolution attempt.  Subclasses
can override this method to prompt the user for the information. An
example of this can be found in C<lwp-request> program distributed
with this library.

The base implementation simply checks a set of pre-stored member
variables, set up with the L<LWP::UserAgent/credentials> method.

=head2 prepare_request

    $request = $ua->prepare_request( $request );

This method is invoked by L<LWP::UserAgent/simple_request>. Its task is
to modify the given C<$request> object by setting up various headers based
on the attributes of the user agent. The return value should normally be the
C<$request> object passed in.  If a different request object is returned
it will be the one actually processed.

The headers affected by the base implementation are; C<User-Agent>,
C<From>, C<Range> and C<Cookie>.

=head2 progress

    my $prog = $ua->progress( $status, $request_or_response );

This is called frequently as the response is received regardless of
how the content is processed.  The method is called with C<$status>
"begin" at the start of processing the request and with C<$state> "end"
before the request method returns.  In between these C<$status> will be
the fraction of the response currently received or the string "tick"
if the fraction can't be calculated.

When C<$status> is "begin" the second argument is the L<HTTP::Request> object,
otherwise it is the L<HTTP::Response> object.

=head2 redirect_ok

    my $bool = $ua->redirect_ok( $prospective_request, $response );

This method is called by L<LWP::UserAgent/request> before it tries to follow a
redirection to the request in C<$response>.  This should return a true
value if this redirection is permissible.  The C<$prospective_request>
will be the request to be sent if this method returns true.

The base implementation will return false unless the method
is in the object's C<requests_redirectable> list,
false if the proposed redirection is to a C<file://...>
URL, and true otherwise.

=head1 BEST PRACTICES

The default settings can get you up and running quickly, but there are settings
you can change in order to make your life easier.

=head2 Handling Cookies

You are encouraged to install L<Mozilla::PublicSuffix> and use
L<HTTP::CookieJar::LWP> as your cookie jar.  L<HTTP::CookieJar::LWP> provides a
better security model matching that of current Web browsers when
L<Mozilla::PublicSuffix> is installed.

    use HTTP::CookieJar::LWP ();

    my $jar = HTTP::CookieJar::LWP->new;
    my $ua = LWP::UserAgent->new( cookie_jar => $jar );

See L</"cookie_jar"> for more information.

=head2 Managing Protocols

C<protocols_allowed> gives you the ability to whitelist the protocols you're
willing to allow.

    my $ua = LWP::UserAgent->new(
        protocols_allowed => [ 'http', 'https' ]
    );

This will prevent you from inadvertently following URLs like
C<file:///etc/passwd>.  See L</"protocols_allowed">.

C<protocols_forbidden> gives you the ability to blacklist the protocols you're
unwilling to allow.

    my $ua = LWP::UserAgent->new(
        protocols_forbidden => [ 'file', 'mailto', 'ssh', ]
    );

This can also prevent you from inadvertently following URLs like
C<file:///etc/passwd>.  See L</protocols_forbidden>.

=head1 SEE ALSO

See L<LWP> for a complete overview of libwww-perl5.  See L<lwpcook>
and the scripts F<lwp-request> and F<lwp-download> for examples of
usage.

See L<HTTP::Request> and L<HTTP::Response> for a description of the
message objects dispatched and received.  See L<HTTP::Request::Common>
and L<HTML::Form> for other ways to build request objects.

See L<WWW::Mechanize> and L<WWW::Search> for examples of more
specialized user agents based on L<LWP::UserAgent>.

=head1 COPYRIGHT AND LICENSE

Copyright 1995-2009 Gisle Aas.

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

=cut
PK       ! h�y�  �    perl5/newgetopt.plnu ��6�$        # Id: newgetopt.pl,v 1.18 2001/09/21 13:34:59 jv

# This library is no longer being maintained, and is included for backward
# compatibility with Perl 4 programs which may require it.
# It is now just a wrapper around the Getopt::Long module.
#
# In particular, this should not be used as an example of modern Perl
# programming techniques.
#
# Suggested alternative: Getopt::Long

{   package newgetopt;

    # Values for $order. See GNU getopt.c for details.
    $REQUIRE_ORDER = 0;
    $PERMUTE = 1;
    $RETURN_IN_ORDER = 2;

    # Handle POSIX compliancy.
    if ( defined $ENV{"POSIXLY_CORRECT"} ) {
	$autoabbrev = 0;	# no automatic abbrev of options (???)
	$getopt_compat = 0;	# disallow '+' to start options
	$option_start = "(--|-)";
	$order = $REQUIRE_ORDER;
	$bundling = 0;
	$passthrough = 0;
    }
    else {
	$autoabbrev = 1;	# automatic abbrev of options
	$getopt_compat = 1;	# allow '+' to start options
	$option_start = "(--|-|\\+)";
	$order = $PERMUTE;
	$bundling = 0;
	$passthrough = 0;
    }

    # Other configurable settings.
    $debug = 0;			# for debugging
    $ignorecase = 1;		# ignore case when matching options
    $argv_end = "--";		# don't change this!
}

use Getopt::Long;

################ Subroutines ################

sub NGetOpt {

    $Getopt::Long::debug = $newgetopt::debug 
	if defined $newgetopt::debug;
    $Getopt::Long::autoabbrev = $newgetopt::autoabbrev 
	if defined $newgetopt::autoabbrev;
    $Getopt::Long::getopt_compat = $newgetopt::getopt_compat 
	if defined $newgetopt::getopt_compat;
    $Getopt::Long::option_start = $newgetopt::option_start 
	if defined $newgetopt::option_start;
    $Getopt::Long::order = $newgetopt::order 
	if defined $newgetopt::order;
    $Getopt::Long::bundling = $newgetopt::bundling 
	if defined $newgetopt::bundling;
    $Getopt::Long::ignorecase = $newgetopt::ignorecase 
	if defined $newgetopt::ignorecase;
    $Getopt::Long::ignorecase = $newgetopt::ignorecase 
	if defined $newgetopt::ignorecase;
    $Getopt::Long::passthrough = $newgetopt::passthrough 
	if defined $newgetopt::passthrough;

    &GetOptions;
}

################ Package return ################

1;

################ End of newgetopt.pl ################
PK       ! z��y  �y    perl5/File/Slurp.pmnu ��6�$        package File::Slurp;

use strict;
use warnings ;

our $VERSION = '9999.32';
$VERSION = eval $VERSION;

use Carp ;
use Exporter qw(import);
use Fcntl qw( :DEFAULT ) ;
use File::Basename ();
use File::Spec;
use File::Temp qw(tempfile);
use IO::Handle ();
use POSIX qw( :fcntl_h ) ;
use Errno ;

my @std_export = qw(
	read_file
	write_file
	overwrite_file
	append_file
	read_dir
) ;

my @edit_export = qw(
	edit_file
	edit_file_lines
) ;

my @abbrev_export = qw(
	rf
	wf
	ef
	efl
) ;

our @EXPORT_OK = (
	@edit_export,
	@abbrev_export,
	qw(
		slurp
		prepend_file
	),
) ;

our %EXPORT_TAGS = (
	'all'	=> [ @std_export, @edit_export, @abbrev_export, @EXPORT_OK ],
	'edit'	=> [ @edit_export ],
	'std'	=> [ @std_export ],
	'abr'	=> [ @abbrev_export ],
) ;

our @EXPORT = @std_export ;

my $max_fast_slurp_size = 1024 * 100 ;

my $is_win32 = $^O =~ /win32/i ;

*slurp = \&read_file ;
*rf = \&read_file ;

sub read_file {
	my $file_name = shift;
	my $opts = (ref $_[0] eq 'HASH') ? shift : {@_};
	# options we care about:
	# array_ref binmode blk_size buf_ref chomp err_mode scalar_ref

	# let's see if we have a stringified object before doing anything else
	# We then only have to deal with when we are given a file handle/globref
	if (ref($file_name)) {
		my $ref_result = _check_ref($file_name, $opts);
		if (ref($ref_result)) {
			@_ = ($opts, $ref_result);
			goto &_error;
		}
		$file_name = $ref_result if $ref_result;
		# we have now stringified $file_name if possible. if it's still a ref
		# then we probably have a file handle
	}

	my $fh;
	if (ref($file_name)) {
		$fh = $file_name;
	}
	else {
		# to keep with the old ways, read in :raw by default
		unless (open $fh, "<:raw", $file_name) {
			@_ = ($opts, "read_file '$file_name' - open: $!");
			goto &_error;
		}
		# even though we set raw, let binmode take place here (busted)
		if (my $bm = $opts->{binmode}) {
			binmode $fh, $bm;
		}
	}

	# we are now sure to have an open file handle. Let's slurp it in the same
	# way that File::Slurper does.
	my $buf;
	my $buf_ref = $opts->{buf_ref} || \$buf;
	${$buf_ref} = '';
	my $blk_size = $opts->{blk_size} || 1024 * 1024;
	if (my $size = -f $fh && -s _) {
		$blk_size = $size if $size < $blk_size;
		my ($pos, $read) = 0;
		do {
			unless(defined($read = read $fh, ${$buf_ref}, $blk_size, $pos)) {
				@_ = ($opts, "read_file '$file_name' - read: $!");
				goto &_error;
			}
			$pos += $read;
		} while ($read && $pos < $size);
	}
	else {
		${$buf_ref} = do { local $/; <$fh> };
	}
	seek($fh, $opts->{_data_tell}, SEEK_SET) if $opts->{_is_data} && $opts->{_data_tell};

	# line endings if we're on Windows
	${$buf_ref} =~ s/\015\012/\012/g if ${$buf_ref} && $is_win32 && !$opts->{binmode};

	# we now have a buffer filled with the file content. Figure out how to
	# return it to the user
	my $want_array = wantarray; # let's only ask for this once
	if ($want_array || $opts->{array_ref}) {
		use re 'taint';
		my $sep = $/;
		$sep = '\n\n+' if defined $sep && $sep eq '';
		# split the buffered content into lines
		my @lines = length(${$buf_ref}) ?
			${$buf_ref} =~ /(.*?$sep|.+)/sg : ();
		chomp @lines if $opts->{chomp};
		return \@lines if $opts->{array_ref};
		return @lines;
	}
	return $buf_ref if $opts->{scalar_ref};
	# if the function was called in scalar context, return the contents
	return ${$buf_ref} if defined $want_array;
	# if we were called in void context, return nothing
	return;
}

# errors in this sub are returned as scalar refs
# a normal IO/GLOB handle is an empty return
# an overloaded object returns its stringified as a scalarfilename

sub _check_ref {

	my( $handle, $opts ) = @_ ;

# check if we are reading from a handle (GLOB or IO object)

	if ( eval { $handle->isa( 'GLOB' ) || $handle->isa( 'IO' ) } ) {

# we have a handle. deal with seeking to it if it is DATA

		my $err = _seek_data_handle( $handle, $opts ) ;

# return the error string if any

		return \$err if $err ;

# we have good handle
		return ;
	}

	eval { require overload } ;

# return an error if we can't load the overload pragma
# or if the object isn't overloaded

	return \"Bad handle '$handle' is not a GLOB or IO object or overloaded"
		 if $@ || !overload::Overloaded( $handle ) ;

# must be overloaded so return its stringified value

	return "$handle" ;
}

sub _seek_data_handle {

	my( $handle, $opts ) = @_ ;
	# store some meta-data about the __DATA__ file handle
	$opts->{_is_data} = 0;
	$opts->{_data_tell} = 0;

# DEEP DARK MAGIC. this checks the UNTAINT IO flag of a
# glob/handle. only the DATA handle is untainted (since it is from
# trusted data in the source file). this allows us to test if this is
# the DATA handle and then to do a sysseek to make sure it gets
# slurped correctly. on some systems, the buffered i/o pointer is not
# left at the same place as the fd pointer. this sysseek makes them
# the same so slurping with sysread will work.

	eval{ require B } ;

	if ( $@ ) {

		return <<ERR ;
Can't find B.pm with this Perl: $!.
That module is needed to properly slurp the DATA handle.
ERR
	}

	if ( B::svref_2object( $handle )->IO->IoFLAGS & 16 ) {

		# we now know we have the data handle. Let's store its original
		# location in the file so that we can put it back after the read.
		# this is only done for Bugwards-compatibility in some dists such as
		# CPAN::Index::API that made use of the oddity where sysread was in use
		# before
		$opts->{_is_data} = 1;
		$opts->{_data_tell} = tell($handle);
# set the seek position to the current tell.

		# unless( sysseek( $handle, tell( $handle ), SEEK_SET ) ) {
		# 	return "read_file '$handle' - sysseek: $!" ;
		# }
	}

# seek was successful, return no error string

	return ;
}

*wf = \&write_file ;

sub write_file {
	my $file_name = shift;
	my $opts = (ref $_[0] eq 'HASH') ? shift : {};
	# options we care about:
	# append atomic binmode buf_ref err_mode no_clobber perms

	my $fh;
	my $no_truncate = 0;
	my $orig_filename;
	# let's see if we have a stringified object or some sort of handle
	# or globref before doing anything else
	if (ref($file_name)) {
		my $ref_result = _check_ref($file_name, $opts);
		if (ref($ref_result)) {
			# some error happened while checking for a ref
			@_ = ($opts, $ref_result);
			goto &_error;
		}
		if ($ref_result) {
			# we have now stringified $file_name from the overloaded obj
			$file_name = $ref_result;
		}
		else {
			# we now have a proper handle ref
			# make sure we don't call truncate on it
			$fh = $file_name;
			$no_truncate = 1;
			# can't do atomic or permissions on a file handle
			delete $opts->{atomic};
			delete $opts->{perms};
		}
	}

	# open the file for writing if we were given a filename
	unless ($fh) {
		$orig_filename = $file_name;
		my $perms = defined($opts->{perms}) ? $opts->{perms} : 0666;
		# set the mode for the sysopen
		my $mode = O_WRONLY | O_CREAT;
		$mode |= O_APPEND if $opts->{append};
		$mode |= O_EXCL if $opts->{no_clobber};
		if ($opts->{atomic}) {
			# in an atomic write, we must open a new file in the same directory
			# as the original to account for ACLs. We must also set the new file
			# to the same permissions as the original unless overridden by the
			# caller's request to set a specified permission set.
			my $dir = File::Spec->rel2abs(File::Basename::dirname($file_name));
			if (!defined($opts->{perms}) && -e $file_name && -f _) {
				$perms = 07777 & (stat $file_name)[2];
			}
			# we must ensure we're using a good temporary filename (doesn't already
			# exist). This is slower, but safer.
			{
				local $^W = 0; # AYFKM
				(undef, $file_name) = tempfile('.tempXXXXX', DIR => $dir, OPEN => 0);
			}
		}
		$fh = local *FH;
		unless (sysopen($fh, $file_name, $mode, $perms)) {
			@_ = ($opts, "write_file '$file_name' - sysopen: $!");
			goto &_error;
		}
	}
	# we now have an open file handle as well as data to write to that handle
	if (my $binmode = $opts->{binmode}) {
		binmode($fh, $binmode);
	}

	# get the data to print to the file
	# get the buffer ref - it depends on how the data is passed in
	# after this if/else $buf_ref will have a scalar ref to the data
	my $buf_ref;
	my $data_is_ref = 0;
	if (ref($opts->{buf_ref}) eq 'SCALAR') {
		# a scalar ref passed in %opts has the data
		# note that the data was passed by ref
		$buf_ref = $opts->{buf_ref};
		$data_is_ref = 1;
	}
	elsif (ref($_[0]) eq 'SCALAR') {
		# the first value in @_ is the scalar ref to the data
		# note that the data was passed by ref
		$buf_ref = shift;
		$data_is_ref = 1;
	}
	elsif (ref($_[0]) eq 'ARRAY') {
		# the first value in @_ is the array ref to the data so join it.
		${$buf_ref} = join '', @{$_[0]};
	}
	else {
		# good old @_ has all the data so join it.
		${$buf_ref} = join '', @_;
	}

	# seek and print
	seek($fh, 0, SEEK_END) if $opts->{append};
	print {$fh} ${$buf_ref};
	truncate($fh, tell($fh)) unless $no_truncate;
	close($fh);

	if ($opts->{atomic} && !rename($file_name, $orig_filename)) {
		@_ = ($opts, "write_file '$file_name' - rename: $!");
		goto &_error;
	}

	return 1;
}

# this is for backwards compatibility with the previous File::Slurp module.
# write_file always overwrites an existing file
*overwrite_file = \&write_file ;

# the current write_file has an append mode so we use that. this
# supports the same API with an optional second argument which is a
# hash ref of options.

sub append_file {

# get the optional opts hash ref
	my $opts = $_[1] ;
	if ( ref $opts eq 'HASH' ) {

# we were passed an opts ref so just mark the append mode

		$opts->{append} = 1 ;
	}
	else {

# no opts hash so insert one with the append mode

		splice( @_, 1, 0, { append => 1 } ) ;
	}

# magic goto the main write_file sub. this overlays the sub without touching
# the stack or @_

	goto &write_file
}

# prepend data to the beginning of a file

sub prepend_file {

	my $file_name = shift ;

#print "FILE $file_name\n" ;

	my $opts = ( ref $_[0] eq 'HASH' ) ? shift : {} ;

# delete unsupported options

	my @bad_opts =
		grep $_ ne 'err_mode' && $_ ne 'binmode', keys %{$opts} ;

	delete @{$opts}{@bad_opts} ;

	my $prepend_data = shift ;
	$prepend_data = '' unless defined $prepend_data ;
	$prepend_data = ${$prepend_data} if ref $prepend_data eq 'SCALAR' ;

#print "PRE [$prepend_data]\n" ;

	my $err_mode = delete $opts->{err_mode} ;
	$opts->{ err_mode } = 'croak' ;
	$opts->{ scalar_ref } = 1 ;

	my $existing_data = eval { read_file( $file_name, $opts ) } ;

	if ( $@ ) {

		@_ = ( { err_mode => $err_mode },
			"prepend_file '$file_name' - read_file: $!" ) ;
		goto &_error ;
	}

#print "EXIST [$$existing_data]\n" ;

	$opts->{atomic} = 1 ;
	my $write_result =
		eval { write_file( $file_name, $opts,
		       $prepend_data, $$existing_data ) ;
	} ;

	if ( $@ ) {

		@_ = ( { err_mode => $err_mode },
			"prepend_file '$file_name' - write_file: $!" ) ;
		goto &_error ;
	}

	return $write_result ;
}

# edit a file as a scalar in $_

*ef = \&edit_file ;

sub edit_file(&$;$) {

	my( $edit_code, $file_name, $opts ) = @_ ;
	$opts = {} unless ref $opts eq 'HASH' ;

# 	my $edit_code = shift ;
# 	my $file_name = shift ;
# 	my $opts = ( ref $_[0] eq 'HASH' ) ? shift : {} ;

#print "FILE $file_name\n" ;

# delete unsupported options

	my @bad_opts =
		grep $_ ne 'err_mode' && $_ ne 'binmode', keys %{$opts} ;

	delete @{$opts}{@bad_opts} ;

# keep the user err_mode and force croaking on internal errors

	my $err_mode = delete $opts->{err_mode} ;
	$opts->{ err_mode } = 'croak' ;

# get a scalar ref for speed and slurp the file into a scalar

	$opts->{ scalar_ref } = 1 ;
	my $existing_data = eval { read_file( $file_name, $opts ) } ;

	if ( $@ ) {

		@_ = ( { err_mode => $err_mode },
			"edit_file '$file_name' - read_file: $!" ) ;
		goto &_error ;
	}

#print "EXIST [$$existing_data]\n" ;

	my( $edited_data ) = map { $edit_code->(); $_ } $$existing_data ;

	$opts->{atomic} = 1 ;
	my $write_result =
		eval { write_file( $file_name, $opts, $edited_data ) } ;

	if ( $@ ) {

		@_ = ( { err_mode => $err_mode },
			"edit_file '$file_name' - write_file: $!" ) ;
		goto &_error ;
	}

	return $write_result ;
}

*efl = \&edit_file_lines ;

sub edit_file_lines(&$;$) {

	my( $edit_code, $file_name, $opts ) = @_ ;
	$opts = {} unless ref $opts eq 'HASH' ;

# 	my $edit_code = shift ;
# 	my $file_name = shift ;
# 	my $opts = ( ref $_[0] eq 'HASH' ) ? shift : {} ;

#print "FILE $file_name\n" ;

# delete unsupported options

	my @bad_opts =
		grep $_ ne 'err_mode' && $_ ne 'binmode', keys %{$opts} ;

	delete @{$opts}{@bad_opts} ;

# keep the user err_mode and force croaking on internal errors

	my $err_mode = delete $opts->{err_mode} ;
	$opts->{ err_mode } = 'croak' ;

# get an array ref for speed and slurp the file into lines

	$opts->{ array_ref } = 1 ;
	my $existing_data = eval { read_file( $file_name, $opts ) } ;

	if ( $@ ) {

		@_ = ( { err_mode => $err_mode },
			"edit_file_lines '$file_name' - read_file: $!" ) ;
		goto &_error ;
	}

#print "EXIST [$$existing_data]\n" ;

	my @edited_data = map { $edit_code->(); $_ } @$existing_data ;

	$opts->{atomic} = 1 ;
	my $write_result =
		eval { write_file( $file_name, $opts, @edited_data ) } ;

	if ( $@ ) {

		@_ = ( { err_mode => $err_mode },
			"edit_file_lines '$file_name' - write_file: $!" ) ;
		goto &_error ;
	}

	return $write_result ;
}

# basic wrapper around opendir/readdir

sub read_dir {

	my $dir = shift ;
	my $opts = ( ref $_[0] eq 'HASH' ) ? shift : { @_ } ;

# this handle will be destroyed upon return

	local(*DIRH);

# open the dir and handle any errors

	unless ( opendir( DIRH, $dir ) ) {

		@_ = ( $opts, "read_dir '$dir' - opendir: $!" ) ;
		goto &_error ;
	}

	my @dir_entries = readdir(DIRH) ;

	@dir_entries = grep( $_ ne "." && $_ ne "..", @dir_entries )
		unless $opts->{'keep_dot_dot'} ;

	if ( $opts->{'prefix'} ) {

		$_ = File::Spec->catfile($dir, $_) for @dir_entries;
	}

	return @dir_entries if wantarray ;
	return \@dir_entries ;
}

# error handling section
#
# all the error handling uses magic goto so the caller will get the
# error message as if from their code and not this module. if we just
# did a call on the error code, the carp/croak would report it from
# this module since the error sub is one level down on the call stack
# from read_file/write_file/read_dir.


my %err_func = (
	'carp'	=> \&carp,
	'croak'	=> \&croak,
) ;

sub _error {

	my( $opts, $err_msg ) = @_ ;

# get the error function to use

 	my $func = $err_func{ $opts->{'err_mode'} || 'croak' } ;

# if we didn't find it in our error function hash, they must have set
# it to quiet and we don't do anything.

	return unless $func ;

# call the carp/croak function

	$func->($err_msg) if $func ;

# return a hard undef (in list context this will be a single value of
# undef which is not a legal in-band value)

	return undef ;
}

1;
__END__

=head1 NAME

File::Slurp - Simple and Efficient Reading/Writing/Modifying of Complete Files

=head1 SYNOPSIS

  use File::Slurp;

  # read in a whole file into a scalar
  my $text = read_file('/path/file');

  # read in a whole file into an array of lines
  my @lines = read_file('/path/file');

  # write out a whole file from a scalar
  write_file('/path/file', $text);

  # write out a whole file from an array of lines
  write_file('/path/file', @lines);

  # Here is a simple and fast way to load and save a simple config file
  # made of key=value lines.
  my %conf = read_file('/path/file') =~ /^(\w+)=(.*)$/mg;
  write_file('/path/file', {atomic => 1}, map "$_=$conf{$_}\n", keys %conf);

  # insert text at the beginning of a file
  prepend_file('/path/file', $text);

  # in-place edit to replace all 'foo' with 'bar' in file
  edit_file { s/foo/bar/g } '/path/file';

  # in-place edit to delete all lines with 'foo' from file
  edit_file_lines sub { $_ = '' if /foo/ }, '/path/file';

  # read in a whole directory of file names (skipping . and ..)
  my @files = read_dir('/path/to/dir');

=head1 DESCRIPTION

This module provides subs that allow you to read or write entire files
with one simple call. They are designed to be simple to use, have
flexible ways to pass in or get the file contents and to be very
efficient. There is also a sub to read in all the files in a
directory.

=head2 WARNING - PENDING DOOM

Although you technically I<can>, do NOT use this module to work on file handles,
pipes, sockets, standard IO, or the C<DATA> handle. These are
features implemented long ago that just really shouldn't be abused here.

Be warned: this activity will lead to inaccurate encoding/decoding of data.

All further mentions of actions on the above have been removed from this
documentation and that feature set will likely be deprecated in the future.

In other words, if you don't have a filename to pass, consider using the
standard C<< do { local $/; <$fh> } >>, or
L<Data::Section>/L<Data::Section::Simple> for working with C<__DATA__>.

=head1 FUNCTIONS

L<File::Slurp> implements the following functions.

=head2 append_file

	use File::Slurp qw(append_file write_file);
	my $res = append_file('/path/file', "Some text");
	# same as
	my $res = write_file('/path/file', {append => 1}, "Some text");

The C<append_file> function is simply a synonym for the
L<File::Slurp/"write_file"> function, but ensures that the C<append> option is
set.

=head2 edit_file

	use File::Slurp qw(edit_file);
	# perl -0777 -pi -e 's/foo/bar/g' /path/file
	edit_file { s/foo/bar/g } '/path/file';
	edit_file sub { s/foo/bar/g }, '/path/file';
	sub replace_foo { s/foo/bar/g }
	edit_file \&replace_foo, '/path/file';

The C<edit_file> function reads in a file into C<$_>, executes a code block that
should modify C<$_>, and then writes C<$_> back to the file. The C<edit_file>
function reads in the entire file and calls the code block one time. It is
equivalent to the C<-pi> command line options of Perl but you can call it from
inside your program and not have to fork out a process.

The first argument to C<edit_file> is a code block or a code reference. The
code block is not followed by a comma (as with C<grep> and C<map>) but a code
reference is followed by a comma.

The next argument is the filename.

The next argument(s) is either a hash reference or a flattened hash,
C<< key => value >> pairs. The options are passed through to the
L<File::Slurp/"write_file"> function. All options are described there.
Only the C<binmode> and C<err_mode> options are supported. The call to
L<File::Slurp/"write_file"> has the C<atomic> option set so you will always
have a consistent file.

=head2 edit_file_lines

	use File::Slurp qw(edit_file_lines);
	# perl -pi -e '$_ = "" if /foo/' /path/file
	edit_file_lines { $_ = '' if /foo/ } '/path/file';
	edit_file_lines sub { $_ = '' if /foo/ }, '/path/file';
	sub delete_foo { $_ = '' if /foo/ }
	edit_file \&delete_foo, '/path/file';

The C<edit_file_lines> function reads each line of a file into C<$_>, and
executes a code block that should modify C<$_>. It will then write C<$_> back
to the file. It is equivalent to the C<-pi> command line options of Perl but
you can call it from inside your program and not have to fork out a process.

The first argument to C<edit_file_lines> is a code block or a code reference.
The code block is not followed by a comma (as with C<grep> and C<map>) but a
code reference is followed by a comma.

The next argument is the filename.

The next argument(s) is either a hash reference or a flattened hash,
C<< key => value >> pairs. The options are passed through to the
L<File::Slurp/"write_file"> function. All options are described there.
Only the C<binmode> and C<err_mode> options are supported. The call to
L<File::Slurp/"write_file"> has the C<atomic> option set so you will always
have a consistent file.

=head2 ef

	use File::Slurp qw(ef);
	# perl -0777 -pi -e 's/foo/bar/g' /path/file
	ef { s/foo/bar/g } '/path/file';
	ef sub { s/foo/bar/g }, '/path/file';
	sub replace_foo { s/foo/bar/g }
	ef \&replace_foo, '/path/file';

The C<ef> function is simply a synonym for the L<File::Slurp/"edit_file">
function.

=head2 efl

	use File::Slurp qw(efl);
	# perl -pi -e '$_ = "" if /foo/' /path/file
	efl { $_ = '' if /foo/ } '/path/file';
	efl sub { $_ = '' if /foo/ }, '/path/file';
	sub delete_foo { $_ = '' if /foo/ }
	efl \&delete_foo, '/path/file';

The C<efl> function is simply a synonym for the L<File::Slurp/"edit_file_lines">
function.

=head2 overwrite_file

	use File::Slurp qw(overwrite_file);
	my $res = overwrite_file('/path/file', "Some text");

The C<overwrite_file> function is simply a synonym for the
L<File::Slurp/"write_file"> function.

=head2 prepend_file

	use File::Slurp qw(prepend_file);
	prepend_file('/path/file', $header);
	prepend_file('/path/file', \@lines);
	prepend_file('/path/file', { binmode => ':raw'}, $bin_data);

	# equivalent to:
	use File::Slurp qw(read_file write_file);
	my $content = read_file('/path/file');
	my $new_content = "hahahaha";
	write_file('/path/file', $new_content . $content);

The C<prepend_file> function is the opposite of L<File::Slurp/"append_file"> as
it writes new contents to the beginning of the file instead of the end. It is a
combination of L<File::Slurp/"read_file"> and L<File::Slurp/"write_file">. It
works by first using C<read_file> to slurp in the file and then calling
C<write_file> with the new data and the existing file data.

The first argument to C<prepend_file> is the filename.

The next argument(s) is either a hash reference or a flattened hash,
C<< key => value >> pairs. The options are passed through to the
L<File::Slurp/"write_file"> function. All options are described there.

Only the C<binmode> and C<err_mode> options are supported. The
C<write_file> call has the C<atomic> option set so you will always have
a consistent file.

=head2 read_dir

	use File::Slurp qw(read_dir);
	my @files = read_dir('/path/to/dir');
	# all files, even the dots
	my @files = read_dir('/path/to/dir', keep_dot_dot => 1);
	# keep the full file path
	my @paths = read_dir('/path/to/dir', prefix => 1);
	# scalar context
	my $files_ref = read_dir('/path/to/dir');

This function returns a list of the filenames in the supplied directory. In
list context, an array is returned, in scalar context, an array reference is
returned.

The first argument is the path to the directory to read.

The next argument(s) is either a hash reference or a flattened hash,
C<< key => value >> pairs. The following options are available:

=over

=item

err_mode

The C<err_mode> option has three possible values: C<quiet>, C<carp>, or the
default, C<croak>. In C<quiet> mode, all errors will be silent. In C<carp> mode,
all errors will be emitted as warnings. And, in C<croak> mode, all errors will
be emitted as exceptions. Take a look at L<Try::Tiny> or
L<Syntax::Keyword::Try> to see how to catch exceptions.

=item

keep_dot_dot

The C<keep_dot_dot> option is a boolean option, defaulted to false (C<0>).
Setting this option to true (C<1>) will also return the C<.> and C<..> files
that are removed from the file list by default.

=item

prefix

The C<prefix> option is a boolean option, defaulted to false (C<0>).
Setting this option to true (C<1>) add the directory as a prefix to the file.
The directory and the filename are joined using C<< File::Spec->catfile() >> to
ensure the proper directory separator is used for your OS. See L<File::Spec>.

=back

=head2 read_file

	use File::Slurp qw(read_file);
	my $text = read_file('/path/file');
	my $bin = read_file('/path/file', { binmode => ':raw' });
	my @lines = read_file('/path/file');
	my $lines_ref = read_file('/path/file', array_ref => 1);
	my $lines_ref = [ read_file('/path/file') ];

	# or we can read into a buffer:
	my $buffer;
	read_file('/path/file', buf_ref => \$buffer);

	# or we can set the block size for the read
	my $text_ref = read_file('/path/file', blk_size => 10_000_000, array_ref => 1);

	# or we can get a scalar reference
	my $text_ref = read_file('/path/file', scalar_ref => 1);

This function reads in an entire file and returns its contents to the
caller. In scalar context it returns the entire file as a single
scalar. In list context it will return a list of lines (using the
current value of C<$/> as the separator, including support for paragraph
mode when it is set to C<''>).

The first argument is the path to the file to be slurped in.

The next argument(s) is either a hash reference or a flattened hash,
C<< key => value >> pairs. The following options are available:

=over

=item

array_ref

The C<array_ref> option is a boolean option, defaulted to false (C<0>). Setting
this option to true (C<1>) will only have relevance if the C<read_file> function
is called in scalar context. When true, the C<read_file> function will return
a reference to an array of the lines in the file.

=item

binmode

The C<binmode> option is a string option, defaulted to empty (C<''>). If you
set the C<binmode> option, then its value is passed to a call to C<binmode> on
the opened handle. You can use this to set the file to be read in binary mode,
utf8, etc. See C<perldoc -f binmode> for more.

=item

blk_size

You can use this option to set the block size used when slurping from
an already open handle (like C<\*STDIN>). It defaults to 1MB.

=item

buf_ref

The C<buf_ref> option can be used in conjunction with any of the other options.
You can use this option to pass in a scalar reference and the slurped
file contents will be stored in the scalar. This saves an extra copy of
the slurped file and can lower RAM usage vs returning the file. It is
usually the fastest way to read a file into a scalar.

=item

chomp

The C<chomp> option is a boolean option, defaulted to false (C<0>). Setting
this option to true (C<1>) will cause each line to have its contents C<chomp>ed.
This option works in list context or in scalar context with the C<array_ref>
option.

=item

err_mode

The C<err_mode> option has three possible values: C<quiet>, C<carp>, or the
default, C<croak>. In C<quiet> mode, all errors will be silent. In C<carp> mode,
all errors will be emitted as warnings. And, in C<croak> mode, all errors will
be emitted as exceptions. Take a look at L<Try::Tiny> or
L<Syntax::Keyword::Try> to see how to catch exceptions.

=item

scalar_ref

The C<scalar_ref> option is a boolean option, defaulted to false (C<0>). It only
has meaning in scalar context. The return value will be a scalar reference to a
string which is the contents of the slurped file. This will usually be faster
than returning the plain scalar. It will also save memory as it will not make a
copy of the file to return.

=back

=head2 rf

	use File::Slurp qw(rf);
	my $text = rf('/path/file');

The C<rf> function is simply a synonym for the L<File::Slurp/"read_file">
function.

=head2 slurp

	use File::Slurp qw(slurp);
	my $text = slurp('/path/file');

The C<slurp> function is simply a synonym for the L<File::Slurp/"read_file">
function.

=head2 wf

	use File::Slurp qw(wf);
	my $res = wf('/path/file', "Some text");


The C<wf> function is simply a synonym for the
L<File::Slurp/"write_file"> function.

=head2 write_file

	use File::Slurp qw(write_file);
	write_file('/path/file', @data);
	write_file('/path/file', {append => 1}, @data);
	write_file('/path/file', {binmode => ':raw'}, $buffer);
	write_file('/path/file', \$buffer);
	write_file('/path/file', $buffer);
	write_file('/path/file', \@lines);
	write_file('/path/file', @lines);

	# binmode
	write_file('/path/file', {binmode => ':raw'}, @data);
	write_file('/path/file', {binmode => ':utf8'}, $utf_text);

	# buffered
	write_file('/path/file', {buf_ref => \$buffer});
	write_file('/path/file', \$buffer);
	write_file('/path/file', $buffer);

	# append
	write_file('/path/file', {append => 1}, @data);

	# no clobbering
	write_file('/path/file', {no_clobber => 1}, @data);

This function writes out an entire file in one call. By default C<write_file>
returns C<1> upon successfully writing the file or C<undef> if it encountered
an error. You can change how errors are handled with the C<err_mode> option.

The first argument to C<write_file> is the filename.

The next argument(s) is either a hash reference or a flattened hash,
C<< key => value >> pairs. The following options are available:

=over

=item

append

The C<append> option is a boolean option, defaulted to false (C<0>). Setting
this option to true (C<1>) will cause the data to be be written at the end of
the current file. Internally this sets the C<sysopen> mode flag C<O_APPEND>.

The L<File::Slurp/"append_file"> function sets this option by default.

=item

atomic

The C<atomic> option is a boolean option, defaulted to false (C<0>). Setting
this option to true (C<1>) will cause the file to be be written to in an
atomic fashion. A temporary file name is created using L<File::Temp/"tempfile">.
After the file is closed it is renamed to the original file name
(and C<rename> is an atomic operation on most OSes). If the program using
this were to crash in the middle of this, then the temporary file could
be left behind.

=item

binmode

The C<binmode> option is a string option, defaulted to empty (C<''>). If you
set the C<binmode> option, then its value is passed to a call to C<binmode> on
the opened handle. You can use this to set the file to be read in binary mode,
utf8, etc. See C<perldoc -f binmode> for more.

=item

buf_ref

The C<buf_ref> option is used to pass in a scalar reference which has the
data to be written. If this is set then any data arguments (including
the scalar reference shortcut) in C<@_> will be ignored.

=item

err_mode

The C<err_mode> option has three possible values: C<quiet>, C<carp>, or the
default, C<croak>. In C<quiet> mode, all errors will be silent. In C<carp> mode,
all errors will be emitted as warnings. And, in C<croak> mode, all errors will
be emitted as exceptions. Take a look at L<Try::Tiny> or
L<Syntax::Keyword::Try> to see how to catch exceptions.


=item

no_clobber

The C<no_clobber> option is a boolean option, defaulted to false (C<0>). Setting
this option to true (C<1>) will ensure an that existing file will not be
overwritten.

=item

perms

The C<perms> option sets the permissions of newly-created files. This value
is modified by your process's C<umask> and defaults to C<0666> (same as
C<sysopen>).

NOTE: this option is new as of File::Slurp version 9999.14.

=back

=head1 EXPORT

These are exported by default or with

	use File::Slurp qw(:std);
	# read_file write_file overwrite_file append_file read_dir

These are exported with

	use File::Slurp qw(:edit);
	# edit_file edit_file_lines

You can get all subs in the module exported with

	use File::Slurp qw(:all);

=head1 SEE ALSO

=over

=item *

L<File::Slurper> - Provides a straightforward set of functions for the most
common tasks of reading/writing text and binary files.

=item *

L<Path::Tiny> - Lightweight and comprehensive file handling, including simple
methods for reading, writing, and editing text and binary files.

=item *

L<Mojo::File> - Similar to Path::Tiny for the L<Mojo> toolkit, always works in
bytes.

=back

=head1 AUTHOR

Uri Guttman, <F<uri@stemsystems.com>>

=head1 COPYRIGHT & LICENSE

Copyright (c) 2003 Uri Guttman. All rights reserved.

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

=cut
PK       ! ����k  �k    perl5/File/Copy/Recursive.pmnu ��6�$        package File::Copy::Recursive;

use strict;

BEGIN {
    # Keep older versions of Perl from trying to use lexical warnings
    $INC{'warnings.pm'} = "fake warnings entry for < 5.6 perl ($])" if $] < 5.006;
}
use warnings;

use Carp;
use File::Copy;
use File::Spec;    #not really needed because File::Copy already gets it, but for good measure :)
use Cwd ();

use vars qw(
  @ISA      @EXPORT_OK $VERSION  $MaxDepth $KeepMode $CPRFComp $CopyLink
  $PFSCheck $RemvBase $NoFtlPth  $ForcePth $CopyLoop $RMTrgFil $RMTrgDir
  $CondCopy $BdTrgWrn $SkipFlop  $DirPerms
);

require Exporter;
@ISA       = qw(Exporter);
@EXPORT_OK = qw(fcopy rcopy dircopy fmove rmove dirmove pathmk pathrm pathempty pathrmdir rcopy_glob rmove_glob);

$VERSION = '0.45';

$MaxDepth = 0;
$KeepMode = 1;
$CPRFComp = 0;
$CopyLink = eval { local $SIG{'__DIE__'}; symlink '', ''; 1 } || 0;
$PFSCheck = 1;
$RemvBase = 0;
$NoFtlPth = 0;
$ForcePth = 0;
$CopyLoop = 0;
$RMTrgFil = 0;
$RMTrgDir = 0;
$CondCopy = {};
$BdTrgWrn = 0;
$SkipFlop = 0;
$DirPerms = 0777;

my $samecheck = sub {
    return 1 if $^O eq 'MSWin32';    # need better way to check for this on winders...
    return if @_ != 2 || !defined $_[0] || !defined $_[1];
    return if $_[0] eq $_[1];

    my $one = '';
    if ($PFSCheck) {
        $one = join( '-', ( stat $_[0] )[ 0, 1 ] ) || '';
        my $two = join( '-', ( stat $_[1] )[ 0, 1 ] ) || '';
        if ( $one eq $two && $one ) {
            carp "$_[0] and $_[1] are identical";
            return;
        }
    }

    if ( -d $_[0] && !$CopyLoop ) {
        $one = join( '-', ( stat $_[0] )[ 0, 1 ] ) if !$one;
        my $abs = File::Spec->rel2abs( $_[1] );
        my @pth = File::Spec->splitdir($abs);
        while (@pth) {
            if ( $pth[-1] eq '..' ) {    # cheaper than Cwd::realpath() plus we don't want to resolve symlinks at this point, right?
                pop @pth;
                pop @pth unless -l File::Spec->catdir(@pth);
                next;
            }
            my $cur = File::Spec->catdir(@pth);
            last if !$cur;               # probably not necessary, but nice to have just in case :)
            my $two = join( '-', ( stat $cur )[ 0, 1 ] ) || '';
            if ( $one eq $two && $one ) {

                # $! = 62; # Too many levels of symbolic links
                carp "Caught Deep Recursion Condition: $_[0] contains $_[1]";
                return;
            }

            pop @pth;
        }
    }

    return 1;
};

my $glob = sub {
    my ( $do, $src_glob, @args ) = @_;

    local $CPRFComp = 1;
    require File::Glob;

    my @rt;
    for my $path ( File::Glob::bsd_glob($src_glob) ) {
        my @call = [ $do->( $path, @args ) ] or return;
        push @rt, \@call;
    }

    return @rt;
};

my $move = sub {
    my $fl = shift;
    my @x;
    if ($fl) {
        @x = fcopy(@_) or return;
    }
    else {
        @x = dircopy(@_) or return;
    }
    if (@x) {
        if ($fl) {
            unlink $_[0] or return;
        }
        else {
            pathrmdir( $_[0] ) or return;
        }
        if ($RemvBase) {
            my ( $volm, $path ) = File::Spec->splitpath( $_[0] );
            pathrm( File::Spec->catpath( $volm, $path, '' ), $ForcePth, $NoFtlPth ) or return;
        }
    }
    return wantarray ? @x : $x[0];
};

my $ok_todo_asper_condcopy = sub {
    my $org  = shift;
    my $copy = 1;
    if ( exists $CondCopy->{$org} ) {
        if ( $CondCopy->{$org}{'md5'} ) {

        }
        if ($copy) {

        }
    }
    return $copy;
};

sub fcopy {
    $samecheck->(@_) or return;
    if ( $RMTrgFil && ( -d $_[1] || -e $_[1] ) ) {
        my $trg = $_[1];
        if ( -d $trg ) {
            my @trgx = File::Spec->splitpath( $_[0] );
            $trg = File::Spec->catfile( $_[1], $trgx[$#trgx] );
        }
        $samecheck->( $_[0], $trg ) or return;
        if ( -e $trg ) {
            if ( $RMTrgFil == 1 ) {
                unlink $trg or carp "\$RMTrgFil failed: $!";
            }
            else {
                unlink $trg or return;
            }
        }
    }
    my ( $volm, $path ) = File::Spec->splitpath( $_[1] );
    if ( $path && !-d $path ) {
        pathmk( File::Spec->catpath( $volm, $path, '' ), $NoFtlPth );
    }
    if ( -l $_[0] && $CopyLink ) {
        my $target = readlink( shift() );
        ($target) = $target =~ m/(.*)/;    # mass-untaint is OK since we have to allow what the file system does
        carp "Copying a symlink ($_[0]) whose target does not exist"
          if !-e $target && $BdTrgWrn;
        my $new = shift();
        unlink $new if -l $new;
        symlink( $target, $new ) or return;
    }
    elsif ( -d $_[0] && -f $_[1] ) {
        return;
    }
    else {
        return if -d $_[0];                # address File::Copy::copy() bug outlined in https://rt.perl.org/Public/Bug/Display.html?id=132866
        copy(@_) or return;

        my @base_file = File::Spec->splitpath( $_[0] );
        my $mode_trg = -d $_[1] ? File::Spec->catfile( $_[1], $base_file[$#base_file] ) : $_[1];

        chmod scalar( ( stat( $_[0] ) )[2] ), $mode_trg if $KeepMode;
    }
    return wantarray ? ( 1, 0, 0 ) : 1;    # use 0's incase they do math on them and in case rcopy() is called in list context = no uninit val warnings
}

sub rcopy {
    if ( -l $_[0] && $CopyLink ) {
        goto &fcopy;
    }

    goto &dircopy if -d $_[0] || substr( $_[0], ( 1 * -1 ), 1 ) eq '*';
    goto &fcopy;
}

sub rcopy_glob {
    $glob->( \&rcopy, @_ );
}

sub dircopy {
    if ( $RMTrgDir && -d $_[1] ) {
        if ( $RMTrgDir == 1 ) {
            pathrmdir( $_[1] ) or carp "\$RMTrgDir failed: $!";
        }
        else {
            pathrmdir( $_[1] ) or return;
        }
    }
    my $globstar = 0;
    my $_zero    = $_[0];
    my $_one     = $_[1];
    if ( substr( $_zero, ( 1 * -1 ), 1 ) eq '*' ) {
        $globstar = 1;
        $_zero = substr( $_zero, 0, ( length($_zero) - 1 ) );
    }

    $samecheck->( $_zero, $_[1] ) or return;
    if ( !-d $_zero || ( -e $_[1] && !-d $_[1] ) ) {
        $! = 20;
        return;
    }

    if ( !-d $_[1] ) {
        pathmk( $_[1], $NoFtlPth ) or return;
    }
    else {
        if ( $CPRFComp && !$globstar ) {
            my @parts = File::Spec->splitdir($_zero);
            while ( $parts[$#parts] eq '' ) { pop @parts; }
            $_one = File::Spec->catdir( $_[1], $parts[$#parts] );
        }
    }
    my $baseend = $_one;
    my $level   = 0;
    my $filen   = 0;
    my $dirn    = 0;

    my $recurs;    #must be my()ed before sub {} since it calls itself
    $recurs = sub {
        my ( $str, $end, $buf ) = @_;
        $filen++ if $end eq $baseend;
        $dirn++  if $end eq $baseend;

        $DirPerms = oct($DirPerms) if substr( $DirPerms, 0, 1 ) eq '0';
        mkdir( $end, $DirPerms ) or return if !-d $end;
        if ( $MaxDepth && $MaxDepth =~ m/^\d+$/ && $level >= $MaxDepth ) {
            chmod scalar( ( stat($str) )[2] ), $end if $KeepMode;
            return ( $filen, $dirn, $level ) if wantarray;
            return $filen;
        }

        $level++;

        my @files;
        if ( $] < 5.006 ) {
            opendir( STR_DH, $str ) or return;
            @files = grep( $_ ne '.' && $_ ne '..', readdir(STR_DH) );
            closedir STR_DH;
        }
        else {
            opendir( my $str_dh, $str ) or return;
            @files = grep( $_ ne '.' && $_ ne '..', readdir($str_dh) );
            closedir $str_dh;
        }

        for my $file (@files) {
            my ($file_ut) = $file =~ m{ (.*) }xms;
            my $org = File::Spec->catfile( $str, $file_ut );
            my $new = File::Spec->catfile( $end, $file_ut );
            if ( -l $org && $CopyLink ) {
                my $target = readlink($org);
                ($target) = $target =~ m/(.*)/;    # mass-untaint is OK since we have to allow what the file system does
                carp "Copying a symlink ($org) whose target does not exist"
                  if !-e $target && $BdTrgWrn;
                unlink $new if -l $new;
                symlink( $target, $new ) or return;
            }
            elsif ( -d $org ) {
                my $rc;
                if ( !-w $org && $KeepMode ) {
                    local $KeepMode = 0;
                    $rc = $recurs->( $org, $new, $buf ) if defined $buf;
                    $rc = $recurs->( $org, $new ) if !defined $buf;
                    chmod scalar( ( stat($org) )[2] ), $new;
                }
                else {
                    $rc = $recurs->( $org, $new, $buf ) if defined $buf;
                    $rc = $recurs->( $org, $new ) if !defined $buf;
                }
                if ( !$rc ) {
                    if ($SkipFlop) {
                        next;
                    }
                    else {
                        return;
                    }
                }
                $filen++;
                $dirn++;
            }
            else {
                if ( $ok_todo_asper_condcopy->($org) ) {
                    if ($SkipFlop) {
                        fcopy( $org, $new, $buf ) or next if defined $buf;
                        fcopy( $org, $new ) or next if !defined $buf;
                    }
                    else {
                        fcopy( $org, $new, $buf ) or return if defined $buf;
                        fcopy( $org, $new ) or return if !defined $buf;
                    }
                    chmod scalar( ( stat($org) )[2] ), $new if $KeepMode;
                    $filen++;
                }
            }
        }
        $level--;
        chmod scalar( ( stat($str) )[2] ), $end if $KeepMode;
        1;

    };

    $recurs->( $_zero, $_one, $_[2] ) or return;
    return wantarray ? ( $filen, $dirn, $level ) : $filen;
}

sub fmove { $move->( 1, @_ ) }

sub rmove {
    if ( -l $_[0] && $CopyLink ) {
        goto &fmove;
    }

    goto &dirmove if -d $_[0] || substr( $_[0], ( 1 * -1 ), 1 ) eq '*';
    goto &fmove;
}

sub rmove_glob {
    $glob->( \&rmove, @_ );
}

sub dirmove { $move->( 0, @_ ) }

sub pathmk {
    my ( $vol, $dir, $file ) = File::Spec->splitpath( shift() );
    my $nofatal = shift;

    $DirPerms = oct($DirPerms) if substr( $DirPerms, 0, 1 ) eq '0';

    if ( defined($dir) ) {
        my (@dirs) = File::Spec->splitdir($dir);

        for ( my $i = 0; $i < scalar(@dirs); $i++ ) {
            my $newdir = File::Spec->catdir( @dirs[ 0 .. $i ] );
            my $newpth = File::Spec->catpath( $vol, $newdir, "" );

            mkdir( $newpth, $DirPerms ) or return if !-d $newpth && !$nofatal;
            mkdir( $newpth, $DirPerms ) if !-d $newpth && $nofatal;
        }
    }

    if ( defined($file) ) {
        my $newpth = File::Spec->catpath( $vol, $dir, $file );

        mkdir( $newpth, $DirPerms ) or return if !-d $newpth && !$nofatal;
        mkdir( $newpth, $DirPerms ) if !-d $newpth && $nofatal;
    }

    1;
}

sub pathempty {
    my $pth = shift;

    my ( $orig_dev, $orig_ino ) = ( lstat $pth )[ 0, 1 ];
    return 2 if !-d _ || !defined($orig_dev) || ( $^O ne 'MSWin32' && !$orig_ino );    #stat.inode is 0 on Windows

    my $starting_point = Cwd::cwd();
    my ( $starting_dev, $starting_ino ) = ( lstat $starting_point )[ 0, 1 ];
    chdir($pth) or Carp::croak("Failed to change directory to “$pth”: $!");
    $pth = '.';
    _bail_if_changed( $pth, $orig_dev, $orig_ino );

    my @names;
    my $pth_dh;
    if ( $] < 5.006 ) {
        opendir( PTH_DH, $pth ) or return;
        @names = grep !/^\.\.?$/, readdir(PTH_DH);
        closedir PTH_DH;
    }
    else {
        opendir( $pth_dh, $pth ) or return;
        @names = grep !/^\.\.?$/, readdir($pth_dh);
        closedir $pth_dh;
    }
    _bail_if_changed( $pth, $orig_dev, $orig_ino );

    for my $name (@names) {
        my ($name_ut) = $name =~ m{ (.*) }xms;
        my $flpth = File::Spec->catdir( $pth, $name_ut );

        if ( -l $flpth ) {
            _bail_if_changed( $pth, $orig_dev, $orig_ino );
            unlink $flpth or return;
        }
        elsif ( -d $flpth ) {
            _bail_if_changed( $pth, $orig_dev, $orig_ino );
            pathrmdir($flpth) or return;
        }
        else {
            _bail_if_changed( $pth, $orig_dev, $orig_ino );
            unlink $flpth or return;
        }
    }

    chdir($starting_point) or Carp::croak("Failed to change directory to “$starting_point”: $!");
    _bail_if_changed( ".", $starting_dev, $starting_ino );

    return 1;
}

sub pathrm {
    my ( $path, $force, $nofail ) = @_;

    my ( $orig_dev, $orig_ino ) = ( lstat $path )[ 0, 1 ];
    return 2 if !-d _ || !defined($orig_dev) || !$orig_ino;

    # Manual test (I hate this function :/):
    #    sudo mkdir /foo && perl -MFile::Copy::Recursive=pathrm -le 'print pathrm("/foo",1)' && sudo rm -rf /foo
    if ( $force && File::Spec->file_name_is_absolute($path) ) {
        Carp::croak("pathrm() w/ force on abspath is not allowed");
    }

    my @pth = File::Spec->splitdir($path);

    my %fs_check;
    my $aggregate_path;
    for my $part (@pth) {
        $aggregate_path = defined $aggregate_path ? File::Spec->catdir( $aggregate_path, $part ) : $part;
        $fs_check{$aggregate_path} = [ ( lstat $aggregate_path )[ 0, 1 ] ];
    }

    while (@pth) {
        my $cur = File::Spec->catdir(@pth);
        last if !$cur;    # necessary ???

        if ($force) {
            _bail_if_changed( $cur, $fs_check{$cur}->[0], $fs_check{$cur}->[1] );
            if ( !pathempty($cur) ) {
                return unless $nofail;
            }
        }
        _bail_if_changed( $cur, $fs_check{$cur}->[0], $fs_check{$cur}->[1] );
        if ($nofail) {
            rmdir $cur;
        }
        else {
            rmdir $cur or return;
        }
        pop @pth;
    }

    return 1;
}

sub pathrmdir {
    my $dir = shift;
    if ( -e $dir ) {
        return if !-d $dir;
    }
    else {
        return 2;
    }

    my ( $orig_dev, $orig_ino ) = ( lstat $dir )[ 0, 1 ];
    return 2 if !defined($orig_dev) || ( $^O ne 'MSWin32' && !$orig_ino );

    pathempty($dir) or return;
    _bail_if_changed( $dir, $orig_dev, $orig_ino );
    rmdir $dir or return;

    return 1;
}

sub _bail_if_changed {
    my ( $path, $orig_dev, $orig_ino ) = @_;

    my ( $cur_dev, $cur_ino ) = ( lstat $path )[ 0, 1 ];

    if ( !defined $cur_dev || !defined $cur_ino ) {
        $cur_dev ||= "undef(path went away?)";
        $cur_ino ||= "undef(path went away?)";
    }
    else {
        $path = Cwd::abs_path($path);
    }

    if ( $orig_dev ne $cur_dev || $orig_ino ne $cur_ino ) {
        local $Carp::CarpLevel += 1;
        Carp::croak("directory $path changed: expected dev=$orig_dev ino=$orig_ino, actual dev=$cur_dev ino=$cur_ino, aborting");
    }
}

1;

__END__

=head1 NAME

File::Copy::Recursive - Perl extension for recursively copying files and directories

=head1 SYNOPSIS

  use File::Copy::Recursive qw(fcopy rcopy dircopy fmove rmove dirmove);

  fcopy($orig,$new[,$buf]) or die $!;
  rcopy($orig,$new[,$buf]) or die $!;
  dircopy($orig,$new[,$buf]) or die $!;

  fmove($orig,$new[,$buf]) or die $!;
  rmove($orig,$new[,$buf]) or die $!;
  dirmove($orig,$new[,$buf]) or die $!;
  
  rcopy_glob("orig/stuff-*", $trg [, $buf]) or die $!;
  rmove_glob("orig/stuff-*", $trg [,$buf]) or die $!;

=head1 DESCRIPTION

This module copies and moves directories recursively (or single files, well... singley) to an optional depth and attempts to preserve each file or directory's mode.

=head1 EXPORT

None by default. But you can export all the functions as in the example above and the path* functions if you wish.

=head2 fcopy()

This function uses File::Copy's copy() function to copy a file but not a directory. Any directories are recursively created if need be.
One difference to File::Copy::copy() is that fcopy attempts to preserve the mode (see Preserving Mode below)
The optional $buf in the synopsis is the same as File::Copy::copy()'s 3rd argument.
This function returns the same as File::Copy::copy() in scalar context and 1,0,0 in list context to accomodate rcopy()'s list context on regular files. (See below for more info)

=head2 dircopy()

This function recursively traverses the $orig directory's structure and recursively copies it to the $new directory.
$new is created if necessary (multiple non existent directories is ok (i.e. foo/bar/baz). The script logically and portably creates all of them if necessary).
It attempts to preserve the mode (see Preserving Mode below) and 
by default it copies all the way down into the directory (see Managing Depth, below).
If a directory is not specified it croaks just like fcopy croaks if its not a file that is specified.

This function returns true or false: for true in scalar context it returns the number of files and directories copied,
whereas in list context it returns the number of files and directories, number of directories only, depth level traversed.

  my $num_of_files_and_dirs = dircopy($orig,$new);
  my($num_of_files_and_dirs,$num_of_dirs,$depth_traversed) = dircopy($orig,$new);
  
Normally it stops and returns if a copy fails. To continue on regardless, set $File::Copy::Recursive::SkipFlop to true.

    local $File::Copy::Recursive::SkipFlop = 1;

That way it will copy everythging it can in a directory and won't stop because of permissions, etc...

=head2 rcopy()

This function will allow you to specify a file *or* a directory. It calls fcopy() if you passed file and dircopy() if you passed a directory.
If you call rcopy() (or fcopy() for that matter) on a file in list context, the values will be 1,0,0 since no directories and no depth are used. 
This is important because if it's a directory in list context and there is only the initial directory the return value is 1,1,1.

=head2 rcopy_glob()

This function lets you specify a pattern suitable for perl's File::Glob::bsd_glob() as the first argument. Subsequently each path returned by perl's File::Glob::bsd_glob() gets rcopy()ied.

It returns and array whose items are array refs that contain the return value of each rcopy() call.

It forces behavior as if $File::Copy::Recursive::CPRFComp is true.

=head2 fmove()

Copies the file then removes the original. You can manage the path the original file is in according to $RemvBase.

=head2 dirmove()

Uses dircopy() to copy the directory then removes the original. You can manage the path the original directory is in according to $RemvBase.

=head2 rmove()

Like rcopy() but calls fmove() or dirmove() instead.

=head2 rmove_glob()

Like rcopy_glob() but calls rmove() instead of rcopy()

=head3 $RemvBase

Default is false. When set to true the *move() functions will not only attempt to remove the original file or directory but will remove the given path it is in.

So if you:

   rmove('foo/bar/baz', '/etc/');
   # "baz" is removed from foo/bar after it is successfully copied to /etc/
   
   local $File::Copy::Recursive::Remvbase = 1;
   rmove('foo/bar/baz','/etc/');
   # if baz is successfully copied to /etc/ :
   # first "baz" is removed from foo/bar
   # then "foo/bar is removed via pathrm()

=head4 $ForcePth

Default is false. When set to true it calls pathempty() before any directories are removed to empty the directory so it can be rmdir()'ed when $RemvBase is in effect.

=head2 Creating and Removing Paths

=head3 $NoFtlPth

Default is false. If set to true  rmdir(), mkdir(), and pathempty() calls in pathrm() and pathmk() do not return() on failure.

If its set to true they just silently go about their business regardless. This isn't a good idea but it's there if you want it.

=head3 $DirPerms

Mode to pass to any mkdir() calls. Defaults to 0777 as per umask()'s POD. Explicitly having this allows older perls to be able to use FCR and might add a bit of flexibility for you.

Any value you set it to should be suitable for oct().

=head3 Path functions

These functions exist solely because they were necessary for the move and copy functions to have the features they do and not because they are of themselves the purpose of this module. That being said, here is how they work so you can understand how the copy and move functions work and use them by themselves if you wish.

=head4 pathrm()

Removes a given path recursively. It removes the *entire* path so be careful!!!

Returns 2 if the given path is not a directory.

  File::Copy::Recursive::pathrm('foo/bar/baz') or die $!;
  # foo no longer exists

Same as:

  rmdir 'foo/bar/baz' or die $!;
  rmdir 'foo/bar' or die $!;
  rmdir 'foo' or die $!;

An optional second argument makes it call pathempty() before any rmdir()'s when set to true.

  File::Copy::Recursive::pathrm('foo/bar/baz', 1) or die $!;
  # foo no longer exists

Same as:PFSCheck

  File::Copy::Recursive::pathempty('foo/bar/baz') or die $!;
  rmdir 'foo/bar/baz' or die $!;
  File::Copy::Recursive::pathempty('foo/bar/') or die $!;
  rmdir 'foo/bar' or die $!;
  File::Copy::Recursive::pathempty('foo/') or die $!;
  rmdir 'foo' or die $!;

An optional third argument acts like $File::Copy::Recursive::NoFtlPth, again probably not a good idea.

=head4 pathempty()

Recursively removes the given directory's contents so it is empty. Returns 2 if the given argument is not a directory, 1 on successfully emptying the directory.

   File::Copy::Recursive::pathempty($pth) or die $!;
   # $pth is now an empty directory

=head4 pathmk()

Creates a given path recursively. Creates foo/bar/baz even if foo does not exist.

   File::Copy::Recursive::pathmk('foo/bar/baz') or die $!;

An optional second argument if true acts just like $File::Copy::Recursive::NoFtlPth, which means you'd never get your die() if something went wrong. Again, probably a *bad* idea.

=head4 pathrmdir()

Same as rmdir() but it calls pathempty() first to recursively empty it first since rmdir can not remove a directory with contents.
Just removes the top directory the path given instead of the entire path like pathrm(). Returns 2 if the given argument does not exist (i.e. it's already gone). Returns false if it exists but is not a directory.

=head2 Preserving Mode

By default a quiet attempt is made to change the new file or directory to the mode of the old one.
To turn this behavior off set
  $File::Copy::Recursive::KeepMode
to false;

=head2 Managing Depth

You can set the maximum depth a directory structure is recursed by setting:
  $File::Copy::Recursive::MaxDepth 
to a whole number greater than 0.

=head2 SymLinks

If your system supports symlinks then symlinks will be copied as symlinks instead of as the target file.
Perl's symlink() is used instead of File::Copy's copy().
You can customize this behavior by setting $File::Copy::Recursive::CopyLink to a true or false value.
It is already set to true or false depending on your system's support of symlinks so you can check it with an if statement to see how it will behave:

    if($File::Copy::Recursive::CopyLink) {
        print "Symlinks will be preserved\n";
    } else {
        print "Symlinks will not be preserved because your system does not support it\n";
    }

If symlinks are being copied you can set $File::Copy::Recursive::BdTrgWrn to true to make it carp when it copies a link whose target does not exist. It's false by default.

    local $File::Copy::Recursive::BdTrgWrn  = 1;

=head2 Removing existing target file or directory before copying.

This can be done by setting $File::Copy::Recursive::RMTrgFil or $File::Copy::Recursive::RMTrgDir for file or directory behavior respectively.

0 = off (This is the default)

1 = carp() $! if removal fails

2 = return if removal fails

    local $File::Copy::Recursive::RMTrgFil = 1;
    fcopy($orig, $target) or die $!;
    # if it fails it does warn() and keeps going

    local $File::Copy::Recursive::RMTrgDir = 2;
    dircopy($orig, $target) or die $!;
    # if it fails it does your "or die"

This should be unnecessary most of the time but it's there if you need it :)

=head2 Turning off stat() check

By default the files or directories are checked to see if they are the same (i.e. linked, or two paths (absolute/relative or different relative paths) to the same file) by comparing the file's stat() info. 
It's a very efficient check that croaks if they are and shouldn't be turned off but if you must for some weird reason just set $File::Copy::Recursive::PFSCheck to a false value. ("PFS" stands for "Physical File System")

=head2 Emulating cp -rf dir1/ dir2/

By default dircopy($dir1,$dir2) will put $dir1's contents right into $dir2 whether $dir2 exists or not.

You can make dircopy() emulate cp -rf by setting $File::Copy::Recursive::CPRFComp to true.

NOTE: This only emulates -f in the sense that it does not prompt. It does not remove the target file or directory if it exists.
If you need to do that then use the variables $RMTrgFil and $RMTrgDir described in "Removing existing target file or directory before copying" above.

That means that if $dir2 exists it puts the contents into $dir2/$dir1 instead of $dir2 just like cp -rf.
If $dir2 does not exist then the contents go into $dir2 like normal (also like cp -rf).

So assuming 'foo/file':

    dircopy('foo', 'bar') or die $!;
    # if bar does not exist the result is bar/file
    # if bar does exist the result is bar/file

    $File::Copy::Recursive::CPRFComp = 1;
    dircopy('foo', 'bar') or die $!;
    # if bar does not exist the result is bar/file
    # if bar does exist the result is bar/foo/file

You can also specify a star for cp -rf glob type behavior:

    dircopy('foo/*', 'bar') or die $!;
    # if bar does not exist the result is bar/file
    # if bar does exist the result is bar/file

    $File::Copy::Recursive::CPRFComp = 1;
    dircopy('foo/*', 'bar') or die $!;
    # if bar does not exist the result is bar/file
    # if bar does exist the result is bar/file

NOTE: The '*' is only like cp -rf foo/* and *DOES NOT EXPAND PARTIAL DIRECTORY NAMES LIKE YOUR SHELL DOES* (i.e. not like cp -rf fo* to copy foo/*).

=head2 Allowing Copy Loops

If you want to allow:

  cp -rf . foo/

type behavior set $File::Copy::Recursive::CopyLoop to true.

This is false by default so that a check is done to see if the source directory will contain the target directory and croaks to avoid this problem.

If you ever find a situation where $CopyLoop = 1 is desirable let me know. (i.e. it's a bad bad idea but is there if you want it)

(Note: On Windows this was necessary since it uses stat() to determine sameness and stat() is essentially useless for this on Windows. 
The test is now simply skipped on Windows but I'd rather have an actual reliable check if anyone in Microsoft land would care to share)

=head1 SEE ALSO

L<File::Copy> L<File::Spec>

=head1 TO DO

I am currently working on and reviewing some other modules to use in the new interface so we can lose the horrid globals as well as some other undesirable traits and also more easily make available some long standing requests.

Tests will be easier to do with the new interface and hence the testing focus will shift to the new interface and aim to be comprehensive.

The old interface will work, it just won't be brought in until it is used, so it will add no overhead for users of the new interface.

I'll add this after the latest version has been out for a while with no new features or issues found :)

=head1 AUTHOR

Daniel Muey, L<http://drmuey.com/cpan_contact.pl>

=head1 COPYRIGHT AND LICENSE

Copyright 2004 by Daniel Muey

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

=cut
PK       ! `�5\*  \*    perl5/File/chdir.pmnu ��6�$        package File::chdir;
use 5.004;
use strict;
use vars qw($VERSION @ISA @EXPORT $CWD @CWD);
# ABSTRACT: a more sensible way to change directories

our $VERSION = '0.1010';

require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(*CWD);

use Carp;
use Cwd 3.16;
use File::Spec::Functions 3.27 qw/canonpath splitpath catpath splitdir catdir/;

tie $CWD, 'File::chdir::SCALAR' or die "Can't tie \$CWD";
tie @CWD, 'File::chdir::ARRAY'  or die "Can't tie \@CWD";

sub _abs_path {
    # Otherwise we'll never work under taint mode.
    my($cwd) = Cwd::getcwd =~ /(.*)/s;
    # Run through File::Spec, since everything else uses it
    return canonpath($cwd);
}

# splitpath but also split directory
sub _split_cwd {
    my ($vol, $dir) = splitpath(_abs_path, 1);
    my @dirs = splitdir( $dir );
    shift @dirs; # get rid of leading empty "root" directory
    return ($vol, @dirs);
}

# catpath, but take list of directories
# restore the empty root dir and provide an empty file to avoid warnings
sub _catpath {
    my ($vol, @dirs) = @_;
    return catpath($vol, catdir(q{}, @dirs), q{});
}

sub _chdir {
    # Untaint target directory
    my ($new_dir) = $_[0] =~ /(.*)/s;

    local $Carp::CarpLevel = $Carp::CarpLevel + 1;
    if ( ! CORE::chdir($new_dir) ) {
        croak "Failed to change directory to '$new_dir': $!";
    };
    return 1;
}

{
    package File::chdir::SCALAR;
    use Carp;

    BEGIN {
        *_abs_path = \&File::chdir::_abs_path;
        *_chdir = \&File::chdir::_chdir;
        *_split_cwd = \&File::chdir::_split_cwd;
        *_catpath = \&File::chdir::_catpath;
    }

    sub TIESCALAR {
        bless [], $_[0];
    }

    # To be safe, in case someone chdir'd out from under us, we always
    # check the Cwd explicitly.
    sub FETCH {
        return _abs_path;
    }

    sub STORE {
        return unless defined $_[1];
        _chdir($_[1]);
    }
}


{
    package File::chdir::ARRAY;
    use Carp;

    BEGIN {
        *_abs_path = \&File::chdir::_abs_path;
        *_chdir = \&File::chdir::_chdir;
        *_split_cwd = \&File::chdir::_split_cwd;
        *_catpath = \&File::chdir::_catpath;
    }

    sub TIEARRAY {
        bless {}, $_[0];
    }

    sub FETCH {
        my($self, $idx) = @_;
        my ($vol, @cwd) = _split_cwd;
        return $cwd[$idx];
    }

    sub STORE {
        my($self, $idx, $val) = @_;

        my ($vol, @cwd) = _split_cwd;
        if( $self->{Cleared} ) {
            @cwd = ();
            $self->{Cleared} = 0;
        }

        $cwd[$idx] = $val;
        my $dir = _catpath($vol,@cwd);

        _chdir($dir);
        return $cwd[$idx];
    }

    sub FETCHSIZE {
        my ($vol, @cwd) = _split_cwd;
        return scalar @cwd;
    }
    sub STORESIZE {}

    sub PUSH {
        my($self) = shift;

        my $dir = _catpath(_split_cwd, @_);
        _chdir($dir);
        return $self->FETCHSIZE;
    }

    sub POP {
        my($self) = shift;

        my ($vol, @cwd) = _split_cwd;
        my $popped = pop @cwd;
        my $dir = _catpath($vol,@cwd);
        _chdir($dir);
        return $popped;
    }

    sub SHIFT {
        my($self) = shift;

        my ($vol, @cwd) = _split_cwd;
        my $shifted = shift @cwd;
        my $dir = _catpath($vol,@cwd);
        _chdir($dir);
        return $shifted;
    }

    sub UNSHIFT {
        my($self) = shift;

        my ($vol, @cwd) = _split_cwd;
        my $dir = _catpath($vol, @_, @cwd);
        _chdir($dir);
        return $self->FETCHSIZE;
    }

    sub CLEAR  {
        my($self) = shift;
        $self->{Cleared} = 1;
    }

    sub SPLICE {
        my $self = shift;
        my $offset = shift || 0;
        my $len = shift || $self->FETCHSIZE - $offset;
        my @new_dirs = @_;

        my ($vol, @cwd) = _split_cwd;
        my @orig_dirs = splice @cwd, $offset, $len, @new_dirs;
        my $dir = _catpath($vol, @cwd);
        _chdir($dir);
        return @orig_dirs;
    }

    sub EXTEND { }
    sub EXISTS {
        my($self, $idx) = @_;
        return $self->FETCHSIZE >= $idx ? 1 : 0;
    }

    sub DELETE {
        my($self, $idx) = @_;
        croak "Can't delete except at the end of \@CWD"
            if $idx < $self->FETCHSIZE - 1;
        local $Carp::CarpLevel = $Carp::CarpLevel + 1;
        $self->POP;
    }
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

File::chdir - a more sensible way to change directories

=head1 VERSION

version 0.1010

=head1 SYNOPSIS

  use File::chdir;

  $CWD = "/foo/bar";     # now in /foo/bar
  {
      local $CWD = "/moo/baz";  # now in /moo/baz
      ...
  }

  # still in /foo/bar!

=head1 DESCRIPTION

Perl's C<chdir()> has the unfortunate problem of being very, very, very
global.  If any part of your program calls C<chdir()> or if any library
you use calls C<chdir()>, it changes the current working directory for
the *whole* program.

This sucks.

File::chdir gives you an alternative, C<$CWD> and C<@CWD>.  These two
variables combine all the power of C<chdir()>, L<File::Spec> and L<Cwd>.

=head1 $CWD

Use the C<$CWD> variable instead of C<chdir()> and Cwd.

    use File::chdir;
    $CWD = $dir;  # just like chdir($dir)!
    print $CWD;   # prints the current working directory

It can be localized, and it does the right thing.

    $CWD = "/foo";      # it's /foo out here.
    {
        local $CWD = "/bar";  # /bar in here
    }
    # still /foo out here!

C<$CWD> always returns the absolute path in the native form for the
operating system.

C<$CWD> and normal C<chdir()> work together just fine.

=head1 @CWD

C<@CWD> represents the current working directory as an array, each
directory in the path is an element of the array.  This can often make
the directory easier to manipulate, and you don't have to fumble with
C<File::Spec->splitpath> and C<File::Spec->catdir> to make portable code.

  # Similar to chdir("/usr/local/src/perl")
  @CWD = qw(usr local src perl);

pop, push, shift, unshift and splice all work.  pop and push are
probably the most useful.

  pop @CWD;                 # same as chdir(File::Spec->updir)
  push @CWD, 'some_dir'     # same as chdir('some_dir')

C<@CWD> and C<$CWD> both work fine together.

*NOTE* Due to a perl bug you can't localize C<@CWD>.  See L</CAVEATS> for a work around.

=head1 EXAMPLES

(We omit the C<use File::chdir> from these examples for terseness)

Here's C<$CWD> instead of C<chdir()>:

    $CWD = 'foo';           # chdir('foo')

and now instead of Cwd.

    print $CWD;             # use Cwd;  print Cwd::abs_path

you can even do zsh style C<cd foo bar>

    $CWD = '/usr/local/foo';
    $CWD =~ s/usr/var/;

if you want to localize that, make sure you get the parens right

    {
        (local $CWD) =~ s/usr/var/;
        ...
    }

It's most useful for writing polite subroutines which don't leave the
program in some strange directory:

    sub foo {
        local $CWD = 'some/other/dir';
        ...do your work...
    }

which is much simpler than the equivalent:

    sub foo {
        use Cwd;
        my $orig_dir = Cwd::getcwd;
        chdir('some/other/dir');

        ...do your work...

        chdir($orig_dir);
    }

C<@CWD> comes in handy when you want to start moving up and down the
directory hierarchy in a cross-platform manner without having to use
File::Spec.

    pop @CWD;                   # chdir(File::Spec->updir);
    push @CWD, 'some', 'dir'    # chdir(File::Spec->catdir(qw(some dir)));

You can easily change your parent directory:

    # chdir from /some/dir/bar/moo to /some/dir/foo/moo
    $CWD[-2] = 'foo';

=head1 CAVEATS

=head2 C<local @CWD> does not work.

C<local @CWD> will not localize C<@CWD>.  This is a bug in Perl, you
can't localize tied arrays.  As a work around localizing $CWD will
effectively localize @CWD.

    {
        local $CWD;
        pop @CWD;
        ...
    }

=head2 Assigning to C<@CWD> calls C<chdir()> for each element

    @CWD = qw/a b c d/;

Internally, Perl clears C<@CWD> and assigns each element in turn.  Thus, this
code above will do this:

    chdir 'a';
    chdir 'a/b';
    chdir 'a/b/c';
    chdir 'a/b/c/d';

Generally, avoid assigning to C<@CWD> and just use push and pop instead.

=head2 Volumes not handled

There is currently no way to change the current volume via File::chdir.

=head1 NOTES

C<$CWD> returns the current directory using native path separators, i.e. \
on Win32.  This ensures that C<$CWD> will compare correctly with directories
created using File::Spec.  For example:

    my $working_dir = File::Spec->catdir( $CWD, "foo" );
    $CWD = $working_dir;
    doing_stuff_might_chdir();
    is( $CWD, $working_dir, "back to original working_dir?" );

Deleting the last item of C<@CWD> will act like a pop.  Deleting from the
middle will throw an exception.

    delete @CWD[-1]; # OK
    delete @CWD[-2]; # Dies

What should %CWD do?  Something with volumes?

    # chdir to C:\Program Files\Sierra\Half Life ?
    $CWD{C} = '\\Program Files\\Sierra\\Half Life';

=head1 DIAGNOSTICS

If an error is encountered when changing C<$CWD> or C<@CWD>, one of
the following exceptions will be thrown:

* ~Can't delete except at the end of @CWD~
* ~Failed to change directory to '$dir'~

=head1 HISTORY

Michael wanted C<local chdir> to work.  p5p didn't.  But it wasn't over!
Was it over when the Germans bombed Pearl Harbor?  Hell, no!

Abigail and/or Bryan Warnock suggested the C<$CWD> thing (Michael forgets
which).  They were right.

The C<chdir()> override was eliminated in 0.04.

David became co-maintainer with 0.06_01 to fix some chronic
Win32 path bugs.

As of 0.08, if changing C<$CWD> or C<@CWD> fails to change the directory, an
error will be thrown.

=head1 SEE ALSO

L<File::pushd>, L<File::Spec>, L<Cwd>, L<perlfunc/chdir>,
"Animal House" L<http://www.imdb.com/title/tt0077975/quotes>

=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan

=head1 SUPPORT

=head2 Bugs / Feature Requests

Please report any bugs or feature requests through the issue tracker
at L<https://github.com/dagolden/File-chdir/issues>.
You will be notified automatically of any progress on your issue.

=head2 Source Code

This is open source software.  The code repository is available for
public review and contribution under the terms of the license.

L<https://github.com/dagolden/File-chdir>

  git clone https://github.com/dagolden/File-chdir.git

=head1 AUTHORS

=over 4

=item *

David Golden <dagolden@cpan.org>

=item *

Michael G. Schwern <schwern@pobox.com>

=back

=head1 CONTRIBUTOR

=for stopwords Joel Berger

Joel Berger <joel.a.berger@gmail.com>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2015 by Michael G. Schwern and David Golden.

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

=cut
PK       ! �95�.  �.    perl5/File/Which.pmnu ��6�$        package File::Which;

use strict;
use warnings;
use Exporter   ();
use File::Spec ();

# ABSTRACT: Perl implementation of the which utility as an API
our $VERSION = '1.23'; # VERSION


our @ISA       = 'Exporter';
our @EXPORT    = 'which';
our @EXPORT_OK = 'where';

use constant IS_VMS => ($^O eq 'VMS');
use constant IS_MAC => ($^O eq 'MacOS');
use constant IS_WIN => ($^O eq 'MSWin32' or $^O eq 'dos' or $^O eq 'os2');
use constant IS_DOS => IS_WIN();
use constant IS_CYG => ($^O eq 'cygwin' || $^O eq 'msys');

our $IMPLICIT_CURRENT_DIR = IS_WIN || IS_VMS || IS_MAC;

# For Win32 systems, stores the extensions used for
# executable files
# For others, the empty string is used
# because 'perl' . '' eq 'perl' => easier
my @PATHEXT = ('');
if ( IS_WIN ) {
  # WinNT. PATHEXT might be set on Cygwin, but not used.
  if ( $ENV{PATHEXT} ) {
    push @PATHEXT, split ';', $ENV{PATHEXT};
  } else {
    # Win9X or other: doesn't have PATHEXT, so needs hardcoded.
    push @PATHEXT, qw{.com .exe .bat};
  }
} elsif ( IS_VMS ) {
  push @PATHEXT, qw{.exe .com};
} elsif ( IS_CYG ) {
  # See this for more info
  # http://cygwin.com/cygwin-ug-net/using-specialnames.html#pathnames-exe
  push @PATHEXT, qw{.exe .com};
}


sub which {
  my ($exec) = @_;

  return undef unless defined $exec;
  return undef if $exec eq '';

  my $all = wantarray;
  my @results = ();

  # check for aliases first
  if ( IS_VMS ) {
    my $symbol = `SHOW SYMBOL $exec`;
    chomp($symbol);
    unless ( $? ) {
      return $symbol unless $all;
      push @results, $symbol;
    }
  }
  if ( IS_MAC ) {
    my @aliases = split /\,/, $ENV{Aliases};
    foreach my $alias ( @aliases ) {
      # This has not been tested!!
      # PPT which says MPW-Perl cannot resolve `Alias $alias`,
      # let's just hope it's fixed
      if ( lc($alias) eq lc($exec) ) {
        chomp(my $file = `Alias $alias`);
        last unless $file;  # if it failed, just go on the normal way
        return $file unless $all;
        push @results, $file;
        # we can stop this loop as if it finds more aliases matching,
        # it'll just be the same result anyway
        last;
      }
    }
  }

  return $exec
          if !IS_VMS and !IS_MAC and !IS_WIN and $exec =~ /\// and -f $exec and -x $exec;

  my @path;
  if($^O eq 'MSWin32') {
    # File::Spec (at least recent versions)
    # add the implicit . for you on MSWin32,
    # but we may or may not want to include
    # that.
    @path = split(';', $ENV{PATH});
    s/"//g for @path;
    @path = grep length, @path;
  } else {
    @path = File::Spec->path;
  }
  if ( $IMPLICIT_CURRENT_DIR ) {
    unshift @path, File::Spec->curdir;
  }

  foreach my $base ( map { File::Spec->catfile($_, $exec) } @path ) {
    for my $ext ( @PATHEXT ) {
      my $file = $base.$ext;

      # We don't want dirs (as they are -x)
      next if -d $file;

      if (
        # Executable, normal case
        -x _
        or (
          # MacOS doesn't mark as executable so we check -e
          IS_MAC
          ||
          (
            ( IS_WIN or IS_CYG )
            and
            grep {
              $file =~ /$_\z/i
            } @PATHEXT[1..$#PATHEXT]
          )
          # DOSish systems don't pass -x on
          # non-exe/bat/com files. so we check -e.
          # However, we don't want to pass -e on files
          # that aren't in PATHEXT, like README.
          and -e _
        )
      ) {
        return $file unless $all;
        push @results, $file;
      }
    }
  }

  if ( $all ) {
    return @results;
  } else {
    return undef;
  }
}


sub where {
  # force wantarray
  my @res = which($_[0]);
  return @res;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

File::Which - Perl implementation of the which utility as an API

=head1 VERSION

version 1.23

=head1 SYNOPSIS

 use File::Which;                  # exports which()
 use File::Which qw(which where);  # exports which() and where()
 
 my $exe_path = which 'perldoc';
 
 my @paths = where 'perl';
 # Or
 my @paths = which 'perl'; # an array forces search for all of them

=head1 DESCRIPTION

L<File::Which> finds the full or relative paths to executable programs on
the system.  This is normally the function of C<which> utility.  C<which> is
typically implemented as either a program or a built in shell command.  On
some platforms, such as Microsoft Windows it is not provided as part of the
core operating system.  This module provides a consistent API to this
functionality regardless of the underlying platform.

The focus of this module is correctness and portability.  As a consequence
platforms where the current directory is implicitly part of the search path
such as Microsoft Windows will find executables in the current directory,
whereas on platforms such as UNIX where this is not the case executables
in the current directory will only be found if the current directory is
explicitly added to the path.

If you need a portable C<which> on the command line in an environment that
does not provide it, install L<App::pwhich> which provides a command line
interface to this API.

=head2 Implementations

L<File::Which> searches the directories of the user's C<PATH> (the current
implementation uses L<File::Spec#path> to determine the correct C<PATH>),
looking for executable files having the name specified as a parameter to
L</which>. Under Win32 systems, which do not have a notion of directly
executable files, but uses special extensions such as C<.exe> and C<.bat>
to identify them, C<File::Which> takes extra steps to assure that
you will find the correct file (so for example, you might be searching for
C<perl>, it'll try F<perl.exe>, F<perl.bat>, etc.)

=head3 Linux, *BSD and other UNIXes

There should not be any surprises here.  The current directory will not be
searched unless it is explicitly added to the path.

=head3 Modern Windows (including NT, XP, Vista, 7, 8, 10 etc)

Windows NT has a special environment variable called C<PATHEXT>, which is used
by the shell to look for executable files. Usually, it will contain a list in
the form C<.EXE;.BAT;.COM;.JS;.VBS> etc. If C<File::Which> finds such an
environment variable, it parses the list and uses it as the different
extensions.

=head3 Cygwin

Cygwin provides a Unix-like environment for Microsoft Windows users.  In most
ways it works like other Unix and Unix-like environments, but in a few key
aspects it works like Windows.  As with other Unix environments, the current
directory is not included in the search unless it is explicitly included in
the search path.  Like on Windows, files with C<.EXE> or <.BAT> extensions will
be discovered even if they are not part of the query.  C<.COM> or extensions
specified using the C<PATHEXT> environment variable will NOT be discovered
without the fully qualified name, however.

=head3 Windows ME, 98, 95, MS-DOS, OS/2

This set of operating systems don't have the C<PATHEXT> variable, and usually
you will find executable files there with the extensions C<.exe>, C<.bat> and
(less likely) C<.com>. C<File::Which> uses this hardcoded list if it's running
under Win32 but does not find a C<PATHEXT> variable.

As of 2015 none of these platforms are tested frequently (or perhaps ever),
but the current maintainer is determined not to intentionally remove support
for older operating systems.

=head3 VMS

Same case as Windows 9x: uses C<.exe> and C<.com> (in that order).

As of 2015 the current maintainer does not test on VMS, and is in fact not
certain it has ever been tested on VMS.  If this platform is important to you
and you can help me verify and or support it on that platform please contact
me.

=head1 FUNCTIONS

=head2 which

 my $path = which $short_exe_name;
 my @paths = which $short_exe_name;

Exported by default.

C<$short_exe_name> is the name used in the shell to call the program (for
example, C<perl>).

If it finds an executable with the name you specified, C<which()> will return
the absolute path leading to this executable (for example, F</usr/bin/perl> or
F<C:\Perl\Bin\perl.exe>).

If it does I<not> find the executable, it returns C<undef>.

If C<which()> is called in list context, it will return I<all> the
matches.

=head2 where

 my @paths = where $short_exe_name;

Not exported by default.

Same as L</which> in array context.  Similar to the C<where> csh
built-in command or C<which -a> command for platforms that support the
C<-a> option. Will return an array containing all the path names
matching C<$short_exe_name>.

=head1 GLOBALS

=head2 $IMPLICIT_CURRENT_DIR

True if the current directory is included in the search implicitly on
whatever platform you are using.  Normally the default is reasonable,
but on Windows the current directory is included implicitly for older
shells like C<cmd.exe> and C<command.com>, but not for newer shells
like PowerShell.  If you overrule this default, you should ALWAYS
localize the variable to the tightest scope possible, since setting
this variable from a module can affect other modules.  Thus on Windows
you can get the correct result if the user is running either C<cmd.exe>
or PowerShell on Windows you can do this:

 use File::Which qw( which );
 use Shell::Guess;

 my $path = do {
   my $is_power = Shell::Guess->running_shell->is_power;
   local $File::Which::IMPLICIT_CURRENT_DIR = !$is_power;
   which 'foo';
 };

For a variety of reasons it is difficult to accurately compute the
shell that a user is using, but L<Shell::Guess> makes a reasonable
effort.

=head1 CAVEATS

This module has no non-core requirements for Perl 5.6.2 and better.

This module is fully supported back to Perl 5.8.1.  It may work on 5.8.0.
It should work on Perl 5.6.x and I may even test on 5.6.2.  I will accept
patches to maintain compatibility for such older Perls, but you may
need to fix it on 5.6.x / 5.8.0 and send me a patch.

Not tested on VMS although there is platform specific code
for those. Anyone who haves a second would be very kind to send me a
report of how it went.

=head1 SUPPORT

Bugs should be reported via the GitHub issue tracker

L<https://github.com/plicease/File-Which/issues>

For other issues, contact the maintainer.

=head1 SEE ALSO

=over 4

=item L<pwhich>, L<App::pwhich>

Command line interface to this module.

=item L<IPC::Cmd>

This module provides (among other things) a C<can_run> function, which is
similar to C<which>.  It is a much heavier module since it does a lot more,
and if you use C<can_run> it pulls in L<ExtUtils::MakeMaker>.  This combination
may be overkill for applications which do not need L<IPC::Cmd>'s complicated
interface for running programs, or do not need the memory overhead required
for installing Perl modules.

At least some older versions will find executables in the current directory,
even if the current directory is not in the search path (which is the default
on modern Unix).

C<can_run> converts directory path name to the 8.3 version on Windows using
C<Win32::GetShortPathName> in some cases.  This is frequently useful for tools
that just need to run something using C<system> in scalar mode, but may be
inconvenient for tools like L<App::pwhich> where user readability is a premium.
Relying on C<Win32::GetShortPathName> to produce filenames without spaces
is problematic, as 8.3 filenames can be turned off with tweaks to the
registry (see L<https://technet.microsoft.com/en-us/library/cc959352.aspx>).

=item L<Devel::CheckBin>

This module purports to "check that a command is available", but does not
provide any documentation on how you might use it.

=back

=head1 AUTHORS

=over 4

=item *

Per Einar Ellefsen <pereinar@cpan.org>

=item *

Adam Kennedy <adamk@cpan.org>

=item *

Graham Ollis <plicease@cpan.org>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2002 by Per Einar Ellefsen <pereinar@cpan.org>.

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

=cut
PK       ! 6�0|	  |	    perl5/WWW/Mechanize/Link.pmnu ��6�$        package WWW::Mechanize::Link;

use strict;
use warnings;

our $VERSION = '2.02';

#ABSTRACT: Link object for WWW::Mechanize


sub new {
    my $class = shift;

    my $self;

    # The order of the first four must stay as they are for
    # compatibility with older code.
    if ( ref $_[0] eq 'HASH' ) {
        $self = [ @{$_[0]}{ qw( url text name tag base attrs ) } ];
    }
    else {
        $self = [ @_ ];
    }

    return bless $self, $class;
}


sub url   { return ($_[0])->[0]; }
sub text  { return ($_[0])->[1]; }
sub name  { return ($_[0])->[2]; }
sub tag   { return ($_[0])->[3]; }
sub base  { return ($_[0])->[4]; }
sub attrs { return ($_[0])->[5]; }


sub URI {
    my $self = shift;

    require URI::URL;
    my $URI = URI::URL->new( $self->url, $self->base );

    return $URI;
}


sub url_abs {
    my $self = shift;

    return $self->URI->abs;
}


1;

__END__

=pod

=encoding UTF-8

=head1 NAME

WWW::Mechanize::Link - Link object for WWW::Mechanize

=head1 VERSION

version 2.02

=head1 SYNOPSIS

Link object to encapsulate all the stuff that Mech needs but nobody
wants to deal with as an array.

=head1 Constructor

=head2 new()

    my $link = WWW::Mechanize::Link->new( {
        url  => $url,
        text => $text,
        name => $name,
        tag  => $tag,
        base => $base,
        attr => $attr_href,
    } );

For compatibility, this older interface is also supported:

 new( $url, $text, $name, $tag, $base, $attr_href )

Creates and returns a new C<WWW::Mechanize::Link> object.

=head1 Accessors

=head2 $link->url()

URL from the link

=head2 $link->text()

Text of the link

=head2 $link->name()

NAME attribute from the source tag, if any.

=head2 $link->tag()

Tag name (one of: "a", "area", "frame", "iframe" or "meta").

=head2 $link->base()

Base URL to which the links are relative.

=head2 $link->attrs()

Returns hash ref of all the attributes and attribute values in the tag.

=head2 $link->URI()

Returns the URL as a L<URI::URL> object.

=head2 $link->url_abs()

Returns a L<URI::URL> object for the absolute form of the string.

=head1 SEE ALSO

L<WWW::Mechanize> and L<WWW::Mechanize::Image>

=head1 AUTHOR

Andy Lester <andy at petdance.com>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2004 by Andy Lester.

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

=cut
PK       ! � "��@  �@    perl5/WWW/Mechanize/FAQ.podnu ��6�$        # PODNAME: WWW::Mechanize::FAQ
# ABSTRACT: Frequently Asked Questions about WWW::Mechanize

__END__

=pod

=encoding UTF-8

=head1 NAME

WWW::Mechanize::FAQ - Frequently Asked Questions about WWW::Mechanize

=head1 VERSION

version 2.02

=head1 How to get help with WWW::Mechanize

If your question isn't answered here in the FAQ, please turn to the
communities at:

=over

=item * StackOverflow L<https://stackoverflow.com/questions/tagged/www-mechanize>

=item * #lwp on irc.perl.org

=item * L<http://perlmonks.org>

=item * The libwww-perl mailing list at L<http://lists.perl.org>

=back

=head1 JavaScript

=head2 I have this web page that has JavaScript on it, and my Mech program doesn't work.

That's because WWW::Mechanize doesn't operate on the JavaScript.  It only
understands the HTML parts of the page.

=head2 I thought Mech was supposed to work like a web browser.

It does pretty much, but it doesn't support JavaScript.

I added some basic attempts at picking up URLs in C<window.open()>
calls and return them in C<< $mech->links >>.  They work sometimes.

Since Javascript is completely visible to the client, it cannot be used
to prevent a scraper from following links. But it can make life difficult. If
you want to scrape specific pages, then a solution is always possible.

One typical use of Javascript is to perform argument checking before
posting to the server. The URL you want is probably just buried in the
Javascript function. Do a regular expression match on
C<< $mech->content() >>
to find the link that you want and C<< $mech->get >> it directly (this
assumes that you know what you are looking for in advance).

In more difficult cases, the Javascript is used for URL mangling to
satisfy the needs of some middleware. In this case you need to figure
out what the Javascript is doing (why are these URLs always really
long?). There is probably some function with one or more arguments which
calculates the new URL. Step one: using your favorite browser, get the
before and after URLs and save them to files. Edit each file, converting
the argument separators ('?', '&' or ';') into newlines. Now it is
easy to use diff or comm to find out what Javascript did to the URL.
Step 2 - find the function call which created the URL - you will need
to parse and interpret its argument list. The Javascript Debugger in the
Firebug extension for Firefox helps with the analysis. At this point, it is
fairly trivial to write your own function which emulates the Javascript
for the pages you want to process.

Here's another approach that answers the question, "It works in Firefox,
but why not Mech?"  Everything the web server knows about the client is
present in the HTTP request. If two requests are identical, the results
should be identical. So the real question is "What is different between
the mech request and the Firefox request?"

The Firefox extension "Tamper Data" is an effective tool for examining
the headers of the requests to the server. Compare that with what LWP
is sending. Once the two are identical, the action of the server should
be the same as well.

I say "should", because this is an oversimplification - some values
are naturally unique, e.g. a SessionID, but if a SessionID is present,
that is probably sufficient, even though the value will be different
between the LWP request and the Firefox request. The server could use
the session to store information which is troublesome, but that's not
the first place to look (and highly unlikely to be relevant when you
are requesting the login page of your site).

Generally the problem is to be found in missing or incorrect POSTDATA
arguments, Cookies, User-Agents, Accepts, etc. If you are using mech,
then redirects and cookies should not be a problem, but are listed here
for completeness. If you are missing headers, C<< $mech->add_header >>
can be used to add the headers that you need.

=head2 Which modules work like Mechanize and have JavaScript support?

In no particular order: L<Gtk2::WebKit::Mechanize>, L<Win32::IE::Mechanize>,
L<WWW::Mechanize::Firefox>, L<WWW::Scripter>, L<WWW::Selenium>

=head1 How do I do X?

=head2 Can I do [such-and-such] with WWW::Mechanize?

If it's possible with LWP::UserAgent, then yes.  WWW::Mechanize is
a subclass of L<LWP::UserAgent>, so all the wondrous magic of that
class is inherited.

=head2 How do I use WWW::Mechanize through a proxy server?

See the docs in L<LWP::UserAgent> on how to use the proxy.  Short version:

    $mech->proxy(['http', 'ftp'], 'http://proxy.example.com:8000/');

or get the specs from the environment:

    $mech->env_proxy();

    # Environment set like so:
    gopher_proxy=http://proxy.my.place/
    wais_proxy=http://proxy.my.place/
    no_proxy="localhost,my.domain"
    export gopher_proxy wais_proxy no_proxy

=head2 How can I see what fields are on the forms?

Use the mech-dump utility, optionally installed with Mechanize.

    $ mech-dump --forms http://search.cpan.org
    Dumping forms
    GET http://search.cpan.org/search
      query=
      mode=all                        (option)  [*all|module|dist|author]
      <NONAME>=CPAN Search            (submit)

=head2 How do I get Mech to handle authentication?

    use MIME::Base64;

    my $agent = WWW::Mechanize->new();
    my @args = (
        Authorization => "Basic " .
            MIME::Base64::encode( USER . ':' . PASS )
    );

    $agent->credentials( ADDRESS, REALM, USER, PASS );
    $agent->get( URL, @args );

If you want to use the credentials for all future requests, you can
also use the L<LWP::UserAgent> C<default_header()> method instead
of the extra arguments to C<get()>

    $mech->default_header(
        Authorization => 'Basic ' . encode_base64( USER . ':' . PASSWORD ) );

=head2 How can I get WWW::Mechanize to execute this JavaScript?

You can't.  JavaScript is entirely client-based, and WWW::Mechanize
is a client that doesn't understand JavaScript.  See the top part
of this FAQ.

=head2 How do I check a checkbox that doesn't have a value defined?

Set it to the value of "on".

    $mech->field( my_checkbox => 'on' );

=head2 How do I handle frames?

You don't deal with them as frames, per se, but as links.  Extract
them with

    my @frame_links = $mech->find_link( tag => "frame" );

=head2 How do I get a list of HTTP headers and their values?

All L<HTTP::Headers> methods work on a L<HTTP::Response> object which is
returned by the I<get()>, I<reload()>, I<response()/res()>, I<click()>,
I<submit_form()>, and I<request()> methods.

    my $mech = WWW::Mechanize->new( autocheck => 1 );
    $mech->get( 'http://my.site.com' );
    my $response = $mech->response();
    for my $key ( $response->header_field_names() ) {
        print $key, " : ", $response->header( $key ), "\n";
    }

=head2 How do I enable keep-alive?

Since L<WWW::Mechanize> is a subclass of L<LWP::UserAgent>, you can
use the same mechanism to enable keep-alive:

    use LWP::ConnCache;
    ...
    $mech->conn_cache(LWP::ConnCache->new);

=head2 How can I change/specify the action parameter of an HTML form?

You can access the action of the form by utilizing the L<HTML::Form>
object returned from one of the specifying form methods.

Using C<< $mech->form_number($number) >>:

    my $mech = WWW::mechanize->new;
    $mech->get('http://someurlhere.com');
    # Access the form using its Zero-Based Index by DOM order
    $mech->form_number(0)->action('http://newAction'); #ABS URL

Using C<< $mech->form_name($number) >>:

    my $mech = WWW::mechanize->new;
    $mech->get('http://someurlhere.com');
    #Access the form using its Zero-Based Index by DOM order
    $mech->form_name('trgForm')->action('http://newAction'); #ABS URL

=head2 How do I save an image?  How do I save a large tarball?

An image is just content.  You get the image and save it.

    $mech->get( 'photo.jpg' );
    $mech->save_content( '/path/to/my/directory/photo.jpg' );

You can also save any content directly to disk using the C<:content_file>
flag to C<get()>, which is part of L<LWP::UserAgent>.

    $mech->get( 'http://www.cpan.org/src/stable.tar.gz',
                ':content_file' => 'stable.tar.gz' );

=head2 How do I pick a specific value from a C<< <select> >> list?

Find the C<HTML::Form::ListInput> in the page.

    my ($listbox) = $mech->find_all_inputs( name => 'listbox' );

Then create a hash for the lookup:

    my %name_lookup;
    @name_lookup{ $listbox->value_names } = $listbox->possible_values;
    my $value = $name_lookup{ 'Name I want' };

If you have duplicate names, this method won't work, and you'll
have to loop over C<< $listbox->value_names >> and
C<< $listbox->possible_values >> in parallel until you find a
matching name.

=head2 How do I get Mech to not follow redirects?

You use functionality in LWP::UserAgent, not Mech itself.

    $mech->requests_redirectable( [] );

Or you can set C<max_redirect>:

    $mech->max_redirect( 0 );

Both these options can also be set in the constructor.  Mech doesn't
understand them, so will pass them through to the LWP::UserAgent
constructor.

=head1 Why doesn't this work: Debugging your Mechanize program

=head2 My Mech program doesn't work, but it works in the browser.

Mechanize acts like a browser, but apparently something you're doing
is not matching the browser's behavior.  Maybe it's expecting a
certain web client, or maybe you've not handling a field properly.
For some reason, your Mech problem isn't doing exactly what the
browser is doing, and when you find that, you'll have the answer.

=head2 My Mech program gets these 500 errors.

A 500 error from the web server says that the program on the server
side died.  Probably the web server program was expecting certain
inputs that you didn't supply, and instead of handling it nicely,
the program died.

Whatever the cause of the 500 error, if it works in the browser,
but not in your Mech program, you're not acting like the browser.
See the previous question.

=head2 Why doesn't my program handle this form correctly?

Run F<mech-dump> on your page and see what it says.

F<mech-dump> is a marvelous diagnostic tool for figuring out what forms
and fields are on the page.  Say you're scraping CNN.com, you'd get this:

    $ mech-dump http://www.cnn.com/
    GET http://search.cnn.com/cnn/search
      source=cnn                     (hidden readonly)
      invocationType=search/top      (hidden readonly)
      sites=web                      (radio)    [*web/The Web ??|cnn/CNN.com ??]
      query=                         (text)
      <NONAME>=Search                (submit)

    POST http://cgi.money.cnn.com/servlets/quote_redirect
      query=                         (text)
      <NONAME>=GET                   (submit)

    POST http://polls.cnn.com/poll
      poll_id=2112                   (hidden readonly)
      question_1=<UNDEF>             (radio)    [1/Simplistic option|2/VIEW RESULTS]
      <NONAME>=VOTE                  (submit)

    GET http://search.cnn.com/cnn/search
      source=cnn                     (hidden readonly)
      invocationType=search/bottom   (hidden readonly)
      sites=web                      (radio)    [*web/??CNN.com|cnn/??]
      query=                         (text)
      <NONAME>=Search                (submit)

Four forms, including the first one duplicated at the end.  All the
fields, all their defaults, lovingly generated by HTML::Form's C<dump>
method.

If you want to run F<mech-dump> on something that doesn't lend itself
to a quick URL fetch, then use the C<save_content()> method to write
the HTML to a file, and run F<mech-dump> on the file.

=head2 Why don't https:// URLs work?

You need either L<IO::Socket::SSL> or L<Crypt::SSLeay> installed.

=head2 Why do I get "Input 'fieldname' is readonly"?

You're trying to change the value of a hidden field and you have
warnings on.

First, make sure that you actually mean to change the field that you're
changing, and that you don't have a typo.  Usually, hidden variables are
set by the site you're working on for a reason.  If you change the value,
you might be breaking some functionality by faking it out.

If you really do want to change a hidden value, make the changes in a
scope that has warnings turned off:

    {
    local $^W = 0;
    $agent->field( name => $value );
    }

=head2 I tried to [such-and-such] and I got this weird error.

Are you checking your errors?

Are you sure?

Are you checking that your action succeeded after every action?

Are you sure?

For example, if you try this:

    $mech->get( "http://my.site.com" );
    $mech->follow_link( "foo" );

and the C<get> call fails for some reason, then the Mech internals
will be unusable for the C<follow_link> and you'll get a weird
error.  You B<must>, after every action that GETs or POSTs a page,
check that Mech succeeded, or all bets are off.

    $mech->get( "http://my.site.com" );
    die "Can't even get the home page: ", $mech->response->status_line
        unless $mech->success;

    $mech->follow_link( "foo" );
    die "Foo link failed: ", $mech->response->status_line
        unless $mech->success;

=head2 How do I figure out why C<< $mech->get($url) >> doesn't work?

There are many reasons why a C<< get() >> can fail. The server can take
you to someplace you didn't expect. It can generate redirects which are
not properly handled. You can get time-outs. Servers are down more often
than you think! etc, etc, etc. A couple of places to start:

=over 4

=item 1 Check C<< $mech->status() >> after each call

=item 2 Check the URL with C<< $mech->uri() >> to see where you ended up

=item 3 Try debugging with C<< LWP::ConsoleLogger >>.

=back

If things are really strange, turn on debugging with
C<< use LWP::ConsoleLogger::Everywhere; >>
Just put this in the main program. This causes LWP to print out a trace
of the HTTP traffic between client and server and can be used to figure
out what is happening at the protocol level.

It is also useful to set many traps to verify that processing is
proceeding as expected. A Mech program should always have an "I didn't
expect to get here" or "I don't recognize the page that I am processing"
case and bail out.

Since errors can be transient, by the time you notice that the error
has occurred, it might not be possible to reproduce it manually. So
for automated processing it is useful to email yourself the following
information:

=over 4

=item * where processing is taking place

=item * An Error Message

=item * $mech->uri

=item * $mech->content

=back

You can also save the content of the page with C<< $mech->save_content( 'filename.html' ); >>

=head2 I submitted a form, but the server ignored everything!  I got an empty form back!

The post is handled by application software. It is common for PHP
programmers to use the same file both to display a form and to process
the arguments returned. So the first task of the application programmer
is to decide whether there are arguments to processes. The program can
check whether a particular parameter has been set, whether a hidden
parameter has been set, or whether the submit button has been clicked.
(There are probably other ways that I haven't thought of).

In any case, if your form is not setting the parameter (e.g. the submit
button) which the web application is keying on (and as an outsider there
is no way to know what it is keying on), it will not notice that the form
has been submitted. Try using C<< $mech->click() >> instead of
C<< $mech->submit() >> or vice-versa.

=head2 I've logged in to the server, but I get 500 errors when I try to get to protected content.

Some web sites use distributed databases for their processing. It
can take a few seconds for the login/session information to percolate
through to all the servers. For human users with their slow reaction
times, this is not a problem, but a Perl script can outrun the server.
So try adding a C<sleep(5)> between logging in and actually doing anything
(the optimal delay must be determined experimentally).

=head2 Mech is a big memory pig!  I'm running out of RAM!

Mech keeps a history of every page, and the state it was in.  It actually
keeps a clone of the full Mech object at every step along the way.

You can limit this stack size with the C<stack_depth> param in the C<new()>
constructor.  If you set stack_size to 0, Mech will not keep any history.

=head1 AUTHOR

Andy Lester <andy at petdance.com>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2004 by Andy Lester.

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

=cut
PK       ! z��$  $    perl5/WWW/Mechanize/Image.pmnu ��6�$        package WWW::Mechanize::Image;

use strict;
use warnings;

our $VERSION = '2.02';

#ABSTRACT: Image object for WWW::Mechanize


sub new {
    my $class = shift;
    my $params = shift || {};

    my $self = bless {}, $class;

    for my $param ( qw( url base tag height width alt name attrs ) ) {
        # Check for what we passed in, not whether it's defined
        $self->{$param} = $params->{$param} if exists $params->{$param};
    }

    # url and tag are always required
    for ( qw( url tag ) ) {
        exists $self->{$_} or die "WWW::Mechanize::Image->new must have a $_ argument";
    }

    return $self;
}


sub url     { return ($_[0])->{url}; }
sub base    { return ($_[0])->{base}; }
sub name    { return ($_[0])->{name}; }
sub tag     { return ($_[0])->{tag}; }
sub height  { return ($_[0])->{height}; }
sub width   { return ($_[0])->{width}; }
sub alt     { return ($_[0])->{alt}; }
sub attrs   { return ($_[0])->{attrs}; }


sub URI {
    my $self = shift;

    require URI::URL;
    my $URI = URI::URL->new( $self->url, $self->base );

    return $URI;
}


sub url_abs {
    my $self = shift;

    return $self->URI->abs;
}


1;

__END__

=pod

=encoding UTF-8

=head1 NAME

WWW::Mechanize::Image - Image object for WWW::Mechanize

=head1 VERSION

version 2.02

=head1 SYNOPSIS

Image object to encapsulate all the stuff that Mech needs

=head1 Constructor

=head2 new()

Creates and returns a new C<WWW::Mechanize::Image> object.

    my $image = WWW::Mechanize::Image->new( {
        url    => $url,
        base   => $base,
        tag    => $tag,
        name   => $name,     # From the INPUT tag
        height => $height,   # optional
        width  => $width,    # optional
        alt    => $alt,      # optional
        attrs  => $attr_ref, # optional
    } );

=head1 Accessors

=head2 $image->url()

Image URL from the C<src> attribute of the source tag.

May be C<undef> if source tag has no C<src> attribute.

=head2 $image->base()

Base URL to which the links are relative.

=head2 $image->name()

Name for the field from the NAME attribute, if any.

=head2 $image->tag()

Tag name (either "image" or "input")

=head2 $image->height()

Image height

=head2 $image->width()

Image width

=head2 $image->alt()

ALT attribute from the source tag, if any.

=head2 $image->attrs()

Hash ref of all the attributes and attribute values in the tag.

=head2 $image->URI()

Returns the URL as a L<URI::URL> object.

=head2 $image->url_abs()

Returns the URL as an absolute URL string.

=head1 SEE ALSO

L<WWW::Mechanize> and L<WWW::Mechanize::Link>

=head1 AUTHOR

Andy Lester <andy at petdance.com>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2004 by Andy Lester.

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

=cut
PK       ! �}q_
  
     perl5/WWW/Mechanize/Cookbook.podnu ��6�$        # PODNAME: WWW::Mechanize::Cookbook
# ABSTRACT: Recipes for using WWW::Mechanize

__END__

=pod

=encoding UTF-8

=head1 NAME

WWW::Mechanize::Cookbook - Recipes for using WWW::Mechanize

=head1 VERSION

version 2.02

=head1 INTRODUCTION

First, please note that many of these are possible just using
L<LWP::UserAgent>.  Since C<WWW::Mechanize> is a subclass of
L<LWP::UserAgent>, whatever works on C<LWP::UserAgent> should work
on C<WWW::Mechanize>.  See the L<lwpcook> man page included with
the L<libwww-perl> distribution.

=head1 BASICS

=head2 Launch the WWW::Mechanize browser

    use WWW::Mechanize;

    my $mech = WWW::Mechanize->new( autocheck => 1 );

The C<< autocheck => 1 >> tells Mechanize to die if any IO fails,
so you don't have to manually check.  It's easier that way.  If you
want to do your own error checking, leave it out.

=head2 Fetch a page

    $mech->get( "http://search.cpan.org" );
    print $mech->content;

C<< $mech->content >> contains the raw HTML from the web page.  It
is not parsed or handled in any way, at least through the C<content>
method.

=head2 Fetch a page into a file

Sometimes you want to dump your results directly into a file.  For
example, there's no reason to read a JPEG into memory if you're
only going to write it out immediately.  This can also help with
memory issues on large files.

    $mech->get( "http://www.cpan.org/src/stable.tar.gz",
                ":content_file" => "stable.tar.gz" );

=head2 Fetch a password-protected page

Generally, just call C<credentials> before fetching the page.

    $mech->credentials( 'admin' => 'password' );
    $mech->get( 'http://10.11.12.13/password.html' );
    print $mech->content();

=head1 LINKS

=head2 Find all image links

Find all links that point to a JPEG, GIF or PNG.

    my @links = $mech->find_all_links(
        tag => "a", url_regex => qr/\.(jpe?g|gif|png)$/i );

=head2 Find all download links

Find all links that have the word "download" in them.

    my @links = $mech->find_all_links(
        tag => "a", text_regex => qr/\bdownload\b/i );

=head1 ADVANCED

=head2 See what will be sent without actually sending anything

    $mech->add_handler("request_send", sub { shift->dump; exit; });
    $mech->get("http://www.example.com");

=head1 SEE ALSO

L<WWW::Mechanize>

=head1 AUTHOR

Andy Lester <andy at petdance.com>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2004 by Andy Lester.

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

=cut
PK       ! �ܳ-@  @     perl5/WWW/Mechanize/Examples.podnu ��6�$        # PODNAME: WWW::Mechanize::Examples
# ABSTRACT: Sample programs that use WWW::Mechanize

__END__

=pod

=encoding UTF-8

=head1 NAME

WWW::Mechanize::Examples - Sample programs that use WWW::Mechanize

=head1 VERSION

version 2.02

=head1 SYNOPSIS

Plenty of people have learned WWW::Mechanize, and now, you can too!

Following are user-supplied samples of WWW::Mechanize in action.
If you have samples you'd like to contribute, please send 'em to
C<< <andy@petdance.com> >>.

You can also look at the F<t/*.t> files in the distribution.

Please note that these examples are not intended to do any specific task.
For all I know, they're no longer functional because the sites they
hit have changed.  They're here to give examples of how people have
used WWW::Mechanize.

Note that the examples are in reverse order of my having received them,
so the freshest examples are always at the top.

=head2 Starbucks Density Calculator, by Nat Torkington

Here's a pair of programs from Nat Torkington, editor for O'Reilly Media
and co-author of the I<Perl Cookbook>.

=over 4

Rael [Dornfest] discovered that you can easily find out how many Starbucks
there are in an area by searching for "Starbucks".  So I wrote a silly
scraper for some old census data and came up with some Starbucks density
figures.  There's no meaning to these numbers thanks to errors from using
old census data coupled with false positives in Yahoo search (e.g.,
"Dodie Starbuck-Your Style Desgn" in Portland OR).  But it was fun to
waste a night on.

Here are the top twenty cities in descending order of population,
with the amount of territory each Starbucks has.  E.g., A New York NY
Starbucks covers 1.7 square miles of ground.

    New York, NY        1.7
    Los Angeles, CA     1.2
    Chicago, IL         1.0
    Houston, TX         4.6
    Philadelphia, PA    6.8
    San Diego, CA       2.7
    Detroit, MI        19.9
    Dallas, TX          2.7
    Phoenix, AZ         4.1
    San Antonio, TX    12.3
    San Jose, CA        1.1
    Baltimore, MD       3.9
    Indianapolis, IN   12.1
    San Francisco, CA   0.5
    Jacksonville, FL   39.9
    Columbus, OH        7.3
    Milwaukee, WI       5.1
    Memphis, TN        15.1
    Washington, DC      1.4
    Boston, MA          0.5

=back

C<get_pop_data>

    #!/usr/bin/perl -w

    use WWW::Mechanize;
    use Storable;

    $url = 'http://www.census.gov/population/www/documentation/twps0027.html';
    $m = WWW::Mechanize->new();
    $m->get($url);

    $c = $m->content;

    $c =~ m{<A NAME=.tabA.>(.*?)</TABLE>}s
      or die "Can't find the population table\n";
    $t = $1;
    @outer = $t =~ m{<TR.*?>(.*?)</TR>}gs;
    shift @outer;
    foreach $r (@outer) {
      @bits = $r =~ m{<TD.*?>(.*?)</TD>}gs;
      for ($x = 0; $x < @bits; $x++) {
        $b = $bits[$x];
        @v = split /\s*<BR>\s*/, $b;
        foreach (@v) { s/^\s+//; s/\s+$// }
        push @{$data[$x]}, @v;
      }
    }

    for ($y = 0; $y < @{$data[0]}; $y++) {
        $data{$data[1][$y]} = {
            NAME => $data[1][$y],
            RANK => $data[0][$y],
            POP  => comma_free($data[2][$y]),
            AREA => comma_free($data[3][$y]),
            DENS => comma_free($data[4][$y]),
        };
    }

    store(\%data, "cities.dat");

    sub comma_free {
      my $n = shift;
      $n =~ s/,//;
      return $n;
    }

C<plague_of_coffee>

    #!/usr/bin/perl -w

    use WWW::Mechanize;
    use strict;
    use Storable;

    $SIG{__WARN__} = sub {} ;  # ssssssh

    my $Cities = retrieve("cities.dat");

    my $m = WWW::Mechanize->new();
    $m->get("http://local.yahoo.com/");

    my @cities = sort { $Cities->{$a}{RANK} <=> $Cities->{$b}{RANK} } keys %$Cities;
    foreach my $c ( @cities ) {
      my $fields = {
        'stx' => "starbucks",
        'csz' => $c,
      };

      my $r = $m->submit_form(form_number => 2,
                              fields => $fields);
      die "Couldn't submit form" unless $r->is_success;

      my $hits = number_of_hits($r);
      #  my $ppl  = sprintf("%d", 1000 * $Cities->{$c}{POP} / $hits);
      #  print "$c has $hits Starbucks.  That's one for every $ppl people.\n";
      my $density = sprintf("%.1f", $Cities->{$c}{AREA} / $hits);
      print "$c : $density\n";
    }

    sub number_of_hits {
      my $r = shift;
      my $c = $r->content;
      if ($c =~ m{\d+ out of <b>(\d+)</b> total results for}) {
        return $1;
      }
      if ($c =~ m{Sorry, no .*? found in or near}) {
        return 0;
      }
      if ($c =~ m{Your search matched multiple cities}) {
        warn "Your search matched multiple cities\n";
        return 0;
      }
      if ($c =~ m{Sorry we couldn.t find that location}) {
        warn "No cities\n";
        return 0;
      }
      if ($c =~ m{Could not find.*?, showing results for}) {
        warn "No matches\n";
        return 0;
      }
      die "Unknown response\n$c\n";
    }

=head2 pb-upload, by John Beppu

This program takes filenames of images from the command line and
uploads them to a www.photobucket.com folder.  John Beppu, the author, says:

=over 4

I had 92 pictures I wanted to upload, and doing it through a browser
would've been torture.  But thanks to mech, all I had to do was
`./pb.upload *.jpg` and watch it do its thing.  It felt good.
If I had more time, I'd implement WWW::Photobucket on top of
WWW::Mechanize.

=back

    #!/usr/bin/perl -w -T

    use strict;
    use WWW::Mechanize;

    my $login    = "login_name";
    my $password = "password";
    my $folder   = "folder";

    my $url = "http://img78.photobucket.com/albums/v281/$login/$folder/";

    # login to your photobucket.com account
    my $mech = WWW::Mechanize->new();
    $mech->get($url);
    $mech->submit_form(
        form_number => 1,
        fields      => { password => $password },
    );
    die unless ($mech->success);

    # upload image files specified on command line
    foreach (@ARGV) {
        print "$_\n";
        $mech->form_number(2);
        $mech->field('the_file[]' => $_);
        $mech->submit();
    }

=head2 listmod, by Ian Langworth

Ian Langworth contributes this little gem that will bring joy to
beleaguered mailing list admins.  It discards spam messages through
mailman's web interface.

    #!/arch/unix/bin/perl
    use strict;
    use warnings;
    #
    # listmod - fast alternative to mailman list interface
    #
    # usage: listmod crew XXXXXXXX
    #

    die "usage: $0 <listname> <password>\n" unless @ARGV == 2;
    my ($listname, $password) = @ARGV;

    use CGI qw(unescape);

    use WWW::Mechanize;
    my $m = WWW::Mechanize->new( autocheck => 1 );

    use Term::ReadLine;
    my $term = Term::ReadLine->new($0);

    # submit the form, get the cookie, go to the list admin page
    $m->get("https://lists.ccs.neu.edu/bin/admindb/$listname");
    $m->set_visible( $password );
    $m->click;

    # exit if nothing to do
    print "There are no pending requests.\n" and exit
        if $m->content =~ /There are no pending requests/;

    # select the first form and examine its contents
    $m->form_number(1);
    my $f = $m->current_form or die "Couldn't get first form!\n";

    # get me the base form element for each email item
    my @items = map {m/^.+?-(.+)/} grep {m/senderbanp/} $f->param
        or die "Couldn't get items in first form!\n";

    # iterate through items, prompt user, commit actions
    foreach my $item (@items) {

        # show item info
        my $sender = unescape($item);
        my ($subject) = [$f->find_input("senderbanp-$item")->value_names]->[1]
            =~ /Subject:\s+(.+?)\s+Size:/g;

        # prompt user
        my $choice = '';
        while ( $choice !~ /^[DAX]$/ ) {
            print "$sender\: '$subject'\n";
            $choice = uc $term->readline("Action: defer/accept/discard [dax]: ");
            print "\n\n";
        }

        # set button
        $m->field("senderaction-$item" => {D=>0,A=>1,X=>3}->{$choice});
    }

    # submit actions
    $m->click;

=head2 ccdl, by Andy Lester

Steve McConnell, author of the landmark I<Code Complete> has put
up the chapters for the 2nd edition in PDF format on his website.
I needed to download them to take to Kinko's to have printed.  This
little program did it for me.

    #!/usr/bin/perl -w

    use strict;
    use WWW::Mechanize;

    my $start = "http://www.stevemcconnell.com/cc2/cc.htm";

    my $mech = WWW::Mechanize->new( autocheck => 1 );
    $mech->get( $start );

    my @links = $mech->find_all_links( url_regex => qr/\d+.+\.pdf$/ );

    for my $link ( @links ) {
        my $url = $link->url_abs;
        my $filename = $url;
        $filename =~ s[^.+/][];

        print "Fetching $url";
        $mech->get( $url, ':content_file' => $filename );

        print "   ", -s $filename, " bytes\n";
    }

=head2 quotes.pl, by Andy Lester

This was a program that was going to get a hack in I<Spidering Hacks>,
but got cut at the last minute, probably because it's against IMDB's TOS
to scrape from it.  I present it here as an example, not a suggestion
that you break their TOS.

Last I checked, it didn't work because their HTML didn't match, but it's
still good as sample code.

    #!/usr/bin/perl -w

    use strict;

    use WWW::Mechanize;
    use Getopt::Long;
    use Text::Wrap;

    my $match = undef;
    my $random = undef;
    GetOptions(
        "match=s" => \$match,
        "random" => \$random,
    ) or exit 1;

    my $movie = shift @ARGV or die "Must specify a movie\n";

    my $quotes_page = get_quotes_page( $movie );
    my @quotes = extract_quotes( $quotes_page );

    if ( $match ) {
        $match = quotemeta($match);
        @quotes = grep /$match/i, @quotes;
    }

    if ( $random ) {
        print $quotes[rand @quotes];
    }
    else {
        print join( "\n", @quotes );
    }


    sub get_quotes_page {
        my $movie = shift;

        my $mech = WWW::Mechanize->new;
        $mech->get( "http://www.imdb.com/search" );
        $mech->success or die "Can't get the search page";

        $mech->submit_form(
            form_number => 2,
            fields => {
                title	=> $movie,
                restrict    => "Movies only",
            },
        );

        my @links = $mech->find_all_links( url_regex => qr[^/Title] )
            or die "No matches for \"$movie\" were found.\n";

        # Use the first link
        my ( $url, $title ) = @{$links[0]};

        warn "Checking $title...\n";

        $mech->get( $url );
        my $link = $mech->find_link( text_regex => qr/Memorable Quotes/i )
            or die qq{"$title" has no quotes in IMDB!\n};

        warn "Fetching quotes...\n\n";
        $mech->get( $link->[0] );

        return $mech->content;
    }


    sub extract_quotes {
        my $page = shift;

        # Nibble away at the unwanted HTML at the beginnning...
        $page =~ s/.+Memorable Quotes//si;
        $page =~ s/.+?(<a name)/$1/si;

        # ... and the end of the page
        $page =~ s/Browse titles in the movie quotes.+$//si;
        $page =~ s/<p.+$//g;

        # Quotes separated by an <HR> tag
        my @quotes = split( /<hr.+?>/, $page );

        for my $quote ( @quotes ) {
            my @lines = split( /<br>/, $quote );
            for ( @lines ) {
                s/<[^>]+>//g;   # Strip HTML tags
                s/\s+/ /g;	    # Squash whitespace
                s/^ //;	    # Strip leading space
                s/ $//;	    # Strip trailing space
                s/&#34;/"/g;    # Replace HTML entity quotes

                # Word-wrap to fit in 72 columns
                $Text::Wrap::columns = 72;
                $_ = wrap( '', '    ', $_ );
            }
            $quote = join( "\n", @lines );
        }

        return @quotes;
    }

=head2 cpansearch.pl, by Ed Silva

A quick little utility to search the CPAN and fire up a browser
with a results page.

    #!/usr/bin/perl

    # turn on perl's safety features
    use strict;
    use warnings;

    # work out the name of the module we're looking for
    my $module_name = $ARGV[0]
      or die "Must specify module name on command line";

    # create a new browser
    use WWW::Mechanize;
    my $browser = WWW::Mechanize->new();

    # tell it to get the main page
    $browser->get("http://search.cpan.org/");

    # okay, fill in the box with the name of the
    # module we want to look up
    $browser->form_number(1);
    $browser->field("query", $module_name);
    $browser->click();

    # click on the link that matches the module name
    $browser->follow_link( text_regex => $module_name );

    my $url = $browser->uri;

    # launch a browser...
    system('galeon', $url);

    exit(0);

=head2 lj_friends.cgi, by Matt Cashner

    #!/usr/bin/perl

    # Provides an rss feed of a paid user's LiveJournal friends list
    # Full entries, protected entries, etc.
    # Add to your favorite rss reader as
    # http://your.site.com/cgi-bin/lj_friends.cgi?user=USER&password=PASSWORD

    use warnings;
    use strict;

    use WWW::Mechanize;
    use CGI;

    my $cgi = CGI->new();
    my $form = $cgi->Vars;

    my $agent = WWW::Mechanize->new();

    $agent->get('http://www.livejournal.com/login.bml');
    $agent->form_number('3');
    $agent->field('user',$form->{user});
    $agent->field('password',$form->{password});
    $agent->submit();
    $agent->get('http://www.livejournal.com/customview.cgi?user='.$form->{user}.'&styleid=225596&checkcookies=1');
    print "Content-type: text/plain\n\n";
    print $agent->content();

=head2 Hacking Movable Type, by Dan Rinzel

    use strict;
    use WWW::Mechanize;

    # a tool to automatically post entries to a moveable type weblog, and set arbitrary creation dates

    my $mech = WWW::Mechanize->new();
    my $entry;
    $entry->{title} = "Test AutoEntry Title";
    $entry->{btext} = "Test AutoEntry Body";
    $entry->{date} = '2002-04-15 14:18:00';
    my $start = qq|http://my.blog.site/mt.cgi|;

    $mech->get($start);
    $mech->field('username','und3f1n3d');
    $mech->field('password','obscur3d');
    $mech->submit(); # to get login cookie
    $mech->get(qq|$start?__mode=view&_type=entry&blog_id=1|);
    $mech->form_name('entry_form');
    $mech->field('title',$entry->{title});
    $mech->field('category_id',1); # adjust as needed
    $mech->field('text',$entry->{btext});
    $mech->field('status',2); # publish, or 1 = draft
    $results = $mech->submit();

    # if we're ok with this entry being datestamped "NOW" (no {date} in %entry)
    # we're done. Otherwise, time to be tricksy
    # MT returns a 302 redirect from this form. the redirect itself contains a <body onload=""> handler
    # which takes the user to an editable version of the form where the create date can be edited
    # MT date format of YYYY-MM-DD HH:MI:SS is the only one that won't error out

    if ($entry->{date} && $entry->{date} =~ /^\d{4}-\d{2}-\d{2}\s+\d{2}:\d{2}:\d{2}/) {
        # travel the redirect
        $results = $mech->get($results->{_headers}->{location});
        $results->{_content} =~ /<body onLoad="([^\"]+)"/is;
        my $js = $1;
        $js =~ /\'([^']+)\'/;
        $results = $mech->get($start.$1);
        $mech->form_name('entry_form');
        $mech->field('created_on_manual',$entry->{date});
        $mech->submit();
    }

=head2 get-despair, by Randal Schwartz

Randal submitted this bot that walks the despair.com site sucking down
all the pictures.

    use strict;
    $|++;

    use WWW::Mechanize;
    use File::Basename;

    my $m = WWW::Mechanize->new;

    $m->get("http://www.despair.com/indem.html");

    my @top_links = @{$m->links};

    for my $top_link_num (0..$#top_links) {
        next unless $top_links[$top_link_num][0] =~ /^http:/;

        $m->follow_link( n=>$top_link_num ) or die "can't follow $top_link_num";

        print $m->uri, "\n";
        for my $image (grep m{^http://store4}, map $_->[0], @{$m->links}) {
            my $local = basename $image;
            print " $image...", $m->mirror($image, $local)->message, "\n"
        }

        $m->back or die "can't go back";
    }

=head1 AUTHOR

Andy Lester <andy at petdance.com>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2004 by Andy Lester.

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

=cut
PK       !  ��� ��   perl5/WWW/Mechanize.pmnu ��6�$        package WWW::Mechanize;

#ABSTRACT: Handy web browsing in a Perl object


use strict;
use warnings;

our $VERSION = '2.02';

use Tie::RefHash;
use HTTP::Request 1.30;
use LWP::UserAgent 6.45;
use HTML::Form 1.00;
use HTML::TokeParser;
use Scalar::Util qw(tainted);

use base 'LWP::UserAgent';

our $HAS_ZLIB;
BEGIN {
    $HAS_ZLIB = eval 'use Compress::Zlib (); 1;';
}


sub new {
    my $class = shift;

    my %parent_params = (
        agent       => "WWW-Mechanize/$VERSION",
        cookie_jar  => {},
    );

    my %mech_params = (
        autocheck       => ($class eq 'WWW::Mechanize' ? 1 : 0),
        onwarn          => \&WWW::Mechanize::_warn,
        onerror         => \&WWW::Mechanize::_die,
        quiet           => 0,
        stack_depth     => 8675309,     # Arbitrarily humongous stack
        headers         => {},
        noproxy         => 0,
        strict_forms    => 0,           # pass-through to HTML::Form
        verbose_forms   => 0,           # pass-through to HTML::Form
        marked_sections => 1,
    );

    my %passed_params = @_;

    # Keep the mech-specific params before creating the object.
    while ( my($key,$value) = each %passed_params ) {
        if ( exists $mech_params{$key} ) {
            $mech_params{$key} = $value;
        }
        else {
            $parent_params{$key} = $value;
        }
    }

    my $self = $class->SUPER::new( %parent_params );
    bless $self, $class;

    # Use the mech params now that we have a mech object.
    for my $param ( keys %mech_params ) {
        $self->{$param} = $mech_params{$param};
    }
    $self->{page_stack} = [];
    $self->env_proxy() unless $mech_params{noproxy};

    # libwww-perl 5.800 (and before, I assume) has a problem where
    # $ua->{proxy} can be undef and clone() doesn't handle it.
    $self->{proxy} = {} unless defined $self->{proxy};
    push( @{$self->requests_redirectable}, 'POST' );

    $self->_reset_page();

    return $self;
}

# overriding LWP::UA's static method
sub _agent { "WWW-Mechanize/$VERSION" }


my %known_agents = (
    'Windows IE 6'      => 'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)',
    'Windows Mozilla'   => 'Mozilla/5.0 (Windows; U; Windows NT 5.0; en-US; rv:1.4b) Gecko/20030516 Mozilla Firebird/0.6',
    'Mac Safari'        => 'Mozilla/5.0 (Macintosh; U; PPC Mac OS X; en-us) AppleWebKit/85 (KHTML, like Gecko) Safari/85',
    'Mac Mozilla'       => 'Mozilla/5.0 (Macintosh; U; PPC Mac OS X Mach-O; en-US; rv:1.4a) Gecko/20030401',
    'Linux Mozilla'     => 'Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.4) Gecko/20030624',
    'Linux Konqueror'   => 'Mozilla/5.0 (compatible; Konqueror/3; Linux)',
);

sub agent_alias {
    my $self = shift;
    my $alias = shift;

    if ( defined $known_agents{$alias} ) {
        return $self->agent( $known_agents{$alias} );
    }
    else {
        $self->warn( qq{Unknown agent alias "$alias"} );
        return $self->agent();
    }
}


sub known_agent_aliases {
    return sort keys %known_agents;
}


sub get {
    my $self = shift;
    my $uri = shift;

    $uri = $uri->url if ref($uri) eq 'WWW::Mechanize::Link';

    $uri = $self->base
            ? URI->new_abs( $uri, $self->base )
            : URI->new( $uri );

    # It appears we are returning a super-class method,
    # but it in turn calls the request() method here in Mechanize
    return $self->SUPER::get( $uri->as_string, @_ );
}


sub post {
    my $self = shift;
    my $uri = shift;

    $uri = $uri->url if ref($uri) eq 'WWW::Mechanize::Link';

    $uri = $self->base
            ? URI->new_abs( $uri, $self->base )
            : URI->new( $uri );

    # It appears we are returning a super-class method,
    # but it in turn calls the request() method here in Mechanize
    return $self->SUPER::post( $uri->as_string, @_ );
}


sub put {
    my $self = shift;
    my $uri = shift;

    $uri = $uri->url if ref($uri) eq 'WWW::Mechanize::Link';

    $uri = $self->base
            ? URI->new_abs( $uri, $self->base )
            : URI->new( $uri );

    # It appears we are returning a super-class method,
    # but it in turn calls the request() method here in Mechanize
    return $self->_SUPER_put( $uri->as_string, @_ );
}


# Added until LWP::UserAgent has it.
sub _SUPER_put {
    require HTTP::Request::Common;
    my($self, @parameters) = @_;
    my @suff = $self->_process_colonic_headers(\@parameters,1);
    return $self->request( HTTP::Request::Common::PUT( @parameters ), @suff );
}


sub reload {
    my $self = shift;

    return unless my $req = $self->{req};

    # LWP::UserAgent sets up a request_prepare handler that calls
    # $self->cookie_jar->add_cookie_header($req)
    #
    # HTTP::Cookies::add_cookie_header always preserves existing
    # cookies in a request object
    #
    # we pass an existing request to _make_request
    #
    # result: cookies will get repeated every time someone calls
    # ->reload, sooner or later leading to a "request too big" from
    # the server
    #
    # until https://rt.cpan.org/Public/Bug/Display.html?id=75897 is
    # fixed, let's clear the cookies from the existing request
    $req->remove_header('Cookie');

    return $self->_update_page( $req, $self->_make_request( $req, @_ ) );
}


sub back {
    my $self = shift;

    my $stack = $self->{page_stack};
    return unless $stack && @{$stack};

    my $popped = pop @{$self->{page_stack}};
    my $req    = $popped->{req};
    my $res    = $popped->{res};

    $self->_update_page( $req, $res );

    return 1;
}


sub clear_history {
    my $self = shift;

    delete $self->{page_stack};

    return 1;
}


sub history_count {
    my $self = shift;

    # If we don't have a "current" page, we certainly don't have any previous
    # ones.
    return 0 unless $self->{req} && $self->{res};

    my $stack = $self->{page_stack};

    return 1 unless $stack;

    return 1 + @$stack;
}


sub history {
    my $self = shift;
    my $n    = shift;

    return undef unless $self->{req} && $self->{res};

    if ($n == 0) {
      return { req => $self->{req}, res => $self->{res} };
    }

    my $stack = $self->{page_stack};
    return undef unless $stack && @$stack >= $n;

    return { req => $stack->[-$n]{req}, res => $stack->[-$n]{res} };
}


sub success {
    my $self = shift;

    return $self->res && $self->res->is_success;
}


sub uri {
    my $self = shift;
    return $self->response ? $self->response->request->uri : undef;
}

sub res {           my $self = shift; return $self->{res}; }
sub response {      my $self = shift; return $self->{res}; }
sub status {        my $self = shift; return $self->{status}; }
sub ct {            my $self = shift; return $self->{ct}; }
sub content_type {  my $self = shift; return $self->{ct}; }
sub base {          my $self = shift; return $self->{base}; }
sub is_html {
    my $self = shift;
    return defined $self->ct &&
        ($self->ct eq 'text/html' || $self->ct eq 'application/xhtml+xml');
}


sub title {
    my $self = shift;

    return unless $self->is_html;

    if ( not defined $self->{title} ) {
        require HTML::HeadParser;
        my $p = HTML::HeadParser->new;
        $p->parse($self->content);
        $self->{title} = $p->header('Title');
    }
    return $self->{title};
}


sub redirects {
    my $self = shift;

    return $self->response->redirects;
}


sub content {
    my $self = shift;
    my %params = @_;

    my $content = $self->{content};
    if (delete $params{raw}) {
        $content = $self->response()->content();
    }
    elsif (delete $params{decoded_by_headers}) {
        $content = $self->response()->decoded_content(charset => 'none');
    }
    elsif (my $charset = delete $params{charset}) {
        $content = $self->response()->decoded_content(charset => $charset);
    }
    elsif ( $self->is_html ) {
        if ( exists $params{base_href} ) {
            my $base_href = (delete $params{base_href}) || $self->base;
            $content=~s/<head>/<head>\n<base href="$base_href">/i;
        }

        if ( my $format = delete $params{format} ) {
            if ( $format eq 'text' ) {
                $content = $self->text;
            }
            else {
                $self->die( qq{Unknown "format" parameter "$format"} );
            }
        }

        $self->_check_unhandled_params( %params );
    }

    return $content;
}


sub text {
    my $self = shift;

    if ( not defined $self->{text} ) {
        unless ( exists $INC{'HTML::TreeBuilder'} ) {
            require HTML::TreeBuilder;
            HTML::TreeBuilder->VERSION(5);
            HTML::TreeBuilder->import('-weak');
        }
        my $tree = HTML::TreeBuilder->new();
        $tree->parse( $self->content );
        $tree->eof();
        $tree->elementify(); # just for safety
        $self->{text} = $tree->as_text();
    }

    return $self->{text};
}

sub _check_unhandled_params {
    my $self  = shift;
    my %params = @_;

    for my $cmd ( sort keys %params ) {
        $self->die( qq{Unknown named argument "$cmd"} );
    }
}


sub links {
    my $self = shift;

    $self->_extract_links() unless $self->{links};

    return @{$self->{links}} if wantarray;
    return $self->{links};
}


sub follow_link {
    my $self = shift;
    $self->die( qq{Needs to get key-value pairs of parameters.} ) if @_ % 2;
    my %params = ( n=>1, @_ );

    if ( $params{n} eq 'all' ) {
        delete $params{n};
        $self->warn( q{follow_link(n=>"all") is not valid} );
    }

    my $link = $self->find_link(%params);
    if ( $link ) {
        return $self->get( $link->url );
    }

    if ( $self->{autocheck} ) {
        $self->die( 'Link not found' );
    }

    return;
}


sub find_link {
    my $self = shift;
    my %params = ( n=>1, @_ );

    my $wantall = ( $params{n} eq 'all' );

    $self->_clean_keys( \%params, qr/^(n|(text|url|url_abs|name|tag|id|class|rel)(_regex)?)$/ );

    my @links = $self->links or return;

    my $nmatches = 0;
    my @matches;
    for my $link ( @links ) {
        if ( _match_any_link_params($link,\%params) ) {
            if ( $wantall ) {
                push( @matches, $link );
            }
            else {
                ++$nmatches;
                return $link if $nmatches >= $params{n};
            }
        }
    } # for @links

    if ( $wantall ) {
        return @matches if wantarray;
        return \@matches;
    }

    return;
} # find_link

# Used by find_links to check for matches
# The logic is such that ALL param criteria that are given must match
sub _match_any_link_params {
    my $link = shift;
    my $p = shift;

    # No conditions, anything matches
    return 1 unless keys %$p;

    return if defined $p->{url}           && !($link->url eq $p->{url} );
    return if defined $p->{url_regex}     && !($link->url =~ $p->{url_regex} );
    return if defined $p->{url_abs}       && !($link->url_abs eq $p->{url_abs} );
    return if defined $p->{url_abs_regex} && !($link->url_abs =~ $p->{url_abs_regex} );
    return if defined $p->{text}          && !(defined($link->text) && $link->text eq $p->{text} );
    return if defined $p->{text_regex}    && !(defined($link->text) && $link->text =~ $p->{text_regex} );
    return if defined $p->{name}          && !(defined($link->name) && $link->name eq $p->{name} );
    return if defined $p->{name_regex}    && !(defined($link->name) && $link->name =~ $p->{name_regex} );
    return if defined $p->{tag}           && !($link->tag && $link->tag eq $p->{tag} );
    return if defined $p->{tag_regex}     && !($link->tag && $link->tag =~ $p->{tag_regex} );

    return if defined $p->{id}            && !($link->attrs->{id} && $link->attrs->{id} eq $p->{id} );
    return if defined $p->{id_regex}      && !($link->attrs->{id} && $link->attrs->{id} =~ $p->{id_regex} );
    return if defined $p->{class}         && !($link->attrs->{class} && $link->attrs->{class} eq $p->{class} );
    return if defined $p->{class_regex}   && !($link->attrs->{class} && $link->attrs->{class} =~ $p->{class_regex} );

    return if defined $p->{rel}         && !($link->attrs->{rel} && $link->attrs->{rel} eq $p->{rel} );
    return if defined $p->{rel_regex}   && !($link->attrs->{rel} && $link->attrs->{rel} =~ $p->{rel_regex} );

    # Success: everything that was defined passed.
    return 1;

}

# Cleans the %params parameter for the find_link and find_image methods.
sub _clean_keys {
    my $self = shift;
    my $params = shift;
    my $rx_keyname = shift;

    for my $key ( keys %$params ) {
        my $val = $params->{$key};
        if ( $key !~ qr/$rx_keyname/ ) {
            $self->warn( qq{Unknown link-finding parameter "$key"} );
            delete $params->{$key};
            next;
        }

        my $key_regex = ( $key =~ /_regex$/ );
        my $val_regex = ( ref($val) eq 'Regexp' );

        if ( $key_regex ) {
            if ( !$val_regex ) {
                $self->warn( qq{$val passed as $key is not a regex} );
                delete $params->{$key};
                next;
            }
        }
        else {
            if ( $val_regex ) {
                $self->warn( qq{$val passed as '$key' is a regex} );
                delete $params->{$key};
                next;
            }
            if ( $val =~ /^\s|\s$/ ) {
                $self->warn( qq{'$val' is space-padded and cannot succeed} );
                delete $params->{$key};
                next;
            }
        }
    } # for keys %params

    return;
} # _clean_keys()


sub find_all_links {
    my $self = shift;
    return $self->find_link( @_, n=>'all' );
}


sub find_all_inputs {
    my $self = shift;
    my %criteria = @_;

    my $form = $self->current_form() or return;

    my @found;
    foreach my $input ( $form->inputs ) { # check every pattern for a match on the current hash
        my $matched = 1;
        foreach my $criterion ( sort keys %criteria ) { # Sort so we're deterministic
            my $field = $criterion;
            my $is_regex = ( $field =~ s/(?:_regex)$// );
            my $what = $input->{$field};
            $matched = defined($what) && (
                $is_regex
                    ? ( $what =~ $criteria{$criterion} )
                    : ( $what eq $criteria{$criterion} )
                );
            last if !$matched;
        }
        push @found, $input if $matched;
    }
    return @found;
}


sub find_all_submits {
    my $self = shift;

    return $self->find_all_inputs( @_, type_regex => qr/^(submit|image)$/ );
}


sub images {
    my $self = shift;

    $self->_extract_images() unless $self->{images};

    return @{$self->{images}} if wantarray;
    return $self->{images};
}


sub find_image {
    my $self = shift;
    my %params = ( n=>1, @_ );

    my $wantall = ( $params{n} eq 'all' );

    $self->_clean_keys( \%params, qr/^(?:n|(?:alt|url|url_abs|tag|id|class)(?:_regex)?)$/ );

    my @images = $self->images or return;

    my $nmatches = 0;
    my @matches;
    for my $image ( @images ) {
        if ( _match_any_image_params($image,\%params) ) {
            if ( $wantall ) {
                push( @matches, $image );
            }
            else {
                ++$nmatches;
                return $image if $nmatches >= $params{n};
            }
        }
    } # for @images

    if ( $wantall ) {
        return @matches if wantarray;
        return \@matches;
    }

    return;
}

# Used by find_images to check for matches
# The logic is such that ALL param criteria that are given must match
sub _match_any_image_params {
    my $image = shift;
    my $p = shift;

    # No conditions, anything matches
    return 1 unless keys %$p;

    return if defined $p->{url}           && !(defined($image->url) && $image->url eq $p->{url} );
    return if defined $p->{url_regex}     && !(defined($image->url) && $image->url =~ $p->{url_regex} );
    return if defined $p->{url_abs}       && !(defined($image->url_abs) && $image->url_abs eq $p->{url_abs} );
    return if defined $p->{url_abs_regex} && !(defined($image->url_abs) && $image->url_abs =~ $p->{url_abs_regex} );
    return if defined $p->{alt}           && !(defined($image->alt) && $image->alt eq $p->{alt} );
    return if defined $p->{alt_regex}     && !(defined($image->alt) && $image->alt =~ $p->{alt_regex} );
    return if defined $p->{tag}           && !($image->tag && $image->tag eq $p->{tag} );
    return if defined $p->{tag_regex}     && !($image->tag && $image->tag =~ $p->{tag_regex} );
    return if defined $p->{id}            && !($image->attrs && $image->attrs->{id} && $image->attrs->{id} eq $p->{id} );
    return if defined $p->{id_regex}      && !($image->attrs && $image->attrs->{id} && $image->attrs->{id} =~ $p->{id_regex} );
    return if defined $p->{class}         && !($image->attrs && $image->attrs->{class} && $image->attrs->{class} eq $p->{class} );
    return if defined $p->{class_regex}   && !($image->attrs && $image->attrs->{class} && $image->attrs->{class} =~ $p->{class_regex} );

    # Success: everything that was defined passed.
    return 1;
}


sub find_all_images {
    my $self = shift;
    return $self->find_image( @_, n=>'all' );
}


sub forms {
    my $self = shift;

    $self->_extract_forms() unless $self->{forms};

    return @{$self->{forms}} if wantarray;
    return $self->{forms};
}

sub current_form {
    my $self = shift;

    if ( !$self->{current_form} ) {
        $self->form_number(1);
    }

    return $self->{current_form};
}


sub form_number {
    my ($self, $form) = @_;
    # XXX Should we die if no $form is defined? Same question for form_name()

    my $forms = $self->forms;
    if ( $forms->[$form-1] ) {
        $self->{current_form} = $forms->[$form-1];
        return wantarray
          ? ($self->{current_form}, $form)
          : $self->{current_form};
    }

    return wantarray ? () : undef;
}


sub form_name {
    my ($self, $form) = @_;
    return $self->form_with( name => $form );
}


sub form_id {
    my ($self, $formid) = @_;
    defined( my $form = $self->form_with( id => $formid ) )
      or $self->warn(qq{ There is no form with ID "$formid"});
    return $form;
}


sub all_forms_with_fields {
    my ($self, @fields) = @_;
    die 'no fields provided' unless scalar @fields;

    my @matches;
    FORMS: for my $form (@{ $self->forms }) {
        my @fields_in_form = $form->param();
        for my $field (@fields) {
            next FORMS unless grep { $_ eq $field } @fields_in_form;
        }
        push @matches, $form;
    }
    return @matches;
}


sub form_with_fields {
    my ($self, @fields) = @_;
    die 'no fields provided' unless scalar @fields;

    my @matches = $self->all_forms_with_fields(@fields);
    my $nmatches = @matches;
    if ( $nmatches > 0 ) {
        if ( $nmatches > 1 ) {
            $self->warn( "There are $nmatches forms with the named fields.  The first one was used." )
        }
        return $self->{current_form} = $matches[0];
    }
    else {
        $self->warn( qq{There is no form with the requested fields} );
        return undef;
    }
}


sub all_forms_with {
    my ( $self, %spec ) = @_;

    my @forms = $self->forms;
    foreach my $attr ( keys %spec ) {
        @forms = grep _equal( $spec{$attr}, $_->attr($attr) ), @forms or return;
    }
    return @forms;
}


sub form_with {
    my ( $self, %spec ) = @_;

    return if not $self->forms;
    my @forms = $self->all_forms_with(%spec);
    if ( @forms > 1 ) {    # Warn if several forms matched.
        # For ->form_with( method => 'POST', action => '', id => undef ) we get:
        # >>There are 2 forms with empty action and no id and method "POST".
        # The first one was used.<<

        $self->warn(
            'There are ' . @forms . ' forms ' . (
                keys %spec    # explain search criteria if there were any
                ? 'with ' . join(
                    ' and ',    # "with ... and ... and ..."
                    map {
                        unless ( defined $spec{$_} ) {    # case $attr => undef
                            qq{no $_};
                        }
                        elsif ( $spec{$_} eq '' ) {       # case $attr=> ''
                            qq{empty $_};
                        }
                        else {                            # case $attr => $value
                            qq{$_ "$spec{$_}"};
                        }
                      }                # case $attr => undef
                      sort keys %spec  # sort keys to get deterministic messages
                  )
                : ''
              )
              . '.  The first one was used.'
        );
    }

    return $self->{current_form} = $forms[0];
}

# NOT an object method!
# Expects two values and returns true only when either
# both are defined and eq(ual) or when both are not defined.
sub _equal {
    my ( $x, $y ) = @_;
    defined $x ? defined $y && $x eq $y : !defined $y;
}


sub field {
    my ($self, $name, $value, $number) = @_;
    $number ||= 1;

    my $form = $self->current_form();
    if ($number > 1) {
        $form->find_input($name, undef, $number)->value($value);
    }
    else {
        if ( ref($value) eq 'ARRAY' ) {
            $form->param($name, $value);
        }
        else {
            $form->value($name => $value);
        }
    }
}


sub select {
    my ($self, $name, $value) = @_;

    my $form = $self->current_form();

    my $input = $form->find_input($name);
    if (!$input) {
        $self->warn( qq{Input "$name" not found} );
        return;
    }

    if ($input->type ne 'option') {
        $self->warn( qq{Input "$name" is not type "select"} );
        return;
    }

    # For $mech->select($name, {n => 3}) or $mech->select($name, {n => [2,4]}),
    # transform the 'n' number(s) into value(s) and put it in $value.
    if (ref($value) eq 'HASH') {
        for (keys %$value) {
            $self->warn(qq{Unknown select value parameter "$_"})
              unless $_ eq 'n';
        }

        if (defined($value->{n})) {
            my @inputs = $form->find_input($name, 'option');
            my @values = ();
            # distinguish between multiple and non-multiple selects
            # (see INPUTS section of `perldoc HTML::Form`)
            if (@inputs == 1) {
                @values = $inputs[0]->possible_values();
            }
            else {
                foreach my $input (@inputs) {
                    my @possible = $input->possible_values();
                    push @values, pop @possible;
                }
            }

            my $n = $value->{n};
            if (ref($n) eq 'ARRAY') {
                $value = [];
                for (@$n) {
                    unless (/^\d+$/) {
                        $self->warn(qq{"n" value "$_" is not a positive integer});
                        return;
                    }
                    push @$value, $values[$_ - 1];  # might be undef
                }
            }
            elsif (!ref($n) && $n =~ /^\d+$/) {
                $value = $values[$n - 1];           # might be undef
            }
            else {
                $self->warn('"n" value is not a positive integer or an array ref');
                return;
            }
        }
        else {
            $self->warn('Hash value is invalid');
            return;
        }
    } # hashref

    if (ref($value) eq 'ARRAY') {
        $form->param($name, $value);
        return 1;
    }

    $form->value($name => $value);
    return 1;
}


sub set_fields {
    my $self = shift;
    my %fields = @_;

    my $form = $self->current_form or $self->die( 'No form defined' );

    while ( my ( $field, $value ) = each %fields ) {
        if ( ref $value eq 'ARRAY' ) {
            $form->find_input( $field, undef,
                         $value->[1])->value($value->[0] );
        }
        else {
            $form->value($field => $value);
        }
    } # while
} # set_fields()


sub set_visible {
    my $self = shift;

    my $form = $self->current_form;
    my @inputs = $form->inputs;

    my $num_set = 0;
    for my $value ( @_ ) {
        # Handle type/value pairs an arrayref
        if ( ref $value eq 'ARRAY' ) {
            my ( $type, $value ) = @$value;
            while ( my $input = shift @inputs ) {
                next if $input->type eq 'hidden';
                if ( $input->type eq $type ) {
                    $input->value( $value );
                    $num_set++;
                    last;
                }
            } # while
        }
        # by default, it's a value
        else {
            while ( my $input = shift @inputs ) {
                next if $input->type eq 'hidden';
                $input->value( $value );
                $num_set++;
                last;
            } # while
        }
    } # for

    return $num_set;
} # set_visible()


sub tick {
    my $self = shift;
    my $name = shift;
    my $value = shift;
    my $set = @_ ? shift : 1;  # default to 1 if not passed

    # loop though all the inputs
    my $index = 1;
    while ( my $input = $self->current_form->find_input( $name, 'checkbox', $index ) ) {
        # Can't guarantee that the first element will be undef and the second
        # element will be the right name
        foreach my $val ($input->possible_values()) {
            next unless defined $val;
            if ($val eq $value) {
                $input->value($set ? $value : undef);
                return;
            }
        }

        # move onto the next input
        $index++;
    } # while

    # got this far?  Didn't find anything
    $self->die( qq{No checkbox "$name" for value "$value" in form} );
} # tick()


sub untick {
    shift->tick(shift,shift,undef);
}


sub value {
    my $self = shift;
    my $name = shift;
    my $number = shift || 1;

    my $form = $self->current_form;
    if ( $number > 1 ) {
        return $form->find_input( $name, undef, $number )->value();
    }
    else {
        return $form->value( $name );
    }
} # value


sub click {
    my ($self, $button, $x, $y) = @_;
    for ($x, $y) { $_ = 1 unless defined; }
    my $request = $self->current_form->click($button, $x, $y);
    return $self->request( $request );
}


sub click_button {
    my $self = shift;
    my %args = @_;

    for ( keys %args ) {
        if ( !/^(number|name|value|id|input|x|y)$/ ) {
            $self->warn( qq{Unknown click_button parameter "$_"} );
        }
    }

    for ($args{x}, $args{y}) {
        $_ = 1 unless defined;
    }

    my $form = $self->current_form or $self->die( 'click_button: No form has been selected' );

    my $request;
    if ( $args{name} ) {
        $request = $form->click( $args{name}, $args{x}, $args{y} );
    }
    # 0 is a valid id in HTML5
    elsif ( defined $args{id} ) {
        # HTML::Form expects ids to be prefixed with '#'
        my $input = $form->find_input('#' . $args{id});
        $request = $input->click( $form, $args{x}, $args{y} );
    }
    elsif ( $args{number} ) {
        # changing this 'submit' to qw/submit button image/ will probably break people's code
        my $input = $form->find_input( undef, 'submit', $args{number} );
        $request = $input->click( $form, $args{x}, $args{y} );
    }
    elsif ( $args{input} ) {
        $request = $args{input}->click( $form, $args{x}, $args{y} );
    }
    elsif ( $args{value} ) {
        my @inputs = map { $form->find_input(undef, $_) } qw/submit button image/;
        foreach  my $input ( @inputs ) {
            if ( $input->value && ($args{value} eq $input->value) ) {
                $request = $input->click( $form, $args{x}, $args{y} );
                last;
            }
        } # foreach
    } # $args{value}

    return $self->request( $request );
}


sub submit {
    my $self = shift;

    my $request = $self->current_form->make_request;
    return $self->request( $request );
}


sub submit_form {
    my( $self, %args ) = @_;

    for ( keys %args ) {
        if ( !/^(form_(number|name|fields|id)|(with_)?fields|button|x|y|strict_forms)$/ ) {
            $self->die( qq{Unknown submit_form parameter "$_"} );
        }
    }

    my $fields;
    for (qw/with_fields fields/) {
        if ($args{$_}) {
            if ( ref $args{$_} eq 'HASH' ) {
                $fields = $args{$_};
            }
            else {
                $self->die("$_ arg to submit_form must be a hashref");
            }
            last;
        }
    }

    my @filtered_sets;
    if ( $args{with_fields} ) {
        $fields || die q{must submit some 'fields' with with_fields};
        my @got = $self->all_forms_with_fields(keys %{$fields});
        $self->die("There is no form with the requested fields") if not @got;
        push @filtered_sets, \@got;
    }
    if ( my $form_number = $args{form_number} ) {
        my $got = $self->form_number( $form_number );
        $self->die("There is no form numbered $form_number") if not $got;
        push @filtered_sets, [ $got ];
    }
    if ( my $form_name = $args{form_name} ) {
        my @got = $self->all_forms_with( name => $form_name );
        $self->die(qq{There is no form named "$form_name"}) if not @got;
        push @filtered_sets, \@got;
    }
    if ( my $form_id = $args{form_id} ) {
        my @got = $self->all_forms_with( id => $form_id );
        $self->die(qq{There is no form with ID "$form_id"}) if not @got;
        push @filtered_sets, \@got;
    }

    if (not @filtered_sets) {
        # No form selector was used.
        # Maybe a form was set separately, or we'll default to the first form.
    }
    else {
        # Need to intersect to apply all the various filters.
        # Assume that each filtered set only has a given form object once.
        # So we can count occurrences.
        #
        tie my %c, 'Tie::RefHash' or die;
        foreach (@filtered_sets) {
            foreach (@$_) {
                ++$c{$_};
            }
        }
        my $expected_count = scalar @filtered_sets;
        my @matched = grep { $c{$_} == $expected_count } keys %c;
        if (not @matched) {
            $self->die('There is no form that satisfies all the criteria');
        }
        if (@matched > 1) {
            $self->die('More than one form satisfies all the criteria');
        }
        $self->{current_form} = $matched[0];
    }

    if (defined($args{strict_forms})) {
        # Strict argument has been passed, set the flag as appropriate
        # this must be done prior to attempting to set the fields
        $self->current_form->strict($args{strict_forms});
    }

    $self->set_fields( %{$fields} ) if $fields;

    my $response;
    if ( $args{button} ) {
        $response = $self->click( $args{button}, $args{x} || 0, $args{y} || 0 );
    }
    else {
        $response = $self->submit();
    }

    return $response;
}


sub add_header {
    my $self = shift;
    my $npairs = 0;

    while ( @_ ) {
        my $key = shift;
        my $value = shift;
        ++$npairs;

        $self->{headers}{$key} = $value;
    }

    return $npairs;
}


sub delete_header {
    my $self = shift;

    while ( @_ ) {
        my $key = shift;

        delete $self->{headers}{$key};
    }

    return;
}


sub quiet {
    my $self = shift;

    $self->{quiet} = $_[0] if @_;

    return $self->{quiet};
}


sub stack_depth {
    my $self = shift;
    $self->{stack_depth} = shift if @_;
    return $self->{stack_depth};
}


sub save_content {
    my $self = shift;
    my $filename = shift;
    my %opts = @_;
    if (delete $opts{binary}) {
        $opts{binmode} = ':raw';
        $opts{decoded_by_headers} = 1;
    }

    open( my $fh, '>', $filename ) or $self->die( "Unable to create $filename: $!" );
    if ((my $binmode = delete($opts{binmode}) || '') || ($self->content_type() !~ m{^text/})) {
        if (length($binmode) && (substr($binmode, 0, 1) eq ':')) {
            binmode $fh, $binmode;
        }
        else {
            binmode $fh;
        }
    }
    print {$fh} $self->content(%opts) or $self->die( "Unable to write to $filename: $!" );
    close $fh or $self->die( "Unable to close $filename: $!" );

    return;
}


sub _get_fh_default_stdout {
    my $self = shift;
    my $p = shift || '';
    if ( !$p ) {
        return \*STDOUT;
    } elsif ( !ref($p) ) {
        open my $fh, '>', $p or $self->die( "Unable to write to $p: $!" );;
        return $fh;
    } else {
        return $p;
    }
}

sub dump_headers {
    my $self = shift;
    my $fh   = $self->_get_fh_default_stdout(shift);

    print {$fh} $self->response->headers_as_string;

    return;
}


sub dump_links {
    my $self = shift;
    my $fh = shift || \*STDOUT;
    my $absolute = shift;

    for my $link ( $self->links ) {
        my $url = $absolute ? $link->url_abs : $link->url;
        $url = '' if not defined $url;
        print {$fh} $url, "\n";
    }
    return;
}


sub dump_images {
    my $self = shift;
    my $fh = shift || \*STDOUT;
    my $absolute = shift;

    for my $image ( $self->images ) {
        my $url = $absolute ? $image->url_abs : $image->url;
        $url = '' if not defined $url;
        print {$fh} $url, "\n";
    }
    return;
}


sub dump_forms {
    my $self = shift;
    my $fh = shift || \*STDOUT;

    for my $form ( $self->forms ) {
        print {$fh} $form->dump, "\n";
    }
    return;
}


sub dump_text {
    my $self = shift;
    my $fh = shift || \*STDOUT;
    my $absolute = shift;

    print {$fh} $self->text, "\n";

    return;
}


sub clone {
    my $self  = shift;
    my $clone = $self->SUPER::clone();

    $clone->cookie_jar( $self->cookie_jar );
    $clone->{headers} = { %{$self->{headers}} };

    return $clone;
}


sub redirect_ok {
    my $self = shift;
    my $prospective_request = shift;
    my $response = shift;

    my $ok = $self->SUPER::redirect_ok( $prospective_request, $response );
    if ( $ok ) {
        $self->{redirected_uri} = $prospective_request->uri;
    }

    return $ok;
}


sub request {
    my $self = shift;
    my $request = shift;

    _die( '->request was called without a request parameter' )
        unless $request;

    $request = $self->_modify_request( $request );

    if ( $request->method eq 'GET' || $request->method eq 'POST' ) {
        $self->_push_page_stack();
    }

    return $self->_update_page($request, $self->_make_request( $request, @_ ));
}


sub update_html {
    my $self = shift;
    my $html = shift;

    $self->_reset_page;
    $self->{ct} = 'text/html';
    $self->{content} = $html;

    return;
}


sub credentials {
    my $self = shift;

    # The latest LWP::UserAgent also supports 2 arguments,
    # in which case the first is host:port
    if (@_ == 4 || (@_ == 2 && $_[0] =~ /:\d+$/)) {
        return $self->SUPER::credentials(@_);
    }

    @_ == 2
        or $self->die( 'Invalid # of args for overridden credentials()' );

    return @$self{qw( __username __password )} = @_;
}


sub get_basic_credentials {
    my $self = shift;
    my @cred = grep { defined } @$self{qw( __username __password )};
    return @cred if @cred == 2;
    return $self->SUPER::get_basic_credentials(@_);
}


sub clear_credentials {
    my $self = shift;
    delete @$self{qw( __username __password )};
}


sub _update_page {
    my ($self, $request, $res) = @_;

    $self->{req} = $request;
    $self->{redirected_uri} = $request->uri->as_string;

    $self->{res} = $res;

    $self->{status}  = $res->code;
    $self->{base}    = $res->base;
    $self->{ct}      = $res->content_type || '';

    if ( $res->is_success ) {
        $self->{uri} = $self->{redirected_uri};
        $self->{last_uri} = $self->{uri};
    }

    if ( $res->is_error ) {
        if ( $self->{autocheck} ) {
            $self->die( 'Error ', $request->method, 'ing ', $request->uri, ': ', $res->message );
        }
    }

    $self->_reset_page;

    # Try to decode the content. Undef will be returned if there's nothing to decompress.
    # See docs in HTTP::Message for details. Do we need to expose the options there?
    my $content = $res->decoded_content();
    $content = $res->content if (not defined $content);

    $content .= _taintedness();

    if ($self->is_html) {
        $self->update_html($content);
    }
    else {
        $self->{content} = $content;
    }

    return $res;
} # _update_page

our $_taintbrush;

# This is lifted wholesale from Test::Taint
sub _taintedness {
    return $_taintbrush if defined $_taintbrush;

    # Somehow we need to get some taintedness into our $_taintbrush.
    # Let's try the easy way first. Either of these should be
    # tainted, unless somebody has untainted them, so this
    # will almost always work on the first try.
    # (Unless, of course, taint checking has been turned off!)
    $_taintbrush = substr("$0$^X", 0, 0);
    return $_taintbrush if tainted( $_taintbrush );

    # Let's try again. Maybe somebody cleaned those.
    $_taintbrush = substr(join('', grep { defined } @ARGV, %ENV), 0, 0);
    return $_taintbrush if tainted( $_taintbrush );

    # If those don't work, go try to open some file from some unsafe
    # source and get data from them.  That data is tainted.
    # (Yes, even reading from /dev/null works!)
    for my $filename ( qw(/dev/null / . ..), values %INC, $0, $^X ) {
        if ( open my $fh, '<', $filename ) {
            my $data;
            if ( defined sysread $fh, $data, 1 ) {
                $_taintbrush = substr( $data, 0, 0 );
                last if tainted( $_taintbrush );
            }
        }
    }

    # Sanity check
    die "Our taintbrush should have zero length!" if length $_taintbrush;

    return $_taintbrush;
}


sub _modify_request {
    my $self = shift;
    my $req = shift;

    # add correct Accept-Encoding header to restore compliance with
    # http://www.freesoft.org/CIE/RFC/2068/158.htm
    # http://use.perl.org/~rhesa/journal/25952
    if (not $req->header( 'Accept-Encoding' ) ) {
        # "identity" means "please! unencoded content only!"
        $req->header( 'Accept-Encoding', $HAS_ZLIB ? 'gzip' : 'identity' );
    }

    my $last = $self->{last_uri};
    if ( $last ) {
        $last = $last->as_string if ref($last);
        $req->header( Referer => $last );
    }
    while ( my($key,$value) = each %{$self->{headers}} ) {
        if ( defined $value ) {
            $req->header( $key => $value );
        }
        else {
            $req->remove_header( $key );
        }
    }

    return $req;
}


sub _make_request {
    my $self = shift;
    return $self->SUPER::request(@_);
}


sub _reset_page {
    my $self = shift;

    $self->{links}        = undef;
    $self->{images}       = undef;
    $self->{forms}        = undef;
    $self->{current_form} = undef;
    $self->{title}        = undef;
    $self->{text}         = undef;

    return;
}


my %link_tags = (
    a      => 'href',
    area   => 'href',
    frame  => 'src',
    iframe => 'src',
    link   => 'href',
    meta   => 'content',
);

sub _new_parser {
    my $self = shift;
    my $content_ref = shift;

    my $parser = HTML::TokeParser->new($content_ref);
    $parser->marked_sections( $self->{marked_sections});
    $parser->xml_mode( $$content_ref=~/^\s*<\?xml/ ); # NOT GENERALLY RELIABLE

    return $parser;
}

sub _extract_links {
    my $self = shift;


    $self->{links} = [];
    if ( defined $self->{content} ) {
        my $parser = $self->_new_parser(\$self->{content});
        while ( my $token = $parser->get_tag( keys %link_tags ) ) {
            my $link = $self->_link_from_token( $token, $parser );
            push( @{$self->{links}}, $link ) if $link;
        } # while
    }

    return;
}


my %image_tags = (
    img   => 'src',
    input => 'src',
);

sub _extract_images {
    my $self = shift;

    $self->{images} = [];

    if ( defined $self->{content} ) {
        if ($self->content_type eq 'text/css') {
            push( @{$self->{images}}, $self->_images_from_css($self->{content}) );
        }
        else {
            my $parser = $self->_new_parser(\$self->{content});
            while ( my $token = $parser->get_tag() ) {
                my ($tag_name, $attrs) = @{$token};
                next if $tag_name =~ m{^/};

                if ($image_tags{$tag_name}) {
                    my $image = $self->_image_from_token( $token, $parser );
                    push( @{$self->{images}}, $image ) if $image;
                }
                elsif ($tag_name eq 'style') {
                    push( @{$self->{images}}, $self->_images_from_css($parser->get_text) );
                }

                if ($attrs->{style}) {
                    push( @{$self->{images}}, $self->_images_from_css($attrs->{style}) );
                }
            } # while
        }
    }

    return;
}

sub _image_from_token {
    my $self = shift;
    my $token = shift;
    my $parser = shift;

    my $tag = $token->[0];
    my $attrs = $token->[1];

    if ( $tag eq 'input' ) {
        my $type = $attrs->{type} or return;
        return unless $type eq 'image';
    }

    require WWW::Mechanize::Image;
    return
        WWW::Mechanize::Image->new({
            tag     => $tag,
            base    => $self->base,
            url     => $attrs->{src},
            name    => $attrs->{name},
            height  => $attrs->{height},
            width   => $attrs->{width},
            alt     => $attrs->{alt},
            attrs   => $attrs,
        });
}

my $STYLE_URL_REGEXP = qr{
    # ex. "url('/site.css')"
    (             # capture non url path of the string
        url       # url
        \s*       #
        \(        # (
        \s*       #
        (['"]?)   # opening ' or "
    )
    (             # the rest is url
        .+?       # non greedy "everything"
    )
    (
        \2        # closing ' or "
        \s*       #
        \)        # )
    )
}xmsi;

sub _images_from_css {
    my $self = shift;
    my $css  = shift;

    my @images;
    while ($css =~ m/$STYLE_URL_REGEXP/g) {
        my $url = $3;
        require WWW::Mechanize::Image;
        push(
            @images,
            WWW::Mechanize::Image->new({
                tag     => 'css',
                base    => $self->base,
                url     => $url,
                name    => undef,
                height  => undef,
                width   => undef,
                alt     => undef,
            })
        );
    }

    return @images;
}

sub _link_from_token {
    my $self = shift;
    my $token = shift;
    my $parser = shift;

    my $tag = $token->[0];
    my $attrs = $token->[1];
    my $url = $attrs->{$link_tags{$tag}};

    my $text;
    my $name;
    if ( $tag eq 'a' ) {
        $text = $parser->get_trimmed_text("/$tag");
        $text = '' unless defined $text;

        my $onClick = $attrs->{onclick};
        if ( $onClick && ($onClick =~ /^window\.open\(\s*'([^']+)'/) ) {
            $url = $1;
        }
        elsif( $url && $url =~ /^javascript\:\s*(?:void\(\s*)?window\.open\(\s*'([^']+)'/s ){
            $url = $1;
        }
    } # a

    # Of the tags we extract from, only 'AREA' has an alt tag
    # The rest should have a 'name' attribute.
    # ... but we don't do anything with that bit of wisdom now.

    $name = $attrs->{name};

    if ( $tag eq 'meta' ) {
        my $equiv = $attrs->{'http-equiv'};
        my $content = $attrs->{'content'};
        return unless $equiv && (lc $equiv eq 'refresh') && defined $content;

        if ( $content =~ /^\d+\s*;\s*url\s*=\s*(\S+)/i ) {
            $url = $1;
            $url =~ s/^"(.+)"$/$1/ or $url =~ s/^'(.+)'$/$1/;
        }
        else {
            undef $url;
        }
    } # meta

    return unless defined $url;   # probably just a name link or <AREA NOHREF...>

    require WWW::Mechanize::Link;
    return
        WWW::Mechanize::Link->new({
            url  => $url,
            text => $text,
            name => $name,
            tag  => $tag,
            base => $self->base,
            attrs => $attrs,
        });
} # _link_from_token


sub _extract_forms {
    my $self = shift;

    my @forms = HTML::Form->parse(
        $self->content,
        base    => $self->base,
        strict  => $self->{strict_forms},
        verbose => $self->{verbose_forms},
    );
    $self->{forms} = \@forms;
    for my $form ( @forms ) {
        for my $input ($form->inputs) {
             if ($input->type eq 'file') {
                 $input->value( undef );
             }
        }
    }

    return;
}


sub _push_page_stack {
    my $self = shift;

    my $req = $self->{req};
    my $res = $self->{res};

    return unless $req && $res && $self->stack_depth;

    # Don't push anything if it's a virgin object
    my $stack = $self->{page_stack} ||= [];
    if ( @{$stack} >= $self->stack_depth ) {
        shift @{$stack};
    }
    push( @{$stack}, { req => $req, res => $res } );

    return 1;
}


sub warn {
    my $self = shift;

    return unless my $handler = $self->{onwarn};

    return if $self->quiet;

    return $handler->(@_);
}


sub die {
    my $self = shift;

    return unless my $handler = $self->{onerror};

    return $handler->(@_);
}


# NOT an object method!
sub _warn {
    require Carp;
    return &Carp::carp; ## no critic
}

# NOT an object method!
sub _die {
    require Carp;
    return &Carp::croak; ## no critic
}

1; # End of module

__END__

=pod

=encoding UTF-8

=head1 NAME

WWW::Mechanize - Handy web browsing in a Perl object

=head1 VERSION

version 2.02

=head1 SYNOPSIS

WWW::Mechanize supports performing a sequence of page fetches including
following links and submitting forms. Each fetched page is parsed
and its links and forms are extracted. A link or a form can be
selected, form fields can be filled and the next page can be fetched.
Mech also stores a history of the URLs you've visited, which can
be queried and revisited.

    use WWW::Mechanize ();
    my $mech = WWW::Mechanize->new();

    $mech->get( $url );

    $mech->follow_link( n => 3 );
    $mech->follow_link( text_regex => qr/download this/i );
    $mech->follow_link( url => 'http://host.com/index.html' );

    $mech->submit_form(
        form_number => 3,
        fields      => {
            username    => 'mungo',
            password    => 'lost-and-alone',
        }
    );

    $mech->submit_form(
        form_name => 'search',
        fields    => { query  => 'pot of gold', },
        button    => 'Search Now'
    );

    # Enable strict form processing to catch typos and non-existant form fields.
    my $strict_mech = WWW::Mechanize->new( strict_forms => 1);

    $strict_mech->get( $url );

    # This method call will die, saving you lots of time looking for the bug.
    $strict_mech->submit_form(
        form_number => 3,
        fields      => {
            usernaem     => 'mungo',           # typo in field name
            password     => 'lost-and-alone',
            extra_field  => 123,               # field does not exist
        }
    );

=head1 DESCRIPTION

C<WWW::Mechanize>, or Mech for short, is a Perl module for stateful
programmatic web browsing, used for automating interaction with
websites.

Features include:

=over 4

=item * All HTTP methods

=item * High-level hyperlink and HTML form support, without having to parse HTML yourself

=item * SSL support

=item * Automatic cookies

=item * Custom HTTP headers

=item * Automatic handling of redirections

=item * Proxies

=item * HTTP authentication

=back

Mech is well suited for use in testing web applications.  If you use
one of the Test::*, like L<Test::HTML::Lint> modules, you can check the
fetched content and use that as input to a test call.

    use Test::More;
    like( $mech->content(), qr/$expected/, "Got expected content" );

Each page fetch stores its URL in a history stack which you can
traverse.

    $mech->back();

If you want finer control over your page fetching, you can use
these methods. C<follow_link> and C<submit_form> are just high
level wrappers around them.

    $mech->find_link( n => $number );
    $mech->form_number( $number );
    $mech->form_name( $name );
    $mech->field( $name, $value );
    $mech->set_fields( %field_values );
    $mech->set_visible( @criteria );
    $mech->click( $button );

L<WWW::Mechanize> is a proper subclass of L<LWP::UserAgent> and
you can also use any of L<LWP::UserAgent>'s methods.

    $mech->add_header($name => $value);

Please note that Mech does NOT support JavaScript, you need additional software
for that. Please check L<WWW::Mechanize::FAQ/"JavaScript"> for more.

=head1 IMPORTANT LINKS

=over 4

=item * L<https://github.com/libwww-perl/WWW-Mechanize/issues>

The queue for bugs & enhancements in WWW::Mechanize.  Please note that the
queue at L<http://rt.cpan.org> is no longer maintained.

=item * L<https://metacpan.org/pod/WWW::Mechanize>

The CPAN documentation page for Mechanize.

=item * L<https://metacpan.org/pod/distribution/WWW-Mechanize/lib/WWW/Mechanize/FAQ.pod>

Frequently asked questions.  Make sure you read here FIRST.

=back

=head1 CONSTRUCTOR AND STARTUP

=head2 new()

Creates and returns a new WWW::Mechanize object, hereafter referred to as
the "agent".

    my $mech = WWW::Mechanize->new()

The constructor for WWW::Mechanize overrides two of the params to the
LWP::UserAgent constructor:

    agent => 'WWW-Mechanize/#.##'
    cookie_jar => {}    # an empty, memory-only HTTP::Cookies object

You can override these overrides by passing params to the constructor,
as in:

    my $mech = WWW::Mechanize->new( agent => 'wonderbot 1.01' );

If you want none of the overhead of a cookie jar, or don't want your
bot accepting cookies, you have to explicitly disallow it, like so:

    my $mech = WWW::Mechanize->new( cookie_jar => undef );

Here are the params that WWW::Mechanize recognizes.  These do not include
params that L<LWP::UserAgent> recognizes.

=over 4

=item * C<< autocheck => [0|1] >>

Checks each request made to see if it was successful.  This saves
you the trouble of manually checking yourself.  Any errors found
are errors, not warnings.

The default value is ON, unless it's being subclassed, in which
case it is OFF.  This means that standalone L<WWW::Mechanize> instances
have autocheck turned on, which is protective for the vast majority
of Mech users who don't bother checking the return value of get()
and post() and can't figure why their code fails. However, if
L<WWW::Mechanize> is subclassed, such as for L<Test::WWW::Mechanize>
or L<Test::WWW::Mechanize::Catalyst>, this may not be an appropriate
default, so it's off.

=item * C<< noproxy => [0|1] >>

Turn off the automatic call to the L<LWP::UserAgent> C<env_proxy> function.

This needs to be explicitly turned off if you're using L<Crypt::SSLeay> to
access a https site via a proxy server.  Note: you still need to set your
HTTPS_PROXY environment variable as appropriate.

=item * C<< onwarn => \&func >>

Reference to a C<warn>-compatible function, such as C<< L<Carp>::carp >>,
that is called when a warning needs to be shown.

If this is set to C<undef>, no warnings will ever be shown.  However,
it's probably better to use the C<quiet> method to control that behavior.

If this value is not passed, Mech uses C<Carp::carp> if L<Carp> is
installed, or C<CORE::warn> if not.

=item * C<< onerror => \&func >>

Reference to a C<die>-compatible function, such as C<< L<Carp>::croak >>,
that is called when there's a fatal error.

If this is set to C<undef>, no errors will ever be shown.

If this value is not passed, Mech uses C<Carp::croak> if L<Carp> is
installed, or C<CORE::die> if not.

=item * C<< quiet => [0|1] >>

Don't complain on warnings.  Setting C<< quiet => 1 >> is the same as
calling C<< $mech->quiet(1) >>.  Default is off.

=item * C<< stack_depth => $value >>

Sets the depth of the page stack that keeps track of all the
downloaded pages. Default is effectively infinite stack size.  If
the stack is eating up your memory, then set this to a smaller
number, say 5 or 10.  Setting this to zero means Mech will keep no
history.

=back

In addition, WWW::Mechanize also allows you to globally enable
strict and verbose mode for form handling, which is done with L<HTML::Form>.

=over 4

=item * C<< strict_forms => [0|1] >>

Globally sets the HTML::Form strict flag which causes form submission to
croak if any of the passed fields don't exist in the form, and/or a value
doesn't exist in a select element. This can still be disabled in individual
calls to C<L<< submit_form()|"$mech->submit_form( ... )" >>>.

Default is off.

=item * C<< verbose_forms => [0|1] >>

Globally sets the HTML::Form verbose flag which causes form submission to
warn about any bad HTML form constructs found. This cannot be disabled
later.

Default is off.

=item * C<< marked_sections => [0|1] >>

Globally sets the HTML::Parser marked sections flag which causes HTML
C<< CDATA[[ >> sections to be honoured. This cannot be disabled
later.

Default is on.

=back

To support forms, WWW::Mechanize's constructor pushes POST
on to the agent's C<requests_redirectable> list (see also
L<LWP::UserAgent>.)

=head2 $mech->agent_alias( $alias )

Sets the user agent string to the expanded version from a table of actual user strings.
I<$alias> can be one of the following:

=over 4

=item * Windows IE 6

=item * Windows Mozilla

=item * Mac Safari

=item * Mac Mozilla

=item * Linux Mozilla

=item * Linux Konqueror

=back

then it will be replaced with a more interesting one.  For instance,

    $mech->agent_alias( 'Windows IE 6' );

sets your User-Agent to

    Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)

The list of valid aliases can be returned from C<known_agent_aliases()>.  The current list is:

=over

=item * Windows IE 6

=item * Windows Mozilla

=item * Mac Safari

=item * Mac Mozilla

=item * Linux Mozilla

=item * Linux Konqueror

=back

=head2 known_agent_aliases()

Returns a list of all the agent aliases that Mech knows about.

=head1 PAGE-FETCHING METHODS

=head2 $mech->get( $uri )

Given a URL/URI, fetches it.  Returns an L<HTTP::Response> object.
I<$uri> can be a well-formed URL string, a L<URI> object, or a
L<WWW::Mechanize::Link> object.

The results are stored internally in the agent object, but you don't
know that.  Just use the accessors listed below.  Poking at the
internals is deprecated and subject to change in the future.

C<get()> is a well-behaved overloaded version of the method in
L<LWP::UserAgent>.  This lets you do things like

    $mech->get( $uri, ':content_file' => $tempfile );

and you can rest assured that the params will get filtered down
appropriately.

B<NOTE:> Because C<:content_file> causes the page contents to be
stored in a file instead of the response object, some Mech functions
that expect it to be there won't work as expected. Use with caution.

=head2 $mech->post( $uri, content => $content )

POSTs I<$content> to $uri.  Returns an L<HTTP::Response> object.
I<$uri> can be a well-formed URI string, a L<URI> object, or a
L<WWW::Mechanize::Link> object.

=head2 $mech->put( $uri, content => $content )

PUTs I<$content> to $uri.  Returns an L<HTTP::Response> object.
I<$uri> can be a well-formed URI string, a L<URI> object, or a
L<WWW::Mechanize::Link> object.

=head2 $mech->reload()

Acts like the reload button in a browser: repeats the current
request. The history (as per the L<< back()|/$mech->back() >> method) is not altered.

Returns the L<HTTP::Response> object from the reload, or C<undef>
if there's no current request.

=head2 $mech->back()

The equivalent of hitting the "back" button in a browser.  Returns to
the previous page.  Won't go back past the first page. (Really, what
would it do if it could?)

Returns true if it could go back, or false if not.

=head2 $mech->clear_history()

This deletes all the history entries and returns true.

=head2 $mech->history_count()

This returns the number of items in the browser history.  This number I<does>
include the most recently made request.

=head2 $mech->history($n)

This returns the I<n>th item in history.  The 0th item is the most recent
request and response, which would be acted on by methods like
C<L<< find_link()|"$mech->find_link( ... )" >>>.
The 1st item is the state you'd return to if you called
C<L<< back()|/$mech->back() >>>.

The maximum useful value for C<$n> is C<< $mech->history_count - 1 >>.
Requests beyond that bound will return C<undef>.

History items are returned as hash references, in the form:

  { req => $http_request, res => $http_response }

=head1 STATUS METHODS

=head2 $mech->success()

Returns a boolean telling whether the last request was successful.
If there hasn't been an operation yet, returns false.

This is a convenience function that wraps C<< $mech->res->is_success >>.

=head2 $mech->uri()

Returns the current URI as a L<URI> object. This object stringifies
to the URI itself.

=head2 $mech->response() / $mech->res()

Return the current response as an L<HTTP::Response> object.

Synonym for C<< $mech->response() >>

=head2 $mech->status()

Returns the HTTP status code of the response.  This is a 3-digit
number like 200 for OK, 404 for not found, and so on.

=head2 $mech->ct() / $mech->content_type()

Returns the content type of the response.

=head2 $mech->base()

Returns the base URI for the current response

=head2 $mech->forms()

When called in a list context, returns a list of the forms found in
the last fetched page. In a scalar context, returns a reference to
an array with those forms. The forms returned are all L<HTML::Form>
objects.

=head2 $mech->current_form()

Returns the current form as an L<HTML::Form> object.

=head2 $mech->links()

When called in a list context, returns a list of the links found in the
last fetched page.  In a scalar context it returns a reference to an array
with those links.  Each link is a L<WWW::Mechanize::Link> object.

=head2 $mech->is_html()

Returns true/false on whether our content is HTML, according to the
HTTP headers.

=head2 $mech->title()

Returns the contents of the C<< <TITLE> >> tag, as parsed by
L<HTML::HeadParser>.  Returns undef if the content is not HTML.

=head2 $mech->redirects()

Convenience method to get the L<< redirects|HTTP::Response/$r->redirects >> from the most recent L<HTTP::Response>.

Note that you can also use L<< is_redirect|HTTP::Response/$r->is_redirect >> to see if the most recent response was a redirect like this.

    $mech->get($url);
    do_stuff() if $mech->res->is_redirect;

=head1 CONTENT-HANDLING METHODS

=head2 $mech->content(...)

Returns the content that the mech uses internally for the last page
fetched. Ordinarily this is the same as
C<< $mech->response()->decoded_content() >>,
but this may differ for HTML documents if L<< update_html|/$mech->update_html( $html ) >> is
overloaded (in which case the value passed to the base-class
implementation of same will be returned), and/or extra named arguments
are passed to I<content()>:

=over 2

=item I<< $mech->content( format => 'text' ) >>

Returns a text-only version of the page, with all HTML markup
stripped. This feature requires I<HTML::TreeBuilder> version 5 or higher
to be installed, or a fatal error will be thrown. This works only if
the contents are HTML.

=item I<< $mech->content( base_href => [$base_href|undef] ) >>

Returns the HTML document, modified to contain a
C<< <base href="$base_href"> >> mark-up in the header.
I<$base_href> is C<< $mech->base() >> if not specified. This is
handy to pass the HTML to e.g. L<HTML::Display>. This works only if
the contents are HTML.

=item I<< $mech->content( raw => 1 ) >>

Returns C<< $self->response()->content() >>, i.e. the raw contents from the
response.

=item I<< $mech->content( decoded_by_headers => 1 ) >>

Returns the content after applying all C<Content-Encoding> headers but
with not additional mangling.

=item I<< $mech->content( charset => $charset ) >>

Returns C<< $self->response()->decoded_content(charset => $charset) >>
(see L<HTTP::Response> for details).

=back

To preserve backwards compatibility, additional parameters will be
ignored unless none of C<< raw | decoded_by_headers | charset >> is
specified and the text is HTML, in which case an error will be triggered.

A fresh instance of WWW::Mechanize will return C<undef> when C<< $mech->content() >>
is called, because no content is present before a request has been made.

=head2 $mech->text()

Returns the text of the current HTML content.  If the content isn't
HTML, C<$mech> will die.

The text is extracted by parsing the content, and then the extracted
text is cached, so don't worry about performance of calling this
repeatedly.

=head1 LINK METHODS

=head2 $mech->links()

Lists all the links on the current page.  Each link is a
WWW::Mechanize::Link object. In list context, returns a list of all
links.  In scalar context, returns an array reference of all links.

=head2 $mech->follow_link(...)

Follows a specified link on the page.  You specify the match to be
found using the same params that C<L<< find_link()|"$mech->find_link( ... )" >>> uses.

Here some examples:

=over 4

=item * 3rd link called "download"

    $mech->follow_link( text => 'download', n => 3 );

=item * first link where the URL has "download" in it, regardless of case:

    $mech->follow_link( url_regex => qr/download/i );

or

    $mech->follow_link( url_regex => qr/(?i:download)/ );

=item * 3rd link on the page

    $mech->follow_link( n => 3 );

=item * the link with the url

    $mech->follow_link( url => '/other/page' );

or

    $mech->follow_link( url => 'http://example.com/page' );

=back

Returns the result of the C<GET> method (an L<HTTP::Response> object) if a link
was found.

If the page has no links, or the specified link couldn't be found, returns
C<undef>.  If C<autocheck> is enabled an exception will be thrown instead.

=head2 $mech->find_link( ... )

Finds a link in the currently fetched page. It returns a
L<WWW::Mechanize::Link> object which describes the link.  (You'll
probably be most interested in the C<url()> property.)  If it fails
to find a link it returns undef.

You can take the URL part and pass it to the C<get()> method.  If
that's your plan, you might as well use the C<follow_link()> method
directly, since it does the C<get()> for you automatically.

Note that C<< <FRAME SRC="..."> >> tags are parsed out of the HTML and
treated as links so this method works with them.

You can select which link to find by passing in one or more of these
key/value pairs:

=over 4

=item * C<< text => 'string', >> and C<< text_regex => qr/regex/, >>

C<text> matches the text of the link against I<string>, which must be an
exact match.  To select a link with text that is exactly "download", use

    $mech->find_link( text => 'download' );

C<text_regex> matches the text of the link against I<regex>.  To select a
link with text that has "download" anywhere in it, regardless of case, use

    $mech->find_link( text_regex => qr/download/i );

Note that the text extracted from the page's links are trimmed.  For
example, C<< <a> foo </a> >> is stored as 'foo', and searching for
leading or trailing spaces will fail.

=item * C<< url => 'string', >> and C<< url_regex => qr/regex/, >>

Matches the URL of the link against I<string> or I<regex>, as appropriate.
The URL may be a relative URL, like F<foo/bar.html>, depending on how
it's coded on the page.

=item * C<< url_abs => string >> and C<< url_abs_regex => regex >>

Matches the absolute URL of the link against I<string> or I<regex>,
as appropriate.  The URL will be an absolute URL, even if it's relative
in the page.

=item * C<< name => string >> and C<< name_regex => regex >>

Matches the name of the link against I<string> or I<regex>, as appropriate.

=item * C<< rel => string >> and C<< rel_regex => regex >>

Matches the rel of the link against I<string> or I<regex>, as appropriate.
This can be used to find stylesheets, favicons, or links the author of the
page does not want bots to follow.

=item * C<< id => string >> and C<< id_regex => regex >>

Matches the attribute 'id' of the link against I<string> or
I<regex>, as appropriate.

=item * C<< class => string >> and C<< class_regex => regex >>

Matches the attribute 'class' of the link against I<string> or
I<regex>, as appropriate.

=item * C<< tag => string >> and C<< tag_regex => regex >>

Matches the tag that the link came from against I<string> or I<regex>,
as appropriate.  The C<tag_regex> is probably most useful to check for
more than one tag, as in:

    $mech->find_link( tag_regex => qr/^(a|frame)$/ );

The tags and attributes looked at are defined below.

=back

If C<n> is not specified, it defaults to 1.  Therefore, if you don't
specify any params, this method defaults to finding the first link on the
page.

Note that you can specify multiple text or URL parameters, which
will be ANDed together.  For example, to find the first link with
text of "News" and with "cnn.com" in the URL, use:

    $mech->find_link( text => 'News', url_regex => qr/cnn\.com/ );

The return value is a reference to an array containing a
L<WWW::Mechanize::Link> object for every link in C<< $self->content >>.

The links come from the following:

=over 4

=item C<< <a href=...> >>

=item C<< <area href=...> >>

=item C<< <frame src=...> >>

=item C<< <iframe src=...> >>

=item C<< <link href=...> >>

=item C<< <meta content=...> >>

=back

=head2 $mech->find_all_links( ... )

Returns all the links on the current page that match the criteria.  The
method for specifying link criteria is the same as in
C<L<< find_link()|"$mech->find_link( ... )" >>>.
Each of the links returned is a L<WWW::Mechanize::Link> object.

In list context, C<find_all_links()> returns a list of the links.
Otherwise, it returns a reference to the list of links.

C<find_all_links()> with no parameters returns all links in the
page.

=head2 $mech->find_all_inputs( ... criteria ... )

find_all_inputs() returns an array of all the input controls in the
current form whose properties match all of the regexes passed in.
The controls returned are all descended from HTML::Form::Input.
See L<HTML::Form/INPUTS> for details.

If no criteria are passed, all inputs will be returned.

If there is no current page, there is no form on the current
page, or there are no submit controls in the current form
then the return will be an empty array.

You may use a regex or a literal string:

    # get all textarea controls whose names begin with "customer"
    my @customer_text_inputs = $mech->find_all_inputs(
        type       => 'textarea',
        name_regex => qr/^customer/,
    );

    # get all text or textarea controls called "customer"
    my @customer_text_inputs = $mech->find_all_inputs(
        type_regex => qr/^(text|textarea)$/,
        name       => 'customer',
    );

=head2 $mech->find_all_submits( ... criteria ... )

C<find_all_submits()> does the same thing as C<find_all_inputs()>
except that it only returns controls that are submit controls,
ignoring other types of input controls like text and checkboxes.

=head1 IMAGE METHODS

=head2 $mech->images

Lists all the images on the current page.  Each image is a
WWW::Mechanize::Image object. In list context, returns a list of all
images.  In scalar context, returns an array reference of all images.

=head2 $mech->find_image()

Finds an image in the current page. It returns a
L<WWW::Mechanize::Image> object which describes the image.  If it fails
to find an image it returns undef.

You can select which image to find by passing in one or more of these
key/value pairs:

=over 4

=item * C<< alt => 'string' >> and C<< alt_regex => qr/regex/ >>

C<alt> matches the ALT attribute of the image against I<string>, which must be an
exact match. To select a image with an ALT tag that is exactly "download", use

    $mech->find_image( alt => 'download' );

C<alt_regex> matches the ALT attribute of the image  against a regular
expression.  To select an image with an ALT attribute that has "download"
anywhere in it, regardless of case, use

    $mech->find_image( alt_regex => qr/download/i );

=item * C<< url => 'string' >> and C<< url_regex => qr/regex/ >>

Matches the URL of the image against I<string> or I<regex>, as appropriate.
The URL may be a relative URL, like F<foo/bar.html>, depending on how
it's coded on the page.

=item * C<< url_abs => string >> and C<< url_abs_regex => regex >>

Matches the absolute URL of the image against I<string> or I<regex>,
as appropriate.  The URL will be an absolute URL, even if it's relative
in the page.

=item * C<< tag => string >> and C<< tag_regex => regex >>

Matches the tag that the image came from against I<string> or I<regex>,
as appropriate.  The C<tag_regex> is probably most useful to check for
more than one tag, as in:

    $mech->find_image( tag_regex => qr/^(img|input)$/ );

The tags supported are C<< <img> >> and C<< <input> >>.

=item * C<< id => string >> and C<< id_regex => regex >>

C<id> matches the id attribute of the image against I<string>, which must
be an exact match. To select an image with the exact id "download-image", use

    $mech->find_image( id => 'download-image' );

C<id_regex> matches the id attribute of the image against a regular
expression. To select the first image with an id that contains "download"
anywhere in it, use

    $mech->find_image( id_regex => qr/download/ );

=item * C<< classs => string >> and C<< class_regex => regex >>

C<class> matches the class attribute of the image against I<string>, which must
be an exact match. To select an image with the exact class "img-fuid", use

    $mech->find_image( class => 'img-fluid' );

To select an image with the class attribute "rounded float-left", use

    $mech->find_image( class => 'rounded float-left' );

Note that the classes have to be matched as a complete string, in the exact
order they appear in the website's source code.

C<class_regex> matches the class attribute of the image against a regular
expression. Use this if you want a partial class name, or if an image has
several classes, but you only care about one.

To select the first image with the class "rounded", where there are multiple
images that might also have either class "float-left" or "float-right", use

    $mech->find_image( class_regex => qr/\brounded\b/ );

Selecting an image with multiple classes where you do not care about the
order they appear in the website's source code is not currently supported.

=back

If C<n> is not specified, it defaults to 1.  Therefore, if you don't
specify any params, this method defaults to finding the first image on the
page.

Note that you can specify multiple ALT or URL parameters, which
will be ANDed together.  For example, to find the first image with
ALT text of "News" and with "cnn.com" in the URL, use:

    $mech->find_image( image => 'News', url_regex => qr/cnn\.com/ );

The return value is a reference to an array containing a
L<WWW::Mechanize::Image> object for every image in C<< $self->content >>.

=head2 $mech->find_all_images( ... )

Returns all the images on the current page that match the criteria.  The
method for specifying image criteria is the same as in
C<L<< find_image()|"$mech->find_image()" >>>.
Each of the images returned is a L<WWW::Mechanize::Image> object.

In list context, C<find_all_images()> returns a list of the images.
Otherwise, it returns a reference to the list of images.

C<find_all_images()> with no parameters returns all images in the page.

=head1 FORM METHODS

These methods let you work with the forms on a page.  The idea is
to choose a form that you'll later work with using the field methods
below.

=head2 $mech->forms

Lists all the forms on the current page.  Each form is an L<HTML::Form>
object.  In list context, returns a list of all forms.  In scalar
context, returns an array reference of all forms.

=head2 $mech->form_number($number)

Selects the I<number>th form on the page as the target for subsequent
calls to C<L<< field()|"$mech->field( $name, $value, $number )" >>>
and C<L<< click()|"$mech->click( $button [, $x, $y] )" >>>.
Also returns the form that was selected.

If it is found, the form is returned as an L<HTML::Form> object and set internally
for later use with Mech's form methods such as
C<L<< field()|"$mech->field( $name, $value, $number )" >>> and
C<L<< click()|"$mech->click( $button [, $x, $y] )" >>>.
When called in a list context, the number of the found form is also returned as
a second value.

Emits a warning and returns undef if no form is found.

The first form is number 1, not zero.

=head2 $mech->form_name( $name )

Selects a form by name.  If there is more than one form on the page
with that name, then the first one is used, and a warning is
generated.

If it is found, the form is returned as an L<HTML::Form> object and
set internally for later use with Mech's form methods such as
C<L<< field()|"$mech->field( $name, $value, $number )" >>> and
C<L<< click()|"$mech->click( $button [, $x, $y] )" >>>.

Returns undef if no form is found.

=head2 $mech->form_id( $name )

Selects a form by ID.  If there is more than one form on the page
with that ID, then the first one is used, and a warning is generated.

If it is found, the form is returned as an L<HTML::Form> object and
set internally for later use with Mech's form methods such as
C<L<< field()|"$mech->field( $name, $value, $number )" >>> and
C<L<< click()|"$mech->click( $button [, $x, $y] )" >>>.

If no form is found it returns C<undef>.  This will also trigger a warning,
unless C<quiet> is enabled.

=head2 $mech->all_forms_with_fields( @fields )

Selects a form by passing in a list of field names it must contain.  All matching forms (perhaps none) are returned as a list of L<HTML::Form> objects.

=head2 $mech->form_with_fields( @fields )

Selects a form by passing in a list of field names it must contain.  If there
is more than one form on the page with that matches, then the first one is used,
and a warning is generated.

If it is found, the form is returned as an L<HTML::Form> object and set internally
for later used with Mech's form methods such as
C<L<< field()|"$mech->field( $name, $value, $number )" >>> and
C<L<< click()|"$mech->click( $button [, $x, $y] )" >>>.

Returns undef and emits a warning if no form is found.

Note that this functionality requires libwww-perl 5.69 or higher.

=head2 $mech->all_forms_with( $attr1 => $value1, $attr2 => $value2, ... )

Searches for forms with arbitrary attribute/value pairs within the E<lt>formE<gt>
tag.
(Currently does not work for attribute C<action> due to implementation details
of L<HTML::Form>.)
When given more than one pair, all criteria must match.
Using C<undef> as value means that the attribute in question must not be present.

All matching forms (perhaps none) are returned as a list of L<HTML::Form> objects.

=head2 $mech->form_with( $attr1 => $value1, $attr2 => $value2, ... )

Searches for forms with arbitrary attribute/value pairs within the E<lt>formE<gt>
tag.
(Currently does not work for attribute C<action> due to implementation details
of L<HTML::Form>.)
When given more than one pair, all criteria must match.
Using C<undef> as value means that the attribute in question must not be present.

If it is found, the form is returned as an L<HTML::Form> object and set internally
for later used with Mech's form methods such as
C<L<< field()|"$mech->field( $name, $value, $number )" >>> and
C<L<< click()|"$mech->click( $button [, $x, $y] )" >>>.

Returns undef if no form is found.

=head1 FIELD METHODS

These methods allow you to set the values of fields in a given form.

=head2 $mech->field( $name, $value, $number )

=head2 $mech->field( $name, \@values, $number )

Given the name of a field, set its value to the value specified.
This applies to the current form (as set by the
C<L<< form_name()|"$mech->form_name( $name )" >>> or
C<L<< form_number()|"$mech->form_number($number)" >>>
method or defaulting to the first form on the page).

The optional I<$number> parameter is used to distinguish between two fields
with the same name.  The fields are numbered from 1.

=head2 $mech->select($name, $value)

=head2 $mech->select($name, \@values)

Given the name of a C<select> field, set its value to the value
specified.  If the field is not C<< <select multiple> >> and the
C<$value> is an array, only the B<first> value will be set.  [Note:
the documentation previously claimed that only the last value would
be set, but this was incorrect.]  Passing C<$value> as a hash with
an C<n> key selects an item by number (e.g.
C<< {n => 3} >> or C<< {n => [2,4]} >>).
The numbering starts at 1.  This applies to the current form.

If you have a field with C<< <select multiple> >> and you pass a single
C<$value>, then C<$value> will be added to the list of fields selected,
without clearing the others.  However, if you pass an array reference,
then all previously selected values will be cleared.

Returns true on successfully setting the value. On failure, returns
false and calls C<< $self->warn() >> with an error message.

=head2 $mech->set_fields( $name => $value ... )

This method sets multiple fields of the current form. It takes a list
of field name and value pairs. If there is more than one field with
the same name, the first one found is set. If you want to select which
of the duplicate field to set, use a value which is an anonymous array
which has the field value and its number as the 2 elements.

        # set the second foo field
        $mech->set_fields( $name => [ 'foo', 2 ] );

The fields are numbered from 1.

This applies to the current form.

=head2 $mech->set_visible( @criteria )

This method sets fields of the current form without having to know
their names.  So if you have a login screen that wants a username and
password, you do not have to fetch the form and inspect the source (or
use the F<mech-dump> utility, installed with WWW::Mechanize) to see
what the field names are; you can just say

    $mech->set_visible( $username, $password );

and the first and second fields will be set accordingly.  The method
is called set_I<visible> because it acts only on visible fields;
hidden form inputs are not considered.  The order of the fields is
the order in which they appear in the HTML source which is nearly
always the order anyone viewing the page would think they are in,
but some creative work with tables could change that; caveat user.

Each element in C<@criteria> is either a field value or a field
specifier.  A field value is a scalar.  A field specifier allows
you to specify the I<type> of input field you want to set and is
denoted with an arrayref containing two elements.  So you could
specify the first radio button with

    $mech->set_visible( [ radio => 'KCRW' ] );

Field values and specifiers can be intermixed, hence

    $mech->set_visible( 'fred', 'secret', [ option => 'Checking' ] );

would set the first two fields to "fred" and "secret", and the I<next>
C<OPTION> menu field to "Checking".

The possible field specifier types are: "text", "password", "hidden",
"textarea", "file", "image", "submit", "radio", "checkbox" and "option".

C<set_visible> returns the number of values set.

=head2 $mech->tick( $name, $value [, $set] )

"Ticks" the first checkbox that has both the name and value associated
with it on the current form.  Dies if there is no named check box for
that value.  Passing in a false value as the third optional argument
will cause the checkbox to be unticked.

=head2 $mech->untick($name, $value)

Causes the checkbox to be unticked.  Shorthand for
C<tick($name,$value,undef)>

=head2 $mech->value( $name [, $number] )

Given the name of a field, return its value. This applies to the current
form.

The optional I<$number> parameter is used to distinguish between two fields
with the same name.  The fields are numbered from 1.

If the field is of type file (file upload field), the value is always
cleared to prevent remote sites from downloading your local files.
To upload a file, specify its file name explicitly.

=head2 $mech->click( $button [, $x, $y] )

Has the effect of clicking a button on the current form.  The first
argument is the name of the button to be clicked.  The second and
third arguments (optional) allow you to specify the (x,y) coordinates
of the click.

If there is only one button on the form, C<< $mech->click() >> with
no arguments simply clicks that one button.

Returns an L<HTTP::Response> object.

=head2 $mech->click_button( ... )

Has the effect of clicking a button on the current form by specifying
its attributes. The arguments are a list of key/value pairs. Only one
of name, id, number, input or value must be specified in the keys.

Dies if no button is found.

=over 4

=item * C<< name => name >>

Clicks the button named I<name> in the current form.

=item * C<< id => id >>

Clicks the button with the id I<id> in the current form.

=item * C<< number => n >>

Clicks the I<n>th button with type I<submit> in the current form.
Numbering starts at 1.

=item * C<< value => value >>

Clicks the button with the value I<value> in the current form.

=item * C<< input => $inputobject >>

Clicks on the button referenced by $inputobject, an instance of
L<HTML::Form::SubmitInput> obtained e.g. from

    $mech->current_form()->find_input( undef, 'submit' )

C<$inputobject> must belong to the current form.

=item * C<< x => x >>

=item * C<< y => y >>

These arguments (optional) allow you to specify the (x,y) coordinates
of the click.

=back

=head2 $mech->submit()

Submits the current form, without specifying a button to click.  Actually,
no button is clicked at all.

Returns an L<HTTP::Response> object.

This used to be a synonym for C<< $mech->click( 'submit' ) >>, but is no
longer so.

=head2 $mech->submit_form( ... )

This method lets you select a form from the previously fetched page,
fill in its fields, and submit it. It combines the C<form_number>/C<form_name>,
C<set_fields> and C<click> methods into one higher level call. Its arguments
are a list of key/value pairs, all of which are optional.

=over 4

=item * C<< fields => \%fields >>

Specifies the fields to be filled in the current form.

=item * C<< with_fields => \%fields >>

Probably all you need for the common case. It combines a smart form selector
and data setting in one operation. It selects the first form that contains all
fields mentioned in C<\%fields>.  This is nice because you don't need to know
the name or number of the form to do this.

(calls C<L<< form_with_fields()|"$mech->form_with_fields( @fields )" >>> and
       C<L<< set_fields()|"$mech->set_fields( $name => $value ... )" >>>).

If you choose C<with_fields>, the C<fields> option will be ignored. The
C<form_number>, C<form_name> and C<form_id> options will still be used.  An
exception will be thrown unless exactly one form matches all of the provided
criteria.

=item * C<< form_number => n >>

Selects the I<n>th form (calls
C<L<< form_number()|"$mech->form_number($number)" >>>.  If this param is not
specified, the currently-selected form is used.

=item * C<< form_name => name >>

Selects the form named I<name> (calls
C<L<< form_name()|"$mech->form_name( $name )" >>>)

=item * C<< form_id => ID >>

Selects the form with ID I<ID> (calls
C<L<< form_id()|"$mech->form_id( $name )" >>>)

=item * C<< button => button >>

Clicks on button I<button> (calls C<L<< click()|"$mech->click( $button [, $x, $y] )" >>>)

=item * C<< x => x, y => y >>

Sets the x or y values for C<L<< click()|"$mech->click( $button [, $x, $y] )" >>>

=item * C<< strict_forms => bool >>

Sets the HTML::Form strict flag which causes form submission to croak if any of the passed
fields don't exist on the page, and/or a value doesn't exist in a select element.
By default HTML::Form sets this value to false.

This behavior can also be turned on globally by passing C<< strict_forms => 1 >> to
C<< WWW::Mechanize->new >>. If you do that, you can still disable it for individual calls
by passing C<< strict_forms => 0 >> here.

=back

If no form is selected, the first form found is used.

If I<button> is not passed, then the C<L<< submit()|"$mech->submit()" >>>
method is used instead.

If you want to submit a file and get its content from a scalar rather
than a file in the filesystem, you can use:

    $mech->submit_form(with_fields => { logfile => [ [ undef, 'whatever', Content => $content ], 1 ] } );

Returns an L<HTTP::Response> object.

=head1 MISCELLANEOUS METHODS

=head2 $mech->add_header( name => $value [, name => $value... ] )

Sets HTTP headers for the agent to add or remove from the HTTP request.

    $mech->add_header( Encoding => 'text/klingon' );

If a I<value> is C<undef>, then that header will be removed from any
future requests.  For example, to never send a Referer header:

    $mech->add_header( Referer => undef );

If you want to delete a header, use C<delete_header>.

Returns the number of name/value pairs added.

B<NOTE>: This method was very different in WWW::Mechanize before 1.00.
Back then, the headers were stored in a package hash, not as a member of
the object instance.  Calling C<add_header()> would modify the headers
for every WWW::Mechanize object, even after your object no longer existed.

=head2 $mech->delete_header( name [, name ... ] )

Removes HTTP headers from the agent's list of special headers.  For
instance, you might need to do something like:

    # Don't send a Referer for this URL
    $mech->add_header( Referer => undef );

    # Get the URL
    $mech->get( $url );

    # Back to the default behavior
    $mech->delete_header( 'Referer' );

=head2 $mech->quiet(true/false)

Allows you to suppress warnings to the screen.

    $mech->quiet(0); # turns on warnings (the default)
    $mech->quiet(1); # turns off warnings
    $mech->quiet();  # returns the current quietness status

=head2 $mech->stack_depth( $max_depth )

Get or set the page stack depth. Use this if you're doing a lot of page
scraping and running out of memory.

A value of 0 means "no history at all."  By default, the max stack depth
is humongously large, effectively keeping all history.

=head2 $mech->save_content( $filename, %opts )

Dumps the contents of C<< $mech->content >> into I<$filename>.
I<$filename> will be overwritten.  Dies if there are any errors.

If the content type does not begin with "text/", then the content
is saved in binary mode (i.e. C<binmode()> is set on the output
filehandle).

Additional arguments can be passed as I<key>/I<value> pairs:

=over

=item I<< $mech->save_content( $filename, binary => 1 ) >>

Filehandle is set with C<binmode> to C<:raw> and contents are taken
calling C<< $self->content(decoded_by_headers => 1) >>. Same as calling:

    $mech->save_content( $filename, binmode => ':raw',
                         decoded_by_headers => 1 );

This I<should> be the safest way to save contents verbatim.

=item I<< $mech->save_content( $filename, binmode => $binmode ) >>

Filehandle is set to binary mode. If C<$binmode> begins with ':', it is
passed as a parameter to C<binmode>:

    binmode $fh, $binmode;

otherwise the filehandle is set to binary mode if C<$binmode> is true:

    binmode $fh;

=item I<all other arguments>

are passed as-is to C<< $mech->content(%opts) >>. In particular,
C<decoded_by_headers> might come handy if you want to revert the effect
of line compression performed by the web server but without further
interpreting the contents (e.g. decoding it according to the charset).

=back

=head2 $mech->dump_headers( [$fh] )

Prints a dump of the HTTP response headers for the most recent
response.  If I<$fh> is not specified or is undef, it dumps to
STDOUT.

Unlike the rest of the dump_* methods, $fh can be a scalar. It
will be used as a file name.

=head2 $mech->dump_links( [[$fh], $absolute] )

Prints a dump of the links on the current page to I<$fh>.  If I<$fh>
is not specified or is undef, it dumps to STDOUT.

If I<$absolute> is true, links displayed are absolute, not relative.

=head2 $mech->dump_images( [[$fh], $absolute] )

Prints a dump of the images on the current page to I<$fh>.  If I<$fh>
is not specified or is undef, it dumps to STDOUT.

If I<$absolute> is true, links displayed are absolute, not relative.

The output will include empty lines for images that have no C<src> attribute
and therefore no C<<->url>>.

=head2 $mech->dump_forms( [$fh] )

Prints a dump of the forms on the current page to I<$fh>.  If I<$fh>
is not specified or is undef, it dumps to STDOUT. Running the following:

    my $mech = WWW::Mechanize->new();
    $mech->get("https://www.google.com/");
    $mech->dump_forms;

will print:

    GET https://www.google.com/search [f]
      ie=ISO-8859-1                  (hidden readonly)
      hl=en                          (hidden readonly)
      source=hp                      (hidden readonly)
      biw=                           (hidden readonly)
      bih=                           (hidden readonly)
      q=                             (text)
      btnG=Google Search             (submit)
      btnI=I'm Feeling Lucky         (submit)
      gbv=1                          (hidden readonly)

=head2 $mech->dump_text( [$fh] )

Prints a dump of the text on the current page to I<$fh>.  If I<$fh>
is not specified or is undef, it dumps to STDOUT.

=head1 OVERRIDDEN LWP::UserAgent METHODS

=head2 $mech->clone()

Clone the mech object.  The clone will be using the same cookie jar
as the original mech.

=head2 $mech->redirect_ok()

An overloaded version of C<redirect_ok()> in L<LWP::UserAgent>.
This method is used to determine whether a redirection in the request
should be followed.

Note that WWW::Mechanize's constructor pushes POST on to the agent's
C<requests_redirectable> list.

=head2 $mech->request( $request [, $arg [, $size]])

Overloaded version of C<request()> in L<LWP::UserAgent>.  Performs
the actual request.  Normally, if you're using WWW::Mechanize, it's
because you don't want to deal with this level of stuff anyway.

Note that C<$request> will be modified.

Returns an L<HTTP::Response> object.

=head2 $mech->update_html( $html )

Allows you to replace the HTML that the mech has found.  Updates the
forms and links parse-trees that the mech uses internally.

Say you have a page that you know has malformed output, and you want to
update it so the links come out correctly:

    my $html = $mech->content;
    $html =~ s[</option>.{0,3}</td>][</option></select></td>]isg;
    $mech->update_html( $html );

This method is also used internally by the mech itself to update its
own HTML content when loading a page. This means that if you would
like to I<systematically> perform the above HTML substitution, you
would overload I<update_html> in a subclass thusly:

   package MyMech;
   use base 'WWW::Mechanize';

   sub update_html {
       my ($self, $html) = @_;
       $html =~ s[</option>.{0,3}</td>][</option></select></td>]isg;
       $self->WWW::Mechanize::update_html( $html );
   }

If you do this, then the mech will use the tidied-up HTML instead of
the original both when parsing for its own needs, and for returning to
you through C<L<< content()|"$mech->content(...)" >>>.

Overloading this method is also the recommended way of implementing
extra validation steps (e.g. link checkers) for every HTML page
received.  L</warn> and L</die> would then come in handy to signal
validation errors.

=head2 $mech->credentials( $username, $password )

Provide credentials to be used for HTTP Basic authentication for
all sites and realms until further notice.

The four argument form described in L<LWP::UserAgent> is still
supported.

=head2 $mech->get_basic_credentials( $realm, $uri, $isproxy )

Returns the credentials for the realm and URI.

=head2 $mech->clear_credentials()

Remove any credentials set up with C<credentials()>.

=head1 INHERITED UNCHANGED LWP::UserAgent METHODS

As a subclass of L<LWP::UserAgent>, WWW::Mechanize inherits all of
L<LWP::UserAgent>'s methods.  Many of which are overridden or
extended. The following methods are inherited unchanged. View the
L<LWP::UserAgent> documentation for their implementation descriptions.

This is not meant to be an inclusive list.  LWP::UA may have added
others.

=head2 $mech->head()

Inherited from L<LWP::UserAgent>.

=head2 $mech->mirror()

Inherited from L<LWP::UserAgent>.

=head2 $mech->simple_request()

Inherited from L<LWP::UserAgent>.

=head2 $mech->is_protocol_supported()

Inherited from L<LWP::UserAgent>.

=head2 $mech->prepare_request()

Inherited from L<LWP::UserAgent>.

=head2 $mech->progress()

Inherited from L<LWP::UserAgent>.

=head1 INTERNAL-ONLY METHODS

These methods are only used internally.  You probably don't need to
know about them.

=head2 $mech->_update_page($request, $response)

Updates all internal variables in $mech as if $request was just
performed, and returns $response. The page stack is B<not> altered by
this method, it is up to caller (e.g.
C<L<< request|"$mech->request( $request [, $arg [, $size]])" >>>)
to do that.

=head2 $mech->_modify_request( $req )

Modifies a L<HTTP::Request> before the request is sent out,
for both GET and POST requests.

We add a C<Referer> header, as well as header to note that we can accept gzip
encoded content, if L<Compress::Zlib> is installed.

=head2 $mech->_make_request()

Convenience method to make it easier for subclasses like
L<WWW::Mechanize::Cached> to intercept the request.

=head2 $mech->_reset_page()

Resets the internal fields that track page parsed stuff.

=head2 $mech->_extract_links()

Extracts links from the content of a webpage, and populates the C<{links}>
property with L<WWW::Mechanize::Link> objects.

=head2 $mech->_push_page_stack()

The agent keeps a stack of visited pages, which it can pop when it needs
to go BACK and so on.

The current page needs to be pushed onto the stack before we get a new
page, and the stack needs to be popped when BACK occurs.

Neither of these take any arguments, they just operate on the $mech
object.

=head2 warn( @messages )

Centralized warning method, for diagnostics and non-fatal problems.
Defaults to calling C<CORE::warn>, but may be overridden by setting
C<onwarn> in the constructor.

=head2 die( @messages )

Centralized error method.  Defaults to calling C<CORE::die>, but
may be overridden by setting C<onerror> in the constructor.

=head1 BEST PRACTICES

The default settings can get you up and running quickly, but there are settings
you can change in order to make your life easier.

=over 4

=item autocheck

C<autocheck> can save you the overhead of checking status codes for success.
You may outgrow it as your needs get more sophisticated, but it's a safe option
to start with.

    my $agent = WWW::Mechanize->new( autocheck => 1 );

=item cookie_jar

You are encouraged to install L<Mozilla::PublicSuffix> and use
L<HTTP::CookieJar::LWP> as your cookie jar.  L<HTTP::CookieJar::LWP> provides a
better security model matching that of current Web browsers when
L<Mozilla::PublicSuffix> is installed.

    use HTTP::CookieJar::LWP ();

    my $jar = HTTP::CookieJar::LWP->new;
    my $agent = WWW::Mechanize->new( cookie_jar => $jar );

=item protocols_allowed

This option is inherited directly from L<LWP::UserAgent>.  It allows you to
whitelist the protocols you're willing to allow.

    my $agent = WWW::Mechanize->new(
        protocols_allowed => [ 'http', 'https' ]
    );

This will prevent you from inadvertently following URLs like
C<file:///etc/passwd>

=item protocols_forbidden

This option is also inherited directly from L<LWP::UserAgent>.  It allows you to
blacklist the protocols you're unwilling to allow.

    my $agent = WWW::Mechanize->new(
        protocols_forbidden => [ 'file', 'mailto', 'ssh', ]
    );

This will prevent you from inadvertently following URLs like
C<file:///etc/passwd>

=item strict_forms

Consider turning on the C<strict_forms> option when you create a new Mech.
This will perform a helpful sanity check on form fields every time you are
submitting a form, which can save you a lot of debugging time.

    my $agent = WWW::Mechanize->new( strict_forms => 1 );

If you do not want to have this option globally, you can still turn it on for
individual forms.

    $agent->submit_form( fields => { foo => 'bar' } , strict_forms => 1 );

=back

=head1 WWW::MECHANIZE'S GIT REPOSITORY

WWW::Mechanize is hosted at GitHub.

Repository: L<https://github.com/libwww-perl/WWW-Mechanize>.
Bugs: L<https://github.com/libwww-perl/WWW-Mechanize/issues>.

=head1 OTHER DOCUMENTATION

=head2 I<Spidering Hacks>, by Kevin Hemenway and Tara Calishain

I<Spidering Hacks> from O'Reilly
(L<http://www.oreilly.com/catalog/spiderhks/>) is a great book for anyone
wanting to know more about screen-scraping and spidering.

There are six hacks that use Mech or a Mech derivative:

=over 4

=item #21 WWW::Mechanize 101

=item #22 Scraping with WWW::Mechanize

=item #36 Downloading Images from Webshots

=item #44 Archiving Yahoo! Groups Messages with WWW::Yahoo::Groups

=item #64 Super Author Searching

=item #73 Scraping TV Listings

=back

The book was also positively reviewed on Slashdot:
L<http://books.slashdot.org/article.pl?sid=03/12/11/2126256>

=head1 ONLINE RESOURCES AND SUPPORT

=over 4

=item * WWW::Mechanize mailing list

The Mech mailing list is at
L<http://groups.google.com/group/www-mechanize-users> and is specific
to Mechanize, unlike the LWP mailing list below.  Although it is a
users list, all development discussion takes place here, too.

=item * LWP mailing list

The LWP mailing list is at
L<http://lists.perl.org/showlist.cgi?name=libwww>, and is more
user-oriented and well-populated than the WWW::Mechanize list.

=item * Perlmonks

L<http://perlmonks.org> is an excellent community of support, and
many questions about Mech have already been answered there.

=item * L<WWW::Mechanize::Examples>

A random array of examples submitted by users, included with the
Mechanize distribution.

=back

=head1 ARTICLES ABOUT WWW::MECHANIZE

=over 4

=item * L<http://www.ibm.com/developerworks/linux/library/wa-perlsecure/>

IBM article "Secure Web site access with Perl"

=item * L<http://www.oreilly.com/catalog/googlehks2/chapter/hack84.pdf>

Leland Johnson's hack #84 in I<Google Hacks, 2nd Edition> is
an example of a production script that uses WWW::Mechanize and
HTML::TableContentParser. It takes in keywords and returns the estimated
price of these keywords on Google's AdWords program.

=item * L<http://www.perl.com/pub/a/2004/06/04/recorder.html>

Linda Julien writes about using HTTP::Recorder to create WWW::Mechanize
scripts.

=item * L<http://www.developer.com/lang/other/article.php/3454041>

Jason Gilmore's article on using WWW::Mechanize for scraping sales
information from Amazon and eBay.

=item * L<http://www.perl.com/pub/a/2003/01/22/mechanize.html>

Chris Ball's article about using WWW::Mechanize for scraping TV
listings.

=item * L<http://www.stonehenge.com/merlyn/LinuxMag/col47.html>

Randal Schwartz's article on scraping Yahoo News for images.  It's
already out of date: He manually walks the list of links hunting
for matches, which wouldn't have been necessary if the
C<L<< find_link()|"$mech->find_link( ... )" >>> method existed at press time.

=item * L<http://www.perladvent.org/2002/16th/>

WWW::Mechanize on the Perl Advent Calendar, by Mark Fowler.

=item * L<http://www.linux-magazin.de/ausgaben/2004/03/datenruessel/>

Michael Schilli's article on Mech and L<WWW::Mechanize::Shell> for the
German magazine I<Linux Magazin>.

=back

=head2 Other modules that use Mechanize

Here are modules that use or subclass Mechanize.  Let me know of any others:

=over 4

=item * L<Finance::Bank::LloydsTSB>

=item * L<HTTP::Recorder>

Acts as a proxy for web interaction, and then generates WWW::Mechanize scripts.

=item * L<Win32::IE::Mechanize>

Just like Mech, but using Microsoft Internet Explorer to do the work.

=item * L<WWW::Bugzilla>

=item * L<WWW::CheckSite>

=item * L<WWW::Google::Groups>

=item * L<WWW::Hotmail>

=item * L<WWW::Mechanize::Cached>

=item * L<WWW::Mechanize::Cached::GZip>

=item * L<WWW::Mechanize::FormFiller>

=item * L<WWW::Mechanize::Shell>

=item * L<WWW::Mechanize::Sleepy>

=item * L<WWW::Mechanize::SpamCop>

=item * L<WWW::Mechanize::Timed>

=item * L<WWW::SourceForge>

=item * L<WWW::Yahoo::Groups>

=item * L<WWW::Scripter>

=back

=head1 ACKNOWLEDGEMENTS

Thanks to the numerous people who have helped out on WWW::Mechanize in
one way or another, including
Kirrily Robert for the original C<WWW::Automate>,
Lyle Hopkins,
Damien Clark,
Ansgar Burchardt,
Gisle Aas,
Jeremy Ary,
Hilary Holz,
Rafael Kitover,
Norbert Buchmuller,
Dave Page,
David Sainty,
H.Merijn Brand,
Matt Lawrence,
Michael Schwern,
Adriano Ferreira,
Miyagawa,
Peteris Krumins,
Rafael Kitover,
David Steinbrunner,
Kevin Falcone,
Mike O'Regan,
Mark Stosberg,
Uri Guttman,
Peter Scott,
Philippe Bruhat,
Ian Langworth,
John Beppu,
Gavin Estey,
Jim Brandt,
Ask Bjoern Hansen,
Greg Davies,
Ed Silva,
Mark-Jason Dominus,
Autrijus Tang,
Mark Fowler,
Stuart Children,
Max Maischein,
Meng Wong,
Prakash Kailasa,
Abigail,
Jan Pazdziora,
Dominique Quatravaux,
Scott Lanning,
Rob Casey,
Leland Johnson,
Joshua Gatcomb,
Julien Beasley,
Abe Timmerman,
Peter Stevens,
Pete Krawczyk,
Tad McClellan,
and the late great Iain Truskett.

=head1 AUTHOR

Andy Lester <andy at petdance.com>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2004 by Andy Lester.

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

=cut
PK       ! �t��  �    perl5/Alien/Util.pmnu ��6�$        package Alien::Util;

use strict;
use warnings;
use Exporter qw( import );

# ABSTRACT: Alien Utilities used at build and runtime
our $VERSION = '2.83'; # VERSION


our @EXPORT_OK = qw( version_cmp );


# Sort::Versions isn't quite the same algorithm because it differs in
# behaviour with leading zeroes.
#   See also  https://dev.gentoo.org/~mgorny/pkg-config-spec.html#version-comparison
sub version_cmp {
  my @x = (shift =~ m/([0-9]+|[a-z]+)/ig);
  my @y = (shift =~ m/([0-9]+|[a-z]+)/ig);

  while(@x and @y) {
    my $x = shift @x; my $x_isnum = $x =~ m/[0-9]/;
    my $y = shift @y; my $y_isnum = $y =~ m/[0-9]/;

    if($x_isnum and $y_isnum) {
      # Numerical comparison
      return $x <=> $y if $x != $y;
    }
    elsif(!$x_isnum && !$y_isnum) {
      # Alphabetic comparison
      return $x cmp $y if $x ne $y;
    }
    else {
      # Of differing types, the numeric one is newer
      return $x_isnum - $y_isnum;
    }
  }

  # Equal so far; the longer is newer
  return @x <=> @y;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Util - Alien Utilities used at build and runtime

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use Alien::Util qw( version_cmp );

=head1 DESCRIPTION

This module contains some functions used by both the L<Alien::Build> build-time and <Alien::Base>
run-time for Alien.

=head2 version_cmp

  $cmp = version_cmp($x, $y)

Comparison method used by L<Alien::Base/atleast_version>, L<Alien::Base/exact_version> and
L<Alien::Base/max_version>. May be useful to implement custom comparisons, or for
subclasses to overload to get different version comparison semantics than the
default rules, for packages that have some other rules than the F<pkg-config>
behaviour.

Should return a number less than, equal to, or greater than zero; similar in
behaviour to the C<< <=> >> and C<cmp> operators.

=head1 SEE ALSO

L<Alien::Base>, L<alienfile>, L<Alien::Build>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! z�ħp  �p    perl5/Alien/Base.pmnu ��6�$        package Alien::Base;

use strict;
use warnings;
use 5.008004;
use Carp;
use Path::Tiny ();
use Scalar::Util qw/blessed/;
use Capture::Tiny 0.17 qw/capture_stdout/;
use Text::ParseWords qw/shellwords/;
use Alien::Util;

# ABSTRACT: Base classes for Alien:: modules
our $VERSION = '2.83'; # VERSION


sub import {
  my $class = shift;

  return if $class eq __PACKAGE__;

  return if $class->runtime_prop;

  return if $class->install_type('system');

  require DynaLoader;

  # Sanity check in order to ensure that dist_dir can be found.
  # This will throw an exception otherwise.
  $class->dist_dir;

  # get a reference to %Alien::MyLibrary::AlienLoaded
  # which contains names of already loaded libraries
  # this logic may be replaced by investigating the DynaLoader arrays
  my $loaded = do {
    no strict 'refs';
    no warnings 'once';
    \%{ $class . "::AlienLoaded" };
  };

  my @libs = $class->split_flags( $class->libs );

  my @L = grep { s/^-L// } map { "$_" } @libs;  ## no critic (ControlStructures::ProhibitMutatingListFunctions)
  my @l = grep { /^-l/ } @libs;

  unshift @DynaLoader::dl_library_path, @L;

  my @libpaths;
  foreach my $l (@l) {
    next if $loaded->{$l};

    my $path = DynaLoader::dl_findfile( $l );
    unless ($path) {
      carp "Could not resolve $l";
      next;
    }

    push @libpaths, $path;
    $loaded->{$l} = $path;
  }

  push @DynaLoader::dl_resolve_using, @libpaths;

  my @librefs = map { DynaLoader::dl_load_file( $_, 0x01 ) } grep !/\.(a|lib)$/, @libpaths;
  push @DynaLoader::dl_librefs, @librefs;

}


sub _dist_dir ($)
{
  my($dist_name) = @_;

  my @pm = split /-/, $dist_name;
  $pm[-1] .= ".pm";

  foreach my $inc (@INC)
  {
    my $pm = Path::Tiny->new($inc, @pm);
    if(-f $pm)
    {
      my $share = Path::Tiny->new($inc, qw( auto share dist ), $dist_name );
      if(-d $share)
      {
        return $share->absolute->stringify;
      }
      last;
    }
  }
  Carp::croak("unable to find dist share directory for $dist_name");
}

sub dist_dir {
  my $class = shift;

  my $dist = blessed $class || $class;
  $dist =~ s/::/-/g;

  my $dist_dir =
    $class->config('finished_installing')
      ? _dist_dir $dist
      : $class->config('working_directory');

  croak "Failed to find share dir for dist '$dist'"
    unless defined $dist_dir && -d $dist_dir;

  return $dist_dir;
}


sub new { return bless {}, $_[0] }

sub _flags
{
  my($class, $key) = @_;

  my $config = $class->runtime_prop;
  my $flags = $config->{$key};

  my $prefix = $config->{prefix};
  $prefix =~ s{\\}{/}g if $^O =~ /^(MSWin32|msys)$/;
  my $distdir = $config->{distdir};
  $distdir =~ s{\\}{/}g if $^O =~ /^(MSWin32|msys)$/;

  if(defined $flags && $prefix ne $distdir)
  {
    $flags = join ' ', map {
      my $flag = $_;
      $flag =~ s/^(-I|-L|-LIBPATH:)?\Q$prefix\E/$1$distdir/;
      $flag =~ s/(\s)/\\$1/g;
      $flag;
    } $class->split_flags($flags);
  }

  $flags;
}


sub cflags {
  my $class = shift;
  return $class->runtime_prop ? $class->_flags('cflags') : $class->_pkgconfig_keyword('Cflags');
}


sub cflags_static {
  my $class = shift;
  return $class->runtime_prop ? $class->_flags('cflags_static') : $class->_pkgconfig_keyword('Cflags', 'static');
}


sub libs {
  my $class = shift;
  return $class->runtime_prop ? $class->_flags('libs') : $class->_pkgconfig_keyword('Libs');
}


sub libs_static {
  my $class = shift;
  return $class->runtime_prop ? $class->_flags('libs_static') : $class->_pkgconfig_keyword('Libs', 'static');
}


sub version {
  my $self = shift;
  return $self->runtime_prop
    ? $self->runtime_prop->{version}
    : do {
      my $version = $self->config('version');
      chomp $version;
      $version;
    };
}


sub atleast_version {
  my $self = shift;
  my ($wantver) = @_;

  defined(my $version = $self->version) or
    croak "$self has no defined ->version";

  return $self->version_cmp($version, $wantver) >= 0;
}

sub exact_version {
  my $self = shift;
  my ($wantver) = @_;

  defined(my $version = $self->version) or
    croak "$self has no defined ->version";

  return $self->version_cmp($version, $wantver) == 0;
}

sub max_version {
  my $self = shift;
  my ($wantver) = @_;

  defined(my $version = $self->version) or
    croak "$self has no defined ->version";

  return $self->version_cmp($version, $wantver) <= 0;
}


sub version_cmp {
  shift;
  goto &Alien::Util::version_cmp;
}


sub install_type {
  my $self = shift;
  my $type = $self->config('install_type');
  return @_ ? $type eq $_[0] : $type;
}

sub _pkgconfig_keyword {
  my $self = shift;
  my $keyword = shift;
  my $static = shift;

  # use pkg-config if installed system-wide
  if ($self->install_type('system')) {
    my $name = $self->config('name');
    require Alien::Base::PkgConfig;
    my $command = Alien::Base::PkgConfig->pkg_config_command . " @{[ $static ? '--static' : '' ]} --\L$keyword\E $name";

    $! = 0;
    chomp ( my $pcdata = capture_stdout { system( $command ) } );

    # if pkg-config fails for whatever reason, then we try to
    # fallback on alien_provides_*
    $pcdata = '' if $! || $?;

    $pcdata =~ s/\s*$//;

    if($self->config('system_provides')) {
      if(my $system_provides = $self->config('system_provides')->{$keyword}) {
        $pcdata = length $pcdata ? "$pcdata $system_provides" : $system_provides;
      }
    }

    return $pcdata;
  }

  # use parsed info from build .pc file
  my $dist_dir = $self->dist_dir;
  my @pc = $self->_pkgconfig(@_);
  my @strings =
    grep defined,
    map { $_->keyword($keyword,
      #{ pcfiledir => $dist_dir }
    ) }
    @pc;

  if(defined $self->config('original_prefix') && $self->config('original_prefix') ne $self->dist_dir)
  {
    my $dist_dir = $self->dist_dir;
    $dist_dir =~ s{\\}{/}g if $^O eq 'MSWin32';
    my $old = quotemeta $self->config('original_prefix');
    @strings = map {
      my $flag = $_;
      $flag =~ s{^(-I|-L|-LIBPATH:)?($old)}{$1.$dist_dir}e;
      $flag =~ s/(\s)/\\$1/g;
      $flag;
    } map { $self->split_flags($_) } @strings;
  }

  return join( ' ', @strings );
}

sub _pkgconfig {
  my $self = shift;
  my %all = %{ $self->config('pkgconfig') };

  # merge in found pc files
  require File::Find;
  my $wanted = sub {
    return if ( -d or not /\.pc$/ );
    require Alien::Base::PkgConfig;
    my $pkg = Alien::Base::PkgConfig->new($_);
    $all{$pkg->{package}} = $pkg;
  };
  File::Find::find( $wanted, $self->dist_dir );

  croak "No Alien::Base::PkgConfig objects are stored!"
    unless keys %all;

  # Run through all pkgconfig objects and ensure that their modules are loaded:
  for my $pkg_obj (values %all) {
    my $perl_module_name = blessed $pkg_obj;
    my $pm = "$perl_module_name.pm";
    $pm =~ s/::/\//g;
    eval { require $pm };
  }

  return @all{@_} if @_;

  my $manual = delete $all{_manual};

  if (keys %all) {
    return values %all;
  } else {
    return $manual;
  }
}


# helper method to call Alien::MyLib::ConfigData->config(@_)
sub config {
  my $class = shift;
  $class = blessed $class || $class;

  if(my $ab_config = $class->runtime_prop)
  {
    my $key = shift;
    return $ab_config->{legacy}->{$key};
  }

  my $config = $class . '::ConfigData';
  my $pm = "$class/ConfigData.pm";
  $pm =~ s{::}{/}g;
  eval { require $pm };

  if($@)
  {
    warn "Cannot find either a share directory or a ConfigData module for $class.\n";
    my $pm = "$class.pm";
    $pm =~ s{::}{/}g;
    warn "($class loaded from $INC{$pm})\n" if $INC{$pm};
    warn "Please see https://metacpan.org/pod/distribution/Alien-Build/lib/Alien/Build/Manual/FAQ.pod#Cannot-find-either-a-share-directory-or-a-ConfigData-module\n";
    die $@;
  }

  return $config->config(@_);
}

# helper method to split flags based on the OS
sub split_flags {
  my ($class, $line) = @_;
  if( $^O eq 'MSWin32' ) {
    $class->split_flags_windows($line);
  } else {
    # $os eq 'Unix'
    $class->split_flags_unix($line);
  }
}

sub split_flags_unix {
  my ($class, $line) = @_;
  shellwords($line);
}

sub split_flags_windows {
  # NOTE a better approach would be to write a function that understands cmd.exe metacharacters.
  my ($class, $line) = @_;

  # Double the backslashes so that when they are unescaped by shellwords(),
  # they become a single backslash. This should be fine on Windows since
  # backslashes are not used to escape metacharacters in cmd.exe.
  $line =~ s,\\,\\\\,g;
  shellwords($line);
}


sub dynamic_libs {
  my ($class) = @_;

  require FFI::CheckLib;

  my @find_lib_flags;

  if($class->install_type('system')) {

    if(my $prop = $class->runtime_prop)
    {
      if($prop->{ffi_checklib}->{system})
      {
        push @find_lib_flags, @{ $prop->{ffi_checklib}->{system} };
      }
      return FFI::CheckLib::find_lib( lib => $prop->{ffi_name}, @find_lib_flags )
        if defined $prop->{ffi_name};
    }

    my $name = $class->config('ffi_name');
    unless(defined $name)
    {
      $name = $class->config('name');
      $name = '' unless defined $name;
      # strip leading lib from things like libarchive or libffi
      $name =~ s/^lib//;
      # strip trailing version numbers
      $name =~ s/-[0-9\.]+$//;
    }

    my @libpath;
    if(defined $class->libs)
    {
      foreach my $flag ($class->split_flags($class->libs))
      {
        if($flag =~ /^-L(.*)$/)
        {
          push @libpath, $1;
        }
      }
    }

    return FFI::CheckLib::find_lib(lib => $name, libpath => \@libpath, @find_lib_flags );

  } else {

    my $dir = $class->dist_dir;
    my $dynamic = Path::Tiny->new($class->dist_dir, 'dynamic');

    if(my $prop = $class->runtime_prop)
    {
      if($prop->{ffi_checklib}->{share})
      {
        push @find_lib_flags, @{ $prop->{ffi_checklib}->{share_flags} };
      }
    }

    if(-d $dynamic)
    {
      return FFI::CheckLib::find_lib(
        lib        => '*',
        libpath    => "$dynamic",
        systempath => [],
      );
    }

    return FFI::CheckLib::find_lib(
      lib        => '*',
      libpath    => $dir,
      systempath => [],
      recursive  => 1,
    );
  }
}


sub bin_dir {
  my ($class) = @_;
  if($class->install_type('system'))
  {
    my $prop = $class->runtime_prop;
    return () unless defined $prop;
    return () unless defined $prop->{system_bin_dir};
    return ref $prop->{system_bin_dir} ? @{ $prop->{system_bin_dir} } : ($prop->{system_bin_dir});
  }
  else
  {
    my $dir = Path::Tiny->new($class->dist_dir, 'bin');
    return -d $dir ? ("$dir") : ();
  }
}


sub dynamic_dir {
  my ($class) = @_;
  if($class->install_type('system'))
  {
    return ();
  }
  else
  {
    my $dir = Path::Tiny->new($class->dist_dir, 'dynamic');
    return -d $dir ? ("$dir") : ();
  }
}


sub alien_helper {
  {};
}


sub inline_auto_include {
  my ($class) = @_;
  $class->runtime_prop->{inline_auto_include} || $class->config('inline_auto_include') || []
}

sub Inline {
  my ($class, $language) = @_;
  return unless defined $language;
  return if $language !~ /^(C|CPP)$/;
  my $config = {
    # INC should arguably be for -I flags only, but
    # this improves compat with ExtUtils::Depends.
    # see gh#107, gh#108
    INC          => $class->cflags,
    LIBS         => $class->libs,
  };

  if (@{ $class->inline_auto_include } > 0) {
    $config->{AUTO_INCLUDE} = join "\n", map { "#include \"$_\"" } @{ $class->inline_auto_include };
  }

  $config;
}


{
  my %alien_build_config_cache;

  sub runtime_prop
  {
    my($class) = @_;

    if(ref($class))
    {
      # called as an instance method.
      my $self = $class;
      $class = ref $self;
      return $self->{_alt}->{runtime_prop} if defined $self->{_alt};
    }

    return $alien_build_config_cache{$class} if
      exists $alien_build_config_cache{$class};

    $alien_build_config_cache{$class} ||= do {
      my $dist = ref $class ? ref $class : $class;
      $dist =~ s/::/-/g;
      my $dist_dir = eval { _dist_dir $dist };
      return if $@;
      my $alien_json = Path::Tiny->new($dist_dir, '_alien', 'alien.json');
      return unless -r $alien_json;
      my $json = $alien_json->slurp;
      require JSON::PP;
      my $config = JSON::PP::decode_json($json);
      $config->{distdir} = $dist_dir;
      $config;
    };
  }
}


sub alt
{
  my($old, $name) = @_;
  my $new = ref $old ? (ref $old)->new : $old->new;

  my $orig;

  if(ref($old) && defined $old->{_alt})
  { $orig = $old->{_alt}->{orig} }
  else
  { $orig = $old->runtime_prop }

  require Storable;
  my $runtime_prop = Storable::dclone($orig);

  if($runtime_prop->{alt}->{$name})
  {
    foreach my $key (keys %{ $runtime_prop->{alt}->{$name} })
    {
      $runtime_prop->{$key} = $runtime_prop->{alt}->{$name}->{$key};
    }
  }
  else
  {
    Carp::croak("no such alt: $name");
  }

  $new->{_alt} = {
    runtime_prop => $runtime_prop,
    orig         => $orig,
  };

  $new;
}


sub alt_names
{
  my($class) = @_;
  my $alts = $class->runtime_prop->{alt};
  defined $alts
    ? sort keys %$alts
    : ();
}


sub alt_exists
{
  my($class, $alt_name) = @_;
  my $alts = $class->runtime_prop->{alt};
  defined $alts
    ? exists $alts->{$alt_name} && defined $alts->{$alt_name}
    : 0;
}

1;

=pod

=encoding UTF-8

=head1 NAME

Alien::Base - Base classes for Alien:: modules

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 package Alien::MyLibrary;
 
 use strict;
 use warnings;
 
 use parent 'Alien::Base';
 
 1;

(for details on the C<Makefile.PL> or C<Build.PL> and L<alienfile>
that should be bundled with your L<Alien::Base> subclass, please see
L<Alien::Build::Manual::AlienAuthor>).

Then a C<MyLibrary::XS> can use C<Alien::MyLibrary> in its C<Makefile.PL>:

 use Alien::MyLibrary
 use ExtUtils::MakeMaker;
 use Alien::Base::Wrapper qw( Alien::MyLibrary !export );
 use Config;
 
 WriteMakefile(
   ...
   Alien::Base::Wrapper->mm_args,
   ...
 );

Or if you prefer L<Module::Build>, in its C<Build.PL>:

 use Alien::MyLibrary;
 use Module::Build 0.28; # need at least 0.28
 use Alien::Base::Wrapper qw( Alien::MyLibrary !export );
 
 my $builder = Module::Build->new(
   ...
   Alien::Base::Wrapper->mb_args,
   ...
 );
 
 $builder->create_build_script;

Or if you are using L<ExtUtils::Depends>:

 use ExtUtils::MakeMaker;
 use ExtUtils::Depends;
 my $eud = ExtUtils::Depends->new(qw( MyLibrary::XS Alien::MyLibrary ));
 WriteMakefile(
   ...
   $eud->get_makefile_vars
 );

If you are using L<Alien::Base::ModuleBuild> instead of the recommended L<Alien::Build>
and L<alienfile>, then in your C<MyLibrary::XS> module, you may need something like
this in your main C<.pm> file IF your library uses dynamic libraries:

 package MyLibrary::XS;
 
 use Alien::MyLibrary; # may only be needed if you are using Alien::Base::ModuleBuild
 
 ...

Or you can use it from an FFI module:

 package MyLibrary::FFI;
 
 use Alien::MyLibrary;
 use FFI::Platypus;
 use FFI::CheckLib 0.28 qw( find_lib_or_die );
 
 my $ffi = FFI::Platypus->new;
 $ffi->lib(find_lib_or_die lib => 'mylib', alien => ['Alien::MyLibrary']);
 
 $ffi->attach( 'my_library_function' => [] => 'void' );

You can even use it with L<Inline> (C and C++ languages are supported):

 package MyLibrary::Inline;
 
 use Alien::MyLibrary;
 # Inline 0.56 or better is required
 use Inline 0.56 with => 'Alien::MyLibrary';
 ...

=head1 DESCRIPTION

B<NOTE>: L<Alien::Base::ModuleBuild> is no longer bundled with L<Alien::Base> and has been spun off into a separate distribution.
L<Alien::Base::ModuleBuild> will be a prerequisite for L<Alien::Base> until October 1, 2017.  If you are using L<Alien::Base::ModuleBuild>
you need to make sure it is declared as a C<configure_requires> in your C<Build.PL>.  You may want to also consider using L<Alien::Base> and
L<alienfile> as a more modern alternative.

L<Alien::Base> comprises base classes to help in the construction of C<Alien::> modules. Modules in the L<Alien> namespace are used to locate and install (if necessary) external libraries needed by other Perl modules.

This is the documentation for the L<Alien::Base> module itself. If you
are starting out you probably want to do so from one of these documents:

=over 4

=item L<Alien::Build::Manual::AlienUser>

For users of an C<Alien::libfoo> that is implemented using L<Alien::Base>.
(The developer of C<Alien::libfoo> I<should> provide the documentation
necessary, but if not, this is the place to start).

=item L<Alien::Build::Manual::AlienAuthor>

If you are writing your own L<Alien> based on L<Alien::Build> and L<Alien::Base>.

=item L<Alien::Build::Manual::FAQ>

If you have a common question that has already been answered, like
"How do I use L<alienfile> with some build system".

=item L<Alien::Build::Manual::PluginAuthor>

This is for the brave souls who want to write plugins that will work with
L<Alien::Build> + L<alienfile>.

=back

Before using an L<Alien::Base> based L<Alien> directly, please consider the following advice:

If you are wanting to use an L<Alien::Base> based L<Alien> with an XS module using L<ExtUtils::MakeMaker> or L<Module::Build>, it is highly
recommended that you use L<Alien::Base::Wrapper>, rather than using the L<Alien> directly, because it handles a number of sharp edges and avoids
pitfalls common when trying to use an L<Alien> directly with L<ExtUtils::MakeMaker>.

In the same vein, if you are wanting to use an L<Alien::Base> based L<Alien> with an XS module using L<Dist::Zilla> it is highly recommended
that you use L<Dist::Zilla::Plugin::AlienBase::Wrapper> for the same reasons.

As of version 0.28, L<FFI::CheckLib> has a good interface for working with L<Alien::Base> based L<Alien>s in fallback mode, which is
recommended.

You should typically only be using an L<Alien::Base> based L<Alien> directly, if you need to integrate it with some other system, or if it
is a tool based L<Alien> that you don't need to link.

The above synopsis and linked manual documents will lead you down the right path, but it is worth knowing before you read further in this
document.

=head1 METHODS

In the example snippets here, C<Alien::MyLibrary> represents any
subclass of L<Alien::Base>.

=head2 dist_dir

 my $dir = Alien::MyLibrary->dist_dir;

Returns the directory that contains the install root for
the packaged software, if it was built from install (i.e., if
C<install_type> is C<share>).

=head2 new

 my $alien = Alien::MyLibrary->new;

Creates an instance of an L<Alien::Base> object.  This is typically
unnecessary.

=head2 cflags

 my $cflags = Alien::MyLibrary->cflags;
 
 use Text::ParseWords qw( shellwords );
 my @cflags = shellwords( Alien::MyLibrary->cflags );

Returns the C compiler flags necessary to compile an XS
module using the alien software.  If you need this in list
form (for example if you are calling system with a list
argument) you can pass this value into C<shellwords> from
the Perl core L<Text::ParseWords> module.

=head2 cflags_static

 my $cflags = Alien::MyLibrary->cflags_static;

Same as C<cflags> above, but gets the static compiler flags,
if they are different.

=head2 libs

 my $libs = Alien::MyLibrary->libs;
 
 use Text::ParseWords qw( shellwords );
 my @cflags = shellwords( Alien::MyLibrary->libs );

Returns the library linker flags necessary to link an XS
module against the alien software.  If you need this in list
form (for example if you are calling system with a list
argument) you can pass this value into C<shellwords> from
the Perl core L<Text::ParseWords> module.

=head2 libs_static

 my $libs = Alien::MyLibrary->libs_static;

Same as C<libs> above, but gets the static linker flags,
if they are different.

=head2 version

 my $version = Alien::MyLibrary->version;

Returns the version of the alienized library or tool that was
determined at install time.

=head2 atleast_version

=head2 exact_version

=head2 max_version

 my $ok = Alien::MyLibrary->atleast_version($wanted_version);
 my $ok = Alien::MyLibrary->exact_version($wanted_version);
 my $ok = Alien::MyLibrary->max_version($wanted_version);

Returns true if the version of the alienized library or tool is at least,
exactly, or at most the version specified, respectively.

=head2 version_cmp

  $cmp = Alien::MyLibrary->version_cmp($x, $y)

Comparison method used by L</atleast_version>, L</exact_version> and
L</max_version>. May be useful to implement custom comparisons, or for
subclasses to overload to get different version comparison semantics than the
default rules, for packages that have some other rules than the F<pkg-config>
behaviour.

Should return a number less than, equal to, or greater than zero; similar in
behaviour to the C<< <=> >> and C<cmp> operators.

=head2 install_type

 my $install_type = Alien::MyLibrary->install_type;
 my $bool = Alien::MyLibrary->install_type($install_type);

Returns the install type that was used when C<Alien::MyLibrary> was
installed.  If a type is provided (the second form in the synopsis)
returns true if the actual install type matches.  Types include:

=over 4

=item system

The library was provided by the operating system

=item share

The library was not available when C<Alien::MyLibrary> was installed, so
it was built from source code, either downloaded from the Internet
or bundled with C<Alien::MyLibrary>.

=back

=head2 config

 my $value = Alien::MyLibrary->config($key);

Returns the configuration data as determined during the install
of C<Alien::MyLibrary>.  For the appropriate config keys, see
L<Alien::Base::ModuleBuild::API/"CONFIG DATA">.

This is not typically used by L<Alien::Base> and L<alienfile>,
but a compatible interface will be provided.

=head2 dynamic_libs

 my @dlls = Alien::MyLibrary->dynamic_libs;
 my($dll) = Alien::MyLibrary->dynamic_libs;

Returns a list of the dynamic library or shared object files for the
alien software.

=head2 bin_dir

 my(@dir) = Alien::MyLibrary->bin_dir

Returns a list of directories with executables in them.  For a C<system>
install this will be an empty list.  For a C<share> install this will be
a directory under C<dist_dir> named C<bin> if it exists.  You may wish
to override the default behavior if you have executables or scripts that
get installed into non-standard locations.

Example usage:

 use Env qw( @PATH );
 
 unshift @PATH, Alien::MyLibrary->bin_dir;

=head2 dynamic_dir

 my(@dir) = Alien::MyLibrary->dynamic_dir

Returns the dynamic dir for a dynamic build (if the main
build is static).  For a C<share> install this will be a
directory under C<dist_dir> named C<dynamic> if it exists.
System builds return an empty list.

Example usage:

 use Env qw( @PATH );
 
 unshift @PATH, Alien::MyLibrary->dynamic_dir;

=head2 alien_helper

 my $helpers = Alien::MyLibrary->alien_helper;

Returns a hash reference of helpers provided by the Alien module.
The keys are helper names and the values are code references.  The
code references will be executed at command time and the return value
will be interpolated into the command before execution.  The default
implementation returns an empty hash reference, and you are expected
to override the method to create your own helpers.

For use with commands specified in and L<alienfile> or in your C<Build.Pl>
when used with L<Alien::Base::ModuleBuild>.

Helpers allow users of your Alien module to use platform or environment
determined logic to compute command names or arguments in your installer
logic.  Helpers allow you to do this without making your Alien module a
requirement when a build from source code is not necessary.

As a concrete example, consider L<Alien::gmake>, which provides the
helper C<gmake>:

 package Alien::gmake;
 
 ...
 
 sub alien_helper {
   my($class) = @_;
   return {
     gmake => sub {
       # return the executable name for GNU make,
       # usually either make or gmake depending on
       # the platform and environment
       $class->exe;
     }
   },
 }

Now consider L<Alien::nasm>.  C<nasm> requires GNU Make to build from
source code, but if the system C<nasm> package is installed we don't
need it.  From the L<alienfile> of C<Alien::nasm>:

 use alienfile;
 
 plugin 'Probe::CommandLine' => (
   command => 'nasm',
   args    => ['-v'],
   match   => qr/NASM version/,
 );
 
 share {
   ...
   plugin 'Extract' => 'tar.gz';
   plugin 'Build::MSYS';
 
   build [
     'sh configure --prefix=%{alien.install.prefix}',
     '%{gmake}',
     '%{gmake} install',
   ];
 };
 
 ...

=head2 inline_auto_include

 my(@headers) = Alien::MyLibrary->inline_auto_include;

List of header files to automatically include in inline C and C++
code when using L<Inline::C> or L<Inline::CPP>.  This is provided
as a public interface primarily so that it can be overridden at run
time.  This can also be specified in your C<Build.PL> with
L<Alien::Base::ModuleBuild> using the C<alien_inline_auto_include>
property.

=head2 runtime_prop

 my $hashref = Alien::MyLibrary->runtime_prop;

Returns a hash reference of the runtime properties computed by L<Alien::Build> during its
install process.  If the L<Alien::Base> based L<Alien> was not built using L<Alien::Build>,
then this will return undef.

=head2 alt

 my $new_alien = Alien::MyLibrary->alt($alt_name);
 my $new_alien = $old_alien->alt($alt_name);

Returns an L<Alien::Base> instance with the alternate configuration.

Some packages come with multiple libraries, and multiple C<.pc> files to
use with them.  This method can be used with C<pkg-config> plugins to
access different configurations.  (It could also be used with non-pkg-config
based packages too, though there are not as of this writing any build
time plugins that take advantage of this feature).

From your L<alienfile>

 use alienfile;
 
 plugin 'PkgConfig' => (
   pkg_name => [ 'libfoo', 'libbar', ],
 );

Then in your base class works like normal:

 package Alien::MyLibrary;
 
 use parent qw( Alien::Base );
 
 1;

Then you can use it:

 use Alien::MyLibrary;
 
 my $cflags = Alien::MyLibrary->alt('foo1')->cflags;
 my $libs   = Alien::MyLibrary->alt('foo1')->libs;

=head2 alt_names

 my @alt_names = Alien::MyLibrary->alt_names

Returns the list of all available alternative configuration names.

=head2 alt_exists

 my $bool = Alien::MyLibrary->alt_exists($alt_name)

Returns true if the given alternative configuration exists.

=head1 SUPPORT AND CONTRIBUTING

First check the L<Alien::Build::Manual::FAQ> for questions that have already been answered.

IRC: #native on irc.perl.org

L<(click for instant chatroom login)|http://chat.mibbit.com/#native@irc.perl.org>

If you find a bug, please report it on the projects issue tracker on GitHub:

=over 4

=item L<https://github.com/PerlAlien/Alien-Build/issues>

=back

Development is discussed on the projects google groups.  This is also
a reasonable place to post a question if you don't want to open an issue
in GitHub.

=over 4

=item L<https://groups.google.com/forum/#!forum/perl5-alien>

=back

If you have implemented a new feature or fixed a bug, please open a pull
request.

=over 4

=item L<https://github.com/PerlAlien/Alien-Build/pulls>

=back

=head1 SEE ALSO

=over

=item *

L<Alien::Build>

=item *

L<alienfile>

=item *

L<Alien>

=item *

L<Alien::Build::Manual::FAQ>

=back

=head1 THANKS

C<Alien::Base> was originally written by Joel Berger, and that
code is still Copyright (C) 2012-2017 Joel Berger.  It has the
same license as the rest of the L<Alien::Build>.

Special thanks for the early development of C<Alien::Base> go to:

=over

=item Christian Walde (Mithaldu)

For productive conversations about component interoperability.

=item kmx

For writing Alien::Tidyp from which I drew many of my initial ideas.

=item David Mertens (run4flat)

For productive conversations about implementation.

=item Mark Nunberg (mordy, mnunberg)

For graciously teaching me about rpath and dynamic loading,

=back

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut

__END__
__POD__

PK       ! tJ J   perl5/Alien/Build.pmnu ��6�$        package Alien::Build;

use strict;
use warnings;
use 5.008004;
use Path::Tiny ();
use Carp ();
use File::chdir;
use JSON::PP ();
use Env qw( @PATH @PKG_CONFIG_PATH );
use Config ();
use Alien::Build::Log;

# ABSTRACT: Build external dependencies for use in CPAN
our $VERSION = '2.83'; # VERSION


sub _path { goto \&Path::Tiny::path }


sub new
{
  my($class, %args) = @_;
  my $self = bless {
    install_prop => {
      root  => _path($args{root} || "_alien")->absolute->stringify,
      patch => (defined $args{patch}) ? _path($args{patch})->absolute->stringify : undef,
    },
    runtime_prop => {
      alien_build_version => $Alien::Build::VERSION || 'dev',
    },
    plugin_instance_prop => {},
    bin_dir => [],
    pkg_config_path => [],
    aclocal_path => [],
  }, $class;

  # force computing this as soon as possible
  $self->download_rule;

  $self->meta->filename(
    $args{filename} || do {
      my(undef, $filename) = caller;
      _path($filename)->absolute->stringify;
    }
  );

  if($args{meta_prop})
  {
    $self->meta->prop->{$_} = $args{meta_prop}->{$_} for keys %{ $args{meta_prop} };
  }

  $self;
}


my $count = 0;

sub load
{
  my(undef, $alienfile, @args) = @_;

  my $rcfile = Path::Tiny->new($ENV{ALIEN_BUILD_RC} || '~/.alienbuild/rc.pl')->absolute;
  if(-r $rcfile)
  {
    require Alien::Build::rc;
    package Alien::Build::rc;
    require $rcfile;
  }

  unless(-r $alienfile)
  {
    Carp::croak "Unable to read alienfile: $alienfile";
  }

  my $file = _path $alienfile;
  my $name = $file->parent->basename;
  $name =~ s/^alien-//i;
  $name =~ s/[^a-z]//g;
  $name = 'x' if $name eq '';
  $name = ucfirst $name;

  my $class = "Alien::Build::Auto::$name@{[ $count++ ]}";

  { no strict 'refs';
  @{ "${class}::ISA" } = ('Alien::Build');
  *{ "${class}::Alienfile::meta" } = sub {
    $class =~ s{::Alienfile$}{};
    $class->meta;
  }};

  my @preload = qw( Core::Setup Core::Download Core::FFI Core::Override Core::CleanInstall );
  push @preload, @Alien::Build::rc::PRELOAD;
  push @preload, split /;/, $ENV{ALIEN_BUILD_PRELOAD}
    if defined $ENV{ALIEN_BUILD_PRELOAD};

  my @postload = qw( Core::Legacy Core::Gather Core::Tail );
  push @postload, @Alien::Build::rc::POSTLOAD;
  push @postload, split /;/, $ENV{ALIEN_BUILD_POSTLOAD}
    if defined $ENV{ALIEN_BUILD_POSTLOAD};

  my $self = $class->new(
    filename => $file->absolute->stringify,
    @args,
  );

  require alienfile;

  foreach my $preload (@preload)
  {
    ref $preload eq 'CODE' ? $preload->($self->meta) : $self->meta->apply_plugin($preload);
  }

  # TODO: do this without a string eval ?
  ## no critic
  eval '# line '. __LINE__ . ' "' . __FILE__ . qq("\n) . qq{
    package ${class}::Alienfile;
    do '@{[ $file->absolute->stringify ]}';
    die \$\@ if \$\@;
  };
  die $@ if $@;
  ## use critic

  foreach my $postload (@postload)
  {
    ref $postload eq 'CODE' ? $postload->($self->meta) : $self->meta->apply_plugin($postload);
  }

  $self->{args} = \@args;
  unless(defined $self->meta->prop->{arch})
  {
    $self->meta->prop->{arch} = 1;
  }

  unless(defined $self->meta->prop->{network})
  {
    $self->meta->prop->{network} = 1;
    ## https://github.com/PerlAlien/Alien-Build/issues/23#issuecomment-341114414
    #$self->meta->prop->{network} = 0 if $ENV{NO_NETWORK_TESTING};
    $self->meta->prop->{network} = 0 if (defined $ENV{ALIEN_INSTALL_NETWORK}) && ! $ENV{ALIEN_INSTALL_NETWORK};
  }

  unless(defined $self->meta->prop->{local_source})
  {
    if(! defined $self->meta->prop->{start_url})
    {
      $self->meta->prop->{local_source} = 0;
    }
    # we assume URL schemes are at least two characters, that
    # way Windows absolute paths can be used as local start_url
    elsif($self->meta->prop->{start_url} =~ /^([a-z]{2,}):/i)
    {
      my $scheme = $1;
      $self->meta->prop->{local_source} = $scheme eq 'file';
    }
    else
    {
      $self->meta->prop->{local_source} = 1;
    }
  }

  return $self;
}


sub resume
{
  my(undef, $alienfile, $root) = @_;
  my $h = JSON::PP::decode_json(_path("$root/state.json")->slurp);
  my $self = Alien::Build->load("$alienfile", @{ $h->{args} });
  $self->{install_prop}         = $h->{install};
  $self->{plugin_instance_prop} = $h->{plugin_instance};
  $self->{runtime_prop}         = $h->{runtime};
  $self;
}


sub meta_prop
{
  my($class) = @_;
  $class->meta->prop;
}


sub install_prop
{
  shift->{install_prop};
}


sub plugin_instance_prop
{
  my($self, $plugin) = @_;
  my $instance_id = $plugin->instance_id;
  $self->{plugin_instance_prop}->{$instance_id} ||= {};
}


sub runtime_prop
{
  shift->{runtime_prop};
}


sub hook_prop
{
  shift->{hook_prop};
}

sub _command_prop
{
  my($self) = @_;

  return {
    alien => {
      install => $self->install_prop,
      runtime => $self->runtime_prop,
      hook    => $self->hook_prop,
      meta    => $self->meta_prop,
    },
    perl => {
      config => \%Config::Config,
    },
    env => \%ENV,
  };
}


sub checkpoint
{
  my($self) = @_;
  my $root = $self->root;
  _path("$root/state.json")->spew(
    JSON::PP->new->pretty->canonical(1)->ascii->encode({
      install         => $self->install_prop,
      runtime         => $self->runtime_prop,
      plugin_instance => $self->{plugin_instance_prop},
      args            => $self->{args},
    })
  );
  $self;
}


sub root
{
  my($self) = @_;
  my $root = $self->install_prop->{root};
  _path($root)->mkpath unless -d $root;
  $root;
}


sub install_type
{
  my($self) = @_;
  $self->{runtime_prop}->{install_type} ||= $self->probe;
}


sub download_rule
{
  my($self) = @_;

  $self->install_prop->{download_rule} ||= do {
    my $dr = $ENV{ALIEN_DOWNLOAD_RULE};
    $dr = 'warn' unless defined $dr;
    $dr = 'warn' if $dr eq 'default';
    unless($dr =~ /^(warn|digest|encrypt|digest_or_encrypt|digest_and_encrypt)$/)
    {
      $self->log("unknown ALIEN_DOWNLOAD_RULE \"$dr\", using \"warn\" instead");
      $dr = 'warn';
    }
    $dr;
  };
}


sub set_prefix
{
  my($self, $prefix) = @_;

  if($self->meta_prop->{destdir})
  {
    $self->runtime_prop->{prefix} =
    $self->install_prop->{prefix} = $prefix;
  }
  else
  {
    $self->runtime_prop->{prefix} = $prefix;
    $self->install_prop->{prefix} = $self->install_prop->{stage};
  }
}


sub set_stage
{
  my($self, $dir) = @_;
  $self->install_prop->{stage} = $dir;
}

sub _merge
{
  my %h;
  while(@_)
  {
    my $mod = shift;
    my $ver = shift;
    if((!defined $h{$mod}) || $ver > $h{$mod})
    { $h{$mod} = $ver }
  }
  \%h;
}


sub requires
{
  my($self, $phase) = @_;
  $phase ||= 'any';
  my $meta = $self->meta;
  $phase =~ /^(?:any|configure)$/
  ? $meta->{require}->{$phase} || {}
  : _merge %{ $meta->{require}->{any} }, %{ $meta->{require}->{$phase} };
}


sub load_requires
{
  my($self, $phase, $eval) = @_;
  my $reqs = $self->requires($phase);
  foreach my $mod (keys %$reqs)
  {
    my $ver = $reqs->{$mod};
    my $check = sub {
      my $pm = "$mod.pm";
      $pm =~ s{::}{/}g;
      require $pm;
    };
    if($eval)
    {
      eval { $check->() };
      die "Required $mod @{[ $ver || 'undef' ]}, missing" if $@;
    }
    else
    {
      $check->();
    }
    # note Test::Alien::Build#alienfile_skip_if_missing_prereqs does a regex
    # on this diagnostic, so if you change it here, change it there too.
    die "Required $mod $ver, have @{[ $mod->VERSION || 0 ]}" if $ver && ! $mod->VERSION($ver);

    # allow for requires on Alien::Build or Alien::Base
    next if $mod eq 'Alien::Build';
    next if $mod eq 'Alien::Base';

    if($mod->can('bin_dir'))
    {
      push @{ $self->{bin_dir} }, $mod->bin_dir;
    }

    if(($mod->can('runtime_prop') && $mod->runtime_prop)
    || ($mod->isa('Alien::Base')  && $mod->install_type('share')))
    {
      for my $dir (qw(lib share)) {
          my $path = _path($mod->dist_dir)->child("$dir/pkgconfig");
          if(-d $path)
          {
            push @{ $self->{pkg_config_path} }, $path->stringify;
          }
      }
      my $path = _path($mod->dist_dir)->child('share/aclocal');
      if(-d $path)
      {
        $path = "$path";
        if($^O eq 'MSWin32')
        {
          # convert to MSYS path
          $path =~ s{^([a-z]):}{/$1/}i;
        }
        push @{ $self->{aclocal_path} }, $path;
      }
    }

    # sufficiently new Autotools have a aclocal_dir which will
    # give us the directories we need.
    if($mod eq 'Alien::Autotools' && $mod->can('aclocal_dir'))
    {
      push @{ $self->{aclocal_path} }, $mod->aclocal_dir;
    }

    if($mod->can('alien_helper'))
    {
      my $helpers = $mod->alien_helper;
      foreach my $name (sort keys %$helpers)
      {
        my $code = $helpers->{$name};
        $self->meta->interpolator->replace_helper($name => $code);
      }
    }

  }
  1;
}

sub _call_hook
{
  my $self = shift;

  local $ENV{PATH} = $ENV{PATH};
  unshift @PATH, @{ $self->{bin_dir} };

  local $ENV{PKG_CONFIG_PATH} = $ENV{PKG_CONFIG_PATH};
  unshift @PKG_CONFIG_PATH, @{ $self->{pkg_config_path} };

  local $ENV{ACLOCAL_PATH} = $ENV{ACLOCAL_PATH};
  # autoconf uses MSYS paths, even for the ACLOCAL_PATH environment variable, so we can't use Env for this.
  {
    my @path;
    @path = split /:/, $ENV{ACLOCAL_PATH} if defined $ENV{ACLOCAL_PATH};
    unshift @path, @{ $self->{aclocal_path} };
    $ENV{ACLOCAL_PATH} = join ':', @path;
  }

  my $config = ref($_[0]) eq 'HASH' ? shift : {};
  my($name, @args) = @_;

  local $self->{hook_prop} = {};

  $self->meta->call_hook( $config, $name => $self, @args );
}


sub probe
{
  my($self) = @_;
  local $CWD = $self->root;
  my $dir;

  my $env = $self->_call_hook('override');
  my $type;
  my $error;

  $env = '' if $env eq 'default';

  if($env eq 'share')
  {
    $type = 'share';
  }
  else
  {
    $type = eval {
      $self->_call_hook(
        {
          before   => sub {
            $dir = Alien::Build::TempDir->new($self, "probe");
            $CWD = "$dir";
          },
          after    => sub {
            $CWD = $self->root;
          },
          ok       => 'system',
          continue => sub {
            if($_[0] eq 'system')
            {
              foreach my $name (qw( probe_class probe_instance_id ))
              {
                if(exists $self->hook_prop->{$name} && defined $self->hook_prop->{$name})
                {
                  $self->install_prop->{"system_$name"} = $self->hook_prop->{$name};
                }
              }
              return undef;
            }
            else
            {
              return 1;
            }
          },
        },
        'probe',
      );
    };
    $error = $@;
    $type = 'share' unless defined $type;
  }

  if($error)
  {
    if($env eq 'system')
    {
      die $error;
    }
    $self->log("error in probe (will do a share install): $@");
    $self->log("Don't panic, we will attempt a share build from source if possible.");
    $self->log("Do not file a bug unless you expected a system install to succeed.");
    $type = 'share';
  }

  if($env && $env ne $type)
  {
    die "requested $env install not available";
  }

  if($type !~ /^(system|share)$/)
  {
    Carp::croak "probe hook returned something other than system or share: $type";
  }

  if($type eq 'share' && (!$self->meta_prop->{network}) && (!$self->meta_prop->{local_source}))
  {
    $self->log("install type share requested or detected, but network fetch is turned off");
    $self->log("see https://metacpan.org/pod/Alien::Build::Manual::FAQ#Network-fetch-is-turned-off");
    Carp::croak "network fetch is turned off";
  }

  $self->runtime_prop->{install_type} = $type;

  $type;
}


sub download
{
  my($self) = @_;

  return $self unless $self->install_type eq 'share';
  return $self if $self->install_prop->{complete}->{download};

  if($self->meta->has_hook('download'))
  {
    my $tmp;
    local $CWD;
    my $valid = 0;

    $self->_call_hook(
      {
        before => sub {
          $tmp = Alien::Build::TempDir->new($self, "download");
          $CWD = "$tmp";
        },
        verify => sub {
          my @list = grep { $_->basename !~ /^\./, } _path('.')->children;

          my $count = scalar @list;

          if($count == 0)
          {
            die "no files downloaded";
          }
          elsif($count == 1)
          {
            my($archive) = $list[0];
            if(-d $archive)
            {
              # TODO: this is probably a bug that we don't set
              # download or compelte properties?
              $self->log("single dir, assuming directory");
            }
            else
            {
              $self->log("single file, assuming archive");
            }
            $self->install_prop->{download} = $archive->absolute->stringify;
            $self->install_prop->{complete}->{download} = 1;
            $valid = 1;
          }
          else
          {
            $self->log("multiple files, assuming directory");
            $self->install_prop->{complete}->{download} = 1;
            $self->install_prop->{download} = _path('.')->absolute->stringify;
            $valid = 1;
          }
        },
        after  => sub {
          $CWD = $self->root;
        },
      },
      'download',
    );

    # experimental and undocumented for now
    if($self->meta->has_hook('check_download'))
    {
      $self->meta->call_hook(check_download => $self);
    }

    return $self if $valid;
  }
  else
  {
    # This will call the default download hook
    # defined in Core::Download since the recipe
    # does not provide a download hook
    my $ret = $self->_call_hook('download');

    # experimental and undocumented for now
    if($self->meta->has_hook('check_download'))
    {
      $self->meta->call_hook(check_download => $self);
    }

    return $self;
  }

  die "download failed";
}


sub fetch
{
  my $self = shift;
  my $url = $_[0] || $self->meta_prop->{start_url};

  my $secure = 0;

  if(defined $url && ($url =~ /^(https|file):/ || $url !~ /:/))
  {
    # considered secure when either https or a local file
    $secure = 1;
  }
  elsif(!defined $url)
  {
    $self->log("warning: undefined url in fetch");
  }
  else
  {
    $self->log("warning: attempting to fetch a non-TLS or bundled URL: @{[ $url ]}");
  }

  die "insecure fetch is not allowed" if $self->download_rule =~ /^(encrypt|digest_and_encrypt)$/ && !$secure;

  my $file = $self->_call_hook( 'fetch' => @_ );

  $secure = 0;

  if(ref($file) ne 'HASH')
  {
    $self->log("warning: fetch returned non-hash reference");
  }
  elsif(!defined $file->{protocol})
  {
    $self->log("warning: fetch did not return a protocol");
  }
  elsif($file->{protocol} !~ /^(https|file)$/)
  {
    $self->log("warning: fetch did not use a secure protocol: @{[ $file->{protocol} ]}");
  }
  else
  {
    $secure = 1;
  }

  die "insecure fetch is not allowed" if $self->download_rule =~ /^(encrypt|digest_and_encrypt)$/ && !$secure;

  $file;
}


sub check_digest
{
  my($self, $file) = @_;

  return '' unless $self->meta_prop->{check_digest};

  unless(ref($file) eq 'HASH')
  {
    my $path = Path::Tiny->new($file);
    $file = {
      type     => 'file',
      filename => $path->basename,
      path     => "$path",
      tmp      => 0,
    };
  }

  my $path = $file->{path};
  if(defined $path)
  {
    # there is technically a race condition here
    die "Missing file in digest check: @{[ $file->{filename} ]}" unless -f $path;
    die "Unreadable file in digest check: @{[ $file->{filename} ]}" unless -r $path;
  }
  else
  {
    die "File is wrong type" unless defined $file->{type} && $file->{type} eq 'file';
    die "File has no filename" unless defined $file->{filename};
    die "@{[ $file->{filename} ]} has no content" unless defined $file->{content};
  }

  my $filename = $file->{filename};
  my $signature = $self->meta_prop->{digest}->{$filename} || $self->meta_prop->{digest}->{'*'};

  die "No digest for $filename" unless defined $signature && ref $signature eq 'ARRAY';

  my($algo, $expected) = @$signature;

  if($self->meta->call_hook( check_digest => $self, $file, $algo, $expected ))
  {
    # record the verification here so that we can check in the extract step that the signature
    # was checked.
    $self->install_prop->{download_detail}->{$path}->{digest} = [$algo, $expected] if defined $path; return 1;
  }
  else
  {
    die "No plugin provides digest algorithm for $algo";
  }
}


sub decode
{
  my($self, $res) = @_;
  my $res2 = $self->_call_hook( decode => $res );
  $res2->{protocol} = $res->{protocol}
    if !defined $res2->{protocol}
    &&  defined $res->{protocol};
  return $res2;
}


sub prefer
{
  my($self, $res) = @_;
  my $res2 = $self->_call_hook( prefer => $res );
  $res2->{protocol} = $res->{protocol}
    if !defined $res2->{protocol}
    &&  defined $res->{protocol};
  return $res2;
}


sub extract
{
  my($self, $archive) = @_;

  $archive ||= $self->install_prop->{download};

  unless(defined $archive)
  {
    die "tried to call extract before download";
  }

  {
    my $checked_digest  = 0;
    my $encrypted_fetch = 0;
    my $detail = $self->install_prop->{download_detail}->{$archive};
    if(defined $detail)
    {
      if(defined $detail->{digest})
      {
        my($algo, $expected) = @{ $detail->{digest} };
        my $file = {
          type     => 'file',
          filename => Path::Tiny->new($archive)->basename,
          path     => $archive,
          tmp      => 0,
        };
        $checked_digest = $self->meta->call_hook( check_digest => $self, $file, $algo, $expected )
      }
      if(!defined $detail->{protocol})
      {
        $self->log("warning: extract did not receive protocol details for $archive") unless $checked_digest;
      }
      elsif($detail->{protocol} !~ /^(https|file)$/)
      {
        $self->log("warning: extracting from a file that was fetched via insecure protocol @{[ $detail->{protocol} ]}") unless $checked_digest ;
      }
      else
      {
        $encrypted_fetch = 1;
      }
    }
    else
    {
      $self->log("warning: extract received no download details for $archive");
    }

    if($self->download_rule eq 'digest')
    {
      die "required digest missing for $archive" unless $checked_digest;
    }
    elsif($self->download_rule eq 'encrypt')
    {
      die "file was fetched insecurely for $archive" unless $encrypted_fetch;
    }
    elsif($self->download_rule eq 'digest_or_encrypt')
    {
      die "file was fetched insecurely and required digest missing for $archive" unless $checked_digest || $encrypted_fetch;
    }
    elsif($self->download_rule eq 'digest_and_encrypt')
    {
      die "file was fetched insecurely and required digest missing for $archive" unless $checked_digest || $encrypted_fetch;
      die "required digest missing for $archive" unless $checked_digest;
      die "file was fetched insecurely for $archive" unless $encrypted_fetch;
    }
    elsif($self->download_rule eq 'warn')
    {
      unless($checked_digest || $encrypted_fetch)
      {
        $self->log("!!! NOTICE OF FUTURE CHANGE IN BEHAVIOR !!!");
        $self->log("a future version of Alien::Build will die here by default with this exception: file was fetched insecurely and required digest missing for $archive");
        $self->log("!!! NOTICE OF FUTURE CHANGE IN BEHAVIOR !!!");
      }
    }
    else
    {
      die "internal error, unknown download rule: @{[ $self->download_rule ]}";
    }

  }

  my $nick_name = 'build';

  if($self->meta_prop->{out_of_source})
  {
    $nick_name = 'extract';
    my $extract = $self->install_prop->{extract};
    return $extract if defined $extract && -d $extract;
  }

  my $tmp;
  local $CWD;
  my $ret;

  $self->_call_hook({

    before => sub {
      # called build instead of extract, because this
      # will be used for the build step, and technically
      # extract is a substage of build anyway.
      $tmp = Alien::Build::TempDir->new($self, $nick_name);
      $CWD = "$tmp";
    },
    verify => sub {

      my $path = '.';
      if($self->meta_prop->{out_of_source} && $self->install_prop->{extract})
      {
        $path = $self->install_prop->{extract};
      }

      my @list = grep { $_->basename !~ /^\./ && $_->basename ne 'pax_global_header' } _path($path)->children;

      my $count = scalar @list;

      if($count == 0)
      {
        die "no files extracted";
      }
      elsif($count == 1 && -d $list[0])
      {
        $ret = $list[0]->absolute->stringify;
      }
      else
      {
        $ret = "$tmp";
      }

    },
    after => sub {
      $CWD = $self->root;
    },

  }, 'extract', $archive);

  $self->install_prop->{extract} ||= $ret;
  $ret ? $ret : ();
}


sub build
{
  my($self) = @_;

  # save the evironment, in case some plugins decide
  # to alter it.  Or us!  See just a few lines below.
  local %ENV = %ENV;

  my $stage = _path($self->install_prop->{stage});
  $stage->mkpath;

  my $tmp;

  if($self->install_type eq 'share')
  {
    foreach my $suffix ('', '_ffi')
    {
      local $CWD;
      delete $ENV{DESTDIR} unless $self->meta_prop->{destdir};

      my %env_meta = %{ $self->meta_prop   ->{env} || {} };
      my %env_inst = %{ $self->install_prop->{env} || {} };

      if($self->meta_prop->{env_interpolate})
      {
        foreach my $key (keys %env_meta)
        {
          $env_meta{$key} = $self->meta->interpolator->interpolate($env_meta{$key}, $self);
        }
      }

      %ENV = (%ENV, %env_meta);
      %ENV = (%ENV, %env_inst);

      my $destdir;

      $self->_call_hook(
      {
        before => sub {
          if($self->meta_prop->{out_of_source})
          {
            $self->extract;
            $CWD = $tmp = Alien::Build::TempDir->new($self, 'build');
          }
          else
          {
            $CWD = $tmp = $self->extract;
          }
          if($self->meta_prop->{destdir})
          {
            $destdir = Alien::Build::TempDir->new($self, 'destdir');
            $ENV{DESTDIR} = "$destdir";
          }
          $self->_call_hook({ all => 1 }, "patch${suffix}");
        },
        after => sub {
          $destdir = "$destdir" if $destdir;
        },
      }, "build${suffix}");

      $self->install_prop->{"_ab_build@{[ $suffix || '_share' ]}"} = "$CWD";

      $self->_call_hook("gather@{[ $suffix || '_share' ]}");
    }
  }

  elsif($self->install_type eq 'system')
  {
    local $CWD = $self->root;
    my $dir;

    $self->_call_hook(
      {
        before => sub {
          $dir = Alien::Build::TempDir->new($self, "gather");
          $CWD = "$dir";
        },
        after  => sub {
          $CWD = $self->root;
        },
      },
      'gather_system',
    );

    $self->install_prop->{finished} = 1;
    $self->install_prop->{complete}->{gather_system} = 1;
  }

  $self;
}


sub test
{
  my($self) = @_;

  if($self->install_type eq 'share')
  {
    foreach my $suffix ('_share', '_ffi')
    {
      if($self->meta->has_hook("test$suffix"))
      {
        my $dir = $self->install_prop->{"_ab_build$suffix"};
        Carp::croak("no build directory to run tests") unless $dir && -d $dir;
        local $CWD = $dir;
        $self->_call_hook("test$suffix");
      }
    }
  }
  else
  {
    if($self->meta->has_hook("test_system"))
    {
      my $dir = Alien::Build::TempDir->new($self, "test");
      local $CWD = "$dir";
      $self->_call_hook("test_system");
    }
  }

}


sub clean_install
{
  my($self) = @_;
  if($self->install_type eq 'share')
  {
    $self->_call_hook("clean_install");
  }
}


sub system
{
  my($self, $command, @args) = @_;

  my $prop = $self->_command_prop;

  ($command, @args) = map {
    $self->meta->interpolator->interpolate($_, $prop)
  } ($command, @args);

  $self->log("+ $command @args");

  scalar @args
    ? system $command, @args
    : system $command;
}


sub log
{
  my(undef, $message) = @_;
  my $caller = [caller];
  chomp $message;
  foreach my $line (split /\n/, $message)
  {
    Alien::Build::Log->default->log(
      caller  => $caller,
      message => $line,
    );
  }
}


{
  my %meta;

  sub meta
  {
    my($class) = @_;
    $class = ref $class if ref $class;
    $meta{$class} ||= Alien::Build::Meta->new( class => $class );
  }
}

package Alien::Build::Meta;

our @CARP_NOT = qw( alienfile );

sub new
{
  my($class, %args) = @_;
  my $self = bless {
    phase => 'any',
    build_suffix => '',
    require => {
      any    => {},
      share  => {},
      system => {},
    },
    around => {},
    prop => {},
    %args,
  }, $class;
  $self;
}


sub prop
{
  shift->{prop};
}

sub filename
{
  my($self, $new) = @_;
  $self->{filename} = $new if defined $new;
  $self->{filename};
}


sub add_requires
{
  my $self = shift;
  my $phase = shift;
  while(@_)
  {
    my $module = shift;
    my $version = shift;
    my $old = $self->{require}->{$phase}->{$module};
    if((!defined $old) || $version > $old)
    { $self->{require}->{$phase}->{$module} = $version }
  }
  $self;
}


sub interpolator
{
  my($self, $new) = @_;
  if(defined $new)
  {
    if(defined $self->{intr})
    {
      Carp::croak "tried to set interpolator twice";
    }
    if(ref $new)
    {
      $self->{intr} = $new;
    }
    else
    {
      $self->{intr} = $new->new;
    }
  }
  elsif(!defined $self->{intr})
  {
    require Alien::Build::Interpolate::Default;
    $self->{intr} = Alien::Build::Interpolate::Default->new;
  }
  $self->{intr};
}


sub has_hook
{
  my($self, $name) = @_;
  defined $self->{hook}->{$name};
}


sub _instr
{
  my($self, $name, $instr) = @_;
  if(ref($instr) eq 'CODE')
  {
    return $instr;
  }
  elsif(ref($instr) eq 'ARRAY')
  {
    my %phase = (
      download      => 'share',
      fetch         => 'share',
      decode        => 'share',
      prefer        => 'share',
      extract       => 'share',
      patch         => 'share',
      patch_ffi     => 'share',
      build         => 'share',
      build_ffi     => 'share',
      stage         => 'share',
      gather_ffi    => 'share',
      gather_share  => 'share',
      gather_system => 'system',
      test_ffi      => 'share',
      test_share    => 'share',
      test_system   => 'system',
    );
    require Alien::Build::CommandSequence;
    my $seq = Alien::Build::CommandSequence->new(@$instr);
    $seq->apply_requirements($self, $phase{$name} || 'any');
    return $seq;
  }
  else
  {
    Carp::croak "type not supported as a hook";
  }
}

sub register_hook
{
  my($self, $name, $instr) = @_;
  push @{ $self->{hook}->{$name} }, _instr $self, $name, $instr;
  $self;
}


sub default_hook
{
  my($self, $name, $instr) = @_;
  $self->{default_hook}->{$name} = _instr $self, $name, $instr;
  $self;
}


sub around_hook
{
  my($self, $name, $code) = @_;
  if(my $old = $self->{around}->{$name})
  {
    # this is the craziest shit I have ever
    # come up with.
    $self->{around}->{$name} = sub {
      my $orig = shift;
      $code->(sub { $old->($orig, @_) }, @_);
    };
  }
  else
  {
    $self->{around}->{$name} = $code;
  }
}


sub after_hook
{
  my($self, $name, $code) = @_;
  $self->around_hook(
    $name => sub {
      my $orig = shift;
      my $ret = $orig->(@_);
      $code->(@_);
      $ret;
    }
  );
}


sub before_hook
{
  my($self, $name, $code) = @_;
  $self->around_hook(
    $name => sub {
      my $orig = shift;
      $code->(@_);
      my $ret = $orig->(@_);
      $ret;
    }
  );
}


sub call_hook
{
  my $self = shift;
  my %args = ref $_[0] ? %{ shift() } : ();
  my($name, @args) = @_;
  my $error;

  my @hooks = @{ $self->{hook}->{$name} || []};

  if(@hooks == 0)
  {
    if(defined $self->{default_hook}->{$name})
    {
      @hooks = ($self->{default_hook}->{$name})
    }
    elsif(!$args{all})
    {
      Carp::croak "No hooks registered for $name";
    }
  }

  my $value;

  foreach my $hook (@hooks)
  {
    if(eval { $args[0]->isa('Alien::Build') })
    {
      %{ $args[0]->{hook_prop} } = (
        name => $name,
      );
    }

    my $wrapper = $self->{around}->{$name} || sub { my $code = shift; $code->(@_) };
    my $value;
    $args{before}->() if $args{before};
    if(ref($hook) eq 'CODE')
    {
      $value = eval {
        my $value = $wrapper->(sub { $hook->(@_) }, @args);
        $args{verify}->('code') if $args{verify};
        $value;
      };
    }
    else
    {
      $value = $wrapper->(sub {
        eval {
          $hook->execute(@_);
          $args{verify}->('command') if $args{verify};
        };
        defined $args{ok} ? $args{ok} : 1;
      }, @args);
    }
    $error = $@;
    $args{after}->() if $args{after};
    if($args{all})
    {
      die if $error;
    }
    else
    {
      next if $error;
      next if $args{continue} && $args{continue}->($value);
      return $value;
    }
  }

  die $error if $error && ! $args{all};

  $value;
}


sub apply_plugin
{
  my($self, $name, @args) = @_;

  my $class;
  my $pm;
  my $found;

  if($name =~ /^=(.*)$/)
  {
    $class = $1;
    $pm    = "$class.pm";
    $pm    =~ s!::!/!g;
    $found = 1;
  }

  if($name !~ /::/ && !$found)
  {
    foreach my $inc (@INC)
    {
      # TODO: allow negotiators to work with @INC hooks
      next if ref $inc;
      my $file = Path::Tiny->new("$inc/Alien/Build/Plugin/$name/Negotiate.pm");
      if(-r $file)
      {
        $class = "Alien::Build::Plugin::${name}::Negotiate";
        $pm    = "Alien/Build/Plugin/$name/Negotiate.pm";
        $found = 1;
        last;
      }
    }
  }

  unless($found)
  {
    $class = "Alien::Build::Plugin::$name";
    $pm    = "Alien/Build/Plugin/$name.pm";
    $pm    =~ s{::}{/}g;
  }

  require $pm unless $class->can('new');
  my $plugin = $class->new(@args);
  $plugin->init($self);
  $self;
}

package Alien::Build::TempDir;

# TODO: it's confusing that there is both a AB::TempDir and AB::Temp
# although they do different things.  there could maybe be a better
# name for AB::TempDir (maybe AB::TempBuildDir, though that is a little
# redundant).  Happily both are private classes, and either are able to
# rename, if a good name can be thought of.

use overload '""' => sub { shift->as_string }, bool => sub { 1 }, fallback => 1;
use File::Temp qw( tempdir );

sub new
{
  my($class, $build, $name) = @_;
  my $root = $build->install_prop->{root};
  Path::Tiny->new($root)->mkpath unless -d $root;
  bless {
    dir => Path::Tiny->new(tempdir( "${name}_XXXX", DIR => $root)),
  }, $class;
}

sub as_string
{
  shift->{dir}->stringify;
}

sub DESTROY
{
  my($self) = @_;
  if(-d $self->{dir} && $self->{dir}->children == 0)
  {
    rmdir($self->{dir}) || warn "unable to remove @{[ $self->{dir} ]} $!";
  }
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build - Build external dependencies for use in CPAN

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 my $build = Alien::Build->load('./alienfile');
 $build->load_requires('configure');
 $build->set_prefix('/usr/local');
 $build->set_stage('/foo/mystage');  # needs to be absolute
 $build->load_requires($build->install_type);
 $build->download;
 $build->build;
 # files are now in /foo/mystage, it is your job (or
 # ExtUtils::MakeMaker, Module::Build, etc) to copy
 # those files into /usr/local

=head1 DESCRIPTION

This module provides tools for building external (non-CPAN) dependencies
for CPAN.  It is mainly designed to be used at install time of a CPAN
client, and work closely with L<Alien::Base> which is used at runtime.

This is the detailed documentation for the L<Alien::Build> class.
If you are starting out you probably want to do so from one of these documents:

=over 4

=item L<Alien::Build::Manual::Alien>

A broad overview of C<Alien-Build> and its ecosystem.

=item L<Alien::Build::Manual::AlienUser>

For users of an C<Alien::libfoo> that is implemented using L<Alien::Base>.
(The developer of C<Alien::libfoo> I<should> provide the documentation
necessary, but if not, this is the place to start).

=item L<Alien::Build::Manual::AlienAuthor>

If you are writing your own L<Alien> based on L<Alien::Build> and L<Alien::Base>.

=item L<Alien::Build::Manual::FAQ>

If you have a common question that has already been answered, like
"How do I use L<alienfile> with some build system".

=item L<Alien::Build::Manual::PluginAuthor>

This is for the brave souls who want to write plugins that will work with
L<Alien::Build> + L<alienfile>.

=item L<Alien::Build::Manual::Security>

If you are concerned that L<Alien>s might be downloading tarballs off
the internet, then this is the place for you.  This will discuss some
of the risks of downloading (really any) software off the internet
and will give you some tools to remediate these risks.

=back

Note that you will not usually create a L<Alien::Build> instance
directly, but rather be using a thin installer layer, such as
L<Alien::Build::MM> (for use with L<ExtUtils::MakeMaker>) or
L<Alien::Build::MB> (for use with L<Module::Build>).  One of the
goals of this project is to remain installer agnostic.

=head1 CONSTRUCTORS

=head2 new

 my $build = Alien::Build->new;

This creates a new empty instance of L<Alien::Build>.  Normally you will
want to use C<load> below to create an instance of L<Alien::Build> from
an L<alienfile> recipe.

=head2 load

 my $build = Alien::Build->load($alienfile);

This creates an L<Alien::Build> instance with the given L<alienfile>
recipe.

=head2 resume

 my $build = Alien::Build->resume($alienfile, $root);

Load a checkpointed L<Alien::Build> instance.  You will need the original
L<alienfile> and the build root (usually C<_alien>), and a build that
had been properly checkpointed using the C<checkpoint> method below.

=head1 PROPERTIES

There are three main properties for L<Alien::Build>.  There are a number
of properties documented here with a specific usage.  Note that these
properties may need to be serialized into something primitive like JSON
that does not support: regular expressions, code references of blessed
objects.

If you are writing a plugin (L<Alien::Build::Plugin>) you should use a
prefix like "plugin_I<name>" (where I<name> is the name of your plugin)
so that it does not interfere with other plugin or future versions of
L<Alien::Build>.  For example, if you were writing
C<Alien::Build::Plugin::Fetch::NewProtocol>, please use the prefix
C<plugin_fetch_newprotocol>:

 sub init
 {
   my($self, $meta) = @_;
 
   $meta->prop( plugin_fetch_newprotocol_foo => 'some value' );
 
   $meta->register_hook(
     some_hook => sub {
       my($build) = @_;
       $build->install_prop->{plugin_fetch_newprotocol_bar} = 'some other value';
       $build->runtime_prop->{plugin_fetch_newprotocol_baz} = 'and another value';
     }
   );
 }

If you are writing a L<alienfile> recipe please use the prefix C<my_>:

 use alienfile;
 
 meta_prop->{my_foo} = 'some value';
 
 probe sub {
   my($build) = @_;
   $build->install_prop->{my_bar} = 'some other value';
   $build->install_prop->{my_baz} = 'and another value';
 };

Any property may be used from a command:

 probe [ 'some command %{.meta.plugin_fetch_newprotocol_foo}' ];
 probe [ 'some command %{.install.plugin_fetch_newprotocol_bar}' ];
 probe [ 'some command %{.runtime.plugin_fetch_newprotocol_baz}' ];
 probe [ 'some command %{.meta.my_foo}' ];
 probe [ 'some command %{.install.my_bar}' ];
 probe [ 'some command %{.runtime.my_baz}' ];

=head2 meta_prop

 my $href = $build->meta_prop;
 my $href = Alien::Build->meta_prop;

Meta properties have to do with the recipe itself, and not any particular
instance that probes or builds that recipe.  Meta properties can be changed
from within an L<alienfile> using the C<meta_prop> directive, or from
a plugin from its C<init> method (though should NOT be modified from any
hooks registered within that C<init> method).  This is not strictly enforced,
but if you do not follow this rule your recipe will likely be broken.

=over

=item arch

This is a hint to an installer like L<Alien::Build::MM> or L<Alien::Build::MB>,
that the library or tool contains architecture dependent files and so should
be stored in an architecture dependent location.  If not specified by your
L<alienfile> then it will be set to true.

=item check_digest

True if cryptographic digest should be checked when files are fetched
or downloaded.  This is set by
L<Digest negotiator plugin|Alien::Build::Plugin::Digest::Negotiate>.

=item destdir

Some plugins (L<Alien::Build::Plugin::Build::Autoconf> for example) support
installing via C<DESTDIR>.  They will set this property to true if they
plan on doing such an install.  This helps L<Alien::Build> find the staged
install files and how to locate them.

If available, C<DESTDIR> is used to stage install files in a sub directory before
copying the files into C<blib>.  This is generally preferred method
if available.

=item destdir_filter

Regular expression for the files that should be copied from the C<DESTDIR>
into the stage directory.  If not defined, then all files will be copied.

=item destdir_ffi_filter

Same as C<destdir_filter> except applies to C<build_ffi> instead of C<build>.

=item digest

This properties contains the cryptographic digests (if any) that should
be used when verifying any fetched and downloaded files.  It is a hash
reference where the key is the filename and the value is an array
reference containing a pair of values, the first being the algorithm
('SHA256' is recommended) and the second is the actual digest.  The
special filename C<*> may be specified to indicate that any downloaded
file should match that digest.  If there are both real filenames and
the C<*> placeholder, the real filenames will be used for filenames
that match and any other files will use the placeholder.  Example:

 $build->meta_prop->{digest} = {
   'foo-1.00.tar.gz' => [ SHA256 => '9feac593aa49a44eb837de52513a57736457f1ea70078346c60f0bfc5f24f2c1' ],
   'foo-1.01.tar.gz' => [ SHA256 => '6bbde6a7f10ae5924cf74afc26ff5b7bc4b4f9dfd85c6b534c51bd254697b9e7' ],
   '*'               => [ SHA256 => '33a20aae3df6ecfbe812b48082926d55391be4a57d858d35753ab1334b9fddb3' ],
 };

Cryptographic signatures will only be checked
if the L<check_digest meta property|/check_digest> is set and if the
L<Digest negotiator plugin|Alien::Build::Plugin::Digest::Negotiate> is loaded.
(The Digest negotiator can be used directly, but is also loaded automatically
if you use the L<digest directive|alienfile/digest> is used by the L<alienfile>).

=item env

Environment variables to override during the build stage.

=item env_interpolate

Environment variable values will be interpolated with helpers.  Example:

 meta->prop->{env_interpolate} = 1;
 meta->prop->{env}->{PERL} = '%{perl}';

=item local_source

Set to true if source code package is available locally.  (that is not fetched
over the internet).  This is computed by default based on the C<start_url>
property.  Can be set by an L<alienfile> or plugin.

=item platform

Hash reference.  Contains information about the platform beyond just C<$^O>.

=over 4

=item platform.compiler_type

Refers to the type of flags that the compiler accepts.  May be expanded in the
future, but for now, will be one of:

=over 4

=item microsoft

On Windows when using Microsoft Visual C++

=item unix

Virtually everything else, including gcc on windows.

=back

The main difference is that with Visual C++ C<-LIBPATH> should be used instead
of C<-L>, and static libraries should have the C<.LIB> suffix instead of C<.a>.

=item platform.system_type

C<$^O> is frequently good enough to make platform specific logic in your
L<alienfile>, this handles the case when $^O can cover platforms that provide
multiple environments that Perl might run under.  The main example is windows,
but others may be added in the future.

=over 4

=item unix

=item vms

=item windows-activestate

=item windows-microsoft

=item windows-mingw

=item windows-strawberry

=item windows-unknown

=back

Note that C<cygwin> and C<msys> are considered C<unix> even though they run
on windows!

=item platform.cpu.count

Contains a non-negative integer of available (possibly virtual) CPUs on the
system. This can be used by build plugins to build in parallel. The environment
variable C<ALIEN_CPU_COUNT> can be set to override the CPU count.

=item platform.cpu.arch.name

Contains a normalized name for the architecture of the current Perl. This can
be used by fetch plugins to determine which binary packages to download.
The value may be one of the following, but this list will be expanded as
needed.

=over 4

=item C<armel>

32-bit ARM soft-float

=item C<armhf>

32-bit ARM hard-float

=item C<aarch64>

64-bit ARM

=item C<ppc>

32-bit PowerPC (big-endian)

=item C<ppc64>

64-bit PowerPC (big-endian)

=item C<x86>

32-bit Intel (i386, i486, i686)

=item C<x86_64>

64-bit Intel (AMD64)

=item C<unknown>

Unable to detect architecture. Please report this if needed.

=back

=back

=item out_of_source

Build in a different directory from the where the source code is stored.
In autoconf this is referred to as a "VPATH" build.  Everyone else calls this
an "out-of-source" build.  When this property is true, instead of extracting
to the source build root, the downloaded source will be extracted to an source
extraction directory and the source build root will be empty.  You can use the
C<extract> install property to get the location of the extracted source.

=item network

True if a network fetch is available.  This should NOT be set by an L<alienfile>
or plugin.  This is computed based on the C<ALIEN_INSTALL_NETWORK> environment
variables.

=item start_url

The default or start URL used by fetch plugins.

=back

=head2 install_prop

 my $href = $build->install_prop;

Install properties are used during the install phase (either
under C<share> or C<system> install).  They are remembered for
the entire install phase, but not kept around during the runtime
phase.  Thus they cannot be accessed from your L<Alien::Base>
based module.

=over

=item autoconf_prefix

The prefix as understood by autoconf.  This is only different on Windows
Where MSYS is used and paths like C<C:/foo> are  represented as C</C/foo>
which are understood by the MSYS tools, but not by Perl.  You should
only use this if you are using L<Alien::Build::Plugin::Build::Autoconf> in
your L<alienfile>.  This is set during before the
L<build hook|Alien::Build::Manual::PluginAuthor/"build hook"> is run.

=item download

The location of the downloaded archive (tar.gz, or similar) or directory.
This will be undefined until the archive is actually downloaded.

=item download_detail

This property contains optional details about a downloaded file.  This
property is populated by L<Alien::Build> core.  This property is a
hash reference.  The key is the path to the file that has been downloaded
and the value is a hash reference with additional detail.  All fields
are optional.

=over 4

=item download_detail.digest

This, if available, with the cryptographic signature that was successfully
matched against the downloaded file.  It is an array reference with a
pair of values, the algorithm (typically something like C<SHA256>) and
the digest.

=item download_detail.protocol

This, if available, will be the URL protocol used to fetch the downloaded
file.

=back

=item env

Environment variables to override during the build stage.  Plugins are
free to set additional overrides using this hash.

=item extract

The location of the last source extraction.  For a "out-of-source" build
(see the C<out_of_source> meta property above), this will only be set once.
For other types of builds, the source code may be extracted multiple times,
and thus this property may change.

=item old

[deprecated]

Hash containing information on a previously installed Alien of the same
name, if available.  This may be useful in cases where you want to
reuse the previous install if it is still sufficient.

=over 4

=item old.prefix

[deprecated]

The prefix for the previous install.  Versions prior to 1.42 unfortunately
had this in typo form of C<preifx>.

=item old.runtime

[deprecated]

The runtime properties from the previous install.

=back

=item patch

Directory with patches, if available.  This will be C<undef> if there
are no patches.  When initially installing an alien this will usually
be a sibling of the C<alienfile>, a directory called C<patch>.  Once
installed this will be in the share directory called C<_alien/patch>.
The former is useful for rebuilding an alienized package using
L<af>.

=item prefix

The install time prefix.  Under a C<destdir> install this is the
same as the runtime or final install location.  Under a non-C<destdir>
install this is the C<stage> directory (usually the appropriate
share directory under C<blib>).

=item root

The build root directory.  This will be an absolute path.  It is the
absolute form of C<./_alien> by default.

=item stage

The stage directory where files will be copied.  This is usually the
root of the blib share directory.

=item system_probe_class

After the probe step this property may contain the plugin class that
performed the system probe.  It shouldn't be filled in directly by
the plugin (instead if should use the hook property C<probe_class>,
see below).  This is optional, and not all probe plugins will provide
this information.

=item system_probe_instance_id

After the probe step this property may contain the plugin instance id that
performed the system probe.  It shouldn't be filled in directly by
the plugin (instead if should use the hook property C<probe_instance_id>,
see below).  This is optional, and not all probe plugins will provide
this information.

=back

=head2 plugin_instance_prop

 my $href = $build->plugin_instance_prop($plugin);

This returns the private plugin instance properties for a given plugin.
This method should usually only be called internally by plugins themselves
to keep track of internal state.  Because the content can be used arbitrarily
by the owning plugin because it is private to the plugin, and thus is not
part of the L<Alien::Build> spec.

=head2 runtime_prop

 my $href = $build->runtime_prop;

Runtime properties are used during the install and runtime phases
(either under C<share> or C<system> install).  This should include
anything that you will need to know to use the library or tool
during runtime, and shouldn't include anything that is no longer
relevant once the install process is complete.

=over 4

=item alien_build_version

The version of L<Alien::Build> used to install the library or tool.

=item alt

Alternate configurations.  If the alienized package has multiple
libraries this could be used to store the different compiler or
linker flags for each library.  Typically this will be set by a
plugin in the gather stage (for either share or system installs).

=item cflags

The compiler flags.  This is typically set by a plugin in the
gather stage (for either share or system installs).

=item cflags_static

The static compiler flags.  This is typically set by a plugin in the
gather stage (for either share or system installs).

=item command

The command name for tools where the name my differ from platform to
platform.  For example, the GNU version of make is usually C<make> in
Linux and C<gmake> on FreeBSD.  This is typically set by a plugin in the
gather stage (for either share or system installs).

=item ffi_name

The name DLL or shared object "name" to use when searching for dynamic
libraries at runtime.  This is passed into L<FFI::CheckLib>, so if
your library is something like C<libarchive.so> or C<archive.dll> you
would set this to C<archive>.  This may be a string or an array of
strings.  This is typically set by a plugin in the gather stage
(for either share or system installs).

=item ffi_checklib

This property contains two sub properties:

=over 4

=item ffi_checklib.share

 $build->runtime_prop->{ffi_checklib}->{share} = [ ... ];

Array of additional L<FFI::CheckLib> flags to pass in to C<find_lib>
for a C<share> install.

=item ffi_checklib.system

Array of additional L<FFI::CheckLib> flags to pass in to C<find_lib>
for a C<system> install.

Among other things, useful for specifying the C<try_linker_script>
flag:

 $build->runtime_prop->{ffi_checklib}->{system} = [ try_linker_script => 1 ];

=back

This is typically set by a plugin in the gather stage
(for either share or system installs).

=item inline_auto_include

[version 2.53]

This property is an array reference of C code that will be passed into
L<Inline::C> to make sure that appropriate headers are automatically
included.  See L<Inline::C/auto_include> for details.

=item install_type

The install type.  This is set by AB core after the
L<probe hook|Alien::Build::Manual::PluginAuthor/"probe hook"> is
executed.  Is one of:

=over 4

=item system

For when the library or tool is provided by the operating system, can be
detected by L<Alien::Build>, and is considered satisfactory by the
C<alienfile> recipe.

=item share

For when a system install is not possible, the library source will be
downloaded from the internet or retrieved in another appropriate fashion
and built.

=back

=item libs

The library flags.  This is typically set by a plugin in the
gather stage (for either share or system installs).

=item libs_static

The static library flags.  This is typically set by a plugin in the
gather stage (for either share or system installs).

=item perl_module_version

The version of the Perl module used to install the alien (if available).
For example if L<Alien::curl> is installing C<libcurl> this would be the
version of L<Alien::curl> used during the install step.

=item prefix

The final install root.  This is usually they share directory.

=item version

The version of the library or tool.  This is typically set by a plugin in the
gather stage (for either share or system installs).

=back

=head2 hook_prop

 my $href = $build->hook_prop;

Hook properties are for the currently running (if any) hook.  They are
used only during the execution of each hook and are discarded after.
If no hook is currently running then C<hook_prop> will return C<undef>.

=over 4

=item name

The name of the currently running hook.

=item version (probe)

Probe and PkgConfig plugins I<may> set this property indicating the
version of the alienized package.  Not all plugins and configurations
may be able to provide this.

=item probe_class (probe)

Probe and PkgConfig plugins I<may> set this property indicating the
plugin class that made the probe.  If the probe results in a system
install this will be propagated to C<system_probe_class> for later
use.

=item probe_instance_id (probe)

Probe and PkgConfig plugins I<may> set this property indicating the
plugin instance id that made the probe.  If the probe results in a
system install this will be propagated to C<system_probe_instance_id>
for later use.

=back

=head1 METHODS

=head2 checkpoint

 $build->checkpoint;

Save any install or runtime properties so that they can be reloaded on
a subsequent run in a separate process.  This is useful if your build
needs to be done in multiple stages from a C<Makefile>, such as with
L<ExtUtils::MakeMaker>.  Once checkpointed you can use the C<resume>
constructor (documented above) to resume the probe/build/install]
process.

=head2 root

 my $dir = $build->root;

This is just a shortcut for:

 my $root = $build->install_prop->{root};

Except that it will be created if it does not already exist.

=head2 install_type

 my $type = $build->install_type;

This will return the install type.  (See the like named install property
above for details).  This method will call C<probe> if it has not already
been called.

=head2 download_rule

 my $rule = $build->download_rule;

This returns install rule as a string.  This is determined by the environment
and should be one of:

=over 4

=item C<warn>

Warn only if fetching via non secure source (secure sources include C<https>,
and bundled files, may include other encrypted protocols in the future).

=item C<digest>

Require that any downloaded source package have a cryptographic signature in
the L<alienfile> and that signature matches what was downloaded.

=item C<encrypt>

Require that any downloaded source package is fetched via secure source.

=item C<digest_or_encrypt>

Require that any downloaded source package is B<either> fetched via a secure source
B<or> has a cryptographic signature in the L<alienfile> and that signature matches
what was downloaded.

=item C<digest_and_encrypt>

Require that any downloaded source package is B<both> fetched via a secure source
B<and> has a cryptographic signature in the L<alienfile> and that signature matches
what was downloaded.

=back

The current default is C<warn>, but in the near future this will be upgraded to
C<digest_or_encrypt>.

=head2 set_prefix

 $build->set_prefix($prefix);

Set the final (unstaged) prefix.  This is normally only called by L<Alien::Build::MM>
and similar modules.  It is not intended for use from plugins or from an L<alienfile>.

=head2 set_stage

 $build->set_stage($dir);

Sets the stage directory.  This is normally only called by L<Alien::Build::MM>
and similar modules.  It is not intended for use from plugins or from an L<alienfile>.

=head2 requires

 my $hash = $build->requires($phase);

Returns a hash reference of the modules required for the given phase.  Phases
include:

=over 4

=item configure

These modules must already be available when the L<alienfile> is read.

=item any

These modules are used during either a C<system> or C<share> install.

=item share

These modules are used during the build phase of a C<share> install.

=item system

These modules are used during the build phase of a C<system> install.

=back

=head2 load_requires

 $build->load_requires($phase);

This loads the appropriate modules for the given phase (see C<requires> above
for a description of the phases).

=head2 probe

 my $install_type = $build->probe;

Attempts to determine if the operating system has the library or
tool already installed.  If so, then the string C<system> will
be returned and a system install will be performed.  If not,
then the string C<share> will be installed and the tool or
library will be downloaded and built from source.

If the environment variable C<ALIEN_INSTALL_TYPE> is set, then that
will force a specific type of install.  If the detection logic
cannot accommodate the install type requested then it will fail with
an exception.

=head2 download

 $build->download;

Download the source, usually as a tarball, usually from the internet.

Under a C<system> install this does not do anything.

=head2 fetch

 my $res = $build->fetch;
 my $res = $build->fetch($url, %options);

Fetch a resource using the fetch hook.  Returns the same hash structure
described below in the
L<fetch hook|Alien::Build::Manual::PluginAuthor/"fetch hook"> documentation.

[version 2.39]

As of L<Alien::Build> 2.39, these options are supported:

=over 4

=item http_headers

 my $res = $build->fetch($url, http_headers => [ $key1 => $value1, $key2 => $value 2, ... ]);

Set the HTTP request headers on all outgoing HTTP requests.  Note that not all
protocols or fetch plugins support setting request headers, but the ones that
do not I<should> issue a warning if you try to set request headers and they
are not supported.

=back

=head2 check_digest

[experimental]

 my $bool = $build->check_digest($path);

Checks any cryptographic signatures for the given file.  The
file is specified by C<$path> which may be one of:

=over 4

=item string

Containing the path to the file to be checked.

=item L<Path::Tiny>

Containing the path to the file to be checked.

=item C<HASH>

A Hash reference containing information about a file.  See
the L<fetch hook|Alien::Build::Manual::PluginAuthor/"fetch hook"> for details
on the format.

=back

Returns true if the cryptographic signature matches, false if cryptographic
signatures are disabled.  Will throw an exception if the signature does not
match, or if no plugin provides the correct algorithm for checking the
signature.

=head2 decode

 my $decoded_res = $build->decode($res);

Decode the HTML or file listing returned by C<fetch>.  Returns the same
hash structure described below in the
L<decode hook|Alien::Build::Manual::PluginAuthor/"decode hook"> documentation.

=head2 prefer

 my $sorted_res = $build->prefer($res);

Filter and sort candidates.  The preferred candidate will be returned first in the list.
The worst candidate will be returned last.  Returns the same hash structure described
below in the
L<prefer hook|Alien::Build::Manual::PluginAuthor/"prefer hook"> documentation.

=head2 extract

 my $dir = $build->extract;
 my $dir = $build->extract($archive);

Extracts the given archive into a fresh directory.  This is normally called internally
to L<Alien::Build>, and for normal usage is not needed from a plugin or L<alienfile>.

=head2 build

 $build->build;

Run the build step.  It is expected that C<probe> and C<download>
have already been performed.  What it actually does depends on the
type of install:

=over 4

=item share

The source is extracted, and built as determined by the L<alienfile>
recipe.  If there is a C<gather_share> that will be executed last.

=item system

The
L<gather_system hook|Alien::Build::Manual::PluginAuthor/"gather_system hook">
will be executed.

=back

=head2 test

 $build->test;

Run the test phase

=head2 clean_install

 $build->clean_install

Clean files from the final install location.  The default implementation removes all
files recursively except for the C<_alien> directory.  This is helpful when you have
an old install with files that may break the new build.

For a non-share install this doesn't do anything.

=head2 system

 $build->system($command);
 $build->system($command, @args);

Interpolates the command and arguments and run the results using
the Perl C<system> command.

=head2 log

 $build->log($message);

Send a message to the log.  By default this prints to C<STDOUT>.

=head2 meta

 my $meta = Alien::Build->meta;
 my $meta = $build->meta;

Returns the meta object for your L<Alien::Build> class or instance.  The
meta object is a way to manipulate the recipe, and so any changes to the
meta object should be made before the C<probe>, C<download> or C<build> steps.

=head1 META METHODS

=head2 prop

 my $href = $build->meta->prop;

Meta properties.  This is the same as calling C<meta_prop> on
the class or L<Alien::Build> instance.

=head2 add_requires

 Alien::Build->meta->add_requires($phase, $module => $version, ...);

Add the requirement to the given phase.  Phase should be one of:

=over 4

=item configure

=item any

=item share

=item system

=back

=head2 interpolator

 my $interpolator = $build->meta->interpolator;
 my $interpolator = Alien::Build->interpolator;

Returns the L<Alien::Build::Interpolate> instance for the L<Alien::Build> class.

=head2 has_hook

 my $bool = $build->meta->has_hook($name);
 my $bool = Alien::Build->has_hook($name);

Returns if there is a usable hook registered with the given name.

=head2 register_hook

 $build->meta->register_hook($name, $instructions);
 Alien::Build->meta->register_hook($name, $instructions);

Register a hook with the given name.  C<$instruction> should be either
a code reference, or a command sequence, which is an array reference.

=head2 default_hook

 $build->meta->default_hook($name, $instructions);
 Alien::Build->meta->default_hook($name, $instructions);

Register a default hook, which will be used if the L<alienfile> does not
register its own hook with that name.

=head2 around_hook

 $build->meta->around_hook($hook_name, $code);
 Alien::Build->meta->around_hook($hook_name, $code);

Wrap the given hook with a code reference.  This is similar to a L<Moose>
method modifier, except that it wraps around the given hook instead of
a method.  For example, this will add a probe system requirement:

 $build->meta->around_hook(
   probe => sub {
     my $orig = shift;
     my $build = shift;
     my $type = $orig->($build, @_);
     return $type unless $type eq 'system';
     # also require a configuration file
     if(-f '/etc/foo.conf')
     {
       return 'system';
     }
     else
     {
       return 'share';
     }
   },
 );

=head2 after_hook

 $build->meta->after_hook($hook_name, sub {
   my(@args) = @_;
   ...
 });

Execute the given code reference after the hook.  The original
arguments are passed into the code reference.

=head2 before_hook

 $build->meta->before_hook($hook_name, sub {
   my(@args) = @_;
   ...
 });

Execute the given code reference before the hook.  The original
arguments are passed into the code reference.

=head2 apply_plugin

 Alien::Build->meta->apply_plugin($name);
 Alien::Build->meta->apply_plugin($name, @args);

Apply the given plugin with the given arguments.

=head1 ENVIRONMENT

L<Alien::Build> responds to these environment variables:

=over 4

=item ALIEN_BUILD_LOG

The default log class used.  See L<Alien::Build::Log> and L<Alien::Build::Log::Default>.

=item ALIEN_BUILD_PKG_CONFIG

Override the logic in L<Alien::Build::Plugin::PkgConfig::Negotiate> which
chooses the best C<pkg-config> plugin.

=item ALIEN_BUILD_POSTLOAD

semicolon separated list of plugins to automatically load after parsing
your L<alienfile>.

=item ALIEN_BUILD_PRELOAD

semicolon separated list of plugins to automatically load before parsing
your L<alienfile>.

=item ALIEN_BUILD_RC

Perl source file which can override some global defaults for L<Alien::Build>,
by, for example, setting preload and postload plugins.

=item ALIEN_DOWNLOAD_RULE

This value determines the rules by which types of downloads are allowed.  The legal
values listed under L</download_rule>, plus C<default> which will be the default for
the current version of L<Alien::Build>.  For this version that default is C<warn>.

=item ALIEN_INSTALL_NETWORK

If set to true (the default), then network fetch will be allowed.  If set to
false, then network fetch will not be allowed.

What constitutes a local vs. network fetch is determined based on the C<start_url>
and C<local_source> meta properties.  An L<alienfile> or plugin C<could> override
this detection (possibly inappropriately), so this variable is not a substitute
for properly auditing of Perl modules for environments that require that.

=item ALIEN_INSTALL_TYPE

If set to C<share> or C<system>, it will override the system detection logic.
If set to C<default>, it will use the default setting for the L<alienfile>.
The behavior of other values is undefined.

Although the recommended way for a consumer to use an L<Alien::Base> based L<Alien>
is to declare it as a static configure and build-time dependency, some consumers
may prefer to fallback on using an L<Alien> only when the consumer itself cannot
detect the necessary package. In some cases the consumer may want the user to opt-in
to using an L<Alien> before requiring it.

To keep the interface consistent among Aliens, the consumer of the fallback opt-in
L<Alien> may fallback on the L<Alien> if the environment variable C<ALIEN_INSTALL_TYPE>
is set to any value. The rationale is that by setting this environment variable the
user is aware that L<Alien> modules may be installed and have indicated consent.
The actual implementation of this, by its nature would have to be in the consuming
CPAN module.

=item DESTDIR

This environment variable will be manipulated during a destdir install.

=item PKG_CONFIG

This environment variable can be used to override the program name for C<pkg-config>
when using the command line plugin: L<Alien::Build::Plugin::PkgConfig::CommandLine>.

=item ftp_proxy, all_proxy

If these environment variables are set, it may influence the Download negotiation
plugin L<Alien::Build::Plugin::Download::Negotiate>.  Other proxy variables may
be used by some Fetch plugins, if they support it.

=back

=head1 SUPPORT

The intent of the C<Alien-Build> team is to support the same versions of
Perl that are supported by the Perl toolchain.  As of this writing that
means 5.16 and better.

Please feel encouraged to report issues that you encounter to the
project GitHub Issue tracker:

=over 4

=item L<https://github.com/PerlAlien/Alien-Build/issues>

=back

Better if you can fix the issue yourself, please feel encouraged to open
pull-request on the project GitHub:

=over 4

=item L<https://github.com/PerlAlien/Alien-Build/pulls>

=back

If you are confounded and have questions, join us on the C<#native>
channel on irc.perl.org.  The C<Alien-Build> developers frequent this
channel and can probably help point you in the right direction.  If you
don't have an IRC client handy, you can use this web interface:

=over 4

=item L<https://chat.mibbit.com/?channel=%23native&server=irc.perl.org>

=back

=head1 SEE ALSO

L<Alien::Build::Manual::AlienAuthor>,
L<Alien::Build::Manual::AlienUser>,
L<Alien::Build::Manual::Contributing>,
L<Alien::Build::Manual::FAQ>,
L<Alien::Build::Manual::PluginAuthor>

L<alienfile>, L<Alien::Build::MM>, L<Alien::Build::Plugin>, L<Alien::Base>, L<Alien>

=head1 THANKS

L<Alien::Base> was originally written by Joel Berger, the rest of this project would
not have been possible without him getting the project started.  Thanks to his support
I have been able to augment the original L<Alien::Base> system with a reliable set
of tools (L<Alien::Build>, L<alienfile>, L<Test::Alien>), which make up this toolset.

The original L<Alien::Base> is still copyright (c) 2012-2020 Joel Berger.  It has
the same license as the rest of the Alien::Build and related tools distributed as
C<Alien-Build>.  Joel Berger thanked a number of people who helped in in the development
of L<Alien::Base>, in the documentation for that module.

I would also like to acknowledge the other members of the PerlAlien github
organization, Zakariyya Mughal (sivoais, ZMUGHAL) and mohawk (ETJ).  Also important
in the early development of L<Alien::Build> were the early adopters Chase Whitener
(genio, CAPOEIRAB, author of L<Alien::libuv>), William N. Braswell, Jr (willthechill,
WBRASWELL, author of L<Alien::JPCRE2> and L<Alien::PCRE2>) and Ahmad Fatoum (a3f,
ATHREEF, author of L<Alien::libudev> and L<Alien::LibUSB>).

The Alien ecosystem owes a debt to Dan Book, who goes by Grinnz on IRC, for answering
question about how to use L<Alien::Build> and friends.

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! 5f�(�  �    perl5/Alien/Base/FAQ.podnu ��6�$        # ABSTRACT: Frequently asked questions
# VERSION
# PODNAME: Alien::Base::FAQ

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Base::FAQ - Frequently asked questions

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 % perldoc Alien::Build::Manual::FAQ
 % perldoc Alien::Base::ModuleBuild::FAQ

=head1 DESCRIPTION

This used to answer FAQs regarding the only way to author an L<Alien::Build>
distribution, which was with L<Alien::Base::ModuleBuild>.  You should now
seriously consider using the newer more reliable method which is via
L<Alien::Build> and L<alienfile>.

=over 4

=item L<Alien::Build::Manual::FAQ>

=item L<Alien::Base::ModuleBuild::FAQ>

=back

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! �r�  �    perl5/Alien/Base/Authoring.podnu ��6�$        # ABSTRACT: Authoring an Alien distribution using Alien::Base
# PODNAME: Alien::Base::Authoring

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Base::Authoring - Authoring an Alien distribution using Alien::Base

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 % perldoc Alien::Build::Manual::AlienAuthor
 % perldoc Alien::Base::ModuleBuild::Authoring

=head1 DESCRIPTION

This used to document the only way to author an L<Alien> distribution, which
was with L<Alien::Base::ModuleBuild>.  You should now seriously consider using
the newer more reliable method which is via L<Alien::Build> and L<alienfile>. Read all about it in L<Alien::Build::Manual::AlienAuthor> and L<Alien::Base::ModuleBuild::Authoring>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! )��l�4  �4    perl5/Alien/Base/Wrapper.pmnu ��6�$        package Alien::Base::Wrapper;

use strict;
use warnings;
use 5.006;
use Config;
use Text::ParseWords qw( shellwords );

# NOTE: Although this module is now distributed with Alien-Build,
# it should have NO non-perl-core dependencies for all Perls
# 5.6.0-5.30.1 (as of this writing, and any Perl more recent).
# You should be able to extract this module from the rest of
# Alien-Build and use it by itself.  (There is a dzil plugin
# for this [AlienBase::Wrapper::Bundle]

# ABSTRACT: Compiler and linker wrapper for Alien
our $VERSION = '2.83'; # VERSION


sub _join
{
  join ' ',
    map {
      my $x = $_;
      $x =~ s/(\s)/\\$1/g;
      $x;
    } @_;
}

sub new
{
  my($class, @aliens) = @_;

  my $export = 1;
  my $writemakefile = 0;

  my @cflags_I;
  my @cflags_other;
  my @ldflags_L;
  my @ldflags_l;
  my @ldflags_other;
  my %requires = (
    'ExtUtils::MakeMaker'  => '6.52',
    'Alien::Base::Wrapper' => '1.97',
  );

  foreach my $alien (@aliens)
  {
    if($alien eq '!export')
    {
      $export = 0;
      next;
    }
    if($alien eq 'WriteMakefile')
    {
      $writemakefile = 1;
      next;
    }
    my $version = 0;
    if($alien =~ s/=(.*)$//)
    {
      $version = $1;
    }
    $alien = "Alien::$alien" unless $alien =~ /::/;
    $requires{$alien} = $version;
    my $alien_pm = $alien . '.pm';
    $alien_pm =~ s/::/\//g;
    require $alien_pm unless eval { $alien->can('cflags') } && eval { $alien->can('libs') };
    my $cflags;
    my $libs;
    if($alien->install_type eq 'share' && $alien->can('cflags_static'))
    {
      $cflags = $alien->cflags_static;
      $libs   = $alien->libs_static;
    }
    else
    {
      $cflags = $alien->cflags;
      $libs   = $alien->libs;
    }

    $cflags = '' unless defined $cflags;
    $libs = '' unless defined $libs;

    push @cflags_I,     grep  /^-I/, shellwords $cflags;
    push @cflags_other, grep !/^-I/, shellwords $cflags;

    push @ldflags_L,     grep  /^-L/,    shellwords $libs;
    push @ldflags_l,     grep  /^-l/,    shellwords $libs;
    push @ldflags_other, grep !/^-[Ll]/, shellwords $libs;
  }

  my @cflags_define = grep  /^-D/, @cflags_other;
  my @cflags_other2 = grep !/^-D/, @cflags_other;

  my @mm;

  push @mm, INC       => _join @cflags_I                             if @cflags_I;
  push @mm, CCFLAGS   => _join(@cflags_other2) . " $Config{ccflags}" if @cflags_other2;
  push @mm, DEFINE    => _join(@cflags_define)                       if @cflags_define;

  # TODO: handle spaces in -L paths
  push @mm, LIBS      => ["@ldflags_L @ldflags_l"];
  my @ldflags = (@ldflags_L, @ldflags_other);
  push @mm, LDDLFLAGS => _join(@ldflags) . " $Config{lddlflags}"     if @ldflags;
  push @mm, LDFLAGS   => _join(@ldflags) . " $Config{ldflags}"       if @ldflags;

  my @mb;

  push @mb, extra_compiler_flags => _join(@cflags_I, @cflags_other);
  push @mb, extra_linker_flags   => _join(@ldflags_l);

  if(@ldflags)
  {
    push @mb, config => {
      lddlflags => _join(@ldflags) . " $Config{lddlflags}",
      ldflags   => _join(@ldflags) . " $Config{ldflags}",
    },
  }

  bless {
    cflags_I       => \@cflags_I,
    cflags_other   => \@cflags_other,
    ldflags_L      => \@ldflags_L,
    ldflags_l      => \@ldflags_l,
    ldflags_other  => \@ldflags_other,
    mm             => \@mm,
    mb             => \@mb,
    _export        => $export,
    _writemakefile => $writemakefile,
    requires       => \%requires,
  }, $class;
}

my $default_abw = __PACKAGE__->new;

# for testing only
sub _reset { __PACKAGE__->new }


sub _myexec
{
  my @command = @_;
  if($^O eq 'MSWin32')
  {
    # To handle weird quoting on MSWin32
    # this logic needs to be improved.
    my $command = "@command";
    $command =~ s{"}{\\"}g;
    system $command;

    if($? == -1 )
    {
      die "failed to execute: $!\n";
    }
    elsif($? & 127)
    {
      die "child died with signal @{[ $? & 128 ]}";
    }
    else
    {
      exit($? >> 8);
    }
  }
  else
  {
    exec @command;
  }
}

sub cc
{
  my @command = (
    shellwords($Config{cc}),
    @{ $default_abw->{cflags_I} },
    @{ $default_abw->{cflags_other} },
    @ARGV,
  );
  print "@command\n" unless $ENV{ALIEN_BASE_WRAPPER_QUIET};
  _myexec @command;
}


sub ld
{
  my @command = (
    shellwords($Config{ld}),
    @{ $default_abw->{ldflags_L} },
    @{ $default_abw->{ldflags_other} },
    @ARGV,
    @{ $default_abw->{ldflags_l} },
  );
  print "@command\n" unless $ENV{ALIEN_BASE_WRAPPER_QUIET};
  _myexec @command;
}


sub mm_args
{
  my $self = ref $_[0] ? shift : $default_abw;
  @{ $self->{mm} };
}


sub mm_args2
{
  my $self = shift;
  $self = $default_abw unless ref $self;
  my %args = @_;

  my @mm = @{ $self->{mm} };

  while(@mm)
  {
    my $key = shift @mm;
    my $value = shift @mm;
    if(defined $args{$key})
    {
      if($args{$key} eq 'LIBS')
      {
        require Carp;
        # Todo: support this maybe?
        Carp::croak("please do not specify your own LIBS key with mm_args2");
      }
      else
      {
        $args{$key} = join ' ', $value, $args{$key};
      }
    }
    else
    {
      $args{$key} = $value;
    }
  }

  foreach my $module (keys %{ $self->{requires} })
  {
    $args{CONFIGURE_REQUIRES}->{$module} = $self->{requires}->{$module};
  }

  %args;
}


sub mb_args
{
  my $self = ref $_[0] ? shift : $default_abw;
  @{ $self->{mb} };
}

sub import
{
  shift;
  my $abw = $default_abw = __PACKAGE__->new(@_);
  if($abw->_export)
  {
    my $caller = caller;
    no strict 'refs';
    *{"${caller}::cc"} = \&cc;
    *{"${caller}::ld"} = \&ld;
  }
  if($abw->_writemakefile)
  {
    my $caller = caller;
    no strict 'refs';
    *{"${caller}::WriteMakefile"} = \&WriteMakefile;
  }
}


sub WriteMakefile
{
  my %args = @_;

  require ExtUtils::MakeMaker;
  ExtUtils::MakeMaker->VERSION('6.52');

  my @aliens;

  if(my $reqs = delete $args{alien_requires})
  {
    if(ref $reqs eq 'HASH')
    {
      @aliens = map {
        my $module  = $_;
        my $version = $reqs->{$module};
        $version ? "$module=$version" : "$module";
      } sort keys %$reqs;
    }
    elsif(ref $reqs eq 'ARRAY')
    {
      @aliens = @$reqs;
    }
    else
    {
      require Carp;
      Carp::croak("aliens_require must be either a hash or array reference");
    }
  }
  else
  {
    require Carp;
    Carp::croak("You are using Alien::Base::Wrapper::WriteMakefile, but didn't specify any alien requirements");
  }

  ExtUtils::MakeMaker::WriteMakefile(
    Alien::Base::Wrapper->new(@aliens)->mm_args2(%args),
  );
}

sub _export        { shift->{_export} }
sub _writemakefile { shift->{_writemakefile} }

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Base::Wrapper - Compiler and linker wrapper for Alien

=head1 VERSION

version 2.83

=head1 SYNOPSIS

From the command line:

 % perl -MAlien::Base::Wrapper=Alien::Foo,Alien::Bar -e cc -- -o foo.o -c foo.c
 % perl -MAlien::Base::Wrapper=Alien::Foo,Alien::Bar -e ld -- -o foo foo.o

From Makefile.PL (static):

 use ExtUtils::MakeMaker;
 use Alien::Base::Wrapper ();
 
 WriteMakefile(
   Alien::Base::Wrapper->new( 'Alien::Foo', 'Alien::Bar')->mm_args2(
     'NAME'              => 'Foo::XS',
     'VERSION_FROM'      => 'lib/Foo/XS.pm',
   ),
 );

From Makefile.PL (static with wrapper)

 use Alien::Base::Wrapper qw( WriteMakefile);
 
 WriteMakefile(
   'NAME'              => 'Foo::XS',
   'VERSION_FROM'      => 'lib/Foo/XS.pm',
   'alien_requires'    => {
     'Alien::Foo' => 0,
     'Alien::Bar' => 0,
   },
 );

From Makefile.PL (dynamic):

 use Devel::CheckLib qw( check_lib );
 use ExtUtils::MakeMaker 6.52;
 
 my @mm_args;
 my @libs;
 
 if(check_lib( lib => [ 'foo' ] )
 {
   push @mm_args, LIBS => [ '-lfoo' ];
 }
 else
 {
   push @mm_args,
     CC => '$(FULLPERL) -MAlien::Base::Wrapper=Alien::Foo -e cc --',
     LD => '$(FULLPERL) -MAlien::Base::Wrapper=Alien::Foo -e ld --',
     BUILD_REQUIRES => {
       'Alien::Foo'           => 0,
       'Alien::Base::Wrapper' => 0,
     }
   ;
 }
 
 WriteMakefile(
   'NAME'         => 'Foo::XS',
   'VERSION_FROM' => 'lib/Foo/XS.pm',
   'CONFIGURE_REQUIRES => {
     'ExtUtils::MakeMaker' => 6.52,
   },
   @mm_args,
 );

=head1 DESCRIPTION

This module acts as a wrapper around one or more L<Alien> modules.  It is designed to work
with L<Alien::Base> based aliens, but it should work with any L<Alien> which uses the same
essential API.

In the first example (from the command line), this class acts as a wrapper around the
compiler and linker that Perl is configured to use.  It takes the normal compiler and
linker flags and adds the flags provided by the Aliens specified, and then executes the
command.  It will print the command to the console so that you can see exactly what is
happening.

In the second example (from Makefile.PL non-dynamic), this class is used to generate the
appropriate L<ExtUtils::MakeMaker> (EUMM) arguments needed to C<WriteMakefile>.

In the third example (from Makefile.PL dynamic), we do a quick check to see if the simple
linker flag C<-lfoo> will work, if so we use that.  If not, we use a wrapper around the
compiler and linker that will use the alien flags that are known at build time.  The
problem that this form attempts to solve is that compiler and linker flags typically
need to be determined at I<configure> time, when a distribution is installed, meaning
if you are going to use an L<Alien> module then it needs to be a configure prerequisite,
even if the library is already installed and easily detected on the operating system.

The author of this module believes that the third (from Makefile.PL dynamic) form is
somewhat unnecessary.  L<Alien> modules based on L<Alien::Base> have a few prerequisites,
but they are well maintained and reliable, so while there is a small cost in terms of extra
dependencies, the overall reliability thanks to reduced overall complexity.

=head1 CONSTRUCTOR

=head2 new

 my $abw = Alien::Base::Wrapper->new(@aliens);

Instead of passing the aliens you want to use into this modules import you can create
a non-global instance of C<Alien::Base::Wrapper> using the OO interface.

=head1 FUNCTIONS

=head2 cc

 % perl -MAlien::Base::Wrapper=Alien::Foo -e cc -- cflags

Invoke the C compiler with the appropriate flags from C<Alien::Foo> and what
is provided on the command line.

=head2 ld

 % perl -MAlien::Base::Wrapper=Alien::Foo -e ld -- ldflags

Invoke the linker with the appropriate flags from C<Alien::Foo> and what
is provided on the command line.

=head2 mm_args

 my %args = $abw->mm_args;
 my %args = Alien::Base::Wrapper->mm_args;

Returns arguments that you can pass into C<WriteMakefile> to compile/link against
the specified Aliens.  Note that this does not set  C<CONFIGURE_REQUIRES>.  You
probably want to use C<mm_args2> below instead for that reason.

=head2 mm_args2

 my %args = $abw->mm_args2(%args);
 my %args = Alien::Base::Wrapper->mm_args2(%args);

Returns arguments that you can pass into C<WriteMakefile> to compile/link against.  It works
a little differently from C<mm_args> above in that you can pass in arguments.  It also adds
the appropriate C<CONFIGURE_REQUIRES> for you so you do not have to do that explicitly.

=head2 mb_args

 my %args = $abw->mb_args;
 my %args = Alien::Base::Wrapper->mb_args;

Returns arguments that you can pass into the constructor to L<Module::Build>.

=head2 WriteMakefile

 use Alien::Base::Wrapper qw( WriteMakefile );
 WriteMakefile(%args, alien_requires => \%aliens);
 WriteMakefile(%args, alien_requires => \@aliens);

This is a thin wrapper around C<WriteMakefile> from L<ExtUtils::MakeMaker>, which adds the
given aliens to the configure requirements and sets the appropriate compiler and linker
flags.

If the aliens are specified as a hash reference, then the keys are the module names and the
values are the versions.  For a list it is just the name of the aliens.

For the list form you can specify a version by appending C<=version> to the name of the
Aliens, that is:

 WriteMakefile(
   alien_requires => [ 'Alien::libfoo=1.23', 'Alien::libbar=4.56' ],
 );

The list form is recommended if the ordering of the aliens matter.  The aliens are sorted in
the hash form to make it consistent, but it may not be the order that you want.

=head1 ENVIRONMENT

Alien::Base::Wrapper responds to these environment variables:

=over 4

=item ALIEN_BASE_WRAPPER_QUIET

If set to true, do not print the command before executing

=back

=head1 SEE ALSO

L<Alien::Base>, L<Alien::Base>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! Op-T(  (    perl5/Alien/Base/PkgConfig.pmnu ��6�$        package Alien::Base::PkgConfig;

use strict;
use warnings;
use 5.008004;
use Carp;
use Config;
use Path::Tiny qw( path );
use Capture::Tiny qw( capture_stderr );

# ABSTRACT: Private legacy pkg-config class for Alien::Base
our $VERSION = '2.83'; # VERSION


sub new {
  my $class   = shift;

  # allow creation of an object from a full spec.
  if (ref $_[0] eq 'HASH') {
    return bless $_[0], $class;
  }

  my ($path) = @_;
  croak "Must specify a file" unless defined $path;

  $path = path( $path )->absolute;

  my($name) = $path->basename =~ /^(.*)\.pc$/;

  my $self = {
    package  => $name,
    vars     => { pcfiledir => $path->parent->stringify },
    keywords => {},
  };

  bless $self, $class;

  $self->read($path);

  return $self;
}

sub read {
  my $self = shift;
  my ($path) = @_;

  open my $fh, '<', $path
    or croak "Cannot open .pc file $path: $!";

  while (my $line = <$fh>) {
    if ($line =~ /^([^=:]+?)=([^\n\r]*)/) {
      $self->{vars}{$1} = $2;
    } elsif ($line =~ /^([^=:]+?):\s*([^\n\r]*)/) {
      $self->{keywords}{$1} = $2;
    }
  }
}

# getter/setter for vars
sub var {
  my $self = shift;
  my ($var, $newval) = @_;
  if (defined $newval) {
    $self->{vars}{$var} = $newval;
  }
  return $self->{vars}{$var};
}

# abstract keywords and other vars in terms of "pure" vars
sub make_abstract {
  my $self = shift;
  die "make_abstract needs a key (and possibly a value)" unless @_;
  my ($var, $value) = @_;

  $value = defined $value ? $value : $self->{vars}{$var};

  # convert other vars
  foreach my $key (keys %{ $self->{vars} }) {
    next if $key eq $var; # don't overwrite the current var
    $self->{vars}{$key} =~ s/\Q$value\E/\$\{$var\}/g;
  }

  # convert keywords
  foreach my $key (keys %{ $self->{keywords} }) {
    $self->{keywords}{$key} =~ s/\Q$value\E/\$\{$var\}/g;
  }

}

sub _interpolate_vars {
  my $self = shift;
  my ($string, $override) = @_;

  $override ||= {};

  foreach my $key (keys %$override) {
    carp "Overriden pkg-config variable $key, contains no data"
      unless $override->{$key};
  }

  if (defined $string) {
    1 while $string =~ s/\$\{(.*?)\}/$override->{$1} || $self->{vars}{$1}/e;
  }
  return $string;
}

sub keyword {
  my $self = shift;
  my ($keyword, $override) = @_;

  {
    no warnings 'uninitialized';
    croak "overrides passed to 'keyword' must be a hashref"
      if defined $override and ref $override ne 'HASH';
  }

  return $self->_interpolate_vars( $self->{keywords}{$keyword}, $override );
}

my $pkg_config_command;

sub pkg_config_command {
  unless (defined $pkg_config_command) {
    capture_stderr {

      # For now we prefer PkgConfig.pm over pkg-config on
      # Solaris 64 bit Perls.  We may need to do this on
      # other platforms, in which case this logic should
      # be abstracted so that it can be shared here and
      # in Build.PL

      if (`pkg-config --version` && $? == 0 && !($^O eq 'solaris' && $Config{ptrsize} == 8)) {
        $pkg_config_command = 'pkg-config';
      } else {
        require PkgConfig;
        $pkg_config_command = "$^X $INC{'PkgConfig.pm'}";
      }
    }
  }

  $pkg_config_command;
}

sub TO_JSON
{
  my($self) = @_;
  my %hash = %$self;
  $hash{'__CLASS__'} = ref($self);
  \%hash;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Base::PkgConfig - Private legacy pkg-config class for Alien::Base

=head1 VERSION

version 2.83

=head1 DESCRIPTION

This class is used internally by L<Alien::Base> and L<Alien::Base::ModuleBuild>
to store information from pkg-config about installed Aliens.  It is not used
internally by the newer L<alienfile> and L<Alien::Build>.  It should never
be used externally, should not be used for code new inside of C<Alien-Build>.

=head1 SEE ALSO

=over

=item L<Alien::Base>

=item L<alienfile>

=item L<Alien::Build>

=back

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! #洊	  	    perl5/Alien/Role.pmnu ��6�$        package Alien::Role;

use strict;
use warnings;
use 5.008004;

# ABSTRACT: Extend Alien::Base with roles!
our $VERSION = '2.83'; # VERSION


1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Role - Extend Alien::Base with roles!

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 package Alien::libfoo;
 
 use parent qw( Alien::Base );
 use Role::Tiny::With qw( with );
 
 with 'Alien::Role::Dino';
 
 1;

=head1 DESCRIPTION

The C<Alien::Role> namespace is intended for writing roles that can be
applied to L<Alien::Base> to extend its functionality.  You could of
course write subclasses that extend L<Alien::Base>, but then you have
to either stick with just one subclass or deal with multiple inheritance!
It is recommended that you use L<Role::Tiny> since it can be used on
plain old Perl classes which is good since L<Alien::Base> doesn't use
anything fancy like L<Moose> or L<Moo>.  There is one working example
that use this technique that are worth checking out in the event you
are interested: L<Alien::Role::Dino>.

This class itself doesn't do anything, it just documents the technique.

=head1 SEE ALSO

=over 4

=item L<Alien>

=item L<Alien::Base>

=item L<alienfile>

=item L<Alien::Build>

=item L<Alien::Role::Dino>

=back

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! >C�D  D    perl5/Alien/Build/Util.pmnu ��6�$        package Alien::Build::Util;

use strict;
use warnings;
use 5.008004;
use Exporter qw( import );
use Path::Tiny qw( path );
use Config;

# ABSTRACT: Private utility functions for Alien::Build
our $VERSION = '2.83'; # VERSION


our @EXPORT_OK = qw( _mirror _dump _destdir_prefix _perl_config _ssl_reqs _has_ssl );

# usage: _mirror $source_directory, $dest_direction, \%options
#
# options:
#  - filter -> regex for files that should match
#  - empty_directory -> if true, create all directories, including empty ones.
#  - verbose -> turn on verbosity

sub _mirror
{
  my($src_root, $dst_root, $opt) = @_;
  ($src_root, $dst_root) = map { path($_) } ($src_root, $dst_root);
  $opt ||= {};

  require Alien::Build;
  require File::Find;
  require File::Copy;

  File::Find::find({
    wanted => sub {
      next unless -e $File::Find::name;
      my $src = path($File::Find::name)->relative($src_root);
      return if $opt->{filter} && "$src" !~ $opt->{filter};
      return if "$src" eq '.';
      my $dst = $dst_root->child("$src");
      $src = $src->absolute($src_root);
      if(-l "$src")
      {
        unless(-d $dst->parent)
        {
          Alien::Build->log("mkdir -p @{[ $dst->parent ]}") if $opt->{verbose};
          $dst->parent->mkpath;
        }
        # TODO: rmtree if a directory?
        if(-e "$dst")
        { unlink "$dst" }
        my $target = readlink "$src";
        Alien::Build->log("ln -s $target $dst") if $opt->{verbose};
        symlink($target, $dst) || die "unable to symlink $target => $dst";
      }
      elsif(-d "$src")
      {
        if($opt->{empty_directory})
        {
          unless(-d $dst)
          {
            Alien::Build->log("mkdir $dst") if $opt->{verbose};
            mkdir($dst) || die "unable to create directory $dst: $!";
          }
        }
      }
      elsif(-f "$src")
      {
        unless(-d $dst->parent)
        {
          Alien::Build->log("mkdir -p @{[ $dst->parent ]}") if $opt->{verbose};
          $dst->parent->mkpath;
        }
        # TODO: rmtree if a directory?
        if(-e "$dst")
        { unlink "$dst" }
        Alien::Build->log("cp $src $dst") if $opt->{verbose};
        File::Copy::cp("$src", "$dst") || die "copy error $src => $dst: $!";
        if($] < 5.012 && -x "$src" && $^O ne 'MSWin32')
        {
          # apparently Perl 5.8 and 5.10 do not preserver perms
          my $mode = [stat "$src"]->[2] & oct(777);
          eval { chmod $mode, "$dst" };
        }
      }
    },
    no_chdir => 1,
  }, "$src_root");

  ();
}

sub _dump
{
  if(eval { require YAML })
  {
    return YAML::Dump(@_);
  }
  else
  {
    require Data::Dumper;
    return Data::Dumper::Dumper(@_);
  }
}

sub _destdir_prefix
{
  my($destdir, $prefix) = @_;
  $prefix =~ s{^/?([a-z]):}{$1}i if $^O eq 'MSWin32';
  path($destdir)->child($prefix)->stringify;
}

sub _perl_config
{
  my($key) = @_;
  $Config{$key};
}

sub _ssl_reqs
{
  return {
    'Net::SSLeay' => '1.49',
    'IO::Socket::SSL' => '1.56',
  };
}

sub _has_ssl
{
  my %reqs = %{ _ssl_reqs() };
  eval {
    require Net::SSLeay;
    die "need Net::SSLeay $reqs{'Net::SSLeay'}" unless Net::SSLeay->VERSION($reqs{'Net::SSLeay'});
    require IO::Socket::SSL;
    die "need IO::Socket::SSL $reqs{'IO::Socket::SSL'}" unless IO::Socket::SSL->VERSION($reqs{'IO::Socket::SSL'});
  };
  $@ eq '';
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Util - Private utility functions for Alien::Build

=head1 VERSION

version 2.83

=head1 DESCRIPTION

This module contains some private utility functions used internally by
L<Alien::Build>.  It shouldn't be used by any distribution other than
C<Alien-Build>.  That includes L<Alien::Build> plugins that are not
part of the L<Alien::Build> core.

You have been warned.  The functionality within may be removed at
any time!

=head1 SEE ALSO

L<Alien::Build>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! 	ڱU9-  9-  %  perl5/Alien/Build/Plugin/Test/Mock.pmnu ��6�$        package Alien::Build::Plugin::Test::Mock;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use Carp ();
use Path::Tiny ();
use File::chdir;

# ABSTRACT: Mock plugin for testing
our $VERSION = '2.83'; # VERSION


has 'probe';


has 'download';


has 'extract';


has 'build';


has 'gather';


has check_digest => 1;

sub init
{
  my($self, $meta) = @_;

  if(my $probe = $self->probe)
  {
    if($probe =~ /^(share|system)$/)
    {
      $meta->register_hook(
        probe => sub {
          $probe;
        },
      );
    }
    elsif($probe eq 'die')
    {
      $meta->register_hook(
        probe => sub {
          die "fail";
        },
      );
    }
    else
    {
      Carp::croak("usage: plugin 'Test::Mock' => ( probe => $probe ); where $probe is one of share, system or die");
    }
  }

  if(my $download = $self->download)
  {
    $download = { 'foo-1.00.tar.gz' => _tarball() } unless ref $download eq 'HASH';
    $meta->register_hook(
      download => sub {
        my($build) = @_;
        _fs($build, $download, 1);
      },
    );
  }

  if(my $extract = $self->extract)
  {
    $extract = {
      'foo-1.00' => {
        'configure' => _tarball_configure(),
        'foo.c'     => _tarball_foo_c(),
      },
    } unless ref $extract eq 'HASH';
    $meta->register_hook(
      extract => sub {
        my($build) = @_;
        _fs($build, $extract);
      },
    );
  }

  if(my $build = $self->build)
  {
    $build = [
      {
        'foo.o',   => _build_foo_o(),
        'libfoo.a' => _build_libfoo_a(),
      },
      {
        'lib' => {
          'libfoo.a' => _build_libfoo_a(),
          'pkgconfig' => {
            'foo.pc' => sub {
              my($build) = @_;
              "prefix=$CWD\n" .
              "exec_prefix=\${prefix}\n" .
              "libdir=\${prefix}/lib\n" .
              "includedir=\${prefix}/include\n" .
              "\n" .
              "Name: libfoo\n" .
              "Description: libfoo\n" .
              "Version: 1.0.0\n" .
              "Cflags: -I\${includedir}\n" .
              "Libs: -L\${libdir} -lfoo\n";
            },
          },
        },
      },
    ] unless ref $build eq 'ARRAY';

    my($build_dir, $install_dir) = @$build;

    $meta->register_hook(
      build => sub {
        my($build) = @_;
        _fs($build, $build_dir);
        local $CWD = $build->install_prop->{prefix};
        _fs($build, $install_dir);
      },
    );
  }

  if(my $gather = $self->gather)
  {
    $meta->register_hook(
      $_ => sub {
        my($build) = @_;
        if(ref $gather eq 'HASH')
        {
          foreach my $key (keys %$gather)
          {
            $build->runtime_prop->{$key} = $gather->{$key};
          }
        }
        else
        {
          my $prefix = $build->runtime_prop->{prefix};
          $build->runtime_prop->{cflags} = "-I$prefix/include";
          $build->runtime_prop->{libs}   = "-L$prefix/lib -lfoo";
        }
      },
    ) for qw( gather_share gather_system );
  }

  if(my $cd = $self->check_digest)
  {
    $meta->register_hook(
      check_digest => ref($cd) eq 'CODE' ? $cd : sub {
        my($build, $file, $algorithm, $digest) = @_;
        if($algorithm ne 'FOO92')
        {
          return 'FAKE';
        }
        if($digest eq 'deadbeaf')
        {
          return 1;
        }
        else
        {
          die "Digest FAKE does not match: got deadbeaf, expected $digest";
        }
      }
    );
    $meta->register_hook(
      check_download => sub {
        my($build) = @_;
        my $path = $build->install_prop->{download};
        if(defined $path)
        {
          $build->check_digest($path);
        }
      },
    );
  }
}

sub _fs
{
  my($build, $hash, $download) = @_;

  foreach my $key (sort keys %$hash)
  {
    my $val = $hash->{$key};
    if(ref $val eq 'HASH')
    {
      mkdir $key;
      local $CWD = $key;
      _fs($build,$val);
    }
    elsif(ref $val eq 'CODE')
    {
      my $path = Path::Tiny->new($key)->absolute;
      $path->spew_raw($val->($build));
      if($download)
      {
        $build->install_prop->{download_detail}->{"$path"}->{protocol} = 'file';
        $build->install_prop->{download_detail}->{"$path"}->{digest}   = [ FAKE => 'deadbeaf' ];
      }
    }
    elsif(defined $val)
    {
      my $path = Path::Tiny->new($key)->absolute;
      $path->spew_raw($val);
      if($download)
      {
        $build->install_prop->{download_detail}->{"$path"}->{protocol} = 'file';
        $build->install_prop->{download_detail}->{"$path"}->{digest}   = [ FAKE => 'deadbeaf' ];
      }
    }
  }
}

sub _tarball
{
  return unpack 'u', <<'EOF';
M'XL(`+DM@5@``^V4P4K$,!"&>YZGF-V]J*SM9#=)#RN^B'BHV;0)U`32U(OX
M[D;0*LJREZVRF.\R?TA@)OS\TWI_S4JBJI@/(JJ%P%19+>AKG4"V)4Z;C922
M(;T=6(%BQIDFQB$V(8WB^]X.W>%WQ^[?_S'5,Z']\%]YU]IN#/KT/8[ZO^6?
M_B=-C-=<%$BG'^4G_]S_U:)ZL*X:#(!6QN/26(Q&![W<P5_/EIF?*?])E&J>
M'BD/DO/#^6<DON__6O*<_]]@99WJQ[W&FR'NK2_-+8!U$1X;ZRZ2P"9T:HW*
D-`&ODGZZN[^$9T`,.H[!(>W@)2^*3":3.3]>`:%LBYL`#@``
`
EOF
}

sub _tarball_configure
{
  return unpack 'u', <<'EOF';
<(R$O8FEN+W-H"@IE8VAO(")H:2!T:&5R92(["@``
`
EOF
}

sub _tarball_foo_c
{
  return unpack 'u', <<'EOF';
M(VEN8VQU9&4@/'-T9&EO+F@^"@II;G0*;6%I;BAI;G0@87)G8RP@8VAA<B`J
887)G=EM=*0I["B`@<F5T=7)N(#`["GT*
`
EOF
}

sub _build_foo_o
{
  return unpack 'u', <<'EOF';
MS_KM_@<```$#`````0````0```"P`0```"`````````9````.`$`````````
M`````````````````````````&@`````````T`$```````!H``````````<`
M```'`````P````````!?7W1E>'0`````````````7U]415A4````````````
M````````````"`````````#0`0``!`````````````````0`@```````````
M`````%]?8V]M<&%C=%]U;G=I;F1?7TQ$````````````````"``````````@
M`````````-@!```#````.`(```$````````"````````````````7U]E:%]F
M<F%M90```````%]?5$585``````````````H`````````$``````````^`$`
M``,```````````````L``&@````````````````D````$``````-"@``````
M`@```!@```!``@```0```%`"```(````"P```%`````````````````````!
M`````0``````````````````````````````````````````````````````
M``````````````````!52(GE,<!=PP``````````"`````````$`````````
M````````````%``````````!>E(``7@0`1`,!PB0`0``)````!P```"X____
M_____P@``````````$$.$(8"0PT&```````````````!```&`0````\!````
/``````````!?;6%I;@``
`
EOF
}

sub _build_libfoo_a
{
  return unpack 'u', <<'EOF';
M(3QA<F-H/@HC,2\R,"`@("`@("`@("`@,34S,S$U-38Q."`@-3`Q("`@,C`@
M("`@,3`P-C0T("`T-"`@("`@("`@8`I?7RY364U$148@4T]25$5$``````@`
M````````<`````@```!?;6%I;@```",Q+S$R("`@("`@("`@("`Q-3,S,34U
M-#8X("`U,#$@("`R,"`@("`Q,#`V-#0@(#8Q,B`@("`@("!@"F9O;RYO````
M`````,_Z[?X'```!`P````$````$````L`$````@````````&0```#@!````
M``````````````````````````````!H`````````-`!````````:```````
M```'````!P````,`````````7U]T97AT`````````````%]?5$585```````
M``````````````````@`````````T`$```0````````````````$`(``````
M``````````!?7V-O;7!A8W1?=6YW:6YD7U],1`````````````````@`````
M````(`````````#8`0```P```#@"```!`````````@```````````````%]?
M96A?9G)A;64```````!?7U1%6%0`````````````*`````````!`````````
M`/@!```#```````````````+``!H````````````````)````!``````#0H`
M``````(````8````0`(```$```!0`@``"`````L```!0````````````````
M`````0````$`````````````````````````````````````````````````
M````````````````````````54B)Y3'`7<,```````````@````````!````
M`````````````````!0``````````7I2``%X$`$0#`<(D`$``"0````<````
MN/________\(``````````!!#A"&`D,-!@```````````````0``!@$````/
3`0``````````````7VUA:6X`````
`
EOF
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Test::Mock - Mock plugin for testing

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 plugin 'Test::Mock' => (
   probe    => 'share',
   download => 1,
   extract  => 1,
   build    => 1,
   gather   => 1,
 );

=head1 DESCRIPTION

This plugin is used for testing L<Alien::Build> plugins.  Usually you only want to test
one or two phases in an L<alienfile> for your plugin, but you still have to have a fully
formed L<alienfile> that contains all required phases.  This plugin lets you fill in the
other phases with the appropriate hooks.  This is usually better than using real plugins
which may pull in additional dynamic requirements that you do not want to rely on at
test time.

=head1 PROPERTIES

=head2 probe

 plugin 'Test::Mock' => (
   probe => $probe,
 );

Override the probe behavior by one of the following:

=over

=item share

For a C<share> build.

=item system

For a C<system> build.

=item die

To throw an exception in the probe hook.  This will usually cause L<Alien::Build>
to try the next probe hook, if available, or to assume a C<share> install.

=back

=head2 download

 plugin 'Test::Mock' => (
   download => \%fs_spec,
 );
 
 plugin 'Test::Mock' => (
   download => 1,
 );

Mock out a download.  The C<%fs_spec> is a hash where the hash values are directories
and the string values are files.  This a spec like this:

 plugin 'Test::Mock' => (
   download => {
     'foo-1.00' => {
       'README.txt' => "something to read",
       'foo.c' => "#include <stdio.h>\n",
                  "int main() {\n",
                  "  printf(\"hello world\\n\");\n",
                  "}\n",
     }
   },
 );

Would generate two files in the directory 'foo-1.00', a C<README.txt> and a C file named C<foo.c>.
The default, if you provide a true non-hash value is to generate a single tarball with the name
C<foo-1.00.tar.gz>.

=head2 extract

 plugin 'Test::Mock' => (
   extract => \%fs_spec,
 );
 
 plugin 'Test::Mock' => (
   extract => 1,
 );

Similar to C<download> above, but for the C<extract> phase.

=head2 build

 plugin 'Test::Mock' => (
   build => [ \%fs_spec_build, \%fs_spec_install ],
 );
 
 plugin 'Test::Mock' => (
   build => 1,
 );

=head2 gather

 plugin 'Test::Mock' => (
   gather => \%runtime_prop,
 );
 
 plugin 'Test::Mock' => (
   gather => 1,
 );

This adds a gather hook (for both C<share> and C<system>) that adds the given runtime properties, or
if a true non-hash value is provided, some reasonable runtime properties for testing.

=head2 check_digest

 plugin 'Test::Mock' => (
   check_digest => 1,  # the default
 );

This adds a check_digest hook that uses fake algorithm FAKE that hashes everything to C<deadbeaf>.
The mock download above will set the digest for download_details so that this will pass the
signature check.

 plugin 'Test::Mock' => (
   check_digest => sub {
     my($build, $file, $algo, $digest) = @_;
     ...
   },
 );

If you give it a code reference then you can write your own faux digest.  See the
L<check_digest hook|Alien::Build::Manual::PluginAuthor/"check_digest hook"> in
L<Alien::Build::Manual::PluginAuthor> for details.

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! ��f �  �  &  perl5/Alien/Build/Plugin/PkgConfig.podnu ��6�$        # PODNAME: Alien::Build::Plugin::PkgConfig
# ABSTRACT: PkgConfig Alien::Build plugins
# VERSION

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::PkgConfig - PkgConfig Alien::Build plugins

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 plugin 'PkgConfig' => (
   pkg_name => 'foo',
 );

=head1 DESCRIPTION

PkgConfig plugins use C<pkg-config> or a compatible library to retrieve flags
at probe and gather stages.

=over 4

=item L<Alien::Build::Plugin::PkgConfig::CommandLine>

Use the command-line C<pkg-config> or C<pkgconf> to get compiler and linker flags.

=item L<Alien::Build::Plugin::PkgConfig::LibPkgConf>

Use the XS L<PkgConfig::LibPkgConf> to get compiler and linker flags.

=item L<Alien::Build::Plugin::PkgConfig::MakeStatic>

Convert .pc file to use static linkage by default.

=item L<Alien::Build::Plugin::PkgConfig::MakeStatic>

Choose the best plugin to do C<pkg-config> work.  The best choice is typically
platform and configuration dependent.

=item L<Alien::Build::Plugin::PkgConfig::PP>

Use the pure-perl L<PkgConfig> to get compiler and linker flags.

=back

=head1 SEE ALSO

L<Alien::Build>, L<Alien::Build::Plugin>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! D�YY�  �  !  perl5/Alien/Build/Plugin/Core.podnu ��6�$        # PODNAME: Alien::Build::Plugin::Core
# ABSTRACT: Core Alien::Build plugins
# VERSION

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Core - Core Alien::Build plugins

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 # core plugins are already loaded

=head1 DESCRIPTION

Core plugins are special plugins that are always loaded, usually first.

=over 4

=item L<Alien::Build::Plugin::Core::CleanInstall>

=item L<Alien::Build::Plugin::Core::Download>

This contains the default machinery for downloading packages, if no
other download plugin or commands are provided.

=item L<Alien::Build::Plugin::Core::FFI>

=item L<Alien::Build::Plugin::Core::Gather>

=item L<Alien::Build::Plugin::Core::Legacy>

Add interoperability with L<Alien::Base::ModuleBuild>

=item L<Alien::Build::Plugin::Core::Override>

The machinery which allows you to override the type of install
with the C<ALIEN_INSTALL_TYPE> environment variable.

=item L<Alien::Build::Plugin::Core::Setup>

=item L<Alien::Build::Plugin::Core::Tail>

=back

=head1 SEE ALSO

L<Alien::Build>, L<Alien::Build::Plugin>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! �:��  �  1  perl5/Alien/Build/Plugin/PkgConfig/CommandLine.pmnu ��6�$        package Alien::Build::Plugin::PkgConfig::CommandLine;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use Carp ();

# ABSTRACT: Probe system and determine library or tool properties using the pkg-config command line interface
our $VERSION = '2.83'; # VERSION


has '+pkg_name' => sub {
  Carp::croak "pkg_name is a required property";
};

# NOT used, for compat with other PkgConfig plugins
has register_prereqs => 1;

sub _bin_name {

  # We prefer pkgconf to pkg-config because it seems to be the future.

  require File::Which;
  File::Which::which($ENV{PKG_CONFIG})
    ? $ENV{PKG_CONFIG}
    : File::Which::which('pkgconf')
      ? 'pkgconf'
      : File::Which::which('pkg-config')
        ? 'pkg-config'
        : undef;
};

has bin_name => \&_bin_name;


has atleast_version => undef;


has exact_version => undef;


has max_version => undef;


has minimum_version => undef;

sub _val
{
  my($build, $args, $prop_name) = @_;
  my $string = $args->{out};
  chomp $string;
  $string =~ s{^\s+}{};
  if($prop_name =~ /version$/)
  { $string =~ s{\s*$}{} }
  else
  { $string =~ s{\s*$}{ } }
  if($prop_name =~ /^(.*?)\.(.*?)\.(.*?)$/)
  { $build->runtime_prop->{$1}->{$2}->{$3} = $string }
  else
  { $build->runtime_prop->{$prop_name} = $string }
  ();
}


sub available
{
  !!_bin_name();
}

sub init
{
  my($self, $meta) = @_;

  my @probe;
  my @gather;

  my $pkgconf = $self->bin_name;

  unless(defined $meta->prop->{env}->{PKG_CONFIG})
  {
    $meta->prop->{env}->{PKG_CONFIG} = $pkgconf;
  }

  my($pkg_name, @alt_names) = (ref $self->pkg_name) ? (@{ $self->pkg_name }) : ($self->pkg_name);

  push @probe, map { [$pkgconf, '--exists', $_] } ($pkg_name, @alt_names);

  if(defined $self->minimum_version)
  {
    push @probe, [ $pkgconf, '--atleast-version=' . $self->minimum_version, $pkg_name ];
  }
  elsif(defined $self->atleast_version)
  {
    push @probe, [ $pkgconf, '--atleast-version=' . $self->atleast_version, $pkg_name ];
  }

  if(defined $self->exact_version)
  {
    push @probe, [ $pkgconf, '--exact-version=' . $self->exact_version, $pkg_name ];
  }

  if(defined $self->max_version)
  {
    push @probe, [ $pkgconf, '--max-version=' . $self->max_version, $pkg_name ];
  }

  push @probe, [ $pkgconf, '--modversion', $pkg_name, sub {
    my($build, $args) = @_;
    my $version = $args->{out};
    $version =~ s{^\s+}{};
    $version =~ s{\s*$}{};
    $build->hook_prop->{version} = $version;
  }];

  unshift @probe, sub {
    my($build) = @_;
    $build->runtime_prop->{legacy}->{name} ||= $pkg_name;
    $build->hook_prop->{probe_class} = __PACKAGE__;
    $build->hook_prop->{probe_instance_id} = $self->instance_id;
  };

  $meta->register_hook(
    probe => \@probe
  );

  push @gather, sub {
    my($build) = @_;
    die 'pkg-config command line probe does not match gather' if $build->hook_prop->{name} eq 'gather_system'
    &&                                                        ($build->install_prop->{system_probe_instance_id} || '') ne $self->instance_id;
  };
  push @gather, map { [ $pkgconf, '--exists', $_] } ($pkg_name, @alt_names);

  foreach my $prop_name (qw( cflags libs version ))
  {
    my $flag = $prop_name eq 'version' ? '--modversion' : "--$prop_name";
    push @gather,
      [ $pkgconf, $flag, $pkg_name, sub { _val @_, $prop_name } ];
    if(@alt_names)
    {
      foreach my $alt ($pkg_name, @alt_names)
      {
        push @gather,
          [ $pkgconf, $flag, $alt, sub { _val @_, "alt.$alt.$prop_name" } ];
      }
    }
  }

  foreach my $prop_name (qw( cflags libs ))
  {
    push @gather,
      [ $pkgconf, '--static', "--$prop_name", $pkg_name, sub { _val @_, "${prop_name}_static" } ];
    if(@alt_names)
    {
      foreach my $alt ($pkg_name, @alt_names)
      {
        push @gather,
          [ $pkgconf, '--static', "--$prop_name", $alt, sub { _val @_, "alt.$alt.${prop_name}_static" } ];
      }
    }
  }

  $meta->register_hook(gather_system => [@gather]);

  if($meta->prop->{platform}->{system_type} eq 'windows-mingw')
  {
    @gather = map {
      if(ref $_ eq 'ARRAY') {
        my($pkgconf, @rest) = @$_;
        [$pkgconf, '--dont-define-prefix', @rest],
      } else {
        $_
      }
    } @gather;
  }

  $meta->register_hook(gather_share => [@gather]);

  $meta->after_hook(
    $_ => sub {
      my($build) = @_;
      if(keys %{ $build->runtime_prop->{alt} } < 2)
      {
        delete $build->runtime_prop->{alt};
      }
    },
  ) for qw( gather_system gather_share );

  $self;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::PkgConfig::CommandLine - Probe system and determine library or tool properties using the pkg-config command line interface

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 plugin 'PkgConfig::CommandLine' => (
   pkg_name => 'libfoo',
 );

=head1 DESCRIPTION

Note: in most case you will want to use L<Alien::Build::Plugin::PkgConfig::Negotiate>
instead.  It picks the appropriate fetch plugin based on your platform and environment.
In some cases you may need to use this plugin directly instead.

This plugin provides Probe and Gather steps for pkg-config based packages.  It uses
the best command line tools to accomplish this task.

=head1 PROPERTIES

=head2 pkg_name

The package name.  If this is a list reference then .pc files with all those package
names must be present.  The first name will be the primary and used by default once
installed.  For the subsequent C<.pc> files you can use the
L<Alien::Base alt method|Alien::Base/alt> to retrieve the alternate configurations
once the L<Alien> is installed.

=head2 atleast_version

The minimum required version that is acceptable version as provided by the system.

=head2 exact_version

The exact required version that is acceptable version as provided by the system.

=head2 max_version

The max required version that is acceptable version as provided by the system.

=head2 minimum_version

Alias for C<atleast_version> for backward compatibility.

=head1 METHODS

=head2 available

 my $bool = Alien::Build::Plugin::PkgConfig::CommandLine->available;

Returns true if the necessary prereqs for this plugin are I<already> installed.

=head1 SEE ALSO

L<Alien::Build::Plugin::PkgConfig::Negotiate>, L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! )��\�  �  0  perl5/Alien/Build/Plugin/PkgConfig/LibPkgConf.pmnu ��6�$        package Alien::Build::Plugin::PkgConfig::LibPkgConf;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use Carp ();

# ABSTRACT: Probe system and determine library or tool properties using PkgConfig::LibPkgConf
our $VERSION = '2.83'; # VERSION


has '+pkg_name' => sub {
  Carp::croak "pkg_name is a required property";
};


has atleast_version => undef;


has exact_version => undef;


has max_version => undef;


has minimum_version => undef;

# private for now, used by negotiator
has register_prereqs => 1;


use constant _min_version => '0.04';

sub available
{
  !!eval { require PkgConfig::LibPkgConf; PkgConfig::LibPkgConf->VERSION(_min_version) };
}

sub init
{
  my($self, $meta) = @_;

  unless(defined $meta->prop->{env}->{PKG_CONFIG})
  {
    # TODO: this doesn't yet find pkgconf in the bin dir of a share
    # install.
    my $command_line =
      File::Which::which('pkgconf')
      ? 'pkgconf'
      : File::Which::which('pkg-config')
        ? 'pkg-config'
        : undef;
    $meta->prop->{env}->{PKG_CONFIG} = $command_line
      if defined $command_line;
  }

  if($self->register_prereqs)
  {
    # Also update in Neotiate.pm
    $meta->add_requires('configure' => 'PkgConfig::LibPkgConf::Client' => _min_version);

    if(defined $self->minimum_version || defined $self->atleast_version || defined $self->exact_version || defined $self->max_version)
    {
      $meta->add_requires('configure' => 'PkgConfig::LibPkgConf::Util' => _min_version);
    }
  }

  my($pkg_name, @alt_names) = (ref $self->pkg_name) ? (@{ $self->pkg_name }) : ($self->pkg_name);

  $meta->register_hook(
    probe => sub {
      my($build) = @_;
      $build->runtime_prop->{legacy}->{name} ||= $pkg_name;

      $build->hook_prop->{probe_class} = __PACKAGE__;
      $build->hook_prop->{probe_instance_id} = $self->instance_id;

      require PkgConfig::LibPkgConf::Client;
      my $client = PkgConfig::LibPkgConf::Client->new;
      my $pkg = $client->find($pkg_name);
      die "package $pkg_name not found" unless $pkg;

      $build->hook_prop->{version} = $pkg->version;
      my $atleast_version = $self->atleast_version;
      $atleast_version = $self->minimum_version unless defined $self->atleast_version;
      if($atleast_version)
      {
        require PkgConfig::LibPkgConf::Util;
        if(PkgConfig::LibPkgConf::Util::compare_version($pkg->version, $atleast_version) < 0)
        {
          die "package $pkg_name is version @{[ $pkg->version ]}, but at least $atleast_version is required.";
        }
      }

      if($self->exact_version)
      {
        require PkgConfig::LibPkgConf::Util;
        if(PkgConfig::LibPkgConf::Util::compare_version($pkg->version, $self->exact_version) != 0)
        {
          die "package $pkg_name is version @{[ $pkg->version ]}, but exactly @{[ $self->exact_version ]} is required.";
        }
      }

      if($self->max_version)
      {
        require PkgConfig::LibPkgConf::Util;
        if(PkgConfig::LibPkgConf::Util::compare_version($pkg->version, $self->max_version) > 0)
        {
          die "package $pkg_name is version @{[ $pkg->version ]}, but max @{[ $self->max_version ]} is required.";
        }
      }

      foreach my $alt (@alt_names)
      {
        my $pkg = $client->find($alt);
        die "package $alt not found" unless $pkg;
      }

      'system';
    },
  );

  $meta->register_hook(
    $_ => sub {
      my($build) = @_;

      return if $build->hook_prop->{name} eq 'gather_system'
      &&        ($build->install_prop->{system_probe_instance_id} || '') ne $self->instance_id;

      require PkgConfig::LibPkgConf::Client;
      my $client = PkgConfig::LibPkgConf::Client->new;

      foreach my $name ($pkg_name, @alt_names)
      {
        my $pkg = $client->find($name);
        die "reload of package $name failed" unless defined $pkg;

        my %prop;
        $prop{version}        = $pkg->version;
        $prop{cflags}         = $pkg->cflags;
        $prop{libs}           = $pkg->libs;
        $prop{cflags_static}  = $pkg->cflags_static;
        $prop{libs_static}    = $pkg->libs_static;
        $build->runtime_prop->{alt}->{$name} = \%prop;
      }

      foreach my $key (keys %{ $build->runtime_prop->{alt}->{$pkg_name} })
      {
        $build->runtime_prop->{$key} = $build->runtime_prop->{alt}->{$pkg_name}->{$key};
      }

      if(keys %{ $build->runtime_prop->{alt} } == 1)
      {
        delete $build->runtime_prop->{alt};
      }
    },
  ) for qw( gather_system gather_share );

  $self;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::PkgConfig::LibPkgConf - Probe system and determine library or tool properties using PkgConfig::LibPkgConf

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 plugin 'PkgConfig::LibPkgConf' => (
   pkg_name => 'libfoo',
 );

=head1 DESCRIPTION

Note: in most case you will want to use L<Alien::Build::Plugin::PkgConfig::Negotiate>
instead.  It picks the appropriate fetch plugin based on your platform and environment.
In some cases you may need to use this plugin directly instead.

This plugin provides Probe and Gather steps for pkg-config based packages.  It uses
L<PkgConfig::LibPkgConf> to accomplish this task.

This plugin is part of the Alien::Build core For Now, but may be removed in a future
date.  While It Seemed Like A Good Idea at the time, it may not be appropriate to keep
it in core.  If it is spun off it will get its own distribution some time in the future.

=head1 PROPERTIES

=head2 pkg_name

The package name.  If this is a list reference then .pc files with all those package
names must be present.  The first name will be the primary and used by default once
installed.  For the subsequent C<.pc> files you can use the
L<Alien::Base alt method|Alien::Base/alt> to retrieve the alternate configurations
once the L<Alien> is installed.

=head2 atleast_version

The minimum required version that is acceptable version as provided by the system.

=head2 exact_version

The exact required version that is acceptable version as provided by the system.

=head2 max_version

The max required version that is acceptable version as provided by the system.

=head2 minimum_version

Alias for C<atleast_version> for backward compatibility.

=head1 METHODS

=head2 available

 my $bool = Alien::Build::Plugin::PkgConfig::LibPkgConf->available;

Returns true if the necessary prereqs for this plugin are I<already> installed.

=head1 SEE ALSO

L<Alien::Build::Plugin::PkgConfig::Negotiate>, L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! t�S  S  /  perl5/Alien/Build/Plugin/PkgConfig/Negotiate.pmnu ��6�$        package Alien::Build::Plugin::PkgConfig::Negotiate;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use Alien::Build::Plugin::PkgConfig::PP;
use Alien::Build::Plugin::PkgConfig::LibPkgConf;
use Alien::Build::Plugin::PkgConfig::CommandLine;
use Alien::Build::Util qw( _perl_config );
use Carp ();

# ABSTRACT: Package configuration negotiation plugin
our $VERSION = '2.83'; # VERSION


has '+pkg_name' => sub {
  Carp::croak "pkg_name is a required property";
};


has atleast_version => undef;


has exact_version => undef;


has max_version => undef;


has minimum_version => undef;


sub pick
{
  my($class) = @_;

  return $ENV{ALIEN_BUILD_PKG_CONFIG} if $ENV{ALIEN_BUILD_PKG_CONFIG};

  if(Alien::Build::Plugin::PkgConfig::LibPkgConf->available)
  {
    return 'PkgConfig::LibPkgConf';
  }

  if(Alien::Build::Plugin::PkgConfig::CommandLine->available)
  {
    # TODO: determine environment or flags necessary for using pkg-config
    # on solaris 64 bit.
    # Some advice on pkg-config and 64 bit Solaris
    # https://docs.oracle.com/cd/E53394_01/html/E61689/gplhi.html
    my $is_solaris64 = (_perl_config('osname') eq 'solaris' && _perl_config('ptrsize') == 8);

    # PkgConfig.pm is more reliable on windows
    my $is_windows = _perl_config('osname') eq 'MSWin32';

    if(!$is_solaris64 && !$is_windows)
    {
      return 'PkgConfig::CommandLine';
    }
  }

  if(Alien::Build::Plugin::PkgConfig::PP->available)
  {
    return 'PkgConfig::PP';
  }
  else
  {
    # this is a fata error.  because we check for a pkg-config implementation
    # at configure time, we expect at least one of these to work.  (and we
    # fallback on installing PkgConfig.pm as a prereq if nothing else is avail).
    # we therefore expect at least one of these to work, if not, then the configuration
    # of the system has shifted from underneath us.
    Carp::croak("Could not find an appropriate pkg-config or pkgconf implementation, please install PkgConfig.pm, PkgConfig::LibPkgConf, pkg-config or pkgconf");
  }
}

sub init
{
  my($self, $meta) = @_;

  my $plugin = $self->pick;
  Alien::Build->log("Using PkgConfig plugin: $plugin");

  if(ref($self->pkg_name) eq 'ARRAY')
  {
    $meta->add_requires('configure', 'Alien::Build::Plugin::PkgConfig::Negotiate' => '0.79');
  }

  if($self->atleast_version || $self->exact_version || $self->max_version)
  {
    $meta->add_requires('configure', 'Alien::Build::Plugin::PkgConfig::Negotiate' => '1.53');
  }

  my @args;
  push @args, pkg_name         => $self->pkg_name;
  push @args, register_prereqs => 0;

  foreach my $method (map { "${_}_version" } qw( minimum atleast exact max ))
  {
    push @args, $method => $self->$method if defined $self->$method;
  }

  $meta->apply_plugin($plugin, @args);

  $self;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::PkgConfig::Negotiate - Package configuration negotiation plugin

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 plugin 'PkgConfig' => (
   pkg_name => 'libfoo',
 );

=head1 DESCRIPTION

This plugin provides Probe and Gather steps for pkg-config based packages.  It picks
the best C<PkgConfig> plugin depending your platform and environment.

=head1 PROPERTIES

=head2 pkg_name

The package name.  If this is a list reference then .pc files with all those package
names must be present.  The first name will be the primary and used by default once
installed.  For the subsequent C<.pc> files you can use the
L<Alien::Base alt method|Alien::Base/alt> to retrieve the alternate configurations
once the L<Alien> is installed.

=head2 atleast_version

The minimum required version that is acceptable version as provided by the system.

=head2 exact_version

The exact required version that is acceptable version as provided by the system.

=head2 max_version

The max required version that is acceptable version as provided by the system.

=head2 minimum_version

Alias for C<atleast_version> for backward compatibility.

=head1 METHODS

=head2 pick

 my $name = Alien::Build::Plugin::PkgConfig::Negotiate->pick;

Returns the name of the negotiated plugin.

=head1 ENVIRONMENT

=over 4

=item ALIEN_BUILD_PKG_CONFIG

If set, this plugin will be used instead of the build in logic
which attempts to automatically pick the best plugin.

=back

=head1 SEE ALSO

L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! n g  g  0  perl5/Alien/Build/Plugin/PkgConfig/MakeStatic.pmnu ��6�$        package Alien::Build::Plugin::PkgConfig::MakeStatic;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use Path::Tiny ();

# ABSTRACT: Convert .pc files into static
our $VERSION = '2.83'; # VERSION


has path => undef;

sub _convert
{
  my($self, $build, $path) = @_;

  die "unable to read $path" unless -r $path;
  die "unable to write $path" unless -w $path;

  $build->log("converting $path to static");

  my %h = map {
    my($key, $value) = /^(.*?):(.*?)$/;
    $value =~ s{^\s+}{};
    $value =~ s{\s+$}{};
    ($key => $value);
  } grep /^(?:Libs|Cflags)(?:\.private)?:/, $path->lines;

  $h{Cflags} = '' unless defined $h{Cflags};
  $h{Libs}   = '' unless defined $h{Libs};

  $h{Cflags} .= ' ' . $h{"Cflags.private"} if defined $h{"Cflags.private"};
  $h{Libs}   .= ' ' . $h{"Libs.private"} if defined $h{"Libs.private"};

  $h{"Cflags.private"} = '';
  $h{"Libs.private"}  = '';

  $path->edit_lines(sub {

    if(/^(.*?):/)
    {
      my $key = $1;
      if(defined $h{$key})
      {
        s/^(.*?):.*$/$1: $h{$key} /;
        delete $h{$key};
      }
    }

  });

  $path->append("$_: $h{$_}\n") foreach keys %h;
}

sub _recurse
{
  my($self, $build, $dir) = @_;

  foreach my $child ($dir->children)
  {
    if(-d $child)
    {
      $self->_recurse($build, $child);
    }
    elsif($child->basename =~ /\.pc$/)
    {
      $self->_convert($build, $child);
    }
  }
}

sub init
{
  my($self, $meta) = @_;

  $meta->add_requires('configure' => 'Alien::Build::Plugin::Build::SearchDep' => '0.35');

  $meta->before_hook(
    gather_share => sub {
      my($build) = @_;

      if($self->path)
      {
        $self->_convert($build, Path::Tiny->new($self->path)->absolute);
      }
      else
      {
        $self->_recurse($build, Path::Tiny->new(".")->absolute);
      }

    },
  );
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::PkgConfig::MakeStatic - Convert .pc files into static

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 
 plugin 'PkgConfig::MakeStatic' => (
   path => 'lib/pkgconfig/foo.pc',
 );

=head1 DESCRIPTION

Convert C<.pc> file to use static linkage by default.  This is an experimental
plugin, so use with caution.

=head1 PROPERTIES

=head2 path

The path to the C<.pc> file.  If not provided, all C<.pc> files in the stage
directory will be converted.

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! �նzc  c  (  perl5/Alien/Build/Plugin/PkgConfig/PP.pmnu ��6�$        package Alien::Build::Plugin::PkgConfig::PP;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use Carp ();
use File::Which ();
use Env qw( @PKG_CONFIG_PATH );

# ABSTRACT: Probe system and determine library or tool properties using PkgConfig.pm
our $VERSION = '2.83'; # VERSION


has '+pkg_name' => sub {
  Carp::croak "pkg_name is a required property";
};


has atleast_version => undef;


has exact_version => undef;


has max_version => undef;


has minimum_version => undef;


use constant _min_version => '0.14026';

# private for now, used by negotiator
has register_prereqs => 1;

sub available
{
  !!eval { require PkgConfig; PkgConfig->VERSION(_min_version) };
}

sub _cleanup
{
  my($value) = @_;
  $value =~ s{\s*$}{ };
  $value;
}

sub init
{
  my($self, $meta) = @_;

  unless(defined $meta->prop->{env}->{PKG_CONFIG})
  {
    # TODO: Better would be to to "execute" lib/PkgConfig.pm
    # as that should always be available, and will match the
    # exact version of PkgConfig.pm that we are using here.
    # there are a few corner cases to deal with before we
    # can do this.  What is here should handle most use cases.
    my $command_line =
      File::Which::which('ppkg-config')
      ? 'ppkg-config'
      : File::Which::which('pkg-config.pl')
        ? 'pkg-config.pl'
        : File::Which::which('pkg-config')
          ? 'pkg-config'
          : undef;
    $meta->prop->{env}->{PKG_CONFIG} = $command_line
      if defined $command_line;
  }

  if($self->register_prereqs)
  {
    $meta->add_requires('configure' => 'PkgConfig' => _min_version);
  }

  my($pkg_name, @alt_names) = (ref $self->pkg_name) ? (@{ $self->pkg_name }) : ($self->pkg_name);

  $meta->register_hook(
    probe => sub {
      my($build) = @_;

      $build->runtime_prop->{legacy}->{name} ||= $pkg_name;
      $build->hook_prop->{probe_class} = __PACKAGE__;
      $build->hook_prop->{probe_instance_id} = $self->instance_id;

      require PkgConfig;
      my $pkg = PkgConfig->find($pkg_name);
      die "package @{[ $pkg_name ]} not found" if $pkg->errmsg;

      $build->hook_prop->{version} = $pkg->pkg_version;
      my $version = PkgConfig::Version->new($pkg->pkg_version);

      my $atleast_version = $self->atleast_version;
      $atleast_version = $self->minimum_version unless defined $atleast_version;
      if(defined $atleast_version)
      {
        my $need    = PkgConfig::Version->new($atleast_version);
        if($version < $need)
        {
          die "package @{[ $pkg_name ]} is @{[ $pkg->pkg_version ]}, but at least $atleast_version is required.";
        }
      }

      if(defined $self->exact_version)
      {
        my $need = PkgConfig::Version->new($self->exact_version);
        if($version != $need)
        {
          die "package @{[ $pkg_name ]} is @{[ $pkg->pkg_version ]}, but exactly @{[ $self->exact_version ]} is required.";
        }
      }

      if(defined $self->max_version)
      {
        my $need = PkgConfig::Version->new($self->max_version);
        if($version > $need)
        {
          die "package @{[ $pkg_name ]} is @{[ $pkg->pkg_version ]}, but max of @{[ $self->max_version ]} is required.";
        }
      }

      foreach my $alt (@alt_names)
      {
        my $pkg = PkgConfig->find($alt);
        die "package $alt not found" if $pkg->errmsg;
      }

      'system';
    },
  );

  $meta->register_hook(
    $_ => sub {
      my($build) = @_;

      return if $build->hook_prop->{name} eq 'gather_system'
      &&        ($build->install_prop->{system_probe_instance_id} || '') ne $self->instance_id;

      require PkgConfig;

      foreach my $name ($pkg_name, @alt_names)
      {
        require PkgConfig;
        my $pkg = PkgConfig->find($name, search_path => [@PKG_CONFIG_PATH]);
        if($pkg->errmsg)
        {
          $build->log("Trying to load the pkg-config information from the source code build");
          $build->log("of your package failed");
          $build->log("You are currently using the pure-perl implementation of pkg-config");
          $build->log("(AB Plugin is named PkgConfig::PP, which uses PkgConfig.pm");
          $build->log("It may work better with the real pkg-config.");
          $build->log("Try installing your OS' version of pkg-config or unset ALIEN_BUILD_PKG_CONFIG");
          die "second load of PkgConfig.pm @{[ $name ]} failed: @{[ $pkg->errmsg ]}"
        }
        my %prop;
        $prop{cflags}  = _cleanup scalar $pkg->get_cflags;
        $prop{libs}    = _cleanup scalar $pkg->get_ldflags;
        $prop{version} = $pkg->pkg_version;
        $pkg = PkgConfig->find($name, static => 1, search_path => [@PKG_CONFIG_PATH]);
        $prop{cflags_static} = _cleanup scalar $pkg->get_cflags;
        $prop{libs_static}   = _cleanup scalar $pkg->get_ldflags;
        $build->runtime_prop->{alt}->{$name} = \%prop;
      }
      foreach my $key (keys %{ $build->runtime_prop->{alt}->{$pkg_name} })
      {
        $build->runtime_prop->{$key} = $build->runtime_prop->{alt}->{$pkg_name}->{$key};
      }
      if(keys %{ $build->runtime_prop->{alt} } == 1)
      {
        delete $build->runtime_prop->{alt};
      }
    }
  ) for qw( gather_system gather_share );

  $self;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::PkgConfig::PP - Probe system and determine library or tool properties using PkgConfig.pm

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 plugin 'PkgConfig::PP' => (
   pkg_name => 'libfoo',
 );

=head1 DESCRIPTION

Note: in most case you will want to use L<Alien::Build::Plugin::PkgConfig::Negotiate>
instead.  It picks the appropriate fetch plugin based on your platform and environment.
In some cases you may need to use this plugin directly instead.

This plugin provides Probe and Gather steps for pkg-config based packages.  It uses
L<PkgConfig> to accomplish this task.

=head1 PROPERTIES

=head2 pkg_name

The package name.  If this is a list reference then .pc files with all those package
names must be present.  The first name will be the primary and used by default once
installed.  For the subsequent C<.pc> files you can use the
L<Alien::Base alt method|Alien::Base/alt> to retrieve the alternate configurations
once the L<Alien> is installed.

=head2 atleast_version

The minimum required version that is acceptable version as provided by the system.

=head2 exact_version

The exact required version that is acceptable version as provided by the system.

=head2 max_version

The max required version that is acceptable version as provided by the system.

=head2 minimum_version

Alias for C<atleast_version> for backward compatibility.

=head1 METHODS

=head2 available

 my $bool = Alien::Build::Plugin::PkgConfig::PP->available;

Returns true if the necessary prereqs for this plugin are I<already> installed.

=head1 SEE ALSO

L<Alien::Build::Plugin::PkgConfig::Negotiate>, L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! 6�O$  �$  .  perl5/Alien/Build/Plugin/Download/Negotiate.pmnu ��6�$        package Alien::Build::Plugin::Download::Negotiate;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use Alien::Build::Util qw( _has_ssl );
use Carp ();

# ABSTRACT: Download negotiation plugin
our $VERSION = '2.83'; # VERSION


has '+url' => undef;


has 'filter'  => undef;


has 'version' => undef;


has 'ssl'     => 0;


has 'passive' => 0;

has 'scheme'  => undef;


has 'bootstrap_ssl' => 0;


has 'prefer' => 1;


has 'decoder' => undef;


sub pick
{
  my($self) = @_;
  my($fetch, @decoders) = $self->_pick;
  if($self->decoder)
  {
    @decoders = ref $self->decoder ? @{ $self->decoder } : ($self->decoder);
  }
  ($fetch, @decoders);
}

sub _pick_decoder
{
  my($self) = @_;

  if(eval { require Mojo::DOM58; Mojo::DOM58->VERSION(1.00); 1 })
  { return "Decode::Mojo" }
  elsif(eval { require Mojo::DOM; require Mojolicious; Mojolicious->VERSION('7.00'); 1 })
  { return "Decode::Mojo" }
  elsif(eval { require HTML::LinkExtor; 1; })
  { return "Decode::HTML" }
  else
  { return "Decode::Mojo" }
}

sub _pick
{
  my($self) = @_;

  $self->scheme(
    $self->url !~ m!(ftps?|https?|file):!i
      ? 'file'
      : $self->url =~ m!^([a-z]+):!i
  ) unless defined $self->scheme;

  if($self->scheme eq 'https' || ($self->scheme eq 'http' && $self->ssl))
  {
    if($self->bootstrap_ssl && ! _has_ssl)
    {
      return (['Fetch::CurlCommand','Fetch::Wget'], __PACKAGE__->_pick_decoder);
    }
    elsif(_has_ssl)
    {
      return ('Fetch::HTTPTiny', __PACKAGE__->_pick_decoder);
    }
    #elsif(do { require Alien::Build::Plugin::Fetch::CurlCommand; Alien::Build::Plugin::Fetch::CurlCommand->protocol_ok('https') })
    #{
    #  return ('Fetch::CurlCommand', __PACKAGE__->_pick_decoder);
    #}
    else
    {
      return ('Fetch::HTTPTiny', __PACKAGE__->_pick_decoder);
    }
  }
  elsif($self->scheme eq 'http')
  {
    return ('Fetch::HTTPTiny', __PACKAGE__->_pick_decoder);
  }
  elsif($self->scheme eq 'ftp')
  {
    if($ENV{ftp_proxy} || $ENV{all_proxy})
    {
      return $self->scheme =~ /^ftps?/
        ? ('Fetch::LWP', 'Decode::DirListing', __PACKAGE__->_pick_decoder)
        : ('Fetch::LWP', __PACKAGE__->_pick_decoder);
    }
    else
    {
      return ('Fetch::NetFTP');
    }
  }
  elsif($self->scheme eq 'file')
  {
    return ('Fetch::Local');
  }
  else
  {
    die "do not know how to handle scheme @{[ $self->scheme ]} for @{[ $self->url ]}";
  }
}

sub init
{
  my($self, $meta) = @_;

  unless(defined $self->url)
  {
    if(defined $meta->prop->{start_url})
    {
      $self->url($meta->prop->{start_url});
    }
    else
    {
      Carp::croak "url is a required property unless you use the start_url directive";
    }
  }

  if($self->url =~ /^http.*github.com.*releases$/)
  {
    Alien::Build->log('!! WARNING !! WARNING !!');
    Alien::Build->log('!! WARNING !! It looks like this alien is using the regular download negotiator');
    Alien::Build->log('plugin on a GitHub release page.  This will typically not work due to changes');
    Alien::Build->log('in the way GitHub release page works now.  The Alien should instead be updated');
    Alien::Build->log('to use the Download::GitHub plugin, which uses the GitHub API to find available');
    Alien::Build->log('releases.  See: https://metacpan.org/pod/Alien::Build::Plugin::Download::GitHub');
    Alien::Build->log('!! WARNING !! WARNING !!');
  }

  $meta->add_requires('share' => 'Alien::Build::Plugin::Download::Negotiate' => '0.61')
    if $self->passive;

  $meta->prop->{plugin_download_negotiate_default_url} = $self->url;

  my($fetch, @decoders) = $self->pick;

  $fetch = [ $fetch ] unless ref $fetch;

  foreach my $fetch (@$fetch)
  {
    my @args;
    push @args, ssl => $self->ssl;
    # For historical reasons, we pass the URL into older fetch plugins, because
    # this used to be the interface.  Using start_url is now preferred!
    push @args, url => $self->url if $fetch =~ /^Fetch::(HTTPTiny|LWP|Local|LocalDir|NetFTP|CurlCommand)$/;
    push @args, passive => $self->passive if $fetch eq 'Fetch::NetFTP';
    push @args, bootstrap_ssl => $self->bootstrap_ssl if $self->bootstrap_ssl;

    $meta->apply_plugin($fetch, @args);
  }

  if($self->version)
  {
    $meta->apply_plugin($_) for @decoders;

    if(defined $self->prefer && ref($self->prefer) eq 'CODE')
    {
      $meta->add_requires('share' => 'Alien::Build::Plugin::Download::Negotiate' => '1.30');
      $meta->register_hook(
        prefer => $self->prefer,
      );
    }
    elsif($self->prefer)
    {
      $meta->apply_plugin('Prefer::SortVersions',
        (defined $self->filter ? (filter => $self->filter) : ()),
        version => $self->version,
      );
    }
    else
    {
      $meta->add_requires('share' => 'Alien::Build::Plugin::Download::Negotiate' => '1.30');
    }
  }
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Download::Negotiate - Download negotiation plugin

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 share {
   start_url 'http://ftp.gnu.org/gnu/make';
   plugin 'Download' => (
     filter => qr/^make-.*\.tar\.gz$/,
     version => qr/([0-9\.]+)/,
   );
 };

=head1 DESCRIPTION

This is a negotiator plugin for downloading packages from the internet.  This
plugin picks the best Fetch, Decode and Prefer plugins to do the actual work.
Which plugins are picked depend on the properties you specify, your platform
and environment.  It is usually preferable to use a negotiator plugin rather
than the Fetch, Decode and Prefer plugins directly from your L<alienfile>.

=head1 PROPERTIES

=head2 url

[DEPRECATED] use C<start_url> instead.

The Initial URL for your package.  This may be a directory listing (either in
HTML or ftp listing format) or the final tarball intended to be downloaded.

=head2 filter

This is a regular expression that lets you filter out files that you do not
want to consider downloading.  For example, if the directory listing contained
tarballs and readme files like this:

 foo-1.0.0.tar.gz
 foo-1.0.0.readme

You could specify a filter of C<qr/\.tar\.gz$/> to make sure only tarballs are
considered for download.

=head2 version

Regular expression to parse out the version from a filename.  The regular expression
should store the result in C<$1>.

Note: if you provide a C<version> property, this plugin will assume that you will
be downloading an initial index to select package downloads from.  Depending on
the protocol (and typically this is the case for http and HTML) that may bring in
additional dependencies.  If start_url points to a tarball or other archive directly
(without needing to do through an index selection process), it is recommended that
you not specify this property.

=head2 ssl

If your initial URL does not need SSL, but you know ahead of time that a subsequent
request will need it (for example, if your directory listing is on C<http>, but includes
links to C<https> URLs), then you can set this property to true, and the appropriate
Perl SSL modules will be loaded.

=head2 passive

If using FTP, attempt a passive mode transfer first, before trying an active mode transfer.

=head2 bootstrap_ssl

If set to true, then the download negotiator will avoid using plugins that have a dependency
on L<Net::SSLeay>, or other Perl SSL modules.  The intent for this option is to allow
OpenSSL to be alienized and be a useful optional dependency for L<Net::SSLeay>.

The implementation may improve over time, but as of this writing, this option relies on you
having a working C<curl> or C<wget> with SSL support in your C<PATH>.

=head2 prefer

How to sort candidates for selection.  This should be one of three types of values:

=over 4

=item code reference

This will be used as the prefer hook.

=item true value

Use L<Alien::Build::Plugin::Prefer::SortVersions>.

=item false value

Don't set any preference at all.  A hook must be installed, or another prefer plugin specified.

=back

=head2 decoder

Override the detected decoder.

=head1 METHODS

=head2 pick

 my($fetch, @decoders) = $plugin->pick;

Returns the fetch plugin and any optional decoders that should be used.

=head1 SEE ALSO

L<Alien::Build::Plugin::Prefer::BadVersion>, L<Alien::Build::Plugin::Prefer::GoodVersion>

L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! �V}K  K  +  perl5/Alien/Build/Plugin/Download/GitLab.pmnu ��6�$        package Alien::Build::Plugin::Download::GitLab;

use strict;
use warnings;
use 5.008004;
use Carp qw( croak );
use URI;
use JSON::PP qw( decode_json );
use URI::Escape qw( uri_escape );
use Alien::Build::Plugin;
use File::Basename qw( basename );
use Path::Tiny qw( path );

# ABSTRACT: Alien::Build plugin to download from GitLab
our $VERSION = '0.01'; # VERSION


has gitlab_host    => 'https://gitlab.com';
has gitlab_user    => undef;
has gitlab_project => undef;


has type => 'source';  # source or link


has format => 'tar.gz';


has version_from    => 'tag_name'; # tag_name or name
has convert_version => undef;
has link_name       => undef;

sub init
{
  my($self, $meta) = @_;

  croak("No gitlab_user provided") unless defined $self->gitlab_user;
  croak("No gitlab_project provided") unless defined $self->gitlab_project;
  croak("Don't set set a start_url with the Download::GitLab plugin") if defined $meta->prop->{start_url};

  $meta->add_requires('configure' => 'Alien::Build::Plugin::Download::GitLab' => 0 );

  my $url = URI->new($self->gitlab_host);
  $url->path("/api/v4/projects/@{[ uri_escape(join '/', $self->gitlab_user, $self->gitlab_project) ]}/releases");
  $meta->prop->{start_url} ||= "$url";

  $meta->apply_plugin('Download');
  $meta->apply_plugin('Extract', format => $self->format );

  # we assume that GitLab returns the releases in reverse
  # chronological order.
  $meta->register_hook(
    prefer => sub {
      my($build, $res) = @_;
      return $res;
    },
  );

  croak "type must be one of source or link" if $self->type !~ /^(source|link)$/;
  croak "version_from must be one of tag_name or name" if $self->version_from !~ /^(tag_name|name)$/;

  ## TODO insert tokens as header if possible
  ## This may help with rate limiting (or if not then don't bother)
  # curl --header "PRIVATE-TOKEN: <your_access_token>" "https://gitlab.example.com/api/v4/projects/24/releases"

  $meta->around_hook(
    fetch => sub {
      my $orig = shift;
      my($build, $url, @the_rest) = @_;

      # only modify the response if we are using the GitLab API
      # to get the release list
      return $orig->($build, $url, @the_rest)
        if defined $url && $url ne $meta->prop->{start_url};

      my $res = $orig->($build, $url, @the_rest);

      my $res2 = {
        type => 'list',
        list => [],
      };

      $res2->{protocol} = $res->{protocol} if exists $res->{protocol};

      my $rel;
      if($res->{content})
      {
        $rel = decode_json $res->{content};
      }
      elsif($res->{path})
      {
        $rel = decode_json path($res->{path})->slurp_raw;
      }
      else
      {
        croak("malformed response object: no content or path");
      }

      foreach my $release (@$rel)
      {
        my $version = $self->version_from eq 'name' ? $release->{name} : $release->{tag_name};
        $version = $self->convert_version->($version) if $self->convert_version;

        if($self->type eq 'source')
        {
          foreach my $source (@{ $release->{assets}->{sources} })
          {
            next unless $source->{format} eq $self->format;
            my $url = URI->new($source->{url});
            my $filename = basename $url->path;
            push @{ $res2->{list} }, {
              filename => $filename,
              url      => $source->{url},
              version  => $version,
            };
          }
        }
        else # link
        {
          foreach my $link (@{ $release->{assets}->{links} })
          {
            my $url = URI->new($link->{url});
            my $filename => basename $url->path;
            if($self->link_name)
            {
              next unless $filename =~ $self->link_name;
            }
            push @{ $res2->{list} }, {
              filename => $filename,
              url      => $link->{url},
              version  => $version,
            };
          }
        }
      }

      return $res2;

    },
  );
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Download::GitLab - Alien::Build plugin to download from GitLab

=head1 VERSION

version 0.01

=head1 SYNOPSIS

 use alienfile;
 
 plugin 'Download::GitLab' => (
   gitlab_user    => 'plicease',
   gitlab_project => 'dontpanic',
 );

=head1 DESCRIPTION

This plugin is designed for downloading assets from a GitLab instance.

=head1 PROPERTIES

=head2 gitlab_host

The host to fetch from L<https://gitlab.com> by default.

=head2 gitlab_user

The user to fetch from.

=head2 gitlab_project

The project to fetch from.

=head2 type

The asset type to fetch.  This must be one of C<source> or C<link>.

=head2 format

The expected format of the asset.  This should be one that
L<Alien::Build::Plugin::Extract::Negotiate> understands.  The
default is C<tar.gz>.

=head2 version_from

Where to compute the version from.  This should be one of
C<tag_name> or C<name>.  The default is C<tag_name>.

=head2 convert_version

This is an optional code reference, which can be used to modify
the version.  For example, if tags have a C<v> prefix you could
remove it like so:

 plugin 'Download::GitLab' => (
   gitlab_user     => 'plicease',
   gitlab_project  => 'dontpanic',
   convert_version => sub {
     my $version = shift;
     $version =~ s/^v//;
     return $version;
   },
 );

=head2 link_name

For C<link> types, this is a regular expression that filters the
asset filenames.  For example, if there are multiple archive
formats provided, you can get just the gzip'd tarball by setting
this to C<qr/\.tar\.gz$/>.

=head1 SEE ALSO

=over 4

=item L<Alien>

=item L<Alien::Build::Plugin::Download::GitHub>

=item L<alienfile>

=item L<Alien::Build>

=back

=head1 AUTHOR

Graham Ollis <plicease@cpan.org>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2022 by Graham Ollis.

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

=cut
PK       ! ���    4  perl5/Alien/Build/Plugin/Decode/DirListingFtpcopy.pmnu ��6�$        package Alien::Build::Plugin::Decode::DirListingFtpcopy;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use File::Basename ();

# ABSTRACT: Plugin to extract links from a directory listing using ftpcopy
our $VERSION = '2.83'; # VERSION


sub init
{
  my($self, $meta) = @_;

  $meta->add_requires('share' => 'File::Listing::Ftpcopy' => 0);
  $meta->add_requires('share' => 'URI' => 0);

  $meta->register_hook( decode => sub {
    my(undef, $res) = @_;

    die "do not know how to decode @{[ $res->{type} ]}"
      unless $res->{type} eq 'dir_listing';

    my $base = URI->new($res->{base});

    return {
      type => 'list',
      list => [
        map {
          my($name) = @$_;
          my $basename = $name;
          $basename =~ s{/$}{};
          my %h = (
            filename => File::Basename::basename($basename),
            url      => URI->new_abs($name, $base)->as_string,
          );
          \%h;
        } File::Listing::Ftpcopy::parse_dir($res->{content})
      ],
    };
  });

  $self;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Decode::DirListingFtpcopy - Plugin to extract links from a directory listing using ftpcopy

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 plugin 'Decode::DirListingFtpcopy';

=head1 DESCRIPTION

Note: in most case you will want to use L<Alien::Build::Plugin::Download::Negotiate>
instead.  It picks the appropriate decode plugin based on your platform and environment.
In some cases you may need to use this plugin directly instead.

This plugin decodes a ftp file listing into a list of candidates for your Prefer plugin.
It is useful when fetching from an FTP server via L<Alien::Build::Plugin::Fetch::LWP>.
It is different from the similarly named L<Alien::Build::Plugin::Decode::DirListingFtpcopy>
in that it uses L<File::Listing::Ftpcopy> instead of L<File::Listing>.  The rationale for
the C<Ftpcopy> version is that it supports a different set of FTP servers, including
OpenVMS.  In most cases, however, you probably want to use the non C<Ftpcopy> version
since it is pure perl.

=head1 SEE ALSO

L<Alien::Build::Plugin::Download::Negotiate>, L<Alien::Build::Plugin::Decode::DirListing>, L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! �w@�3  3  '  perl5/Alien/Build/Plugin/Decode/HTML.pmnu ��6�$        package Alien::Build::Plugin::Decode::HTML;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use File::Basename ();

# ABSTRACT: Plugin to extract links from HTML
our $VERSION = '2.83'; # VERSION


sub init
{
  my($self, $meta) = @_;

  $meta->add_requires('share' => 'HTML::LinkExtor' => 0);
  $meta->add_requires('share' => 'URI' => 0);
  $meta->add_requires('share' => 'URI::Escape' => 0);

  $meta->register_hook( decode => sub {
    my(undef, $res) = @_;

    die "do not know how to decode @{[ $res->{type} ]}"
      unless $res->{type} eq 'html';

    my $base = URI->new($res->{base});

    my @list;

    my $p = HTML::LinkExtor->new(sub {
      my($tag, %links) = @_;
      if($tag eq 'base' && $links{href})
      {
        $base = URI->new($links{href});
      }
      elsif($tag eq 'a' && $links{href})
      {
        my $href = $links{href};
        return if $href =~ m!^\.\.?/?$!;
        my $url = URI->new_abs($href, $base);
        my $path = $url->path;
        $path =~ s{/$}{}; # work around for Perl 5.8.7- gh#8
        push @list, {
          filename => URI::Escape::uri_unescape(File::Basename::basename($path)),
          url      => URI::Escape::uri_unescape($url->as_string),
        };
      }
    });

    $p->parse($res->{content});

    return {
      type => 'list',
      list => \@list,
    };
  });

  $self;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Decode::HTML - Plugin to extract links from HTML

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 plugin 'Decode::HTML';

=head1 DESCRIPTION

Note: in most case you will want to use L<Alien::Build::Plugin::Download::Negotiate>
instead.  It picks the appropriate decode plugin based on your platform and environment.
In some cases you may need to use this plugin directly instead.

This plugin decodes an HTML file listing into a list of candidates for your Prefer plugin.

=head1 SEE ALSO

L<Alien::Build::Plugin::Download::Negotiate>, L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! Mq�Fg  g  -  perl5/Alien/Build/Plugin/Decode/DirListing.pmnu ��6�$        package Alien::Build::Plugin::Decode::DirListing;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use File::Basename ();

# ABSTRACT: Plugin to extract links from a directory listing
our $VERSION = '2.83'; # VERSION


sub init
{
  my($self, $meta) = @_;

  $meta->add_requires('share' => 'File::Listing' => 0);
  $meta->add_requires('share' => 'URI' => 0);

  $meta->register_hook( decode => sub {
    my(undef, $res) = @_;

    die "do not know how to decode @{[ $res->{type} ]}"
      unless $res->{type} eq 'dir_listing';

    my $base = URI->new($res->{base});

    return {
      type => 'list',
      list => [
        map {
          my($name) = @$_;
          my $basename = $name;
          $basename =~ s{/$}{};
          my %h = (
            filename => File::Basename::basename($basename),
            url      => URI->new_abs($name, $base)->as_string,
          );
          \%h;
        } File::Listing::parse_dir($res->{content})
      ],
    };
  });

  $self;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Decode::DirListing - Plugin to extract links from a directory listing

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 plugin 'Decode::DirListing';

=head1 DESCRIPTION

Note: in most case you will want to use L<Alien::Build::Plugin::Download::Negotiate>
instead.  It picks the appropriate decode plugin based on your platform and environment.
In some cases you may need to use this plugin directly instead.

This plugin decodes a ftp file listing into a list of candidates for your Prefer plugin.
It is useful when fetching from an FTP server via L<Alien::Build::Plugin::Fetch::LWP>.

=head1 SEE ALSO

L<Alien::Build::Plugin::Download::Negotiate>, L<Alien::Build::Plugin::Decode::DirListingFtpcopy>, L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! ��tw      '  perl5/Alien/Build/Plugin/Decode/Mojo.pmnu ��6�$        package Alien::Build::Plugin::Decode::Mojo;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;

# ABSTRACT: Plugin to extract links from HTML using Mojo::DOM or Mojo::DOM58
our $VERSION = '2.83'; # VERSION


sub _load ($;$)
{
  my($class, $version) = @_;
  my $pm = "$class.pm";
  $pm =~ s/::/\//g;
  eval { require $pm };
  return 0 if $@;
  if(defined $version)
  {
    eval { $class->VERSION($version) };
    return 0 if $@;
  }
  return 1;
}

has _class => sub {
  return 'Mojo::DOM58' if _load 'Mojo::DOM58';
  return 'Mojo::DOM'   if _load 'Mojo::DOM' and _load 'Mojolicious', 7.00;
  return 'Mojo::DOM58';
};

sub init
{
  my($self, $meta) = @_;

  $meta->add_requires('share' => 'URI' => 0);
  $meta->add_requires('share' => 'URI::Escape' => 0);

  my $class = $meta->prop->{plugin_decode_mojo_class} ||= $self->_class;

  if($class eq 'Mojo::DOM58')
  {
    $meta->add_requires('share' => 'Mojo::DOM58' => '1.00');
  }
  elsif($class eq 'Mojo::DOM')
  {
    $meta->add_requires('share' => 'Mojolicious' => '7.00');
    $meta->add_requires('share' => 'Mojo::DOM'   => '0');
  }
  else
  {
    die "bad class";
  }

  $meta->register_hook( decode => sub {
    my(undef, $res) = @_;

    die "do not know how to decode @{[ $res->{type} ]}"
      unless $res->{type} eq 'html';

    my $dom = $class->new($res->{content});

    my $base = URI->new($res->{base});

    if(my $base_element = $dom->find('head base')->first)
    {
      my $href = $base_element->attr('href');
      $base = URI->new($href) if defined $href;
    }

    my @list = map {
                 my $url = URI->new_abs($_, $base);
                 my $path = $url->path;
                 $path =~ s{/$}{}; # work around for Perl 5.8.7- gh#8
                 {
                   filename => URI::Escape::uri_unescape(File::Basename::basename($path)),
                   url      => URI::Escape::uri_unescape($url->as_string),
                 }
               }
               grep !/^\.\.?\/?$/,
               map { $_->attr('href') || () }
               @{ $dom->find('a')->to_array };

    return {
      type => 'list',
      list => \@list,
    };
  })


}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Decode::Mojo - Plugin to extract links from HTML using Mojo::DOM or Mojo::DOM58

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 plugin 'Decode::Mojo';

Force using C<Decode::Mojo> via the download negotiator:

 use alienfile 1.68;
 
 configure {
   requires 'Alien::Build::Plugin::Decode::Mojo';
 };
 
 plugin 'Download' => (
   ...
   decoder => 'Decode::Mojo',
 );

=head1 DESCRIPTION

Note: in most cases you will want to use L<Alien::Build::Plugin::Download::Negotiate>
instead.  It picks the appropriate decode plugin based on your platform and environment.
In some cases you may need to use this plugin directly instead.

This plugin decodes an HTML file listing into a list of candidates for your Prefer plugin.
It works just like L<Alien::Build::Plugin::Decode::HTML> except it uses either L<Mojo::DOM>
or L<Mojo::DOM58> to do its job.

This plugin is much lighter than The C<Decode::HTML> plugin, and doesn't require XS.  It
is the default decode plugin used by L<Alien::Build::Plugin::Download::Negotiate> if it
detects that you need to parse an HTML index.

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! ��2R  R  %  perl5/Alien/Build/Plugin/Download.podnu ��6�$        # PODNAME: Alien::Build::Plugin::Download
# ABSTRACT: Download Alien::Build plugins
# VERSION

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Download - Download Alien::Build plugins

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile
 share {
   start_url 'http://ftp.gnu.org/gnu/make';
   plugin 'Download';
 };

=head1 DESCRIPTION

Download plugins download packages from the internet.

=over 4

=item L<Alien::Build::Plugin::Download::Negotiate>

=back

=head1 SEE ALSO

L<Alien::Build>, L<Alien::Build::Plugin>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! Y��	  �	  "  perl5/Alien/Build/Plugin/Build.podnu ��6�$        # PODNAME: Alien::Build::Plugin::Build
# ABSTRACT: Build Alien::Build plugins
# VERSION

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Build - Build Alien::Build plugins

=head1 VERSION

version 2.83

=head1 SYNOPSIS

For autoconf:

 use alienfile;
 plugin 'Build::Autoconf';

for unixy (even on windows):

 use alienfile;
 plugin 'Build::MSYS';

=head1 DESCRIPTION

Build plugins provide tools for building your package once it has been
downloaded and extracted.

=over 4

=item L<Alien::Build::Plugin::Build::Autoconf>

For dealing with packages that are configured using autotools,
or an autotools-like C<configure> script.

=item L<Alien::Build::Plugin::Build::CMake>

For dealing with packages that are configured and built using CMake.

=item L<Alien::Build::Plugin::Build::Copy>

For dealing with packages that do not require any build, and can just
be copied into their final location.

=item L<Alien::Build::Plugin::Build::MSYS>

For dealing with packages that require MSYS on Windows in order to
build.  This plugin is typically a no-op on other platforms.

=item L<Alien::Build::Plugin::Build::Make>

For dealing with packages that require Make to build.  Several
flavors of Make are supported, including GNU Make and BSD Make.

=item L<Alien::Build::Plugin::Build::SearchDep>

Add other L<Alien>s as dependencies.

=back

=head1 SEE ALSO

L<Alien::Build>, L<Alien::Build::Plugin>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! W�A0;	  ;	  "  perl5/Alien/Build/Plugin/Probe.podnu ��6�$        # PODNAME: Alien::Build::Plugin::Probe
# ABSTRACT: Probe Alien::Build plugins
# VERSION

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Probe - Probe Alien::Build plugins

=head1 VERSION

version 2.83

=head1 SYNOPSIS

look for libraries in known location:

 use alienfile;
 plugin 'Probe::CBuilder' => (
   cflags => '-I/opt/libfoo/include',
   libs   => '-L/opt/libfoo/lib -lfoo',
 );

look for tools in the path:

 use alienfile;
 plugin 'Probe::CommandLine' => (
   command => 'gzip',
   args    => [ '--version' ],
   match   => qr/gzip/,
   version => qr/gzip ([0-9\.]+)/,
 );

Use C<vcpkg> for Visual C++ Perl:

 use alienfile;
 plugin 'Probe::Vcpkg' => 'libffi';

=head1 DESCRIPTION

Probe plugins try to find existing libraries and tools
I<already> installed on the system.  If found they can
be used instead of downloading the source from the
internet and building.

=over 4

=item L<Alien::Build::Plugin::Probe::CBuilder>

Use L<ExtUtils::CBuilder> to probe for existing installed
library.

=item L<Alien::Build::Plugin::Probe::CommandLine>

Execute commands to probe for existing tools.

=item L<Alien::Build::Plugin::Probe::Vcpkg>

Use L<Win32::Vcpkg> to probe for existing installed library.

=back

=head1 SEE ALSO

L<Alien::Build>, L<Alien::Build::Plugin>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! Ƌ7��  �  #  perl5/Alien/Build/Plugin/Prefer.podnu ��6�$        # PODNAME: Alien::Build::Plugin::Prefer
# ABSTRACT: Prefer Alien::Build plugins
# VERSION

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Prefer - Prefer Alien::Build plugins

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 share {
   start_url 'http://ftp.gnu.org/gnu/make';
   plugin 'Download';
 };

=head1 DESCRIPTION

Prefer plugins sort

Decode plugins decode HTML and FTP file listings.  Normally you
will want to use the L<Alien::Build::Plugin::Download::Negotiate>
plugin which will automatically load the appropriate Prefer plugins.

=over 4

=item L<Alien::Build::Plugin::Prefer::BadVersion>

Filter out known bad versions from a candidate list.

=item L<Alien::Build::Plugin::Prefer::GoodVersion>

Require specific known good versions from a candidate list.

=item L<Alien::Build::Plugin::Prefer::SortVersions>

Sort candidates by version.

=back

=head1 SEE ALSO

L<Alien::Build>, L<Alien::Build::Plugin>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! �<b�  �  '  perl5/Alien/Build/Plugin/Fetch/Local.pmnu ��6�$        package Alien::Build::Plugin::Fetch::Local;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use File::chdir;
use Path::Tiny ();

# ABSTRACT: Plugin for fetching a local file
our $VERSION = '2.83'; # VERSION


has '+url' => '';


has root => undef;


has ssl => 0;

sub init
{
  my($self, $meta) = @_;

  $meta->prop->{start_url} ||= $self->url;
  $self->url($meta->prop->{start_url} || 'patch');

  if($self->url =~ /^file:/)
  {
    $meta->add_requires('share' => 'URI'         => 0 );
    $meta->add_requires('share' => 'URI::file'   => 0 );
    $meta->add_requires('share' => 'URI::Escape' => 0 );
  }

  {
    my $root = $self->root;
    if(defined $root)
    {
      $root = Path::Tiny->new($root)->absolute->stringify;
    }
    else
    {
      $root = "$CWD";
    }
    $self->root($root);
  }

  $meta->register_hook( fetch => sub {
    my($build, $path, %options) = @_;

    $build->log("plugin Fetch::Local does not support http_headers option") if $options{http_headers};

    $path ||= $self->url;

    if($path =~ /^file:/)
    {
      my $root = URI::file->new($self->root);
      my $url = URI->new_abs($path, $root);
      $path = URI::Escape::uri_unescape($url->path);
      $path =~ s{^/([a-z]:)}{$1}i if $^O eq 'MSWin32';
    }

    $path = Path::Tiny->new($path)->absolute($self->root);

    if(-d $path)
    {
      return {
        type     => 'list',
        protocol => 'file',
        list     => [
          map { { filename => $_->basename, url => $_->stringify } }
          sort { $a->basename cmp $b->basename } $path->children,
        ],
      };
    }
    elsif(-f $path)
    {
      return {
        type     => 'file',
        filename => $path->basename,
        path     => $path->stringify,
        tmp      => 0,
        protocol => 'file',
      };
    }
    else
    {
      die "no such file or directory $path";
    }


  });
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Fetch::Local - Plugin for fetching a local file

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 share {
   start_url 'patch/libfoo-1.00.tar.gz';
   plugin 'Fetch::Local';
 };

=head1 DESCRIPTION

Note: in most case you will want to use L<Alien::Build::Plugin::Download::Negotiate>
instead.  It picks the appropriate fetch plugin based on your platform and environment.
In some cases you may need to use this plugin directly instead.

This fetch plugin fetches files from the local file system.  It is mostly useful if you
intend to bundle packages (as tarballs or zip files) with your Alien.  If you intend to
bundle a source tree, use L<Alien::Build::Plugin::Fetch::LocalDir>.

=head1 PROPERTIES

=head2 url

The initial URL to fetch.  This may be a C<file://> style URL, or just the path on the
local system.

=head2 root

The directory from which the URL should be relative.  The default is usually reasonable.

=head2 ssl

This property is for compatibility with other fetch plugins, but is not used.

=head1 SEE ALSO

=over 4

=item L<Alien::Build::Plugin::Download::Negotiate>

=item L<Alien::Build::Plugin::Fetch::LocalDir>

=item L<Alien::Build>

=item L<alienfile>

=item L<Alien::Build::MM>

=item L<Alien>

=back

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! t���   �   -  perl5/Alien/Build/Plugin/Fetch/CurlCommand.pmnu ��6�$        package Alien::Build::Plugin::Fetch::CurlCommand;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use File::Which qw( which );
use Path::Tiny qw( path );
use Capture::Tiny qw( capture );
use File::Temp qw( tempdir );
use List::Util 1.33 qw( any pairmap );
use File::chdir;

# ABSTRACT: Plugin for fetching files using curl
our $VERSION = '2.83'; # VERSION


sub curl_command
{
  defined $ENV{CURL} ? scalar which($ENV{CURL}) : scalar which('curl');
}

has ssl => 0;
has _see_headers => 0;
has '+url' => '';

# when bootstrapping we have to specify this plugin as a prereq
# 1 is the default so that when this plugin is used directly
# you also get the prereq
has bootstrap_ssl => 1;


sub protocol_ok
{
  my($class, $protocol) = @_;
  my $curl = $class->curl_command;
  return 0 unless defined $curl;
  my($out, $err, $exit) = capture {
    system $curl, '--version';
  };

  {
    # make sure curl supports the -J option.
    # CentOS 6 for example is recent enough
    # that it does not.  gh#147, gh#148, gh#149
    local $CWD = tempdir( CLEANUP => 1 );
    my $file1 = path('foo/foo.txt');
    $file1->parent->mkpath;
    $file1->spew("hello world\n");
    my $url = 'file://' . $file1->absolute;
    my($out, $err, $exit) = capture {
      system $curl, '-O', '-J', $url;
    };
    my $file2 = $file1->parent->child($file1->basename);
    unlink "$file1";
    unlink "$file2";
    rmdir($file1->parent);
    return 0 if $exit;
  }

  foreach my $line (split /\n/, $out)
  {
    if($line =~ /^Protocols:\s*(.*)\s*$/)
    {
      my %proto = map { $_ => 1 } split /\s+/, $1;
      return $proto{$protocol} if $proto{$protocol};
    }
  }
  return 0;
}

sub init
{
  my($self, $meta) = @_;

  $meta->prop->{start_url} ||= $self->url;
  $self->url($meta->prop->{start_url});
  $self->url || Carp::croak('url is a required property');

  $meta->add_requires('configure', 'Alien::Build::Plugin::Fetch::CurlCommand' => '1.19')
    if $self->bootstrap_ssl;

  $meta->register_hook(
    fetch => sub {
      my($build, $url, %options) = @_;
      $url ||= $self->url;

      my($scheme) = $url =~ /^([a-z0-9]+):/i;

      if($scheme =~ /^https?$/)
      {
        local $CWD = tempdir( CLEANUP => 1 );

        my @writeout = (
          "ab-filename     :%{filename_effective}",
          "ab-content_type :%{content_type}",
          "ab-url          :%{url_effective}",
        );

        $build->log("writeout: $_\\n") for @writeout;
        path('writeout')->spew(join("\\n", @writeout));

        my @headers;
        if(my $headers = $options{http_headers})
        {
          if(ref $headers eq 'ARRAY')
          {
            @headers = pairmap { -H => "$a: $b" } @$headers;
          }
          else
          {
            $build->log("Fetch for $url with http_headers that is not an array reference");
          }
        }

        my @command = (
          $self->curl_command,
          '-L', '-f', '-O', '-J',
          -w => '@writeout',
          @headers,
        );

        push @command, -D => 'head' if $self->_see_headers;

        push @command, $url;

        my($stdout, $stderr) = $self->_execute($build, @command);

        my %h = map { /^ab-(.*?)\s*:(.*)$/ ? ($1 => $2) : () } split /\n/, $stdout;

        if(-e 'head')
        {
          $build->log(" ~ $_ => $h{$_}") for sort keys %h;
          $build->log(" header: $_") for path('headers')->lines;
        }

        my($type) = split /;/, $h{content_type};

        if($type eq 'text/html')
        {
          return {
            type     => 'html',
            base     => $h{url},
            content  => scalar path($h{filename})->slurp,
            protocol => $scheme,
          };
        }
        else
        {
          return {
            type     => 'file',
            filename => $h{filename},
            path     => path($h{filename})->absolute->stringify,
            protocol => $scheme,
          };
        }
      }
#      elsif($scheme eq 'ftp')
#      {
#        if($url =~ m{/$})
#        {
#          my($stdout, $stderr) = $self->_execute($build, $self->curl_command, -l => $url);
#          chomp $stdout;
#          return {
#            type => 'list',
#            list => [
#              map { { filename => $_, url => "$url$_" } } sort split /\n/, $stdout,
#            ],
#          };
#        }
#
#        my $first_error;
#
#        {
#          local $CWD = tempdir( CLEANUP => 1 );
#
#          my($filename) = $url =~ m{/([^/]+)$};
#          $filename = 'unknown' if (! defined $filename) || ($filename eq '');
#          my($stdout, $stderr) = eval { $self->_execute($build, $self->curl_command, -o => $filename, $url) };
#          $first_error = $@;
#          if($first_error eq '')
#          {
#            return {
#              type     => 'file',
#              filename => $filename,
#              path     => path($filename)->absolute->stringify,
#            };
#          }
#        }
#
#        {
#          my($stdout, $stderr) = eval { $self->_execute($build, $self->curl_command, -l => "$url/") };
#          if($@ eq '')
#          {
#            chomp $stdout;
#            return {
#              type => 'list',
#              list => [
#                map { { filename => $_, url => "$url/$_" } } sort split /\n/, $stdout,
#              ],
#            };
#          };
#        }
#
#        $first_error ||= 'unknown error';
#        die $first_error;
#
#      }
      else
      {
        die "scheme $scheme is not supported by the Fetch::CurlCommand plugin";
      }

    },
  ) if $self->curl_command;

  $self;
}

sub _execute
{
  my($self, $build, @command) = @_;
  $build->log("+ @command");
  my($stdout, $stderr, $err) = capture {
    system @command;
    $?;
  };
  if($err)
  {
    chomp $stderr;
    $build->log($_) for split /\n/, $stderr;
    if($stderr =~ /Remote filename has no length/ && !!(any { /^-O$/ } @command))
    {
      my @new_command = map {
        /^-O$/ ? ( -o => 'index.html' ) : /^-J$/ ? () : ($_)
      } @command;
      return $self->_execute($build, @new_command);
    }
    die "error in curl fetch";
  }
  ($stdout, $stderr);
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Fetch::CurlCommand - Plugin for fetching files using curl

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 
 share {
   start_url 'https://www.openssl.org/source/';
   plugin 'Fetch::CurlCommand';
 };

=head1 DESCRIPTION

This plugin provides a fetch based on the C<curl> command.  It works with other fetch
plugins (that is, the first one which succeeds will be used).  Most of the time the best plugin
to use will be L<Alien::Build::Plugin::Download::Negotiate>, but for some SSL bootstrapping
it may be desirable to try C<curl> first.

Protocols supported: C<http>, C<https>

C<https> support requires that curl was built with SSL support.

=head1 PROPERTIES

=head2 curl_command

The full path to the C<curl> command.  The default is usually correct.

=head2 ssl

Ignored by this plugin.  Provided for compatibility with some other fetch plugins.

=head1 METHODS

=head2 protocol_ok

 my $bool = $plugin->protocol_ok($protocol);
 my $bool = Alien::Build::Plugin::Fetch::CurlCommand->protocol_ok($protocol);

=head1 SEE ALSO

=over 4

=item L<alienfile>

=item L<Alien::Build>

=back

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! .j?��  �  (  perl5/Alien/Build/Plugin/Fetch/NetFTP.pmnu ��6�$        package Alien::Build::Plugin::Fetch::NetFTP;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use Carp ();
use File::Temp ();
use Path::Tiny qw( path );

# ABSTRACT: Plugin for fetching files using Net::FTP
our $VERSION = '2.83'; # VERSION


has '+url' => '';


has ssl => 0;


has passive => 0;

sub init
{
  my($self, $meta) = @_;

  $meta->prop->{start_url} ||= $self->url;
  $self->url($meta->prop->{start_url});
  $self->url || Carp::croak('url is a required property');

  $meta->add_requires('share' => 'Net::FTP' => 0 );
  $meta->add_requires('share' => 'URI' => 0 );
  $meta->add_requires('share' => 'Alien::Build::Plugin::Fetch::NetFTP' => '0.61')
    if $self->passive;

  $meta->register_hook( fetch => sub {
    my($build, $url, %options) = @_;
    $url ||= $self->url;

    $build->log("plugin Fetch::NetFTP does not support http_headers option") if $options{http_headers};

    $url = URI->new($url);

    die "Fetch::NetFTP does not support @{[ $url->scheme ]}"
      unless $url->scheme eq 'ftp';

    $build->log("trying passive mode FTP first") if $self->passive;
    my $ftp = _ftp_connect($url, $self->passive);

    my $path = $url->path;

    unless($path =~ m!/$!)
    {
      my(@parts) = split /\//, $path;
      my $filename = pop @parts;
      my $dir      = join '/', @parts;

      my $path = eval {
        $ftp->cwd($dir) or die;
        my $tdir = File::Temp::tempdir( CLEANUP => 1);
        my $path = path("$tdir/$filename")->stringify;

        unless(eval { $ftp->get($filename, $path) }) # NAT problem? try to use passive mode
        {
          $ftp->quit;

          $build->log("switching to @{[ $self->passive ? 'active' : 'passive' ]} mode");
          $ftp = _ftp_connect($url, !$self->passive);

          $ftp->cwd($dir) or die;

          $ftp->get($filename, $path) or die;
        }

        $path;
      };

      if(defined $path)
      {
        return {
          type     => 'file',
          filename => $filename,
          path     => $path,
          protocol => 'ftp',
        };
      }

      $path .= "/";
    }

    $ftp->quit;
    $ftp = _ftp_connect($url, $self->passive);
    $ftp->cwd($path) or die "unable to fetch $url as either a directory or file";

    my $list = eval { $ftp->ls };
    unless(defined $list) # NAT problem? try to use passive mode
    {
      $ftp->quit;

      $build->log("switching to @{[ $self->passive ? 'active' : 'passive' ]} mode");
      $ftp = _ftp_connect($url, !$self->passive);

      $ftp->cwd($path) or die "unable to fetch $url as either a directory or file";

      $list = $ftp->ls;

      die "cannot list directory $path on $url" unless defined $list;
    }

    die "no files found at $url" unless @$list;

    $path .= '/' unless $path =~ /\/$/;

    return {
      type     => 'list',
      protocol => 'ftp',
      list     => [
        map {
          my $filename = $_;
          my $furl = $url->clone;
          $furl->path($path . $filename);
          my %h = (
            filename => $filename,
            url      => $furl->as_string,
          );
          \%h;
        } sort @$list,
      ],
    };

  });

  $self;
}

sub _ftp_connect {
  my $url = shift;
  my $is_passive = shift || 0;

  my $ftp = Net::FTP->new(
    $url->host, Port =>$url->port, Passive =>$is_passive,
  ) or die "error fetching $url: $@";

  $ftp->login($url->user, $url->password)
    or die "error on login $url: @{[ $ftp->message ]}";

  $ftp->binary;

  $ftp;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Fetch::NetFTP - Plugin for fetching files using Net::FTP

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 share {
   start_url 'ftp://ftp.gnu.org/gnu/make';
   plugin 'Fetch::NetFTP';
 };

=head1 DESCRIPTION

Note: in most case you will want to use L<Alien::Build::Plugin::Download::Negotiate>
instead.  It picks the appropriate fetch plugin based on your platform and environment.
In some cases you may need to use this plugin directly instead.

This fetch plugin fetches files and directory listings via the C<ftp>, protocol using
L<Net::FTP>.

=head1 PROPERTIES

=head2 url

The initial URL to fetch.  This may be a directory or the final file.

=head2 ssl

This property is for compatibility with other fetch plugins, but is not used.

=head2 passive

If set to true, try passive mode FIRST.  By default it will try an active mode, then
passive mode.

=head1 SEE ALSO

L<Alien::Build::Plugin::Download::Negotiate>, L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! 6���  �  *  perl5/Alien/Build/Plugin/Fetch/HTTPTiny.pmnu ��6�$        package Alien::Build::Plugin::Fetch::HTTPTiny;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use File::Basename ();
use Alien::Build::Util qw( _ssl_reqs );
use Carp ();

# ABSTRACT: Plugin for fetching files using HTTP::Tiny
our $VERSION = '2.83'; # VERSION


has '+url' => '';


has ssl => 0;

# ignored for compatability
has bootstrap_ssl => 1;

sub init
{
  my($self, $meta) = @_;

  $meta->add_requires('share' => 'HTTP::Tiny'  => '0.044' );
  $meta->add_requires('share' => 'URI'         => '0'     );
  $meta->add_requires('share' => 'Mozilla::CA' => '0'     );

  $meta->prop->{start_url} ||= $self->url;
  $self->url($meta->prop->{start_url});
  $self->url || Carp::croak('url is a required property');

  if($self->url =~ /^https:/ || $self->ssl)
  {
    my $reqs = _ssl_reqs;
    foreach my $mod (sort keys %$reqs)
    {
      $meta->add_requires('share' => $mod => $reqs->{$mod});
    }
  }

  $meta->register_hook( fetch => sub {
    my($build, $url, %options) = @_;
    $url ||= $self->url;

    $url = URI->new($url) unless ref($url) && $url->isa('URI');

    my %headers;
    if(my $headers = $options{http_headers})
    {
      if(ref $headers eq 'ARRAY')
      {
        my @headers = @$headers;
        while(@headers)
        {
          my $key = shift @headers;
          my $value = shift @headers;
          unless(defined $key && defined $value)
          {
            $build->log("Fetch for $url with http_headers contains undef key or value");
            next;
          }
          push @{ $headers{$key} }, $value;
        }
      }
      else
      {
        $build->log("Fetch for $url with http_headers that is not an array reference");
      }
    }

    my $ua = HTTP::Tiny->new(
      agent      => "Alien-Build/@{[ $Alien::Build::VERSION || 'dev' ]} ",
      verify_SSL => $build->download_rule =~ /encrypt/ ? 1 : 0,
    );
    my $res = $ua->get($url, { headers => \%headers });

    unless($res->{success})
    {
      my $status = $res->{status} || '---';
      my $reason = $res->{reason} || 'unknown';

      $build->log("$status $reason fetching $url");
      if($status == 599)
      {
        $build->log("exception: $_") for split /\n/, $res->{content};

        my($can_ssl, $why_ssl) = HTTP::Tiny->can_ssl;
        if(! $can_ssl)
        {
          if($res->{redirects}) {
            foreach my $redirect (@{ $res->{redirects} })
            {
              if(defined $redirect->{headers}->{location} && $redirect->{headers}->{location} =~ /^https:/)
              {
                $build->log("An attempt at a SSL URL https was made, but your HTTP::Tiny does not appear to be able to use https.");
                $build->log("Please see: https://metacpan.org/pod/Alien::Build::Manual::FAQ#599-Internal-Exception-errors-downloading-packages-from-the-internet");
              }
            }
          }
        }
      }

      die "error fetching $url: $status $reason";
    }

    my($type) = split /;/, $res->{headers}->{'content-type'};
    $type = lc $type;
    my $base            = URI->new($res->{url});
    my $filename        = File::Basename::basename do { my $name = $base->path; $name =~ s{/$}{}; $name };

    # TODO: this doesn't get exercised by t/bin/httpd
    if(my $disposition = $res->{headers}->{"content-disposition"})
    {
      # Note: from memory without quotes does not match the spec,
      # but many servers actually return this sort of value.
      if($disposition =~ /filename="([^"]+)"/ || $disposition =~ /filename=([^\s]+)/)
      {
        $filename = $1;
      }
    }

    if($type eq 'text/html')
    {
      return {
        type     => 'html',
        base     => $base->as_string,
        content  => $res->{content},
        protocol => $url->scheme,
      };
    }
    else
    {
      return {
        type     => 'file',
        filename => $filename || 'downloadedfile',
        content  => $res->{content},
        protocol => $url->scheme,
      };
    }

  });

  $self;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Fetch::HTTPTiny - Plugin for fetching files using HTTP::Tiny

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 share {
   start_url 'http://ftp.gnu.org/gnu/make';
   plugin 'Fetch::HTTPTiny';
 };

=head1 DESCRIPTION

Note: in most case you will want to use L<Alien::Build::Plugin::Download::Negotiate>
instead.  It picks the appropriate fetch plugin based on your platform and environment.
In some cases you may need to use this plugin directly instead.

This fetch plugin fetches files and directory listings via the C<http> and C<https>
protocol using L<HTTP::Tiny>.  If the URL specified uses the C<https> scheme, then
the required SSL modules will automatically be injected as requirements.  If your
initial URL is not C<https>, but you know that it will be needed on a subsequent
request you can use the ssl property below.

=head1 PROPERTIES

=head2 url

The initial URL to fetch.  This may be a directory listing (in HTML) or the final file.

=head2 ssl

If set to true, then the SSL modules required to make an C<https> connection will be
added as prerequisites.

=head1 SEE ALSO

L<Alien::Build::Plugin::Download::Negotiate>, L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! �q_��  �  &  perl5/Alien/Build/Plugin/Fetch/Wget.pmnu ��6�$        package Alien::Build::Plugin::Fetch::Wget;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use File::Temp qw( tempdir );
use Path::Tiny qw( path );
use File::Which qw( which );
use Capture::Tiny qw( capture capture_merged );
use File::chdir;
use List::Util qw( pairmap );

# ABSTRACT: Plugin for fetching files using wget
our $VERSION = '2.83'; # VERSION


sub _wget
{
  my $wget = defined $ENV{WGET} ? which($ENV{WGET}) : which('wget');
  return undef unless defined $wget;
  my $output = capture_merged { system $wget, '--help' };

  # The wget that BusyBox implements does not follow that same interface
  # as GNU wget and may not check ssl certs which is not good.
  return undef if $output =~ /BusyBox/;
  return $wget;
}

has wget_command => sub { _wget() };
has ssl => 0;

# when bootstrapping we have to specify this plugin as a prereq
# 1 is the default so that when this plugin is used directly
# you also get the prereq
has bootstrap_ssl => 1;

sub init
{
  my($self, $meta) = @_;

  $meta->add_requires('configure', 'Alien::Build::Plugin::Fetch::Wget' => '1.19')
    if $self->bootstrap_ssl;

  $meta->register_hook(
    fetch => sub {
      my($build, $url, %options) = @_;
      $url ||= $meta->prop->{start_url};

      my($scheme) = $url =~ /^([a-z0-9]+):/i;

      if($scheme eq 'http' || $scheme eq 'https')
      {
        local $CWD = tempdir( CLEANUP => 1 );

        my @headers;
        if(my $headers = $options{http_headers})
        {
          if(ref $headers eq 'ARRAY')
          {
            my @copy = @$headers;
            my %headers;
            while(@copy)
            {
              my $key = shift @copy;
              my $value = shift @copy;
              push @{ $headers{$key} }, $value;
            }
            @headers = pairmap { "--header=$a: @{[ join ', ', @$b ]}" } %headers;
          }
          else
          {
            $build->log("Fetch for $url with http_headers that is not an array reference");
          }
        }

        my($stdout, $stderr) = $self->_execute(
          $build,
          $self->wget_command,
          '-k', '--content-disposition', '-S',
          @headers,
          $url,
        );

        my($path) = path('.')->children;
        die "no file found after wget" unless $path;
        my($type) = $stderr =~ /Content-Type:\s*(.*?)$/m;
        $type =~ s/;.*$// if $type;
        if($type eq 'text/html')
        {
          return {
            type     => 'html',
            base     => $url,
            content  => scalar $path->slurp,
            protocol => $scheme,
          };
        }
        else
        {
          return {
            type     => 'file',
            filename => $path->basename,
            path     => $path->absolute->stringify,
            protocol => $scheme,
          };
        }
      }
      else
      {
        die "scheme $scheme is not supported by the Fetch::Wget plugin";
      }
    },
  ) if $self->wget_command;
}

sub _execute
{
  my($self, $build, @command) = @_;
  $build->log("+ @command");
  my($stdout, $stderr, $err) = capture {
    system @command;
    $?;
  };
  if($err)
  {
    chomp $stderr;
    $stderr = [split /\n/, $stderr]->[-1];
    die "error in wget fetch: $stderr";
  }
  ($stdout, $stderr);
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Fetch::Wget - Plugin for fetching files using wget

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 
 share {
   start_url 'https://www.openssl.org/source/';
   plugin 'Fetch::Wget';
 };

=head1 DESCRIPTION

B<WARNING>: This plugin is somewhat experimental at this time.

This plugin provides a fetch based on the C<wget> command.  It works with other fetch
plugins (that is, the first one which succeeds will be used).  Most of the time the best plugin
to use will be L<Alien::Build::Plugin::Download::Negotiate>, but for some SSL bootstrapping
it may be desirable to try C<wget> first.

Protocols supported: C<http>, C<https>

=head1 PROPERTIES

=head2 wget_command

The full path to the C<wget> command.  The default is usually correct.

=head2 ssl

Ignored by this plugin.  Provided for compatibility with some other fetch plugins.

=head1 SEE ALSO

=over 4

=item L<alienfile>

=item L<Alien::Build>

=back

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! ���	  	  %  perl5/Alien/Build/Plugin/Fetch/LWP.pmnu ��6�$        package Alien::Build::Plugin::Fetch::LWP;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use Carp ();

# ABSTRACT: Plugin for fetching files using LWP
our $VERSION = '2.83'; # VERSION


has '+url' => '';


has ssl => 0;

sub init
{
  my($self, $meta) = @_;

  $meta->add_requires('share' => 'LWP::UserAgent' => 0 );

  $meta->prop->{start_url} ||= $self->url;
  $self->url($meta->prop->{start_url});
  $self->url || Carp::croak('url is a required property');

  if($self->url =~ /^https:/ || $self->ssl)
  {
    $meta->add_requires('share' => 'LWP::Protocol::https' => 0 );
  }

  $meta->register_hook( fetch => sub {
    my($build, $url, %options) = @_;
    $url ||= $self->url;

    my @headers;
    if(my $headers = $options{http_headers})
    {
      if(ref $headers eq 'ARRAY')
      {
        @headers = @$headers;
      }
      else
      {
        $build->log("Fetch for $url with http_headers that is not an array reference");
      }
    }

    my $ua = LWP::UserAgent->new;
    $ua->env_proxy;
    my $res = $ua->get($url, @headers);

    my($protocol) = $url =~ /^([a-z]+):/;

    die "error fetching $url: @{[ $res->status_line ]}"
      unless $res->is_success;

    my($type, $charset) = $res->content_type_charset;
    my $base            = $res->base;
    my $filename        = $res->filename;

    if($type eq 'text/html')
    {
      return {
        type     => 'html',
        charset  => $charset,
        base     => "$base",
        content  => $res->decoded_content || $res->content,
        protocol => $protocol,
      };
    }
    elsif($type eq 'text/ftp-dir-listing')
    {
      return {
        type     => 'dir_listing',
        base     => "$base",
        content  => $res->decoded_content || $res->content,
        protocol => $protocol,
      };
    }
    else
    {
      return {
        type     => 'file',
        filename => $filename || 'downloadedfile',
        content  => $res->content,
        protocol => $protocol,
      };
    }

  });

  $self;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Fetch::LWP - Plugin for fetching files using LWP

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 share {
   start_url 'http://ftp.gnu.org/gnu/make';
   plugin 'Fetch::LWP';
 };

=head1 DESCRIPTION

Note: in most case you will want to use L<Alien::Build::Plugin::Download::Negotiate>
instead.  It picks the appropriate fetch plugin based on your platform and environment.
In some cases you may need to use this plugin directly instead.

This fetch plugin fetches files and directory listings via the C<http> C<https>, C<ftp>,
C<file> protocol using L<LWP>.  If the URL specified uses the C<https> scheme, then
the required SSL modules will automatically be injected as requirements.  If your
initial URL is not C<https>, but you know that it will be needed on a subsequent
request you can use the ssl property below.

=head1 PROPERTIES

=head2 url

The initial URL to fetch.  This may be a directory listing (in HTML) or the final file.

=head2 ssl

If set to true, then the SSL modules required to make an C<https> connection will be
added as prerequisites.

=head1 SEE ALSO

L<Alien::Build::Plugin::Download::Negotiate>, L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! �F��u  u  *  perl5/Alien/Build/Plugin/Fetch/LocalDir.pmnu ��6�$        package Alien::Build::Plugin::Fetch::LocalDir;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use File::chdir;
use Path::Tiny ();

# ABSTRACT: Plugin for fetching a local directory
our $VERSION = '2.83'; # VERSION


has root => undef;


has ssl => 0;

sub init
{
  my($self, $meta) = @_;

  my $url = $meta->prop->{start_url} || 'patch';

  $meta->add_requires('configure' => 'Alien::Build::Plugin::Fetch::LocalDir' => '0.72' );

  if($url =~ /^file:/)
  {
    $meta->add_requires('share' => 'URI' => 0 );
    $meta->add_requires('share' => 'URI::file' => 0 );
  }

  {
    my $root = $self->root;
    if(defined $root)
    {
      $root = Path::Tiny->new($root)->absolute->stringify;
    }
    else
    {
      $root = "$CWD";
    }
    $self->root($root);
  }

  $meta->register_hook(
    fetch => sub {
      my($build, $path, %options) = @_;

      $build->log("plugin Fetch::LocalDir does not support http_headers option") if $options{http_headers};

      $path ||= $url;

      if($path =~ /^file:/)
      {
        my $root = URI::file->new($self->root);
        my $url  = URI->new_abs($path, $root);
        $path = $url->path;
        $path =~ s{^/([a-z]:)}{$1}i if $^O eq 'MSWin32';
      }

      $path = Path::Tiny->new($path)->absolute($self->root);

      if(-d $path)
      {
        return {
          type     => 'file',
          filename => $path->basename,
          path     => $path->stringify,
          tmp      => 0,
          protocol => 'file',
        };
      }
      else
      {
        $build->log("path $path is not a directory");
        $build->log("(you specified $url with root @{[ $self->root ]})");
        die "$path is not a directory";
      }
    }
  );
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Fetch::LocalDir - Plugin for fetching a local directory

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 share {
   start_url 'patch/libfoo-1.00/';
   plugin 'Fetch::LocalDir';
 };

=head1 DESCRIPTION

Note: in most case you will want to use L<Alien::Build::Plugin::Download::Negotiate>
instead.  It picks the appropriate fetch plugin based on your platform and environment.
In some cases you may need to use this plugin directly instead.

This fetch plugin fetches files from the local file system.  It is mostly useful if you
intend to bundle source with your Alien.  If you are bundling tarballs see
L<Alien::Build::Plugin::Fetch::Local>.

=head1 PROPERTIES

=head2 root

The directory from which the start URL should be relative.  The default is usually reasonable.

=head2 ssl

This property is for compatibility with other fetch plugins, but is not used.

=head1 SEE ALSO

=over 4

=item L<Alien::Build::Plugin::Download::Negotiate>

=item L<Alien::Build::Plugin::Fetch::Local>

=item L<Alien::Build>

=item L<alienfile>

=item L<Alien::Build::MM>

=item L<Alien>

=back

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! j��Y5  Y5  /  perl5/Alien/Build/Plugin/Extract/CommandLine.pmnu ��6�$        package Alien::Build::Plugin::Extract::CommandLine;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use Path::Tiny ();
use File::Which ();
use File::chdir;
use File::Temp qw( tempdir );
use Capture::Tiny qw( capture_merged );

# ABSTRACT: Plugin to extract an archive using command line tools
our $VERSION = '2.83'; # VERSION


has '+format' => 'tar';


sub gzip_cmd
{
  _which('gzip') ? 'gzip' : undef;
}


sub _which { scalar File::Which::which(@_) }

sub bzip2_cmd
{
  _which('bzip2') ? 'bzip2' : undef;
}


sub xz_cmd
{
  _which('xz') ? 'xz' : undef;
}


{
  my $bsd_tar;

  # Note: GNU tar can be iffy to very bad on windows, where absolute
  # paths get confused with remote tars.  We used to assume that 'tar.exe'
  # is borked on Windows, but recent versions of Windows 10 come bundled
  # with bsdtar (libarchive) named 'tar.exe', and we should definitely
  # prefer that to ptar.
  sub _windows_tar_is_bsdtar
  {
    return 1 if $^O ne 'MSWin32';
    return $bsd_tar if defined $bsd_tar;
    my($out) = capture_merged {
      system 'tar', '--version';
    };
    return $bsd_tar = $out =~ /bsdtar/ ? 1 : 0
  }
}

sub tar_cmd
{
  _which('bsdtar')
    ? 'bsdtar'
    # Slowlaris /usr/bin/tar doesn't seem to like pax global header
    # but seems to have gtar in the path by default, which is okay with it
    : $^O eq 'solaris' && _which('gtar')
      ? 'gtar'
      # See note above for Windows logic.
      : _which('tar') && _windows_tar_is_bsdtar()
        ? 'tar'
        : _which('ptar')
          ? 'ptar'
          : undef;
};


sub unzip_cmd
{
  if($^O eq 'MSWin32' && _which('tar') && _windows_tar_is_bsdtar())
  {
    (_which('tar'), 'xf');
  }
  else
  {
    _which('unzip') ? 'unzip' : undef;
  }
}

sub _run
{
  my(undef, $build, @cmd) = @_;
  $build->log("+ @cmd");
  system @cmd;
  die "execute failed" if $?;
}

sub _cp
{
  my(undef, $build, $from, $to) = @_;
  require File::Copy;
  $build->log("copy $from => $to");
  File::Copy::cp($from, $to) || die "unable to copy: $!";
}

sub _mv
{
  my(undef, $build, $from, $to) = @_;
  $build->log("move $from => $to");
  rename($from, $to) || die "unable to rename: $!";
}

sub _dcon
{
  my($self, $src) = @_;

  my $name;
  my $cmd;

  if($src =~ /\.(gz|tgz|Z|taz)$/)
  {
    $self->gzip_cmd(_which('gzip')) unless defined $self->gzip_cmd;
    if($src =~ /\.(gz|tgz)$/)
    {
      $cmd = $self->gzip_cmd unless $self->_tar_can('tar.gz');
    }
    elsif($src =~ /\.(Z|taz)$/)
    {
      $cmd = $self->gzip_cmd unless $self->_tar_can('tar.Z');
    }
  }
  elsif($src =~ /\.(bz2|tbz)$/)
  {
    $self->bzip2_cmd(_which('bzip2')) unless defined $self->bzip2_cmd;
    $cmd = $self->bzip2_cmd unless $self->_tar_can('tar.bz2');
  }
  elsif($src =~ /\.(xz|txz)$/)
  {
    $self->xz_cmd(_which('xz')) unless defined $self->xz_cmd;
    $cmd = $self->xz_cmd unless $self->_tar_can('tar.xz');
  }

  if($cmd && $src =~ /\.(gz|bz2|xz|Z)$/)
  {
    $name = $src;
    $name =~ s/\.(gz|bz2|xz|Z)$//g;
  }
  elsif($cmd && $src =~ /\.(tgz|tbz|txz|taz)$/)
  {
    $name = $src;
    $name =~ s/\.(tgz|tbz|txz|taz)$/.tar/;
  }

  ($name,$cmd);
}


sub handles
{
  my($class, $ext) = @_;

  my $self = ref $class
  ? $class
  : __PACKAGE__->new;

  $ext = 'tar.Z'   if $ext eq 'taz';
  $ext = 'tar.gz'  if $ext eq 'tgz';
  $ext = 'tar.bz2' if $ext eq 'tbz';
  $ext = 'tar.xz'  if $ext eq 'txz';

  return 1 if $ext eq 'tar.gz'  && $self->_tar_can('tar.gz');
  return 1 if $ext eq 'tar.Z'   && $self->_tar_can('tar.Z');
  return 1 if $ext eq 'tar.bz2' && $self->_tar_can('tar.bz2');
  return 1 if $ext eq 'tar.xz'  && $self->_tar_can('tar.xz');

  return 0 if $ext =~ s/\.(gz|Z)$// && (!$self->gzip_cmd);
  return 0 if $ext =~ s/\.bz2$//    && (!$self->bzip2_cmd);
  return 0 if $ext =~ s/\.xz$//     && (!$self->xz_cmd);

  return 1 if $ext eq 'tar' && $self->_tar_can('tar');
  return 1 if $ext eq 'zip' && $self->_tar_can('zip');

  return 0;
}


sub available
{
  my(undef, $ext) = @_;

  # this is actually the same as handles
  __PACKAGE__->handles($ext);
}

sub init
{
  my($self, $meta) = @_;

  if($self->format eq 'tar.xz' && !$self->handles('tar.xz'))
  {
    $meta->add_requires('share' => 'Alien::xz' => '0.06');
  }
  elsif($self->format eq 'tar.bz2' && !$self->handles('tar.bz2'))
  {
    $meta->add_requires('share' => 'Alien::Libbz2' => '0.22');
  }
  elsif($self->format =~ /^tar\.(gz|Z)$/ && !$self->handles($self->format))
  {
    $meta->add_requires('share' => 'Alien::gzip' => '0.03');
  }
  elsif($self->format eq 'zip' && !$self->handles('zip'))
  {
    $meta->add_requires('share' => 'Alien::unzip' => '0');
  }

  $meta->register_hook(
    extract => sub {
      my($build, $src) = @_;

      my($dcon_name, $dcon_cmd) = _dcon($self, $src);

      if($dcon_name)
      {
        unless($dcon_cmd)
        {
          die "unable to decompress $src";
        }
        # if we have already decompressed, then keep it.
        unless(-f $dcon_name)
        {
          # we don't use pipes, because that may not work on Windows.
          # keep the original archive, in case another extract
          # plugin needs it.  keep the decompressed archive
          # in case WE need it again.
          my $src_tmp = Path::Tiny::path($src)
            ->parent
            ->child('x'.Path::Tiny::path($src)->basename);
          my $dcon_tmp = Path::Tiny::path($dcon_name)
            ->parent
            ->child('x'.Path::Tiny::path($dcon_name)->basename);
          $self->_cp($build, $src, $src_tmp);
          $self->_run($build, $dcon_cmd, "-d", $src_tmp);
          $self->_mv($build, $dcon_tmp, $dcon_name);
        }
        $src = $dcon_name;
      }

      if($src =~ /\.zip$/i)
      {
        $self->_run($build, $self->unzip_cmd, $src);
      }
      elsif($src =~ /\.tar/ || $src =~ /(\.tgz|\.tbz|\.txz|\.taz)$/i)
      {
        $self->_run($build, $self->tar_cmd, '-xf', $src);
      }
      else
      {
        die "not sure of archive type from extension";
      }
    }
  );
}

my %tars;

sub _tar_can
{
  my($self, $ext) = @_;

  unless(%tars)
  {
    my $name = '';
    local $_; # to avoid dynamically scoped read-only $_ from upper scopes
    while(my $line = <DATA>)
    {
      if($line =~ /^\[ (.*) \]$/)
      {
        $name = $1;
      }
      else
      {
        $tars{$name} .= $line;
      }
    }

    foreach my $key (keys %tars)
    {
      $tars{$key} = unpack "u", $tars{$key};
    }
  }

  my $name = "xx.$ext";

  return 0 unless $tars{$name};

  local $CWD = tempdir( CLEANUP => 1 );

  my $cleanup = sub {
    my $save = $CWD;
    unlink $name;
    unlink 'xx.txt';
    $CWD = '..';
    rmdir $save;
  };

  Path::Tiny->new($name)->spew_raw($tars{$name});

  my @cmd = ($self->tar_cmd, 'xf', $name);
  if($ext eq 'zip')
  {
    @cmd = ($self->unzip_cmd, $name);
  }

  my(undef, $exit) = capture_merged {
    system(@cmd);
    $?;
  };

  if($exit)
  {
    $cleanup->();
    return 0;
  }

  my $content = eval { Path::Tiny->new('xx.txt')->slurp };
  $cleanup->();

  return defined $content && $content eq "xx\n";
}

1;

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Extract::CommandLine - Plugin to extract an archive using command line tools

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 plugin 'Extract::CommandLine' => (
   format => 'tar.gz',
 );

=head1 DESCRIPTION

Note: in most case you will want to use L<Alien::Build::Plugin::Extract::Negotiate>
instead.  It picks the appropriate Extract plugin based on your platform and environment.
In some cases you may need to use this plugin directly instead.

This plugin extracts from an archive in various formats using command line tools.

=head1 PROPERTIES

=head2 format

Gives a hint as to the expected format.

=head2 gzip_cmd

The C<gzip> command, if available.  C<undef> if not available.

=head2 bzip2_cmd

The C<bzip2> command, if available.  C<undef> if not available.

=head2 xz_cmd

The C<xz> command, if available.  C<undef> if not available.

=head2 tar_cmd

The C<tar> command, if available.  C<undef> if not available.

=head2 unzip_cmd

The C<unzip> command, if available.  C<undef> if not available.

=head1 METHODS

=head2 handles

 Alien::Build::Plugin::Extract::CommandLine->handles($ext);
 $plugin->handles($ext);

Returns true if the plugin is able to handle the archive of the
given format.

=head2 available

 Alien::Build::Plugin::Extract::CommandLine->available($ext);

Returns true if the plugin is available to extract without
installing anything new.

=head1 SEE ALSO

L<Alien::Build::Plugin::Extract::Negotiate>, L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut

__DATA__

[ xx.tar ]
M>'@N='AT````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M`````````````#`P,#8T-"``,#`P-S8U(``P,#`P,C0@`#`P,#`P,#`P,#`S
M(#$S-#,U,#0S-#(R(#`Q,C<P,P`@,```````````````````````````````
M````````````````````````````````````````````````````````````
M``````````````````````````````````````````!U<W1A<@`P,&]L;&ES
M9P``````````````````````````````````<W1A9F8`````````````````
M```````````````````P,#`P,#`@`#`P,#`P,"``````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M``````````````````````!X>`H`````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
7````````````````````````````````


[ xx.tar.Z ]
M'YV0>/"XH(.'#H"#"!,J7,BPH<.'$"-*1`BCH@T:-$``J`CCAHT:&CG"D)%Q
MH\B3,T#$F$%C1@T8+6G(D`$"1@P9-V#,`%!SHL^?0(,*!5!G#ITP<DR^8<,F
MS9PS0Q<:#6/&3-2%)V&$/*GQJM>O8,.*'1I0P=BS:-.J7<NVK=NW<./*G4NW
7KMV[>//JW<NWK]^_@`,+'DRXL.'#0P$`


[ xx.tar.bz2 ]
M0EIH.3%!629365(,+ID``$A[D-$0`8!``7^``!!AI)Y`!```""``=!JGIBC3
M30&CU`]($HHTTR:`>D#0)SI*Z'R%H*J"&3@H]P@J>U$F5BMHOC`$L-"8C!(V
I"`'?*WA:(9*4U)@4)+"(V%.G]#W(_E6B'J8G]D`/Q=R13A0D%(,+ID``


[ xx.tar.gz ]
M'XL("!)'=%P``WAX+G1A<@"KJ-`KJ2AAH"DP,#`P,S%1`-'F9J9@VL`(PH<"
M8P5#8Q-C4P,38Q,C(P4#0R-S`V,&!0/:.@L"2HM+$HN`3LG/R<DL3L>M#J@L
E+0V/.1"/*,#I(0(J*K@&V@FC8!2,@E$P"@8````U:,3F``@`````


[ xx.tar.xz ]
M_3=Z6%H```3FUK1&`@`A`18```!T+^6CX`?_`&!=`#Q@M.AX.4O&N38V648.
M[J6L\\<_[3M*R;CASOTX?B.F\V:^)+G;\YY4"!4MLF9`*\N40G=O+K,J0"NF
M0VU7J%NN(A,R^DM8@/(_YGR5CAO+1CS_YNHE:,1!G%6L1\GT``"[$^?"O*"!
9`P`!?(`0````:OY*7K'$9_L"``````196@``


[ xx.zip ]
M4$L#!`H``````%5V64X:^I"B`P````,````&`!P`>'@N='AT550)``,21W1<
M$D=T7'5X"P`!!/4!```$%````'AX"E!+`0(>`PH``````%5V64X:^I"B`P``
M``,````&`!@```````$```"D@0````!X>"YT>'155`4``Q)'=%QU>`L``03U
>`0``!!0```!02P4&``````$``0!,````0P``````


PK       ! �L�1    .  perl5/Alien/Build/Plugin/Extract/ArchiveTar.pmnu ��6�$        package Alien::Build::Plugin::Extract::ArchiveTar;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use File::chdir;
use File::Temp ();
use Path::Tiny ();

# ABSTRACT: Plugin to extract a tarball using Archive::Tar
our $VERSION = '2.83'; # VERSION


has '+format' => 'tar';


sub handles
{
  my(undef, $ext) = @_;

  return 1 if $ext =~ /^(tar|tar\.gz|tar\.bz2|tar\.xz|tbz|taz|txz)$/;

  return 0;
}


sub available
{
  my(undef, $ext) = @_;

  if($ext eq 'tar.gz')
  {
    return !! eval { require Archive::Tar; Archive::Tar->has_zlib_support };
  }
  elsif($ext eq 'tar.bz2')
  {
    return !! eval { require Archive::Tar; Archive::Tar->has_bzip2_support && __PACKAGE__->_can_bz2 };
  }
  elsif($ext eq 'tar.xz')
  {
    return !! eval { require Archive::Tar; Archive::Tar->has_xz_support };
  }
  else
  {
    return $ext eq 'tar';
  }
}

sub init
{
  my($self, $meta) = @_;

  $meta->add_requires('share' => 'Archive::Tar' => 0);
  if($self->format eq 'tar.gz' || $self->format eq 'tgz')
  {
    $meta->add_requires('share' => 'IO::Zlib' => 0);
  }
  elsif($self->format eq 'tar.bz2' || $self->format eq 'tbz')
  {
    $meta->add_requires('share' => 'IO::Uncompress::Bunzip2' => 0);
    $meta->add_requires('share' => 'IO::Compress::Bzip2' => 0);
  }
  elsif($self->format eq 'tar.xz' || $self->format eq 'txz')
  {
    $meta->add_requires('share' => 'Archive::Tar' => 2.34);
    $meta->add_requires('share' => 'IO::Uncompress::UnXz' => 0);
  }

  $meta->register_hook(
    extract => sub {
      my($build, $src) = @_;
      my $tar = Archive::Tar->new;
      $tar->read($src);
      $tar->extract;
    }
  );
}

sub _can_bz2
{
  # even when Archive::Tar reports that it supports bz2, I can sometimes get this error:
  # 'Cannot read enough bytes from the tarfile', so lets just probe for actual support!
  my $dir = Path::Tiny->new(File::Temp::tempdir( CLEANUP => 1 ));
  eval {
    local $CWD = $dir;
    my $tarball = unpack "u", q{M0EIH.3%!62936=+(]$0``$A[D-$0`8!``7^``!!AI)Y`!```""``=!JGIH-(MT#0]0/2!**---&F@;4#0&:D;X?(6@JH(2<%'N$%3VHC-9E>S/N@"6&I*1@GNJNHCC2>$I5(<0BKR.=XBZ""HVZ;T,CV\LJ!K&*?9`#\7<D4X4)#2R/1$`};
    Path::Tiny->new('xx.tar.bz2')->spew_raw($tarball);
    require Archive::Tar;
    my $tar = Archive::Tar->new;
    $tar->read('xx.tar.bz2');
    $tar->extract;
    my $content = Path::Tiny->new('xx.txt')->slurp;
    die unless $content && $content eq "xx\n";
  };
  my $error = $@;
  $dir->remove_tree;
  !$error;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Extract::ArchiveTar - Plugin to extract a tarball using Archive::Tar

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 plugin 'Extract::ArchiveTar' => (
   format => 'tar.gz',
 );

=head1 DESCRIPTION

Note: in most case you will want to use L<Alien::Build::Plugin::Extract::Negotiate>
instead.  It picks the appropriate Extract plugin based on your platform and environment.
In some cases you may need to use this plugin directly instead.

This plugin extracts from an archive in tarball format (optionally compressed by either
gzip or bzip2) using L<Archive::Tar>.

=head1 PROPERTIES

=head2 format

Gives a hint as to the expected format.  This helps make sure the prerequisites are set
correctly, since compressed archives require extra Perl modules to be installed.

=head1 METHODS

=head2 handles

 Alien::Build::Plugin::Extract::ArchiveTar->handles($ext);
 $plugin->handles($ext);

Returns true if the plugin is able to handle the archive of the
given format.

=head2 available

 Alien::Build::Plugin::Extract::ArchiveTar->available($ext);

Returns true if the plugin has what it needs right now to extract from the given format

=head1 SEE ALSO

L<Alien::Build::Plugin::Extract::Negotiate>, L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! �u�P_  _  -  perl5/Alien/Build/Plugin/Extract/Negotiate.pmnu ��6�$        package Alien::Build::Plugin::Extract::Negotiate;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use Alien::Build::Plugin::Extract::ArchiveTar;
use Alien::Build::Plugin::Extract::ArchiveZip;
use Alien::Build::Plugin::Extract::CommandLine;
use Alien::Build::Plugin::Extract::Directory;

# ABSTRACT: Extraction negotiation plugin
our $VERSION = '2.83'; # VERSION


has '+format' => 'tar';

sub init
{
  my($self, $meta) = @_;

  my $format = $self->format;
  $format = 'tar.gz'  if $format eq 'tgz';
  $format = 'tar.bz2' if $format eq 'tbz';
  $format = 'tar.xz'  if $format eq 'txz';

  my $plugin = $self->pick($format);
  $meta->apply_plugin($plugin, format => $format);
  $self;
}


sub pick
{
  my(undef, $format) = @_;

  if($format =~ /^tar(\.(gz|bz2))?$/)
  {
    if(Alien::Build::Plugin::Extract::ArchiveTar->available($format))
    {
      return 'Extract::ArchiveTar';
    }
    else
    {
      return 'Extract::CommandLine';
    }
  }
  elsif($format eq 'zip')
  {
    # Archive::Zip is not that reliable.  But if it is already installed it is probably working
    if(Alien::Build::Plugin::Extract::ArchiveZip->available($format))
    {
      return 'Extract::ArchiveZip';
    }

    # If it isn't available, then use the command-line unzip.  Alien::unzip will be used
    # as necessary in environments where it isn't already installed.
    else
    {
      return 'Extract::CommandLine';
    }
  }
  elsif($format eq 'tar.xz')
  {
    # The windows version of tar.exe (which is based on BSD tar) will try to use external
    # program xz to decompress tar.xz files if it is available.  The default windows
    # install does not have this in the PATH, but if it IS in the PATH then it often
    # or always can hang, so the pure Perl Archive::Tar is more reliable on that platform,
    # but will require a newer version of Archive::Tar and IO::Uncompress::UnXz
    if(Alien::Build::Plugin::Extract::ArchiveTar->available('tar.xz') || $^O eq 'MSWin32')
    {
      return 'Extract::ArchiveTar';
    }
    else
    {
      return 'Extract::CommandLine';
    }
  }
  elsif($format eq 'tar.Z')
  {
    return 'Extract::CommandLine';
  }
  elsif($format eq 'd')
  {
    return 'Extract::Directory';
  }
  elsif($format eq 'f')
  {
    return 'Extract::File';
  }
  else
  {
    die "do not know how to handle format: $format";
  }
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Extract::Negotiate - Extraction negotiation plugin

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 plugin 'Extract' => (
   format => 'tar.gz',
 );

=head1 DESCRIPTION

This is a negotiator plugin for extracting packages downloaded from the internet.
This plugin picks the best Extract plugin to do the actual work.  Which plugins are
picked depend on the properties you specify, your platform and environment.  It is
usually preferable to use a negotiator plugin rather than using a specific Extract
Plugin from your L<alienfile>.

=head1 PROPERTIES

=head2 format

The expected format for the download.  Possible values include:
C<tar>, C<tar.gz>, C<tar.bz2>, C<tar.xz>, C<zip>, C<d>.

=head1 METHODS

=head2 pick

 my $name = Alien::Build::Plugin::Extract::Negotiate->pick($format);

Returns the name of the best plugin for the given format.

=head1 SEE ALSO

L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! �_Kw�  �  (  perl5/Alien/Build/Plugin/Extract/File.pmnu ��6�$        package Alien::Build::Plugin::Extract::File;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use Alien::Build::Util qw( _mirror );
use Path::Tiny ();

# ABSTRACT: Plugin to extract a downloaded file to a build directory
our $VERSION = '2.83'; # VERSION


has '+format' => 'f';


sub handles
{
  my(undef, $ext) = @_;
  $ext eq 'f' ? 1 : ();
}


sub available
{
  my(undef, $ext) = @_;
  __PACKAGE__->handles($ext);
}

sub init
{
  my($self, $meta) = @_;

  $meta->register_hook(
    extract => sub {
      my($build, $src) = @_;

      die "not a file: $src" unless -f $src;

      $src = Path::Tiny->new($src)->absolute->parent;;

      my $dst = Path::Tiny->new('.')->absolute;
      # Please note: _mirror and Alien::Build::Util are ONLY
      # allowed to be used by core plugins.  If you are writing
      # a non-core plugin it may be removed.  That is why it
      # is private.

      $build->log("extracting $src => $dst");
      _mirror $src => $dst, { verbose => 1 };
    }
  );
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Extract::File - Plugin to extract a downloaded file to a build directory

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 plugin 'Extract::File';

=head1 DESCRIPTION

Some Download or Fetch plugins may produce a single file (usually an executable)
instead of an archive file.  This plugin is used to mirror the file from
the Download step into a fresh directory in the Extract step.

=head1 PROPERTIES

=head2 format

Should always set to C<f> (for file).

=head1 METHODS

=head2 handles

 Alien::Build::Plugin::Extract::File->handles($ext);
 $plugin->handles($ext);

Returns true if the plugin is able to handle the archive of the
given format.  Only returns true for C<f> (for file).

=head2 available

 Alien::Build::Plugin::Extract::File->available($ext);
 $plugin->available($ext);

Returns true if the plugin can extract the given format with
what is already installed.

=head1 SEE ALSO

L<Alien::Build::Plugin::Extract::Negotiate>, L<Alien::Build::Plugin::Extract::File>, L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! NB,��  �  -  perl5/Alien/Build/Plugin/Extract/Directory.pmnu ��6�$        package Alien::Build::Plugin::Extract::Directory;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use Alien::Build::Util qw( _mirror );
use Path::Tiny ();

# ABSTRACT: Plugin to extract a downloaded directory to a build directory
our $VERSION = '2.83'; # VERSION


has '+format' => 'd';


sub handles
{
  my(undef, $ext) = @_;
  $ext eq 'd' ? 1 : ();
}


sub available
{
  my(undef, $ext) = @_;
  __PACKAGE__->handles($ext);
}

sub init
{
  my($self, $meta) = @_;

  $meta->register_hook(
    extract => sub {
      my($build, $src) = @_;

      die "not a directory: $src" unless -d $src;

      if($build->meta_prop->{out_of_source})
      {
        $build->install_prop->{extract} = Path::Tiny->new($src)->absolute->stringify;
      }
      else
      {
        my $dst = Path::Tiny->new('.')->absolute;
        # Please note: _mirror and Alien::Build::Util are ONLY
        # allowed to be used by core plugins.  If you are writing
        # a non-core plugin it may be removed.  That is why it
        # is private.
        _mirror $src => $dst, { verbose => 1 };
      }
    }
  );
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Extract::Directory - Plugin to extract a downloaded directory to a build directory

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 plugin 'Extract::Directory';

=head1 DESCRIPTION

Some Download or Fetch plugins may produce a directory instead of an archive
file.  This plugin is used to mirror the directory from the Download step
into a fresh directory in the Extract step.  An example of when you might use
this plugin is if you were using the C<git> command in the Download step,
which results in a directory hierarchy.

=head1 PROPERTIES

=head2 format

Should always set to C<d> (for directories).

=head1 METHODS

=head2 handles

 Alien::Build::Plugin::Extract::Directory->handles($ext);
 $plugin->handles($ext);

Returns true if the plugin is able to handle the archive of the
given format.  Only returns true for C<d> (for directory).

=head2 available

 Alien::Build::Plugin::Extract::Directory->available($ext);
 $plugin->available($ext);

Returns true if the plugin can extract the given format with
what is already installed.

=head1 SEE ALSO

L<Alien::Build::Plugin::Extract::Negotiate>, L<Alien::Build::Plugin::Extract::File>, L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! ��x  x  .  perl5/Alien/Build/Plugin/Extract/ArchiveZip.pmnu ��6�$        package Alien::Build::Plugin::Extract::ArchiveZip;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;

# ABSTRACT: Plugin to extract a tarball using Archive::Zip
our $VERSION = '2.83'; # VERSION


has '+format' => 'zip';


sub handles
{
  my($class, $ext) = @_;

  return 1 if $ext eq 'zip';

  return 0;
}


sub available
{
  my(undef, $ext) = @_;

  !! ( $ext eq 'zip' && eval { require Archive::Zip; 1} );
}

sub init
{
  my($self, $meta) = @_;

  $meta->add_requires('share' => 'Archive::Zip' => 0);

  $meta->register_hook(
    extract => sub {
      my($build, $src) = @_;
      my $zip = Archive::Zip->new;
      $zip->read($src);
      $zip->extractTree;
    }
  );
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Extract::ArchiveZip - Plugin to extract a tarball using Archive::Zip

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 plugin 'Extract::ArchiveZip' => (
   format => 'zip',
 );

=head1 DESCRIPTION

Note: in most case you will want to use L<Alien::Build::Plugin::Extract::Negotiate>
instead.  It picks the appropriate Extract plugin based on your platform and environment.
In some cases you may need to use this plugin directly instead.

B<Note>: Seriously do NOT use this plugin! L<Archive::Zip> is pretty unreliable and
breaks all-the-time.  If you use the negotiator plugin mentioned above, then it will
prefer installing L<Alien::unzip>, which is much more reliable than L<Archive::Zip>.

This plugin extracts from an archive in zip format using L<Archive::Zip>.

=head2 format

Gives a hint as to the expected format.  This should always be C<zip>.

=head1 METHODS

=head2 handles

 Alien::Build::Plugin::Extract::ArchiveZip->handles($ext);
 $plugin->handles($ext);

Returns true if the plugin is able to handle the archive of the
given format.

=head2 available

 Alien::Build::Plugin::Extract::ArchiveZip->available($ext);

Returns true if the plugin has what it needs right now to extract from the given format

=head1 SEE ALSO

L<Alien::Build::Plugin::Extract::Negotiate>, L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! �����  �  #  perl5/Alien/Build/Plugin/Digest.podnu ��6�$        # PODNAME: Alien::Build::Plugin::Digest
# ABSTRACT: Fetch Alien::Digest plugins
# VERSION

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Digest - Fetch Alien::Digest plugins

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 share {
   start_url 'http://ftp.gnu.org/gnu/make/make-3.75.tar.gz';
   plugin 'Digest' => [ SHA256 => '2bc876304905aee78abf0f7163ba55a2efcec803034f75c75d1b94650c36aba7';
   plugin 'Download';
 };

=head1 DESCRIPTION

Digest plugins checks the cryptographic signatures of downloaded files.
Typically you will probably want to use SHA256 via the
L<Digest Negotiator plugin|Alien::Build::Plugin::Digest::Negotiate>.

=over 4

=item L<Alien::Build::Plugin::Digest::Negotiate>

Negotiate the most appropriate plugin to calculate digest.

=item L<Alien::Build::Plugin::Digest::SHA>

Use the XS based L<Digest::SHA> for computing SHA digests.  This is the default since
L<Digest::SHA> comes with recent versions of Perl.

=item L<Alien::Build::Plugin::Digest::SHAPP>

Use the pure-perl based L<Digest::SHA::PurePerl> for computing SHA digests.

=back

=head1 SEE ALSO

L<Alien::Build>, L<Alien::Build::Plugin>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! �j���  �  %  perl5/Alien/Build/Plugin/Core/Tail.pmnu ��6�$        package Alien::Build::Plugin::Core::Tail;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;

# ABSTRACT: Core tail setup plugin
our $VERSION = '2.83'; # VERSION


sub init
{
  my($self, $meta) = @_;

  if($meta->prop->{out_of_source})
  {
    $meta->add_requires('configure' => 'Alien::Build' => '1.08');
  }
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Core::Tail - Core tail setup plugin

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 # already loaded

=head1 DESCRIPTION

This plugin does some core tail setup for you.

=head1 SEE ALSO

L<Alien::Build>, L<Alien::Base::ModuleBuild>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! ���D�	  �	  '  perl5/Alien/Build/Plugin/Core/Legacy.pmnu ��6�$        package Alien::Build::Plugin::Core::Legacy;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;

# ABSTRACT: Core Alien::Build plugin to maintain compatibility with legacy Alien::Base
our $VERSION = '2.83'; # VERSION


sub init
{
  my($self, $meta) = @_;

  $meta->after_hook(
    $_ => sub {
      my($build) = @_;

      $build->log("adding legacy hash to config");

      my $runtime = $build->runtime_prop;

      if($runtime->{cflags} && ! defined $runtime->{cflags_static})
      {
        $runtime->{cflags_static} = $runtime->{cflags};
      }

      if($runtime->{libs} && ! defined $runtime->{libs_static})
      {
        $runtime->{libs_static} = $runtime->{libs};
      }

      $runtime->{legacy}->{finished_installing} = 1;
      $runtime->{legacy}->{install_type}        = $runtime->{install_type};
      $runtime->{legacy}->{version}             = $runtime->{version};
      $runtime->{legacy}->{original_prefix}     = $runtime->{prefix};
    }
  ) for qw( gather_system gather_share );
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Core::Legacy - Core Alien::Build plugin to maintain compatibility with legacy Alien::Base

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 # already loaded

=head1 DESCRIPTION

This plugin provides some compatibility with the legacy L<Alien::Base::ModuleBuild>
interfaces.

=head1 SEE ALSO

L<Alien::Build>, L<Alien::Base::ModuleBuild>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! 9�a�U  U  &  perl5/Alien/Build/Plugin/Core/Setup.pmnu ��6�$        package Alien::Build::Plugin::Core::Setup;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use Config;
use File::Which qw( which );

# ABSTRACT: Core setup plugin
our $VERSION = '2.83'; # VERSION


sub init
{
  my($self, $meta) = @_;
  $meta->prop->{platform} ||= {};
  $self->_platform($meta->prop->{platform});
}

sub _platform
{
  my(undef, $hash) = @_;

  if($^O eq 'MSWin32' && $Config{ccname} eq 'cl')
  {
    $hash->{compiler_type} = 'microsoft';
  }
  else
  {
    $hash->{compiler_type} = 'unix';
  }

  if($^O eq 'MSWin32')
  {
    $hash->{system_type} = 'windows-unknown';

    if(defined &Win32::BuildNumber)
    {
      $hash->{system_type} = 'windows-activestate';
    }
    elsif($Config{myuname} =~ /strawberry-perl/)
    {
      $hash->{system_type} = 'windows-strawberry';
    }
    elsif($hash->{compiler_type} eq 'microsoft')
    {
      $hash->{system_type} = 'windows-microsoft';
    }
    else
    {
      my $uname_exe = which('uname');
      if($uname_exe)
      {
        my $uname = `$uname_exe`;
        if($uname =~ /^(MINGW)(32|64)_NT/)
        {
          $hash->{system_type} = 'windows-' . lc $1;
        }
      }
    }
  }
  elsif($^O =~ /^(VMS)$/)
  {
    # others probably belong in here...
    $hash->{system_type} = lc $^O;
  }
  else
  {
    $hash->{system_type} = 'unix';
  }

  $hash->{cpu}{count} =
    exists $ENV{ALIEN_CPU_COUNT} && $ENV{ALIEN_CPU_COUNT} > 0
    ? $ENV{ALIEN_CPU_COUNT}
    : _cpu_count();

  $hash->{cpu}{arch} = _cpu_arch(\%Config);
}

# Retrieve number of available CPU cores. Adopted from
# <https://metacpan.org/release/MARIOROY/MCE-1.879/source/lib/MCE/Util.pm#L49>
# which is in turn adopted from Test::Smoke::Util with improvements.
sub _cpu_count {
  local $ENV{PATH} = $ENV{PATH};
  if( $^O ne 'MSWin32' ) {
    $ENV{PATH} = "/usr/sbin:/sbin:/usr/bin:/bin:$ENV{PATH}";
  }
  $ENV{PATH} =~ /(.*)/; $ENV{PATH} = $1;   ## Remove tainted'ness

  my $ncpu = 1;

  OS_CHECK: {
    local $_ = lc $^O;

    /linux/ && do {
      my ( $count, $fh );
      if ( open $fh, '<', '/proc/stat' ) {
        $count = grep { /^cpu\d/ } <$fh>;
        close $fh;
      }
      $ncpu = $count if $count;
      last OS_CHECK;
    };

    /bsd|darwin|dragonfly/ && do {
      chomp( my @output = `sysctl -n hw.ncpu 2>/dev/null` );
      $ncpu = $output[0] if @output;
      last OS_CHECK;
    };

    /aix/ && do {
      my @output = `lparstat -i 2>/dev/null | grep "^Online Virtual CPUs"`;
      if ( @output ) {
        $output[0] =~ /(\d+)\n$/;
        $ncpu = $1 if $1;
      }
      if ( !$ncpu ) {
        @output = `pmcycles -m 2>/dev/null`;
        if ( @output ) {
          $ncpu = scalar @output;
        } else {
          @output = `lsdev -Cc processor -S Available 2>/dev/null`;
          $ncpu = scalar @output if @output;
        }
      }
      last OS_CHECK;
    };

    /gnu/ && do {
      chomp( my @output = `nproc 2>/dev/null` );
      $ncpu = $output[0] if @output;
      last OS_CHECK;
    };

    /haiku/ && do {
      my @output = `sysinfo -cpu 2>/dev/null | grep "^CPU #"`;
      $ncpu = scalar @output if @output;
      last OS_CHECK;
    };

    /hp-?ux/ && do {
      my $count = grep { /^processor/ } `ioscan -fkC processor 2>/dev/null`;
      $ncpu = $count if $count;
      last OS_CHECK;
    };

    /irix/ && do {
      my @out = grep { /\s+processors?$/i } `hinv -c processor 2>/dev/null`;
      $ncpu = (split ' ', $out[0])[0] if @out;
      last OS_CHECK;
    };

    /osf|solaris|sunos|svr5|sco/ && do {
      if (-x '/usr/sbin/psrinfo') {
        my $count = grep { /on-?line/ } `psrinfo 2>/dev/null`;
        $ncpu = $count if $count;
      }
      else {
        my @output = grep { /^NumCPU = \d+/ } `uname -X 2>/dev/null`;
        $ncpu = (split ' ', $output[0])[2] if @output;
      }
      last OS_CHECK;
    };

    /mswin|mingw|msys|cygwin/ && do {
      if (exists $ENV{NUMBER_OF_PROCESSORS}) {
        $ncpu = $ENV{NUMBER_OF_PROCESSORS};
      }
      last OS_CHECK;
    };

    warn "CPU count: unknown operating system";
  }

  $ncpu = 1 if (!$ncpu || $ncpu < 1);

  $ncpu;
}

sub _cpu_arch {
  my ($my_config) = @_;

  my $arch = {};

  my %Config = %$my_config;

  die "Config missing archname" unless exists $Config{archname};
  die "Config missing ptrsize"  unless exists $Config{ptrsize};

  if( $Config{archname} =~ m/
      \b x64    \b # MSWin32-x64
    | \b x86_64 \b # x86_64-linux
    | \b amd64  \b # amd64-freebsd
    /ix) {
    $arch = { name => 'x86_64' };
  } elsif( $Config{archname} =~ m/
      \b x86  \b   # MSWin32-x86
    | \b i386 \b   # freebsd-i386
    | \b i486 \b   # i486-linux
    | \b i686 \b   # i686-cygwin
    /ix ) {
    $arch = { name => 'x86' };
  } elsif( $Config{archname} =~ m/
      \b darwin \b
    /ix ) {
    chomp( my $hw_machine = `sysctl -n hw.machine 2>/dev/null` );
    HW_MACHINE:
    for($hw_machine) {
      $_ eq 'arm64' && do {
        $arch = { name => 'aarch64' };
        last HW_MACHINE;
      };
      $_ eq 'x86_64' && do {
        $arch = { name => $Config{ptrsize} == 8 ? 'x86_64' : 'x86' };
        last HW_MACHINE;
      };
      $_ eq 'i386' && do {
        $arch = { name => 'x86' };
        last HW_MACHINE;
      };
      $_ eq 'Power Macintosh' && do {
        $arch = { name => $Config{ptrsize} == 8 ? 'ppc64' : 'ppc' };
        last HW_MACHINE;
      };

      warn "Architecture detection: unknown macOS arch hw.machine = $_, ptrsize = $Config{ptrsize}";
      $arch = { name => 'unknown' };
    }
  } elsif( $Config{archname} =~ /
      \b aarch64 \b
    | \b arm64 \b    # arm64-freebsd (FreeBSD can have either aarch64 or arm64)
    /ix ) {
    $arch = { name => 'aarch64' };   # ARM64
  } elsif( $Config{archname} =~ m/
      \b arm-linux-gnueabi \b
    /ix ) {
    # 32-bit ARM soft-float
    $arch = { name => 'armel' };
  } elsif( $Config{archname} =~ m/
      \b arm-linux-gnueabihf \b
    /ix ) {
    # 32-bit ARM hard-float
    $arch = { name => 'armhf' };
  }

  unless(exists $arch->{name}) {
    warn "Architecture detection: Unknown archname '$Config{archname}'.";
    $arch->{name} = 'unknown';
  }

  return $arch;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Core::Setup - Core setup plugin

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 # already loaded

=head1 DESCRIPTION

This plugin does some core setup for you.

=head1 SEE ALSO

L<Alien::Build>, L<Alien::Base::ModuleBuild>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! j�ᣢ  �  '  perl5/Alien/Build/Plugin/Core/Gather.pmnu ��6�$        package Alien::Build::Plugin::Core::Gather;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use Env qw( @PATH @PKG_CONFIG_PATH );
use Path::Tiny ();
use File::chdir;
use Alien::Build::Util qw( _mirror _destdir_prefix );
use JSON::PP ();

# ABSTRACT: Core gather plugin
our $VERSION = '2.83'; # VERSION


sub init
{
  my($self, $meta) = @_;

  $meta->default_hook(
    $_ => sub {},
  ) for qw( gather_system gather_share );

  $meta->around_hook(
    gather_share => sub {
      my($orig, $build) = @_;

      local $ENV{PATH} = $ENV{PATH};
      local $ENV{PKG_CONFIG_PATH} = $ENV{PKG_CONFIG_PATH};
      unshift @PATH, Path::Tiny->new('bin')->absolute->stringify
        if -d 'bin';

      for my $dir (qw(share lib)) {
          unshift @PKG_CONFIG_PATH, Path::Tiny->new("$dir/pkgconfig")->absolute->stringify
            if -d "$dir/pkgconfig";
      }

      $orig->($build)
    }
  );

  foreach my $type (qw( share ffi ))
  {
    $meta->around_hook(
      "gather_$type" => sub {
        my($orig, $build) = @_;

        if($build->meta_prop->{destdir})
        {
          my $destdir = $ENV{DESTDIR};
          if(-d $destdir)
          {
            my $src = Path::Tiny->new(_destdir_prefix($ENV{DESTDIR}, $build->install_prop->{prefix}));
            my $dst = Path::Tiny->new($build->install_prop->{stage});

            my $res = do {
              local $CWD = "$src";
              $orig->($build);
            };

            $build->log("mirror $src => $dst");

            $dst->mkpath;
            # Please note: _mirror and Alien::Build::Util are ONLY
            # allowed to be used by core plugins.  If you are writing
            # a non-core plugin it may be removed.  That is why it
            # is private.
            _mirror("$src", "$dst", {
              verbose => 1,
              filter => $build->meta_prop->{$type eq 'share' ? 'destdir_filter' : 'destdir_ffi_filter'},
            });

            return $res;
          }
          else
          {
            die "nothing was installed into destdir" if $type eq 'share';
          }
        }
        else
        {
          local $CWD = $build->install_prop->{stage};
          my $ret = $orig->($build);

          # if we are not doing a double staged install we want to substitute the install
          # prefix with the runtime prefix.
          my $old = $build->install_prop->{prefix};
          my $new = $build->runtime_prop->{prefix};

          foreach my $flag (qw( cflags cflags_static libs libs_static ))
          {
            next unless defined $build->runtime_prop->{$flag};
            $build->runtime_prop->{$flag} =~ s{(-I|-L|-LIBPATH:)\Q$old\E}{$1 . $new}eg;
          }

          return $ret;
        }
      }
    );
  }

  $meta->after_hook(
    $_ => sub {
      my($build) = @_;

      die "stage is not defined.  be sure to call set_stage on your Alien::Build instance"
        unless $build->install_prop->{stage};

      my $stage = Path::Tiny->new($build->install_prop->{stage});
      $build->log("mkdir -p $stage/_alien");
      $stage->child('_alien')->mkpath;

      # drop a alien.json file for the runtime properties
      $stage->child('_alien/alien.json')->spew(
        JSON::PP->new->pretty->canonical(1)->ascii->encode($build->runtime_prop)
      );

      # copy the alienfile, if we managed to keep it around.
      if($build->meta->filename                 &&
         -r $build->meta->filename              &&
         $build->meta->filename !~ /\.(pm|pl)$/ &&
         ! -d $build->meta->filename)
      {
        Path::Tiny->new($build->meta->filename)
                  ->copy($stage->child('_alien/alienfile'));
      }

      if($build->install_prop->{patch} && -d $build->install_prop->{patch})
      {
        # Please note: _mirror and Alien::Build::Util are ONLY
        # allowed to be used by core plugins.  If you are writing
        # a non-core plugin it may be removed.  That is why it
        # is private.
        _mirror($build->install_prop->{patch},
                $stage->child('_alien/patch')->stringify);
      }

    },
  ) for qw( gather_share gather_system );
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Core::Gather - Core gather plugin

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 # already loaded

=head1 DESCRIPTION

This plugin helps make the gather stage work.

=head1 SEE ALSO

L<Alien::Build>, L<Alien::Base::ModuleBuild>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! KF���  �  )  perl5/Alien/Build/Plugin/Core/Override.pmnu ��6�$        package Alien::Build::Plugin::Core::Override;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;

# ABSTRACT: Core override plugin
our $VERSION = '2.83'; # VERSION


sub init
{
  my($self, $meta) = @_;

  $meta->default_hook(
    override => sub {
      my($build) = @_;
      return $ENV{ALIEN_INSTALL_TYPE} || '';
    },
  );
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Core::Override - Core override plugin

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 # already loaded

=head1 DESCRIPTION

This plugin implements the C<ALIEN_INSTALL_TYPE> environment variable.

=head1 SEE ALSO

L<Alien::Build>, L<Alien::Base::ModuleBuild>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! '�l�  �  $  perl5/Alien/Build/Plugin/Core/FFI.pmnu ��6�$        package Alien::Build::Plugin::Core::FFI;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;

# ABSTRACT: Core FFI plugin
our $VERSION = '2.83'; # VERSION


sub init
{
  my($self, $meta) = @_;

  $meta->default_hook(
    $_ => sub {},
  ) for qw( build_ffi gather_ffi );

  $meta->prop->{destdir_ffi_filter} = '^dynamic';

}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Core::FFI - Core FFI plugin

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 # already loaded

=head1 DESCRIPTION

This plugin helps make the build_ffi work.  You should not
need to interact with it directly.

=head1 SEE ALSO

L<Alien::Build>, L<Alien::Base::ModuleBuild>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! du�0�  �  )  perl5/Alien/Build/Plugin/Core/Download.pmnu ��6�$        package Alien::Build::Plugin::Core::Download;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use Path::Tiny ();
use Alien::Build::Util qw( _mirror );

# ABSTRACT: Core download plugin
our $VERSION = '2.83'; # VERSION


sub _hook
{
  my($build) = @_;

  my $res = $build->fetch;

  if($res->{type} =~ /^(?:html|dir_listing)$/)
  {
    my $type = $res->{type};
    $type =~ s/_/ /;
    $build->log("decoding $type");
    $res = $build->decode($res);
  }

  if($res->{type} eq 'list')
  {
    my $orig = $res;
    $res = $build->prefer($res);

    my @exclude;
    if($build->meta->prop->{start_url} =~ /^https:/)
    {
      @{ $res->{list} } = grep {
        $_->{url} =~ /https:/ ? 1 : do {
          push @exclude, $_->{url};
          0;
        }
      } @{ $res->{list} };
    }

    if(@{ $res->{list} } == 0)
    {
      my @excluded = map { $_->{url} } @{ $orig->{list} };
      if(@excluded)
      {
        if(@excluded > 15)
        {
          splice @excluded , 14;
          push @excluded, '...';
        }
        $build->log("These files were excluded by the filter stage:");
        $build->log("excluded $_") for @excluded;
      }
      else
      {
        $build->log("No files found prior to the filter stage");
      }
      die "no matching files in listing";
    }
    my $version = $res->{list}->[0]->{version};
    my($pick, @other) = map { $_->{url} } @{ $res->{list} };

    if(@other > 8)
    {
      splice @other, 7;
      push @other, '...';
    }
    $build->log("candidate *$pick");
    $build->log("candidate  $_") for @other;

    if(@exclude)
    {
      if(@exclude > 8)
      {
        splice @exclude, 7;
        push @exclude, '...';
      }
      $build->log("excluded insecure URLs:");
      $build->log($_) for @exclude;
    }

    $res = $build->fetch($pick);

    if($version)
    {
      $version =~ s/\.+$//;
      $build->log("setting version based on archive to $version");
      $build->runtime_prop->{version} = $version;
    }
  }

  if($res->{type} eq 'file')
  {
    my $alienfile = $res->{filename};
    $build->log("downloaded $alienfile");
    if($res->{content})
    {
      my $tmp = Alien::Build::TempDir->new($build, "download");
      my $path = Path::Tiny->new("$tmp/$alienfile");
      $path->spew_raw($res->{content});
      $build->install_prop->{download} = $path->stringify;
      $build->install_prop->{complete}->{download} = 1;
      $build->install_prop->{download_detail}->{"$path"}->{protocol} = $res->{protocol} if defined $res->{protocol};
      return $build;
    }
    elsif($res->{path})
    {
      if(defined $res->{tmp} && !$res->{tmp})
      {
        if(-e $res->{path})
        {
          $build->install_prop->{download} = $res->{path};
          $build->install_prop->{complete}->{download} = 1;
          $build->install_prop->{download_detail}->{$res->{path}}->{protocol} = $res->{protocol} if defined $res->{protocol};
        }
        else
        {
          die "not a file or directory: @{[ $res->{path} ]}";
        }
      }
      else
      {
        my $from = Path::Tiny->new($res->{path});
        my $tmp = Alien::Build::TempDir->new($build, "download");
        my $to   = Path::Tiny->new("$tmp/@{[ $from->basename ]}");
        if(-d $res->{path})
        {
          # Please note: _mirror and Alien::Build::Util are ONLY
          # allowed to be used by core plugins.  If you are writing
          # a non-core plugin it may be removed.  That is why it
          # is private.
          _mirror $from, $to;
        }
        else
        {
          require File::Copy;
          File::Copy::copy(
            "$from" => "$to",
          ) || die "copy $from => $to failed: $!";
        }
        $build->install_prop->{download} = $to->stringify;
        $build->install_prop->{complete}->{download} = 1;
        $build->install_prop->{download_detail}->{"$to"}->{protocol} = $res->{protocol} if defined $res->{protocol};
      }
      return $build;
    }
    die "file without content or path";
  }
  die "unknown fetch response type: @{[ $res->{type} ]}";
}

sub init
{
  my($self, $meta) = @_;

  $meta->default_hook(download => \&_hook);
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Core::Download - Core download plugin

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 # already loaded

=head1 DESCRIPTION

This plugin does some core download logic.

=head1 SEE ALSO

L<Alien::Build>, L<Alien::Base::ModuleBuild>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! �Y��  �  -  perl5/Alien/Build/Plugin/Core/CleanInstall.pmnu ��6�$        package Alien::Build::Plugin::Core::CleanInstall;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use Path::Tiny ();

# ABSTRACT: Implementation for clean_install hook.
our $VERSION = '2.83'; # VERSION


sub init
{
  my($self, $meta) = @_;

  $meta->default_hook(
    clean_install => sub {
      my($build) = @_;
      my $root = Path::Tiny->new(
        $build->runtime_prop->{prefix}
      );
      if(-d $root)
      {
        foreach my $child ($root->children)
        {
          if($child->basename eq '_alien')
          {
            $build->log("keeping  $child");
          }
          else
          {
            $build->log("removing $child");
            $child->remove_tree({ safe => 0});
          }
        }
      }
    }
  );
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Core::CleanInstall - Implementation for clean_install hook.

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 # already loaded

=head1 DESCRIPTION

This plugin implements the default C<clean_install> hook.
You shouldn't use it directly.

=head1 SEE ALSO

L<Alien::Build>, L<Alien::Base::ModuleBuild>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! �7A��  �  .  perl5/Alien/Build/Plugin/Prefer/GoodVersion.pmnu ��6�$        package Alien::Build::Plugin::Prefer::GoodVersion;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use Carp ();

# ABSTRACT: Plugin to filter known good versions
our $VERSION = '2.83'; # VERSION


has '+filter' => sub { Carp::croak("The filter property is required for the Prefer::GoodVersion plugin") };

sub init
{
  my($self, $meta) = @_;

  $meta->add_requires('configure', __PACKAGE__, '1.44');

  my $filter;

  if(ref($self->filter) eq '')
  {
    my $string = $self->filter;
    $filter = sub {
      my($file) = @_;
      $file->{version} eq $string;
    };
  }
  elsif(ref($self->filter) eq 'ARRAY')
  {
    my %filter = map { $_ => 1 } @{ $self->filter };
    $filter = sub {
      my($file) = @_;
      !! $filter{$file->{version}};
    };
  }
  elsif(ref($self->filter) eq 'CODE')
  {
    my $code = $self->filter;
    $filter = sub { !! $code->($_[0]) };
  }
  else
  {
    Carp::croak("unknown filter type for Prefer::GoodVersion");
  }

  $meta->around_hook(
    prefer => sub {
      my($orig, $build, @therest) = @_;
      my $res1 = $orig->($build, @therest);
      return $res1 unless $res1->{type} eq 'list';

      return {
        type => 'list',
        list => [
          grep { $filter->($_) } @{ $res1->{list} }
        ],
      };
    },
  );
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Prefer::GoodVersion - Plugin to filter known good versions

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 plugin 'Prefer::GoodVersion' => '1.2.3';

=head1 DESCRIPTION

This plugin allows you to specify one or more good versions of a library.  This doesn't affect
a system install at all.  This plugin does the opposite of the C<Prefer::BadVersion> plugin.
You need need a Prefer plugin that filters and sorts files first.  You may specify the filter
in one of three ways:

=over

=item as a string

Filter any files that match the given version.

 use alienfile;
 plugin 'Prefer::GoodVersion' => '1.2.3';

=item as an array

Filter all files that match any of the given versions.

 use alienfile;
 plugin 'Prefer::GoodVersion' => [ '1.2.3', '1.2.4' ];

=item as a code reference

Filter any files return a true value.

 use alienfile;
 plugin 'Prefer::GoodVersion' => sub {
   my($file) = @_;
   $file->{version} eq '1.2.3'; # same as the string version above
 };

=back

This plugin can also be used to filter known good versions of a library on just one platform.
For example, if you know that version 1.2.3 if good on windows, but the default logic is fine
on other platforms:

 use alienfile;
 plugin 'Prefer::GoodVersion' => '1.2.3' if $^O eq 'MSWin32';

=head1 PROPERTIES

=head2 filter

Filter entries that match the filter.

=head1 CAVEATS

If you are using the string or array mode, then you need an existing Prefer plugin that sets the
version number for each file candidate, such as L<Alien::Build::Plugin::Prefer::SortVersions>.

Unless you want to exclude the latest version from a share install, this plugin isn't really
that useful.  It has no effect on system installs, which may not be obvious at first.

=head1 SEE ALSO

=over 4

=item L<alienfile>

=item L<Alien::Build>

=item L<Alien::Build::Plugin::Prefer::SortVersions>

=back

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! ��g  g  /  perl5/Alien/Build/Plugin/Prefer/SortVersions.pmnu ��6�$        package Alien::Build::Plugin::Prefer::SortVersions;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;

# ABSTRACT: Plugin to sort candidates by most recent first
our $VERSION = '2.83'; # VERSION


has 'filter'   => undef;


has '+version' => qr/([0-9](?:[0-9\.]*[0-9])?)/;

sub init
{
  my($self, $meta) = @_;

  $meta->add_requires('share' => 'Sort::Versions' => 0);

  $meta->register_hook( prefer => sub {
    my(undef, $res) = @_;

    my $cmp = sub {
      my($A,$B) = map { ($_ =~ $self->version)[0] } @_;
      Sort::Versions::versioncmp($B,$A);
    };

    my @list = sort { $cmp->($a->{filename}, $b->{filename}) }
               map {
                 ($_->{version}) = $_->{filename} =~ $self->version;
                 $_ }
               grep { $_->{filename} =~ $self->version }
               grep { defined $self->filter ? $_->{filename} =~ $self->filter : 1 }
               @{ $res->{list} };

    return {
      type => 'list',
      list => \@list,
    };
  });
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Prefer::SortVersions - Plugin to sort candidates by most recent first

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 
 plugin 'Prefer::SortVersions';

=head1 DESCRIPTION

Note: in most case you will want to use L<Alien::Build::Plugin::Download::Negotiate>
instead.  It picks the appropriate fetch plugin based on your platform and environment.
In some cases you may need to use this plugin directly instead.

This Prefer plugin sorts the packages that were retrieved from a dir listing, either
directly from a Fetch plugin, or from a Decode plugin.  It Returns a listing with the
items sorted from post preferable to least, and filters out any undesirable candidates.

This plugin updates the file list to include the versions that are extracted, so they
can be used by other plugins, such as L<Alien::Build::Plugin::Prefer::BadVersion>.

=head1 PROPERTIES

=head2 filter

This is a regular expression that lets you filter out files that you do not
want to consider downloading.  For example, if the directory listing contained
tarballs and readme files like this:

 foo-1.0.0.tar.gz
 foo-1.0.0.readme

You could specify a filter of C<qr/\.tar\.gz$/> to make sure only tarballs are
considered for download.

=head2 version

Regular expression to parse out the version from a filename.  The regular expression
should store the result in C<$1>.  The default C<qr/([0-9\.]+)/> is frequently
reasonable.

=head1 SEE ALSO

L<Alien::Build::Plugin::Download::Negotiate>, L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! Ȳ�4�  �  -  perl5/Alien/Build/Plugin/Prefer/BadVersion.pmnu ��6�$        package Alien::Build::Plugin::Prefer::BadVersion;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use Carp ();

# ABSTRACT: Plugin to filter out known bad versions
our $VERSION = '2.83'; # VERSION


has '+filter' => sub { Carp::croak("The filter property is required for the Prefer::BadVersion plugin") };

sub init
{
  my($self, $meta) = @_;

  $meta->add_requires('configure', __PACKAGE__, '1.05');

  my $filter;

  if(ref($self->filter) eq '')
  {
    my $string = $self->filter;
    $filter = sub {
      my($file) = @_;
      $file->{version} ne $string;
    };
  }
  elsif(ref($self->filter) eq 'ARRAY')
  {
    my %filter = map { $_ => 1 } @{ $self->filter };
    $filter = sub {
      my($file) = @_;
      ! $filter{$file->{version}};
    };
  }
  elsif(ref($self->filter) eq 'CODE')
  {
    my $code = $self->filter;
    $filter = sub { ! $code->($_[0]) };
  }
  else
  {
    Carp::croak("unknown filter type for Prefer::BadVersion");
  }

  $meta->around_hook(
    prefer => sub {
      my($orig, $build, @therest) = @_;
      my $res1 = $orig->($build, @therest);
      return $res1 unless $res1->{type} eq 'list';

      return {
        type => 'list',
        list => [
          grep { $filter->($_) } @{ $res1->{list} }
        ],
      };
    },
  );
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Prefer::BadVersion - Plugin to filter out known bad versions

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 plugin 'Prefer::BadVersion' => '1.2.3';

=head1 DESCRIPTION

This plugin allows you to easily filter out known bad versions of libraries in a share install.
It doesn't affect a system install at all.  You need a Prefer plugin that filters and sorts files
first.  You may specify the filter in one of three ways:

=over

=item as a string

Filter out any files that match the given version.

 use alienfile;
 plugin 'Prefer::BadVersion' => '1.2.3';

=item as an array

Filter out all files that match any of the given versions.

 use alienfile;
 plugin 'Prefer::BadVersion' => [ '1.2.3', '1.2.4' ];

=item as a code reference

Filter out any files return a true value.

 use alienfile;
 plugin 'Prefer::BadVersion' => sub {
   my($file) = @_;
   $file->{version} eq '1.2.3'; # same as the string version above
 };

=back

This plugin can also be used to filter out known bad versions of a library on just one platform.
For example, if you know that version 1.2.3 if bad on windows, but okay on other platforms:

 use alienfile;
 plugin 'Prefer::BadVersion' => '1.2.3' if $^O eq 'MSWin32';

=head1 PROPERTIES

=head2 filter

Filter out entries that match the filter.

=head1 CAVEATS

If you are using the string or array mode, then you need an existing Prefer plugin that sets the
version number for each file candidate, such as L<Alien::Build::Plugin::Prefer::SortVersions>.

Unless you want to exclude the latest version from a share install, this plugin isn't really
that useful.  It has no effect on system installs, which may not be obvious at first.

=head1 SEE ALSO

=over 4

=item L<alienfile>

=item L<Alien::Build>

=item L<Alien::Build::Plugin::Prefer::SortVersions>

=back

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! ���
E  E  1  perl5/Alien/Build/Plugin/Gather/IsolateDynamic.pmnu ��6�$        package Alien::Build::Plugin::Gather::IsolateDynamic;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use Path::Tiny ();
use Alien::Build::Util qw( _destdir_prefix );
use File::Copy ();

# ABSTRACT: Plugin to gather dynamic libraries into a separate directory
our $VERSION = '2.83'; # VERSION


sub init
{
  my($self, $meta) = @_;

  # plugin was introduced in 0.42, but had a bug which was fixed in 0.48
  $meta->add_requires('share' => 'Alien::Build::Plugin::Gather::IsolateDynamic' => '0.48' );

  $meta->after_hook(
    gather_share => sub {
      my($build) = @_;
      $build->log("Isolating dynamic libraries ...");

      my $install_root;
      if($build->meta_prop->{destdir})
      {
        my $destdir = $ENV{DESTDIR};
        $install_root = Path::Tiny->new(_destdir_prefix($ENV{DESTDIR}, $build->install_prop->{prefix}));
      }
      else
      {
        $install_root = Path::Tiny->new($build->install_prop->{stage});
      }

      foreach my $dir (map { $install_root->child($_) } qw( bin lib ))
      {
        next unless -d $dir;
        foreach my $from ($dir->children)
        {
          next unless $from->basename =~ /\.so/
          ||          $from->basename =~ /\.(dylib|bundle|la|dll|dll\.a)$/;
          my $to = $install_root->child('dynamic', $from->basename);
          $to->parent->mkpath;
          unlink "$to" if -e $to;
          $build->log("move @{[ $from->parent->basename ]}/@{[ $from->basename ]} => dynamic/@{[ $to->basename ]}");
          File::Copy::move("$from", "$to") || die "unable to move $from => $to $!";
        }
      }

      $build->log("                            Done!");
    },
  );
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Gather::IsolateDynamic - Plugin to gather dynamic libraries into a separate directory

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 plugin 'Gather::IsolateDynamic';

=head1 DESCRIPTION

This plugin moves dynamic libraries from the C<lib> and C<bin> directories and puts them in
their own C<dynamic> directory.  This allows them to be used by FFI modules, but to be ignored
by XS modules.

This plugin provides the equivalent functionality of the C<alien_isolate_dynamic> attribute
from L<Alien::Base::ModuleBuild>.

=head1 SEE ALSO

L<Alien::Build>, L<alienfile>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! �j�o	  	  &  perl5/Alien/Build/Plugin/Digest/SHA.pmnu ��6�$        package Alien::Build::Plugin::Digest::SHA;

use strict;
use warnings;
use Alien::Build::Plugin;

# ABSTRACT: Plugin to check SHA digest with Digest::SHA
our $VERSION = '2.83'; # VERSION


sub init
{
  my($self, $meta) = @_;

  $meta->add_requires('configure' => 'Alien::Build'          => "2.57" );

  $meta->register_hook( check_digest => sub {
    my($build, $file, $algo, $expected_digest) = @_;

    return 0 unless $algo =~ /^SHA[0-9]+$/;

    my $sha = Digest::SHA->new($algo);
    return 0 unless defined $sha;

    if(defined $file->{content})
    {
      $sha->add($file->{content});
    }
    elsif(defined $file->{path})
    {
      $sha->addfile($file->{path}, "b");
    }
    else
    {
      die "unknown file type";
    }

    my $actual_digest = $sha->hexdigest;

    return 1 if $expected_digest eq $actual_digest;
    die "@{[ $file->{filename} ]} SHA@{[ $sha->algorithm ]} digest does not match: got $actual_digest, expected $expected_digest";

  });
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Digest::SHA - Plugin to check SHA digest with Digest::SHA

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 plugin 'Digest::SHA';

=head1 DESCRIPTION

This plugin is experimental.

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! � (Q)  )  ,  perl5/Alien/Build/Plugin/Digest/Negotiate.pmnu ��6�$        package Alien::Build::Plugin::Digest::Negotiate;

use strict;
use warnings;
use Alien::Build::Plugin;

# ABSTRACT: Plugin negotiator for cryptographic signatures
our $VERSION = '2.83'; # VERSION


has '+sig' => sub { {} };

has check_fetch    => 1;
has check_download => 1;
has allow_listing  => 1;

sub init
{
  my($self, $meta) = @_;
  $meta->add_requires('configure' => 'Alien::Build::Plugin::Digest::Negotiate' => "0" );

  $meta->prop->{check_digest} = 1;

  my $sigs = $meta->prop->{digest} ||= {};

  if(ref($self->sig) eq 'HASH') {

    foreach my $filename (keys %{ $self->sig })
    {
      my $signature = $self->sig->{$filename};
      my($algo) = @$signature;
      die "Unknown digest algorithm $algo" unless $algo =~ /^SHA(1|224|256|384|512|512224|512256)$/; # reportedly what is supported by Digest::SHA
      $sigs->{$filename} = $signature;
    }

  } elsif(ref($self->sig) eq 'ARRAY') {

    my $signature = $self->sig;
    my($algo) = @$signature;
    die "Unknown digest algorithm $algo" unless $algo =~ /^SHA(1|224|256|384|512|512224|512256)$/; # reportedly what is supported by Digest::SHA
    $sigs->{'*'} = $signature;
  }

  # In the future if this negotiator supports algorithms other
  # than SHA, we should probably ajust this to keep track of
  # which ones we actually need when we are looping through them
  # above.  Also technically you could call this plugin without
  # any sigs, and we shouldn't in theory need to apply Digest::SHA,
  # but stuff won't work that way so that is a corner case we
  # are not going to worry about.
  $meta->apply_plugin('Digest::SHA');

  $meta->around_hook(
    fetch => sub {
      my($orig, $build, @rest) = @_;
      my $res = $orig->($build, @rest);
      if($res->{type} eq 'file')
      {
        $build->check_digest($res);
      }
      else
      {
        die "listing fetch not allowed" unless $self->allow_listing;
      }
      $res;
    },
  ) if $self->check_fetch;

  # Note that check_download hook is currently undocumented and
  # may change in the future.
  $meta->register_hook(
    check_download => sub {
      my($build) = @_;
      my $path = $build->install_prop->{download};
      die "Checking cryptographic signatures on download only works for single archive" unless defined $path;
      $build->check_digest($path);
    },
  ) if $self->check_download;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Digest::Negotiate - Plugin negotiator for cryptographic signatures

=head1 VERSION

version 2.83

=head1 SYNOPSIS

for a single file:

 use alienfile;
 plugin 'Digest' => [ SHA256 => $digest ];

or for multiple files:

 use alienfile;
 plugin 'Digest' => {
   file1 => [ SHA256 => $digest1 ],
   file2 => [ SHA256 => $digest2 ],
 };

=head1 DESCRIPTION

This plugin is experimental.

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! RC`@t	  t	  (  perl5/Alien/Build/Plugin/Digest/SHAPP.pmnu ��6�$        package Alien::Build::Plugin::Digest::SHAPP;

use strict;
use warnings;
use Alien::Build::Plugin;

# ABSTRACT: Plugin to check SHA digest with Digest::SHA::PurePerl
our $VERSION = '2.83'; # VERSION


sub init
{
  my($self, $meta) = @_;

  $meta->add_requires('configure' => 'Alien::Build'          => "2.57" );
  $meta->add_requires('share'     => 'Digest::SHA::PurePerl' =>    "0" );

  $meta->register_hook( check_digest => sub {
    my($build, $file, $algo, $expected_digest) = @_;

    return 0 unless $algo =~ /^SHA[0-9]+$/;

    my $sha = Digest::SHA::PurePerl->new($algo);
    return 0 unless defined $sha;

    if(defined $file->{content})
    {
      $sha->add($file->{content});
    }
    elsif(defined $file->{path})
    {
      $sha->addfile($file->{path}, "b");
    }
    else
    {
      die "unknown file type";
    }

    my $actual_digest = $sha->hexdigest;

    return 1 if $expected_digest eq $actual_digest;
    die "@{[ $file->{filename} ]} SHA@{[ $sha->algorithm ]} digest does not match: got $actual_digest, expected $expected_digest";

  });
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Digest::SHAPP - Plugin to check SHA digest with Digest::SHA::PurePerl

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 plugin 'Digest::SHAPP';

=head1 DESCRIPTION

This plugin is experimental.

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! � ���  �  !  perl5/Alien/Build/Plugin/Test.podnu ��6�$        # PODNAME: Alien::Build::Plugin::Test
# ABSTRACT: Probe Alien::Build plugins
# VERSION

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Test - Probe Alien::Build plugins

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 plugin 'Test::Mock' => (
   probe    => 'share',
   download => 1,
   extract  => 1,
   build    => 1,
   gather   => 1,
 );

=head1 DESCRIPTION

Test plugins are used in unit tests for L<Alien::Build> and possibly
its plugins.

=over 4

=item L<Alien::Build::Plugin::Test::Mock>

Mocks common steps in an L<alienfile>.

=back

=head1 SEE ALSO

L<Alien::Build>, L<Alien::Build::Plugin>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! �&�mn  n  +  perl5/Alien/Build/Plugin/Build/SearchDep.pmnu ��6�$        package Alien::Build::Plugin::Build::SearchDep;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use Text::ParseWords qw( shellwords );

# ABSTRACT: Add dependencies to library and header search path
our $VERSION = '2.83'; # VERSION


has aliens => {};


has public_I => 0;
has public_l => 0;

sub init
{
  my($self, $meta) = @_;

  $meta->add_requires('configure' => 'Alien::Build::Plugin::Build::SearchDep' => '0.35');
  $meta->add_requires('share'     => 'Env::ShellWords' => 0.01);

  if($self->public_I || $self->public_l)
  {
    $meta->add_requires('configure' => 'Alien::Build::Plugin::Build::SearchDep' => '0.53');
  }

  my @aliens;
  if(ref($self->aliens) eq 'HASH')
  {
    @aliens = keys %{ $self->aliens };
    $meta->add_requires('share' => $_ => $self->aliens->{$_}) for @aliens;
  }
  else
  {
    @aliens = ref $self->aliens ? @{ $self->aliens } : ($self->aliens);
    $meta->add_requires('share' => $_ => 0) for @aliens;
  }

  $meta->around_hook(
    build => sub {
      my($orig, $build) = @_;

      local $ENV{CFLAGS}   = $ENV{CFLAGS};
      local $ENV{CXXFLAGS} = $ENV{CXXFLAGS};
      local $ENV{LDFLAGS}  = $ENV{LDFLAGS};

      tie my @CFLAGS,   'Env::ShellWords', 'CFLAGS';
      tie my @CXXFLAGS, 'Env::ShellWords', 'CXXFLAGS';
      tie my @LDFLAGS,  'Env::ShellWords', 'LDFLAGS';

      my $cflags  = $build->install_prop->{plugin_build_searchdep_cflags}  = [];
      my $ldflags = $build->install_prop->{plugin_build_searchdep_ldflags} = [];
      my $libs    = $build->install_prop->{plugin_build_searchdep_libs}    = [];

      foreach my $other (@aliens)
      {
        my $other_cflags;
        my $other_libs;
        if($other->install_type('share'))
        {
          $other_cflags = $other->cflags_static;
          $other_libs   = $other->libs_static;
        }
        else
        {
          $other_cflags = $other->cflags;
          $other_libs   = $other->libs;
        }
        unshift @$cflags,  grep /^-I/, shellwords($other_cflags);
        unshift @$ldflags, grep /^-L/, shellwords($other_libs);
        unshift @$libs,    grep /^-l/, shellwords($other_libs);
      }

      unshift @CFLAGS, @$cflags;
      unshift @CXXFLAGS, @$cflags;
      unshift @LDFLAGS, @$ldflags;

      $orig->($build);

    },
  );

  $meta->after_hook(
    gather_share => sub {
      my($build) = @_;

      $build->runtime_prop->{libs}        = '' unless defined $build->runtime_prop->{libs};
      $build->runtime_prop->{libs_static} = '' unless defined $build->runtime_prop->{libs_static};

      if($self->public_l)
      {
        $build->runtime_prop->{$_} = join(' ', _space_escape(@{ $build->install_prop->{plugin_build_searchdep_libs} })) . ' ' . $build->runtime_prop->{$_}
          for qw( libs libs_static );
      }

      $build->runtime_prop->{$_} = join(' ', _space_escape(@{ $build->install_prop->{plugin_build_searchdep_ldflags} })) . ' ' . $build->runtime_prop->{$_}
        for qw( libs libs_static );

      if($self->public_I)
      {
        $build->runtime_prop->{cflags}        = '' unless defined $build->runtime_prop->{cflags};
        $build->runtime_prop->{cflags_static} = '' unless defined $build->runtime_prop->{cflags_static};
        $build->runtime_prop->{$_} = join(' ', _space_escape(@{ $build->install_prop->{plugin_build_searchdep_cflags} })) . ' ' . $build->runtime_prop->{$_}
          for qw( cflags cflags_static );
      }
    },
  );
}

sub _space_escape
{
  map {
    my $str = $_;
    $str =~ s{(\s)}{\\$1}g;
    $str;
  } @_;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Build::SearchDep - Add dependencies to library and header search path

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 plugin 'Build::SearchDep' => (
   aliens => [qw( Alien::Foo Alien::Bar )],
 );

=head1 DESCRIPTION

This plugin adds the other aliens as prerequisites, and adds their header and library
search path to C<CFLAGS> and C<LDFLAGS> environment variable, so that tools that use
them (like autoconf) can pick them up.

=head1 PROPERTIES

=head2 aliens

Either a list reference or hash reference of the other aliens.  If a hash reference
then the keys are the class names and the values are the versions of those classes.

=head2 public_I

Include the C<-I> flags when setting the runtime cflags property.

=head2 public_l

Include the C<-l> flags when setting the runtime libs property.

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! �U�O  O  &  perl5/Alien/Build/Plugin/Build/Copy.pmnu ��6�$        package Alien::Build::Plugin::Build::Copy;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use Path::Tiny ();

# ABSTRACT: Copy plugin for Alien::Build
our $VERSION = '2.83'; # VERSION


sub init
{
  my($self, $meta) = @_;

  $meta->add_requires( 'configure', __PACKAGE__, 0);

  if($^O eq 'MSWin32')
  {
    $meta->register_hook(build => sub {
      my($build) = @_;
      my $stage = Path::Tiny->new($build->install_prop->{stage})->canonpath;
      $build->system(qq{xcopy . "$stage" /E});
    });
  }
  elsif($^O eq 'darwin')
  {
    # On recent macOS -pPR is the same as -aR
    # on older Mac OS X (10.5 at least) -a is not supported but -pPR is.

    # Looks like -pPR should also work on coreutils if for some reason
    # someone is using  coreutils on macOS, although there are semantic
    # differences between -pPR and -aR on coreutils, that may or may not be
    # important enough to care about.

    $meta->register_hook(build => [
      'cp -pPR * "%{.install.stage}"',
    ]);
  }
  else
  {
    # TODO: some platforms might not support -a
    # I think most platforms will support -r
    $meta->register_hook(build => [
      'cp -aR * "%{.install.stage}"',
    ]);
  }
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Build::Copy - Copy plugin for Alien::Build

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 plugin 'Build::Copy';

=head1 DESCRIPTION

This plugin copies all of the files from the source to the staging prefix.
This is mainly useful for software packages that are provided as binary
blobs.  It works on both Unix and Windows using the appropriate commands
for those platforms without having worry about the platform details in your
L<alienfile>.

If you want to filter add or remove files from what gets installed you can
use a C<before> hook.

 build {
   ...
   before 'build' => sub {
     # remove or modify files
   };
   plugin 'Build::Copy';
   ...
 };

Some packages might have binary blobs on some platforms and require build
from source on others.  In that situation you can use C<if> statements
with the appropriate logic in your L<alienfile>.

 configure {
   # normally the Build::Copy plugin will insert itself
   # as a config requires, but since it is only used
   # on some platforms, you will want to explicitly
   # require it in your alienfile in case you build your
   # alien dist on a platform that doesn't use it.
   requires 'Alien::Build::Plugin::Build::Copy';
 };
 
 build {
   ...
   if($^O eq 'linux')
   {
     start_url 'http://example.com/binary-blob-linux.tar.gz';
     plugin 'Download';
     plugin 'Extract' => 'tar.gz';
     plugin 'Build::Copy';
   }
   else
   {
     start_url 'http://example.com/source.tar.gz';
     plugin 'Download';
     plugin 'Extract' => 'tar.gz';
     plugin 'Build::Autoconf';
   }
 };

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! HLB4�  �  '  perl5/Alien/Build/Plugin/Build/CMake.pmnu ��6�$        package Alien::Build::Plugin::Build::CMake;

use strict;
use warnings;
use 5.008004;
use Config;
use Alien::Build::Plugin;
use Capture::Tiny qw( capture );

# ABSTRACT: CMake plugin for Alien::Build
our $VERSION = '2.83'; # VERSION


sub cmake_generator
{
  if($^O eq 'MSWin32')
  {
    return 'MinGW Makefiles' if is_dmake();

    {
      my($out, $err) = capture { system $Config{make}, '/?' };
      return 'NMake Makefiles' if $out =~ /NMAKE/;
    }

    {
      my($out, $err) = capture { system $Config{make}, '--version' };
      return 'MinGW Makefiles' if $out =~ /GNU Make/;
    }

    die 'make not detected';
  }
  else
  {
    return 'Unix Makefiles';
  }
}

sub init
{
  my($self, $meta) = @_;

  $meta->prop->{destdir} = $^O eq 'MSWin32' ? 0 : 1;

  $meta->add_requires('configure' => 'Alien::Build::Plugin::Build::CMake' => '0.99');
  $meta->add_requires('share'     => 'Alien::cmake3' => '0.02');

  if(is_dmake())
  {
    # even on at least some older versions of strawberry that do not
    # use it, come with gmake in the PATH.  So to save us the effort
    # of having to install Alien::gmake lets just use that version
    # if we can find it!
    my $found_gnu_make = 0;

    foreach my $exe (qw( gmake make mingw32-make ))
    {
      my($out, $err) = capture { system $exe, '--version' };
      if($out =~ /GNU Make/)
      {
        $meta->interpolator->replace_helper('make' => sub { $exe });
        $found_gnu_make = 1;
        last;
      }
    }

    if(!$found_gnu_make)
    {
      $meta->add_requires('share' => 'Alien::gmake' => '0.20');
      $meta->interpolator->replace_helper('make' => sub { require Alien::gmake; Alien::gmake->exe });
    }
  }

  $meta->interpolator->replace_helper('cmake' => sub { require Alien::cmake3; Alien::cmake3->exe });
  $meta->interpolator->add_helper('cmake_generator' => \&cmake_generator);

  my @args = (
    -G => '%{cmake_generator}',
    '-DCMAKE_POSITION_INDEPENDENT_CODE:BOOL=true',
    '-DCMAKE_INSTALL_PREFIX:PATH=%{.install.prefix}',
    '-DCMAKE_INSTALL_LIBDIR:PATH=lib',
    '-DCMAKE_MAKE_PROGRAM:PATH=%{make}',
  );

  $meta->prop->{plugin_build_cmake}->{args} = \@args;

  $meta->default_hook(
    build => [
      ['%{cmake}', @args, '%{.install.extract}' ],
      ['%{make}' ],
      ['%{make}', 'install' ],
    ],
  );

  # TODO: handle destdir on windows ??
}

my $is_dmake;

sub is_dmake
{
  unless(defined $is_dmake)
  {
    if($^O eq 'MSWin32')
    {
      my($out, $err) = capture { system $Config{make}, '-V' };
      $is_dmake = $out =~ /dmake/ ? 1 : 0;
    }
    else
    {
      $is_dmake = 0;
    }
  }

  $is_dmake;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Build::CMake - CMake plugin for Alien::Build

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 
 share {
   plugin 'Build::CMake';
   build [
     # this is the default build step, if you do not specify one.
     [ '%{cmake}',
         @{ meta->prop->{plugin_build_cmake}->{args} },
         # ... put extra cmake args here ...
         '%{.install.extract}'
     ],
     '%{make}',
     '%{make} install',
   ];
 };

=head1 DESCRIPTION

This plugin helps build alienized projects that use C<cmake>.
The intention is to make this a core L<Alien::Build> plugin if/when
it becomes stable enough.

This plugin provides a meta property C<plugin_build_cmake.args> which may change over time
but for the moment includes:

 -G %{cmake_generator}                          \
 -DCMAKE_POSITION_INDEPENDENT_CODE:BOOL=true    \
 -DCMAKE_INSTALL_PREFIX:PATH=%{.install.prefix} \
 -DCMAKE_INSTALL_LIBDIR:PATH=lib                \
 -DCMAKE_MAKE_PROGRAM:PATH=%{make}

This plugin supports out-of-source builds via the meta property C<out_of_source>.

=head1 METHODS

=head2 cmake_generator

Returns the C<cmake> generator according to your Perl's C<make>.

=head2 is_dmake

Returns true if your Perls C<make> appears to be C<dmake>.

=head1 HELPERS

=head2 cmake

This plugin replaces the default C<cmake> helper with the one that comes from L<Alien::cmake3>.

=head2 cmake_generator

This is the appropriate C<cmake> generator to use based on the make used by your Perl.  This is
frequently C<Unix Makefiles>.  One place where it may be different is if your Windows Perl uses
C<nmake>, which comes with Visual C++.

=head2 make

This plugin I<may> replace the default C<make> helper if the default C<make> is not supported by
C<cmake>.  This is most often an issue with older versions of Strawberry Perl which used C<dmake>.
On Perls that use C<dmake>, this plugin will search for GNU Make in the PATH, and if it can't be
found will fallback on using L<Alien::gmake>.

=head1 SEE ALSO

=over 4

=item L<Alien::Build>

=item L<Alien::Build::Plugin::Build::Autoconf>

=item L<alienfile>

=back

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! UW٧%  �%  *  perl5/Alien/Build/Plugin/Build/Autoconf.pmnu ��6�$        package Alien::Build::Plugin::Build::Autoconf;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use constant _win => $^O eq 'MSWin32';
use Path::Tiny ();
use File::Temp ();

# ABSTRACT: Autoconf plugin for Alien::Build
our $VERSION = '2.83'; # VERSION


has with_pic       => 1;
has ffi            => 0;
has msys_version   => undef;
has config_site    => sub {

  my $config_site  = "# file automatically generated by @{[ __FILE__ ]}\n";
     $config_site .= ". $ENV{CONFIG_SITE}\n" if defined $ENV{CONFIG_SITE};
     $config_site .= ". $ENV{ALIEN_BUILD_SITE_CONFIG}\n" if defined $ENV{ALIEN_BUILD_SITE_CONFIG};

     # on some platforms autofools sorry I mean autotools likes to install into
     # exec_prefix/lib64 or even worse exec_prefix/lib/64 but that messes everything
     # else up so we try to nip that in the bud.
     $config_site .= "libdir='\${prefix}/lib'\n";
   $config_site;
};

sub init
{
  my($self, $meta) = @_;

  $meta->apply_plugin('Build::MSYS',
    (defined $self->msys_version ? (msys_version => $self->msys_version) : ()),
  );

  $meta->prop->{destdir} = 1;
  $meta->prop->{autoconf} = 1;

  my $intr = $meta->interpolator;

  my $set_autoconf_prefix = sub {
    my($build) = @_;
    my $prefix = $build->install_prop->{prefix};
    die "Prefix is not set.  Did you forget to run 'make alien_prefix'?"
      unless $prefix;
    if(_win)
    {
      $prefix = Path::Tiny->new($prefix)->stringify;
      $prefix =~ s!^([a-z]):!/$1!i if _win;
    }
    $build->install_prop->{autoconf_prefix} = $prefix;
  };

  $meta->before_hook(
    build_ffi => $set_autoconf_prefix,
  );

  # FFI mode undocumented for now...

  if($self->ffi)
  {
    $meta->add_requires('configure', 'Alien::Build::Plugin::Build::Autoconf' => '0.41');
    $meta->default_hook(
      build_ffi => [
        '%{configure} --enable-shared --disable-static --libdir=%{.install.autoconf_prefix}/dynamic',
        '%{make}',
        '%{make} install',
      ]
    );

    if($^O eq 'MSWin32')
    {
      # for whatever reason autohell puts the .dll files in bin, even if you
      # point --bindir somewhere else.
      $meta->after_hook(
        build_ffi => sub {
          my($build) = @_;
          my $prefix = $build->install_prop->{autoconf_prefix};
          my $bin = Path::Tiny->new($ENV{DESTDIR})->child($prefix)->child('bin');
          my $lib = Path::Tiny->new($ENV{DESTDIR})->child($prefix)->child('dynamic');
          if(-d $bin)
          {
            foreach my $from (grep { $_->basename =~ /.dll$/i } $bin->children)
            {
              $lib->mkpath;
              my $to = $lib->child($from->basename);
              $build->log("copy $from => $to");
              $from->copy($to);
            }
          }
        }
      );
    }
  }

  $meta->around_hook(
    build => sub {
      my $orig = shift;
      my $build = shift;

      $set_autoconf_prefix->($build);
      my $prefix = $build->install_prop->{autoconf_prefix};
      die "Prefix is not set.  Did you forget to run 'make alien_prefix'?"
        unless $prefix;

      local $ENV{CONFIG_SITE} = do {
        my $site_config = Path::Tiny->new(File::Temp::tempdir( CLEANUP => 1 ))->child('config.site');
        $site_config->spew($self->config_site);
        "$site_config";
      };

      $intr->replace_helper(
        configure => sub {
          my $configure;

          if($build->meta_prop->{out_of_source})
          {
            my $extract = $build->install_prop->{extract};
            $configure = _win ? "sh $extract/configure" : "$extract/configure";
          }
          else
          {
            $configure = _win ? 'sh ./configure' : './configure';
          }
          $configure .= ' --prefix=' . $prefix;
          $configure .= ' --with-pic' if $self->with_pic;
          $configure;
        }
      );

      my $ret = $orig->($build, @_);

      if(_win)
      {
        my $real_prefix = Path::Tiny->new($build->install_prop->{prefix});
        my @pkgconf_dirs;
        push @pkgconf_dirs, Path::Tiny->new($ENV{DESTDIR})->child($prefix)->child("$_/pkgconfig") for qw(lib share);

        # for any pkg-config style .pc files that are dropped, we need
        # to convert the MSYS /C/Foo style paths to C:/Foo
        for my $pkgconf_dir (@pkgconf_dirs) {
            if(-d $pkgconf_dir)
            {
              foreach my $pc_file ($pkgconf_dir->children)
              {
                $pc_file->edit(sub {s/\Q$prefix\E/$real_prefix->stringify/eg;});
              }
            }
        }
      }

      $ret;
    },
  );


  $intr->add_helper(
    configure => sub {
      my $configure = _win ? 'sh configure' : './configure';
      $configure .= ' --with-pic' if $self->with_pic;
      $configure;
    },
  );

  $meta->default_hook(
    build => [
      '%{configure} --disable-shared',
      '%{make}',
      '%{make} install',
    ]
  );

  $self;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Build::Autoconf - Autoconf plugin for Alien::Build

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 plugin 'Build::Autoconf';

=head1 DESCRIPTION

This plugin provides some tools for building projects that use autoconf.  The main thing
this provides is a C<configure> helper, documented below and the default build stage,
which is:

 '%{configure} --disable-shared',
 '%{make}',
 '%{make} install',

On Windows, this plugin also pulls in the L<Alien::Build::Plugin::Build::MSYS> which is
required for autoconf style projects on windows.

The other thing that this plugin does is that it does a double staged C<DESTDIR> install.
The author has found this improves the overall reliability of L<Alien> modules that are
based on autoconf packages.

This plugin supports out-of-source builds (known in autoconf terms as "VPATH" builds) via
the meta property C<out_of_source>.

B<NOTE>: by itself, this plugin is only intended for use on packages that include a
C<configure> script.  For packages that expect you to use Autotools to generate a
configure script before building, you can use L<Alien::Autotools> to generate the
C<configure> script and use this plugin to run it.  For more details see the
documentation for L<Alien::Autotools>.

=head1 PROPERTIES

=head2 with_pic

Adds C<--with-pic> option when running C<configure>.  If supported by your package, it
will generate position independent code on platforms that support it.  This is required
to XS modules, and generally what you want.

autoconf normally ignores options that it does not understand, so it is usually a safe
and reasonable default to include it.  A small number of projects look like they use
autoconf, but are really an autoconf style interface with a different implementation.
They may fail if you try to provide it with options such as C<--with-pic> that they do
not recognize.  Such packages are the rationale for this property.

=head2 msys_version

The version of L<Alien::MSYS> required if it is deemed necessary.  If L<Alien::MSYS>
isn't needed (if running under Unix, or MSYS2, for example) this will do nothing.

=head2 config_site

The content for the generated C<config.site>.

=head1 HELPERS

=head2 configure

 %{configure}

The correct incantation to start an autoconf style C<configure> script on your platform.
Some reasonable default flags will be provided.

=head1 ENVIRONMENT

=over 4

=item C<SITE_CONFIG>

For a share install, this plugin needs to alter the behavior of autotools using C<site.config>.
It does this by generating a C<site.config> file on the fly, and setting the C<SITE_CONFIG>
environment variable.  In the event that you already have your own C<SITE_CONFIG> set, that
file will be sourced from the generated one, so your local defaults should still be honored,
unless it is one that needs to be changed for a share install.

In particular, the C<lib> directory must be overridden, because on some platforms dynamic libraries
will otherwise be placed in directories that L<Alien::Build> doesn't normally look in.  Since
the alienized package will be installed in a share directory, and not a system directory,
that should be fine.

=item C<ALIEN_BUILD_SITE_CONFIG>

If defined, this file will be also be sourced in the generated C<site.config>.  This allows
you to have local defaults for alien share installs only.

=back

=head1 SEE ALSO

L<Alien::Build::Plugin::Build::MSYS>, L<Alien::Build::Plugin>, L<Alien::Build>, L<Alien::Base>, L<Alien>

L<https://www.gnu.org/software/autoconf/autoconf.html>

L<https://www.gnu.org/prep/standards/html_node/DESTDIR.html>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! �#F�  �  &  perl5/Alien/Build/Plugin/Build/MSYS.pmnu ��6�$        package Alien::Build::Plugin::Build::MSYS;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use File::Which ();
use Env qw( @PATH );

# ABSTRACT: MSYS plugin for Alien::Build
our $VERSION = '2.83'; # VERSION


has msys_version   => '0.07';

sub init
{
  my($self, $meta) = @_;

  if($self->msys_version ne '0.07')
  {
    $meta->add_requires('configure' => 'Alien::Build::Plugin::Build::MSYS' => '0.84');
  }

  if(_win_and_needs_msys($meta))
  {
    $meta->add_requires('share' => 'Alien::MSYS' => $self->msys_version);

    $meta->around_hook(
      $_ => sub {
        my $orig = shift;
        my $build = shift;

        local $ENV{PATH} = $ENV{PATH};
        unshift @PATH, Alien::MSYS::msys_path();

        $orig->($build, @_);
      },
    ) for qw( build build_ffi test_share test_ffi );
  }


  if($^O eq 'MSWin32')
  {
    # Most likely if we are trying to build something unix-y and
    # we are using MSYS, then we want to use the make that comes
    # with MSYS.
    $meta->interpolator->replace_helper(
      make => sub { 'make' },
    );

  }

  $self;
}

sub _win_and_needs_msys
{
  my($meta) = @_;
  # check to see if we are running on windows.
  # if we are running on windows, check to see if
  # it is MSYS2, then we can just use that.  Otherwise
  # we are probably on Strawberry, or (less likely)
  # VC Perl, in which case we will still need Alien::MSYS
  return 0 unless $^O eq 'MSWin32';
  return 0 if $meta->prop->{platform}->{system_type} eq 'windows-mingw';
  return 1;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Build::MSYS - MSYS plugin for Alien::Build

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 plugin 'Build::MSYS';

=head1 DESCRIPTION

This plugin sets up the MSYS environment for your build on Windows.  It does
not do anything on non-windows platforms.  MSYS provides the essential tools
for building software that is normally expected in a UNIX or POSIX environment.
This like C<sh>, C<awk> and C<make>.  To provide MSYS, this plugin uses
L<Alien::MSYS>.

=head1 PROPERTIES

=head2 msys_version

The version of L<Alien::MSYS> required if it is deemed necessary.  If L<Alien::MSYS>
isn't needed (if running under Unix, or MSYS2, for example) this will do nothing.

=head1 HELPERS

=head2 make

 %{make}

On windows the default C<%{make}> helper is replace with the make that comes with
L<Alien::MSYS>.  This is almost certainly what you want, as most unix style make
projects will not build with C<nmake> or C<dmake> typically used by Perl on Windows.

=head1 SEE ALSO

L<Alien::Build::Plugin::Build::Autoconf>, L<Alien::Build::Plugin>, L<Alien::Build>, L<Alien::Base>, L<Alien>

L<http://www.mingw.org/wiki/MSYS>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! ����  �  &  perl5/Alien/Build/Plugin/Build/Make.pmnu ��6�$        package Alien::Build::Plugin::Build::Make;

use strict;
use warnings;
use 5.008004;
use Carp ();
use Capture::Tiny qw( capture );
use Alien::Build::Plugin;

# ABSTRACT: Make plugin for Alien::Build
our $VERSION = '2.83'; # VERSION


has '+make_type' => undef;

sub init
{
  my($self, $meta) = @_;

  $meta->add_requires('configure', 'Alien::Build::Plugin::Build::Make', '0.99');

  my $type = $self->make_type;

  return unless defined $type;

  $type = 'gmake' if $^O eq 'MSWin32' && $type eq 'umake';

  if($type eq 'nmake')
  {
    $meta->interpolator->replace_helper( make => sub { 'nmake' } );
  }

  elsif($type eq 'dmake')
  {
    $meta->interpolator->replace_helper( make => sub { 'dmake' } );
  }

  elsif($type eq 'gmake')
  {
    my $found = 0;
    foreach my $make (qw( gmake make mingw32-make ))
    {
      my($out, $err) = capture { system $make, '--version' };
      if($out =~ /GNU Make/)
      {
        $meta->interpolator->replace_helper( make => sub { $make } );
        $found = 1;
      }
    }
    unless($found)
    {
      $meta->add_requires('share' => 'Alien::gmake' => '0.20');
      $meta->interpolator->replace_helper('make' => sub { require Alien::gmake; Alien::gmake->exe });
    }
  }

  elsif($type eq 'umake')
  {
    # nothing
  }

  else
  {
    Carp::croak("unknown make type = ", $self->make_type);
  }
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Build::Make - Make plugin for Alien::Build

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 # For a recipe that requires GNU Make
 plugin 'Build::Make' => 'gmake';

=head1 DESCRIPTION

By default L<Alien::Build> provides a helper for the C<make> that is used by Perl and L<ExtUtils::MakeMaker> itself.
This is handy, because it is the one make that you can mostly guarantee that you will have.  Unfortunately it may be
a C<make> that isn't supported by the library or tool that you are trying to alienize.  This is mostly a problem on
Windows, where the supported C<make>s for years were Microsoft's C<nmake> and Sun's C<dmake>, which many open source
projects do not use.  This plugin will alter the L<alienfile> recipe to use a different C<make>.  It may (as in the
case of C<gmake> / L<Alien::gmake>) automatically download and install an alienized version of that C<make> if it
is not already installed.

This plugin should NOT be used with other plugins that replace the C<make> helper, like
L<Alien::Build::Plugin::Build::CMake>, L<Alien::Build::Plugin::Build::Autoconf>,
L<Alien::Build::Plugin::Build::MSYS>.  This plugin is intended instead for projects that use vanilla makefiles of
a specific type.

This plugin is for now distributed separately from L<Alien::Build>, but the intention is for it to soon become
a core plugin for L<Alien::Build>.

=head1 PROPERTIES

=head2 make_type

The make type needed by the L<alienfile> recipe:

=over 4

=item dmake

Sun's dmake.

=item gmake

GNU Make.

=item nmake

Microsoft's nmake.  It comes with Visual C++.

=item umake

Any UNIX C<make>  Usually either BSD or GNU Make.

=back

=head1 HELPERS

=head2 make

 %{make}

This plugin may change the make helper used by your L<alienfile> recipe.

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! p����  �  #  perl5/Alien/Build/Plugin/Gather.podnu ��6�$        # PODNAME: Alien::Build::Plugin::Gather
# ABSTRACT: Gather Alien::Build plugins
# VERSION

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Gather - Gather Alien::Build plugins

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 plugin 'Gather::IsolateDynamic';  # just as an example

=head1 DESCRIPTION

Gather plugins enhance L<alienfile> recipes at the gather stage, either
during a C<system> or C<share> install.

=over 4

=item L<Alien::Build::Plugin::Gather::IsolateDynamic>

Isolate dynamic libraries (C<.so>, <.DLL> or <.dylib>) so that they aren't used
by XS.

=back

=head1 SEE ALSO

L<Alien::Build>, L<Alien::Build::Plugin>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! W�O�	  	  $  perl5/Alien/Build/Plugin/Extract.podnu ��6�$        # PODNAME: Alien::Build::Plugin::Extract
# ABSTRACT: Extract Alien::Build plugins
# VERSION

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Extract - Extract Alien::Build plugins

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile
 share {
   plugin 'Extract' => 'tar.gz';
 };

=head1 DESCRIPTION

Extract plugins extract packages that have been downloaded from the internet.
Unless you are doing something unusual you will likely want to use the
L<Alien::Build::Plugin::Extract::Negotiate> plugin to select the best
Extract plugin available.

=over 4

=item L<Alien::Build::Plugin::Extract::ArchiveTar>

Extract using C<tar>.  Typically also works with compressed tarballs like C<tar.gz>.

=item L<Alien::Build::Plugin::Extract::ArchiveZip>

Extract using L<Archive::Zip>.

=item L<Alien::Build::Plugin::Extract::CommandLine>

Extract using command line tools like C<tar> or C<unxip>.

=item L<Alien::Build::Plugin::Extract::Directory>

Extract a local directory.

=item L<Alien::Build::Plugin::Extract::File>

"Extract" a single file.

=item L<Alien::Build::Plugin::Extract::Negotiate>

Pick the best extract plugin based on the extension of the package archive.

=back

=head1 SEE ALSO

L<Alien::Build>, L<Alien::Build::Plugin>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! ��� �  �  -  perl5/Alien/Build/Plugin/Probe/CommandLine.pmnu ��6�$        package Alien::Build::Plugin::Probe::CommandLine;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use Carp ();
use Capture::Tiny qw( capture );
use File::Which ();
use Alien::Util qw( version_cmp );

# ABSTRACT: Probe for tools or commands already available
our $VERSION = '2.83'; # VERSION


has '+command' => sub { Carp::croak "@{[ __PACKAGE__ ]} requires command property" };


has 'args'       => [];


has 'secondary' => 0;


has 'match'     => undef;


has 'match_stderr' => undef;


has 'version'   => undef;


has 'version_stderr' => undef;


has 'atleast_version' => undef;


sub init
{
  my($self, $meta) = @_;

  my $check = sub {
    my($build) = @_;

    unless(File::Which::which($self->command))
    {
      die 'Command not found ' . $self->command;
    }

    if(defined $self->match || defined $self->match_stderr || defined $self->version || defined $self->version_stderr)
    {
      my($out,$err,$ret) = capture {
        system( $self->command, @{ $self->args } );
      };
      die 'Command did not return a true value' if $ret;
      die 'Command output did not match' if defined $self->match && $out !~ $self->match;
      die 'Command standard error did not match' if defined $self->match_stderr && $err !~ $self->match_stderr;
      if (defined $self->version or defined $self->version_stderr)
      {
        my $found_version = '0';
        if(defined $self->version)
        {
          if($out =~ $self->version)
          {
            $found_version = $1;
            $build->runtime_prop->{version} = $found_version;
          }
        }
        if(defined $self->version_stderr)
        {
          if($err =~ $self->version_stderr)
          {
            $found_version = $1;
            $build->hook_prop->{version} = $found_version;
            $build->runtime_prop->{version} = $found_version;
          }
        }
        if (my $atleast_version = $self->atleast_version)
        {
          if(version_cmp ($found_version, $self->atleast_version) < 0)
          {
            #  reset the versions
            $build->runtime_prop->{version} = undef;
            $build->hook_prop->{version} = undef;
            die "CommandLine probe found version $found_version, but at least $atleast_version is required.";
          }
        }
      }
    }

    $build->runtime_prop->{command} = $self->command;
    'system';
  };

  if($self->secondary)
  {
    $meta->around_hook(
      probe => sub {
        my $orig = shift;
        my $build = shift;
        my $type = $orig->($build, @_);
        return $type unless $type eq 'system';
        $check->($build);
      },
    );
  }
  else
  {
    $meta->register_hook(
      probe => $check,
    );
  }
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Probe::CommandLine - Probe for tools or commands already available

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 plugin 'Probe::CommandLine' => (
   command => 'gzip',
   args    => [ '--version' ],
   match   => qr/gzip/,
   version => qr/gzip ([0-9\.]+)/,
 );

=head1 DESCRIPTION

This plugin probes for the existence of the given command line program.

=head1 PROPERTIES

=head2 command

The name of the command.

=head2 args

The arguments to pass to the command.

=head2 secondary

If you are using another probe plugin (such as L<Alien::Build::Plugin::Probe::CBuilder> or
L<Alien::Build::Plugin::PkgConfig::Negotiate>) to detect the existence of a library, but
also need a program to exist, then you should set secondary to a true value.  For example
when you need both:

 use alienfile;
 # requires both liblzma library and xz program
 plugin 'PkgConfig' => 'liblzma';
 plugin 'Probe::CommandLine' => (
   command   => 'xz',
   secondary => 1,
 );

When you don't:

 use alienfile;
 plugin 'Probe::CommandLine' => (
   command   => 'gzip',
   secondary => 0, # default
 );

=head2 match

Regular expression for which the program output should match.

=head2 match_stderr

Regular expression for which the program standard error should match.

=head2 version

Regular expression to parse out the version from the program output.
The regular expression should store the version number in C<$1>.

=head2 version_stderr

Regular expression to parse out the version from the program standard error.
The regular expression should store the version number in C<$1>.

=head2 atleast_version

The minimum required version as provided by the system.

=head1 SEE ALSO

L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! �jF    *  perl5/Alien/Build/Plugin/Probe/CBuilder.pmnu ��6�$        package Alien::Build::Plugin::Probe::CBuilder;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use File::chdir;
use File::Temp ();
use Capture::Tiny qw( capture_merged capture );
use Alien::Util qw( version_cmp );

# ABSTRACT: Probe for system libraries by guessing with ExtUtils::CBuilder
our $VERSION = '2.83'; # VERSION


has options => sub { {} };


has cflags  => '';


has libs    => '';


has program => 'int main(int argc, char *argv[]) { return 0; }';


has version => undef;


has 'atleast_version' => undef;


has aliens => [];


has lang => 'C';

sub init
{
  my($self, $meta) = @_;

  $meta->add_requires('configure' => 'ExtUtils::CBuilder' => 0 );

  if(@{ $self->aliens })
  {
    die "You can't specify both 'aliens' and either 'cflags' or 'libs' for the Probe::CBuilder plugin" if $self->cflags || $self->libs;

    $meta->add_requires('configure' => $_ => 0 ) for @{ $self->aliens };
    $meta->add_requires('Alien::Build::Plugin::Probe::CBuilder' => '0.53');

    my $cflags = '';
    my $libs   = '';
    foreach my $alien (@{ $self->aliens })
    {
      my $pm = "$alien.pm";
      $pm =~ s/::/\//g;
      require $pm;
      $cflags .= $alien->cflags . ' ';
      $libs   .= $alien->libs   . ' ';
    }
    $self->cflags($cflags);
    $self->libs($libs);
  }

  my @cpp;

  if($self->lang ne 'C')
  {
    $meta->add_requires('Alien::Build::Plugin::Probe::CBuilder' => '0.53');
    @cpp = ('C++' => 1) if $self->lang eq 'C++';
  }

  $meta->register_hook(
    probe => sub {
      my($build) = @_;

      $build->hook_prop->{probe_class} = __PACKAGE__;
      $build->hook_prop->{probe_instance_id} = $self->instance_id;

      local $CWD = File::Temp::tempdir( CLEANUP => 1, DIR => $CWD );

      open my $fh, '>', 'mytest.c';
      print $fh $self->program;
      close $fh;

      $build->log("trying: cflags=@{[ $self->cflags ]} libs=@{[ $self->libs ]}");

      my $cb = ExtUtils::CBuilder->new(%{ $self->options });

      my($out1, $obj) = capture_merged { eval {
        $cb->compile(
          source               => 'mytest.c',
          extra_compiler_flags => $self->cflags,
          @cpp,
        );
      } };

      if(my $error = $@)
      {
        $build->log("compile failed: $error");
        $build->log("compile failed: $out1");
        die $error;
      }

      my($out2, $exe) = capture_merged { eval {
        $cb->link_executable(
          objects              => [$obj],
          extra_linker_flags   => $self->libs,
        );
      } };

      if(my $error = $@)
      {
        $build->log("link failed: $error");
        $build->log("link failed: $out2");
        die $error;
      }

      my($out, $err, $ret) = capture { system($^O eq 'MSWin32' ? $exe : "./$exe") };
      die "execute failed" if $ret;

      my $cflags = $self->cflags;
      my $libs   = $self->libs;

      $cflags =~ s{\s*$}{ };
      $libs =~ s{\s*$}{ };

      $build->install_prop->{plugin_probe_cbuilder_gather}->{$self->instance_id} = {
        cflags  => $cflags,
        libs    => $libs,
      };

      if(defined $self->version)
      {
        my($version) = $out =~ $self->version;
        if (defined $self->atleast_version)
        {
          if(version_cmp ($version, $self->atleast_version) < 0)
          {
            die "CBuilder probe found version $version, but at least @{[ $self->atleast_version ]} is required.";
          }
        }
        $build->hook_prop->{version} = $version;
        $build->install_prop->{plugin_probe_cbuilder_gather}->{$self->instance_id}->{version} = $version;
      }

      'system';
    }
  );

  $meta->register_hook(
    gather_system => sub {
      my($build) = @_;

      return if $build->hook_prop->{name} eq 'gather_system'
      &&        ($build->install_prop->{system_probe_instance_id} || '') ne $self->instance_id;

      if(my $p = $build->install_prop->{plugin_probe_cbuilder_gather}->{$self->instance_id})
      {
        $build->runtime_prop->{$_} = $p->{$_} for keys %$p;
      }
    },
  );
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Probe::CBuilder - Probe for system libraries by guessing with ExtUtils::CBuilder

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 plugin 'Probe::CBuilder' => (
   cflags => '-I/opt/libfoo/include',
   libs   => '-L/opt/libfoo/lib -lfoo',
 );

alternately:

 ues alienfile;
 plugin 'Probe::CBuilder' => (
   aliens => [ 'Alien::libfoo', 'Alien::libbar' ],
 );

=head1 DESCRIPTION

This plugin probes for compiler and linker flags using L<ExtUtils::CBuilder>.  This is a useful
alternative to L<Alien::Build::Plugin::PkgConfig::Negotiate> for packages that do not provide
a pkg-config C<.pc> file, or for when those C<.pc> files may not be available.  (For example,
on FreeBSD, C<libarchive> is a core part of the operating system, but doesn't include a C<.pc>
file which is usually provided when you install the C<libarchive> package on Linux).

=head1 PROPERTIES

=head2 options

Any extra options that you want to have passed into the constructor to L<ExtUtils::CBuilder>.

=head2 cflags

The compiler flags.

=head2 libs

The linker flags

=head2 program

The program to use in the test.

=head2 version

This is a regular expression to parse the version out of the output from the
test program.

=head2 atleast_version

The minimum required version as provided by the system.

=head2 aliens

List of aliens to query fro compiler and linker flags.

=head2 lang

The programming language to use.  One of either C<C> or C<C++>.

=head1 SEE ALSO

L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! vZ�    '  perl5/Alien/Build/Plugin/Probe/Vcpkg.pmnu ��6�$        package Alien::Build::Plugin::Probe::Vcpkg;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;

# ABSTRACT: Probe for system libraries using Vcpkg
our $VERSION = '2.83'; # VERSION


has '+name';
has 'lib';
has 'ffi_name';
has 'include';

sub init
{
  my($self, $meta) = @_;

  if(defined $self->include)
  {
    $meta->add_requires('configure' => 'Alien::Build::Plugin::Probe::Vcpkg' => '2.16' );
  }
  elsif(defined $self->ffi_name)
  {
    $meta->add_requires('configure' => 'Alien::Build::Plugin::Probe::Vcpkg' => '2.14' );
  }
  else
  {
    $meta->add_requires('configure' => 'Alien::Build::Plugin::Probe::Vcpkg' => '0' );
  }

  if($meta->prop->{platform}->{compiler_type} eq 'microsoft')
  {
    $meta->register_hook(
      probe => sub {
        my($build) = @_;

        $build->hook_prop->{probe_class} = __PACKAGE__;
        $build->hook_prop->{probe_instance_id} = $self->instance_id;

        eval {
          require Win32::Vcpkg;
          require Win32::Vcpkg::List;
          require Win32::Vcpkg::Package;
          Win32::Vcpkg->VERSION('0.02');
        };
        if(my $error = $@)
        {
          $build->log("unable to load Win32::Vcpkg: $error");
          return 'share';
        }

        my $package;
        if($self->name)
        {
          $package = Win32::Vcpkg::List->new
                                       ->search($self->name, include => $self->include);
        }
        elsif($self->lib)
        {
          $package = eval { Win32::Vcpkg::Package->new( lib => $self->lib, include => $self->include) };
          return 'share' if $@;
        }
        else
        {
          $build->log("you must provode either name or lib property for Probe::Vcpkg");
          return 'share';
        }

        my $version = $package->version;
        $version = 'unknown' unless defined $version;

        $build->install_prop->{plugin_probe_vcpkg}->{$self->instance_id} = {
          version  => $version,
          cflags   => $package->cflags,
          libs     => $package->libs,
        };
        $build->hook_prop->{version} = $version;
        $build->install_prop->{plugin_probe_vcpkg}->{$self->instance_id}->{ffi_name} = $self->ffi_name
          if defined $self->ffi_name;
        return 'system';
      },
    );

    $meta->register_hook(
      gather_system => sub {
        my($build) = @_;

        return if $build->hook_prop->{name} eq 'gather_system'
        &&        ($build->install_prop->{system_probe_instance_id} || '') ne $self->instance_id;

        if(my $c = $build->install_prop->{plugin_probe_vcpkg}->{$self->instance_id})
        {
          $build->runtime_prop->{version} = $c->{version} unless defined $build->runtime_prop->{version};
          $build->runtime_prop->{$_} = $c->{$_} for grep { defined $c->{$_} } qw( cflags libs ffi_name );
        }
      },
    );
  }
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Probe::Vcpkg - Probe for system libraries using Vcpkg

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 
 plugin 'Probe::Vcpkg' => 'libffi';

=head1 DESCRIPTION

This plugin probe can be used to find "system" packages using Microsoft's C<Vcpkg> package manager for
Visual C++ builds of Perl.  C<Vcpkg> is a package manager for Visual C++ that includes a number of
open source packages.  Although C<Vcpkg> does also support Linux and macOS, this plugin does not
support finding C<Vcpkg> packages on those platforms.  For more details on C<Vcpkg>, see the project
github page here:

L<https://github.com/microsoft/vcpkg>

Here is the quick start guide for getting L<Alien::Build> to work with C<Vpkg>:

 # install Vcpkg
 C:\> git clone https://github.com/Microsoft/vcpkg.git
 C:\> cd vcpkg
 C:\vcpkg> .\bootstrap-vcpkg.bat
 C:\vcpkg> .\vcpkg integrate install
 
 # update PATH to include the bin directory
 # so that .DLL files can be found by Perl
 C:\vcpkg> path c:\vcpkg\installed\x64-windows\bin;%PATH%
 
 # install the packages that you want
 C:\vcpkg> .\vcpkg install libffi
 
 # install the alien that uses it
 C:\vcpkg> cpanm Alien::FFI

If you are using 32 bit build of Perl, then substitute C<x86-windows> for C<x64-windows>.  If you do
not want to add the C<bin> directory to the C<PATH>, then you can use C<x64-windows-static> instead,
which will provide static libraries.  (As of this writing static libraries for 32 bit Windows are not
available).  The main downside to using C<x64-windows-static> is that Aliens that require dynamic
libraries for FFI will not be installable.

If you do not want to install C<Vcpkg> user wide (the C<integrate install> command above), then you
can use the C<PERL_WIN32_VCPKG_ROOT> environment variable instead:

 # install Vcpkg
 C:\> git clone https://github.com/Microsoft/vcpkg.git
 C:\> cd vcpkg
 C:\vcpkg> .\bootstrap-vcpkg.bat
 C:\vcpkg> set PERL_WIN32_VCPKG_ROOT=c:\vcpkg

=head1 PROPERTIES

=head2 name

Specifies the name of the Vcpkg.  This should not be used with the C<lib> property below, choose only one.

This is the default property, so these two are equivalent:

 plugin 'Probe::Vcpkg' => (name => 'foo');

and

 plugin 'Probe::Vcpkg' => 'foo';

=head2 lib

Specifies the list of libraries that make up the Vcpkg.  This should not be used with the C<name> property
above, choose only one.  Note that using this detection method, the version number of the package will
not be automatically determined (since multiple packages could potentially make up the list of libraries),
so you need to determine the version number another way if you need it.

This must be an array reference.  Do not include the C<.lib> extension.

 plugin 'Probe::Vcpkg' => (lib => ['foo','bar']);

=head2 ffi_name

Specifies an alternate ffi_name for finding dynamic libraries.

=head1 SEE ALSO

L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! 'S)�j
  j
  "  perl5/Alien/Build/Plugin/Fetch.podnu ��6�$        # PODNAME: Alien::Build::Plugin::Fetch
# ABSTRACT: Fetch Alien::Build plugins
# VERSION

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Fetch - Fetch Alien::Build plugins

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 share {
   start_url 'http://ftp.gnu.org/gnu/make';
   plugin 'Download';
 };

=head1 DESCRIPTION

Fetch plugins retrieve single resources from the internet.  The difference
between a Fetch plugin and a Download plugin is that Download
plugin may fetch several resources from the internet (usually using
a Fetch plugin), before finding the final archive.  Normally you
will not need to use Fetch plugins directly but should instead
use the L<Alien::Build::Plugin::Download::Negotiate> plugin, which
will pick the best plugins for your given URL.

=over 4

=item L<Alien::Build::Plugin::Fetch::CurlCommand>

Fetch using the C<curl> command.

=item L<Alien::Build::Plugin::Fetch::HTTPTiny>

Fetch using L<HTTP::Tiny>.

=item L<Alien::Build::Plugin::Fetch::LWP>

Fetch using L<LWP::UserAgent>.

=item L<Alien::Build::Plugin::Fetch::Local>

Fetch from a local file.  This is typically used to bundle packages with your L<Alien>.

=item L<Alien::Build::Plugin::Fetch::LocalDir>

Fetch from a local directory.  This is typically used to bundle packages with your L<Alien>.

=item L<Alien::Build::Plugin::Fetch::NetFTP>

Fetch using L<Net::FTP>.  Use of FTP should be discouraged as of this writing (August 2022).

=item L<Alien::Build::Plugin::Fetch::Wget>

Fetch using C<wget>.

=back

=head1 SEE ALSO

L<Alien::Build>, L<Alien::Build::Plugin>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! ͆s��	  �	  #  perl5/Alien/Build/Plugin/Decode.podnu ��6�$        # PODNAME: Alien::Build::Plugin::Decode
# ABSTRACT: Decode Alien::Build plugins
# VERSION

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin::Decode - Decode Alien::Build plugins

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 use alienfile;
 plugin 'Decode::HTML';
 plugin 'Decode::DirListing';

=head1 DESCRIPTION

Decode plugins decode HTML and FTP file listings.  Normally you
will want to use the L<Alien::Build::Plugin::Download::Negotiate>
plugin which will automatically load the appropriate Decode plugins.

=over 4

=item L<Alien::Build::Plugin::Decode::DirListing>

Default decoder for FTP file listings, that uses the pure-perl L<File::Listing>.

=item L<Alien::Build::Plugin::Decode::DirListingFtpcopy>

Another decoder for FTP file listings, that uses the XS module L<File::Listing::Ftpcopy>.

=item L<Alien::Build::Plugin::Decode::HTML>

Older decoder for HTML file listings, which uses the XS module L<HTML::LinkExtor>.  This
used to be the default decoder until L<Alien::Build> version 1.75.  In some cases, this
will be used as the HTML decoder if you configure with L<Alien::Build> prior to 1.75
and but upgrade to a more recent version for the build stage of your L<Alien>

=item L<Alien::Build::Plugin::Decode::Mojo>

Newer decoder for HTML file listings, which uses the pure-perl L<Mojo::DOM> or L<Mojo::DOM58>.
This became the default decoder at L<Alien::Build> version 1.75.

=back

=head1 SEE ALSO

L<Alien::Build>, L<Alien::Build::Plugin>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       !  ��t�   �   (  perl5/Alien/Build/Interpolate/Default.pmnu ��6�$        package Alien::Build::Interpolate::Default;

use strict;
use warnings;
use 5.008004;
use parent qw( Alien::Build::Interpolate );
use File::chdir;
use File::Which qw( which );
use Capture::Tiny qw( capture );

# ABSTRACT: Default interpolator for Alien::Build
our $VERSION = '2.83'; # VERSION

sub _config
{
  $Config::Config{$_[0]};
}


sub new
{
  my($class) = @_;
  my $self = $class->SUPER::new(@_);


  $self->add_helper( ar => sub { _config 'ar' }, 'Config' );


  $self->add_helper( bison => undef, sub {
    my $helper = shift;
    if(which 'bison')
    {
      $helper->code(sub { 'bison' });
      return  ();
    }
    else
    {
      return 'Alien::bison' => '0.17';
    }
  });


  $self->add_helper( bzip2 => undef, sub {
    my $helper = shift;
    if(which 'bzip2')
    {
      $helper->code( sub { 'bzip2' });
      return ();
    }
    else
    {
      return 'Alien::Libbz2' => '0.04';
    }
  });


  $self->add_helper( cc => sub { _config 'cc' }, 'Config' );


  $self->add_helper( cmake => sub { 'cmake' }, sub {
    if(which 'cmake')
    {
      return ();
    }
    else
    {
      return 'Alien::CMake' => '0.07';
    }
  });


  $self->add_helper( cp => sub { _config 'cp' }, 'Config' );


  $self->add_helper( devnull => sub { $^O eq 'MSWin32' ? 'NUL' : '/dev/null' });


  $self->add_helper( flex => undef, sub {
    my $helper = shift;
    if(which 'flex')
    {
      $helper->code(sub { 'flex' });
      return  ();
    }
    else
    {
      return 'Alien::flex' => '0.08';
    }
  });


  $self->add_helper( gmake => undef, 'Alien::gmake' => '0.11' );


  $self->add_helper( install => sub { 'install' });


  $self->add_helper( ld => sub { _config 'ld' }, 'Config' );


  $self->add_helper( m4 => undef, 'Alien::m4' => '0.08' );


  if($^O eq 'MSWin32')
  {
    # TL;DR: dmake is bad, and shouldn't be used to build anything but older
    # versions of Windows Perl that don't support gmake.
    my $perl_make = _config 'make';
    my $my_make;
    $self->add_helper( make => sub {
      return $my_make if defined $my_make;

      if( $perl_make ne 'dmake' && which $perl_make )
      {
        # assume if it is called nmake or gmake that it really is what it
        # says it is.
        if( $perl_make eq 'nmake' || $perl_make eq 'gmake' )
        {
          return $my_make = $perl_make;
        }

        my $out = capture { system $perl_make, '--version' };
        if( $out =~ /GNU make/i || $out =~ /Microsoft \(R\) Program Maintenance/ )
        {
          return $my_make = $perl_make;
        }

      }

      # if we see something that looks like it might be gmake, use that.
      foreach my $try (qw( gmake mingw32-make ))
      {
        return $my_make = $try if which $try;
      }

      if( which 'make' )
      {
        my $out = capture { system 'make', '--version' };
        if( $out =~ /GNU make/i || $out =~ /Microsoft \(R\) Program Maintenance/ )
        {
          return $my_make = 'make';
        }
      }

      # if we see something that looks like it might be nmake, use that.
      foreach my $try (qw( nmake ))
      {
        return $my_make = $try if which $try;
      }

      $my_make = $perl_make;
    });
  }
  else
  {
    $self->add_helper( make => sub { _config 'make' }, 'Config' );
  }


  $self->add_helper( mkdir_deep => sub { $^O eq 'MSWin32' ? 'md' : 'mkdir -p'}, 'Alien::Build' => '1.04' );
  $self->add_helper( make_path  => sub { $^O eq 'MSWin32' ? 'md' : 'mkdir -p'}, 'Alien::Build' => '1.05' );


  $self->add_helper( nasm => undef, sub {
    my $helper = shift;
    if(which 'nasm')
    {
      $helper->code(sub { 'nasm' });
      return  ();
    }
    else
    {
      return 'Alien::nasm' => '0.11';
    }
  });


  $self->add_helper( patch => undef, sub {
    my $helper = shift;
    if(which 'patch')
    {
      if($^O eq 'MSWin32')
      {
        $helper->code(sub { 'patch --binary' });
      }
      else
      {
        $helper->code(sub { 'patch' });
      }
      return  ();
    }
    else
    {
      return 'Alien::patch' => '0.09';
    }
  });


  $self->add_helper( perl => sub {
      my $perl = Devel::FindPerl::find_perl_interpreter();
      $perl =~ s{\\}{/}g if $^O eq 'MSWin32';
      $perl;
  }, 'Devel::FindPerl' );


  $self->add_helper( pkgconf => undef, 'Alien::pkgconf' => 0.06 );


  $self->add_helper( cwd => sub {
    my $cwd = "$CWD";
    $cwd =~ s{\\}{/}g if $^O eq 'MSWin32';
    $cwd;
  } );


  $self->add_helper( sh => sub { 'sh' }, 'Alien::MSYS' => '0.07' );


  $self->add_helper( rm => sub { _config 'rm' }, 'Config' );


  $self->add_helper( xz => undef, sub {
    my $helper = shift;
    if(which 'xz')
    {
      $helper->code(sub { 'xz' });
      return  ();
    }
    else
    {
      return 'Alien::xz' => '0.02';
    }
  });

  $self;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Interpolate::Default - Default interpolator for Alien::Build

=head1 VERSION

version 2.83

=head1 CONSTRUCTOR

=head2 new

 my $intr = Alien::Build::Interpolate::Default->new;

=head1 HELPERS

=head2 ar

 %{ar}

The ar command.

=head2 bison

 %{bison}

Requires: L<Alien::bison> 0.17 if not already in C<PATH>.

=head2 bzip2

 %{bzip2}

Requires: L<Alien::Libbz2> 0.04 if not already in C<PATH>.

=head2 cc

 %{cc}

The C Compiler used to build Perl

=head2 cmake

 %{cmake}

Requires: L<Alien::CMake> 0.07 if cmake is not already in C<PATH>.

Deprecated: Use the L<Alien::Build::Plugin::Build::CMake> plugin instead (which will replace
this helper with one that works with L<Alien::cmake3> that works better).

=head2 cp

 %{cp}

The copy command.

=head2 devnull

 %{devnull}

The null device, if available.  On Unix style operating systems this will be C</dev/null> on Windows it is C<NUL>.

=head2 flex

 %{flex}

Requires: L<Alien::flex> 0.08 if not already in C<PATH>.

=head2 gmake

 %{gmake}

Requires: L<Alien::gmake> 0.11

Deprecated: use L<Alien::Build::Plugin::Build::Make> instead.

=head2 install

 %{install}

The Unix C<install> command.  Not normally available on Windows.

=head2 ld

 %{ld}

The linker used to build Perl

=head2 m4

 %{m4}

Requires: L<Alien::m4> 0.08

L<Alien::m4> should pull in a version of C<m4> that will work with Autotools.

=head2 make

 %{make}

Make.  On Unix this will be the same make used by Perl.  On Windows this will be
C<gmake> or C<nmake> if those are available, and only C<dmake> if the first two
are not available.

=head2 make_path

 %{make_path}

Make directory, including all parent directories as needed.  This is usually C<mkdir -p>
on Unix and simply C<md> on windows.

=head2 nasm

 %{nasm}

Requires: L<Alien::nasm> 0.11 if not already in the C<PATH>.

=head2 patch

 %{patch}

Requires: L<Alien::patch> 0.09 if not already in the C<PATH>.

On Windows this will normally render C<patch --binary>, which makes patch work like it does on Unix.

=head2 perl

 %{perl}

Requires: L<Devel::FindPerl>

=head2 pkgconf

 %{pkgconf}

Requires: L<Alien::pkgconf> 0.06.

=head2 cwd

 %{cwd}

=head2 sh

 %{sh}

Unix style command interpreter (/bin/sh).

Deprecated: use the L<Alien::Build::Plugin::Build::MSYS> plugin instead.

=head2 rm

 %{rm}

The remove command

=head2 xz

 %{xz}

Requires: L<Alien::xz> 0.02 if not already in the C<PATH>.

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! �6�*�;  �;    perl5/Alien/Build/MM.pmnu ��6�$        package Alien::Build::MM;

use strict;
use warnings;
use 5.008004;
use Alien::Build;
use Path::Tiny ();
use Capture::Tiny qw( capture );
use Carp ();

# ABSTRACT: Alien::Build installer code for ExtUtils::MakeMaker
our $VERSION = '2.83'; # VERSION


sub new
{
  my($class, %prop) = @_;

  my $self = bless {}, $class;

  my %meta = map { $_ => $prop{$_} } grep /^my_/, keys %prop;

  my $build = $self->{build} =
    Alien::Build->load('alienfile',
      root     => "_alien",
      (-d 'patch' ? (patch => 'patch') : ()),
      meta_prop => \%meta,
    )
  ;

  if(%meta)
  {
    $build->meta->add_requires(configure => 'Alien::Build::MM' => '1.20');
    $build->meta->add_requires(configure => 'Alien::Build' => '1.20');
  }

  if(defined $prop{alienfile_meta})
  {
    $self->{alienfile_meta} = $prop{alienfile_meta};
  }
  else
  {
    $self->{alienfile_meta} = 1;
  }

  $self->{clean_install} = $prop{clean_install};

  $self->build->load_requires('configure');
  $self->build->root;
  $self->build->checkpoint;

  $self;
}


sub build
{
  shift->{build};
}


sub alienfile_meta
{
  shift->{alienfile_meta};
}


sub clean_install
{
  shift->{clean_install};
}


sub mm_args
{
  my($self, %args) = @_;

  if($args{DISTNAME})
  {
    $self->build->set_stage(Path::Tiny->new("blib/lib/auto/share/dist/$args{DISTNAME}")->absolute->stringify);
    $self->build->install_prop->{mm}->{distname} = $args{DISTNAME};
    my $module = $args{DISTNAME};
    $module =~ s/-/::/g;
    # See if there is an existing version installed, without pulling it into this process
    my($old_prefix, $err, $ret) = capture { system $^X, "-M$module", -e => "print $module->dist_dir"; $? };
    if($ret == 0)
    {
      chomp $old_prefix;
      my $file = Path::Tiny->new($old_prefix, qw( _alien alien.json ));
      if(-r $file)
      {
        my $old_runtime = eval {
          require JSON::PP;
          JSON::PP::decode_json($file->slurp);
        };
        unless($@)
        {
          $self->build->install_prop->{old}->{runtime} = $old_runtime;
          $self->build->install_prop->{old}->{prefix}  = $old_prefix;
        }
      }
    }
  }
  else
  {
    Carp::croak "DISTNAME is required";
  }

  my $ab_version = '0.25';

  if($self->clean_install)
  {
    $ab_version = '1.74';
  }

  $args{CONFIGURE_REQUIRES} = Alien::Build::_merge(
    'Alien::Build::MM' => $ab_version,
    %{ $args{CONFIGURE_REQUIRES} || {} },
    %{ $self->build->requires('configure') || {} },
  );

  if($self->build->install_type eq 'system')
  {
    $args{BUILD_REQUIRES} = Alien::Build::_merge(
      'Alien::Build::MM' => $ab_version,
      %{ $args{BUILD_REQUIRES} || {} },
      %{ $self->build->requires('system') || {} },
    );
  }
  elsif($self->build->install_type eq 'share')
  {
    $args{BUILD_REQUIRES} = Alien::Build::_merge(
      'Alien::Build::MM' => $ab_version,
      %{ $args{BUILD_REQUIRES} || {} },
      %{ $self->build->requires('share') || {} },
    );
  }
  else
  {
    die "unknown install type: @{[ $self->build->install_type ]}"
  }

  $args{PREREQ_PM} = Alien::Build::_merge(
    'Alien::Build' => $ab_version,
    %{ $args{PREREQ_PM} || {} },
  );

  #$args{META_MERGE}->{'meta-spec'}->{version} = 2;
  $args{META_MERGE}->{dynamic_config} = 1;

  if($self->alienfile_meta)
  {
    $args{META_MERGE}->{x_alienfile} = {
      generated_by => "@{[ __PACKAGE__ ]} version @{[ __PACKAGE__->VERSION || 'dev' ]}",
      requires => {
        map {
          my %reqs = %{ $self->build->requires($_) };
          $reqs{$_} = "$reqs{$_}" for keys %reqs;
          $_ => \%reqs;
        } qw( share system )
      },
    };
  }

  $self->build->checkpoint;
  %args;
}


sub mm_postamble
{
  # NOTE: older versions of the Alien::Build::MM documentation
  # didn't include $mm and @rest args, so anything that this
  # method uses them for has to be optional.
  # (as of this writing they are unused, but are being added
  #  to match the way mm_install works).

  my($self, $mm, @rest) = @_;

  my $postamble = '';

  # remove the _alien directory on a make realclean:
  $postamble .= "realclean :: alien_realclean\n" .
                "\n" .
                "alien_realclean:\n" .
                "\t\$(RM_RF) _alien\n\n";

  # remove the _alien directory on a make clean:
  $postamble .= "clean :: alien_clean\n" .
                "\n" .
                "alien_clean:\n" .
                "\t\$(RM_RF) _alien\n\n";

  my $dirs = $self->build->meta_prop->{arch}
    ? '$(INSTALLARCHLIB) $(INSTALLSITEARCH) $(INSTALLVENDORARCH)'
    : '$(INSTALLPRIVLIB) $(INSTALLSITELIB) $(INSTALLVENDORLIB)'
  ;

  # set prefix
  $postamble .= "alien_prefix : _alien/mm/prefix\n\n" .
                "_alien/mm/prefix :\n" .
                "\t\$(FULLPERL) -MAlien::Build::MM=cmd -e prefix \$(INSTALLDIRS) $dirs\n\n";

  # set verson
  $postamble .= "alien_version : _alien/mm/version\n\n" .
                "_alien/mm/version : _alien/mm/prefix\n" .
                "\t\$(FULLPERL) -MAlien::Build::MM=cmd -e version \$(VERSION)\n\n";

  # download
  $postamble .= "alien_download : _alien/mm/download\n\n" .
                "_alien/mm/download : _alien/mm/prefix _alien/mm/version\n" .
                "\t\$(FULLPERL) -MAlien::Build::MM=cmd -e download\n\n";

  # build
  $postamble .= "alien_build : _alien/mm/build\n\n" .
                "_alien/mm/build : _alien/mm/download\n" .
                "\t\$(FULLPERL) -MAlien::Build::MM=cmd -e build\n\n";

  # append to all
  $postamble .= "pure_all :: _alien/mm/build\n\n";

  $postamble .= "subdirs-test_dynamic subdirs-test_static subdirs-test :: alien_test\n\n";
  $postamble .= "alien_test :\n" .
                "\t\$(FULLPERL) -MAlien::Build::MM=cmd -e test\n\n";

  # prop
  $postamble .= "alien_prop :\n" .
                "\t\$(FULLPERL) -MAlien::Build::MM=cmd -e dumpprop\n\n";
  $postamble .= "alien_prop_meta :\n" .
                "\t\$(FULLPERL) -MAlien::Build::MM=cmd -e dumpprop meta\n\n";
  $postamble .= "alien_prop_install :\n" .
                "\t\$(FULLPERL) -MAlien::Build::MM=cmd -e dumpprop install\n\n";
  $postamble .= "alien_prop_runtime :\n" .
                "\t\$(FULLPERL) -MAlien::Build::MM=cmd -e dumpprop runtime\n\n";

  # install
  $postamble .= "alien_clean_install : _alien/mm/prefix\n" .
                "\t\$(FULLPERL) -MAlien::Build::MM=cmd -e clean_install\n\n";

  $postamble;
}


sub mm_install
{
  # NOTE: older versions of the Alien::Build::MM documentation
  # didn't include this method, so anything that this method
  # does has to be optional

  my($self, $mm, @rest) = @_;

  my $section = do {
    package
      MY;
    $mm->SUPER::install(@rest);
  };

  return
      ".NOTPARALLEL : \n\n"
    . ".NO_PARALLEL : \n\n"
    . "install :: alien_clean_install\n\n"
    . $section;
}

sub import
{
  my(undef, @args) = @_;
  foreach my $arg (@args)
  {
    if($arg eq 'cmd')
    {
      package main;

      *_args = sub
      {
        my $build = Alien::Build->resume('alienfile', '_alien');
        $build->load_requires('configure');
        $build->load_requires($build->install_type);
        ($build, @ARGV)
      };

      *_touch = sub {
        my($name) = @_;
        my $path = Path::Tiny->new("_alien/mm/$name");
        $path->parent->mkpath;
        $path->touch;
      };

      *prefix = sub
      {
        my($build, $type, $perl, $site, $vendor) = _args();

        my $distname = $build->install_prop->{mm}->{distname};

        my $prefix = $type eq 'perl'
          ? $perl
          : $type eq 'site'
            ? $site
            : $type eq 'vendor'
              ? $vendor
              : die "unknown INSTALLDIRS ($type)";
        $prefix = Path::Tiny->new($prefix)->child("auto/share/dist/$distname")->absolute->stringify;

        $build->log("prefix $prefix");
        $build->set_prefix($prefix);
        $build->checkpoint;
        _touch('prefix');
      };

      *version = sub
      {
        my($build, $version) = _args();

        $build->runtime_prop->{perl_module_version} = $version;
        $build->checkpoint;
        _touch('version');
      };

      *download = sub
      {
        my($build) = _args();
        $build->download;
        $build->checkpoint;
       _touch('download');
      };

      *build = sub
      {
        my($build) = _args();

        $build->build;

        my $distname = $build->install_prop->{mm}->{distname};

        if($build->meta_prop->{arch})
        {
          my $archdir = Path::Tiny->new("blib/arch/auto/@{[ join '/', split /-/, $distname ]}");
          $archdir->mkpath;
          my $archfile = $archdir->child($archdir->basename . '.txt');
          $archfile->spew('Alien based distribution with architecture specific file in share');
        }

        my $cflags = $build->runtime_prop->{cflags};
        my $libs   = $build->runtime_prop->{libs};

        if(($cflags && $cflags !~ /^\s*$/)
        || ($libs   && $libs   !~ /^\s*$/))
        {
          my $mod = join '::', split /-/, $distname;
          my $install_files_pm = Path::Tiny->new("blib/lib/@{[ join '/', split /-/, $distname ]}/Install/Files.pm");
          $install_files_pm->parent->mkpath;
          $install_files_pm->spew(
            "package ${mod}::Install::Files;\n",
            "use strict;\n",
            "use warnings;\n",
            "require ${mod};\n",
            "sub Inline { shift; ${mod}->Inline(\@_) }\n",
            "1;\n",
            "\n",
            "=begin Pod::Coverage\n",
            "\n",
            "  Inline\n",
            "\n",
            "=cut\n",
          ) unless -f "$install_files_pm";
        }

        $build->checkpoint;
        _touch('build');
      };

      *test = sub
      {
        my($build) = _args();
        $build->test;
        $build->checkpoint;
      };

      *clean_install = sub
      {
        my($build) = _args();
        $build->clean_install;
        $build->checkpoint;
      };

      *dumpprop = sub
      {
        my($build, $type) = _args();

        my %h = (
          meta    => $build->meta_prop,
          install => $build->install_prop,
          runtime => $build->runtime_prop,
        );

        require Alien::Build::Util;
        print Alien::Build::Util::_dump($type ? $h{$type} : \%h);
      }
    }
  }
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::MM - Alien::Build installer code for ExtUtils::MakeMaker

=head1 VERSION

version 2.83

=head1 SYNOPSIS

In your C<Makefile.PL>:

 use ExtUtils::MakeMaker;
 use Alien::Build::MM;
 
 my $abmm = Alien::Build::MM->new;
 
 WriteMakefile($abmm->mm_args(
   ABSTRACT     => 'Discover or download and install libfoo',
   DISTNAME     => 'Alien-Libfoo',
   NAME         => 'Alien::Libfoo',
   VERSION_FROM => 'lib/Alien/Libfoo.pm',
   ...
 ));
 
 sub MY::postamble {
   $abmm->mm_postamble(@_);
 }
 
 sub MY::install {
   $abmm->mm_install(@_);
 }

In your C<lib/Alien/Libfoo.pm>:

 package Alien::Libfoo;
 use parent qw( Alien::Base );
 1;

In your alienfile (needs to be named C<alienfile> and should be in the root of your dist):

 use alienfile;
 
 plugin 'PkgConfig' => 'libfoo';
 
 share {
   start_url 'http://libfoo.org';
   ...
 };

=head1 DESCRIPTION

This class allows you to use Alien::Build and Alien::Base with L<ExtUtils::MakeMaker>.
It load the L<alienfile> recipe in the root of your L<Alien> dist, updates the prereqs
passed into C<WriteMakefile> if any are specified by your L<alienfile> or its plugins,
and adds a postamble to the C<Makefile> that will download/build/test the alienized
package as appropriate.

The L<alienfile> must be named C<alienfile>.

If you are using L<Dist::Zilla> to author your L<Alien> dist, you should consider using
the L<Dist::Zilla::Plugin::AlienBuild> plugin.

I personally don't recommend it, but if you want to use L<Module::Build> instead, you
can use L<Alien::Build::MB>.

=head1 CONSTRUCTOR

=head2 new

 my $abmm = Alien::Build::MM->new;

Create a new instance of L<Alien::Build::MM>.

=head1 PROPERTIES

=head2 build

 my $build = $abmm->build;

The L<Alien::Build> instance.

=head2 alienfile_meta

 my $bool = $abmm->alienfile_meta

Set to a false value, in order to turn off the x_alienfile meta

=head2 clean_install

 my $bool = $abmm->clean_install;

Set to a true value, in order to clean the share directory prior to
installing.  If you use this you have to make sure that you install
the install handler in your C<Makefile.PL>:

 $abmm = Alien::Build::MM->new(
   clean_install => 1,
 );
 
 ...
 
 sub MY::install {
   $abmm->mm_install(@_);
 }

=head1 METHODS

=head2 mm_args

 my %args = $abmm->mm_args(%args);

Adjust the arguments passed into C<WriteMakefile> as needed by L<Alien::Build>.

=head2 mm_postamble

 my $postamble $abmm->mm_postamble;
 my $postamble $abmm->mm_postamble($mm);

Returns the postamble for the C<Makefile> needed for L<Alien::Build>.
This adds the following C<make> targets which are normally called when
you run C<make all>, but can be run individually if needed for debugging.

=over 4

=item alien_prefix

Determines the final install prefix (C<%{.install.prefix}>).

=item alien_version

Determine the perl_module_version (C<%{.runtime.perl_module_version}>)

=item alien_download

Downloads the source from the internet.  Does nothing for a system install.

=item alien_build

Build from source (if a share install).  Gather configuration (for either
system or share install).

=item alien_prop, alien_prop_meta, alien_prop_install, alien_prop_runtime

Prints the meta, install and runtime properties for the Alien.

=item alien_realclean, alien_clean

Removes the alien specific files.  These targets are executed when you call
the C<realclean> and C<clean> targets respectively.

=item alien_clean_install

Cleans out the Alien's share directory.  Caution should be used in invoking
this target directly, as if you do not understand what you are doing you
are likely to break your already installed Alien.

=back

=head2 mm_install

 sub MY::install {
   $abmm->mm_install(@_);
 }

B<EXPERIMENTAL>

Adds an install rule to clean the final install dist directory prior to installing.

=head1 SEE ALSO

L<Alien::Build>, L<Alien::Base>, L<Alien>, L<Dist::Zilla::Plugin::AlienBuild>, L<Alien::Build::MB>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! ā%�O  O    perl5/Alien/Build/rc.pmnu ��6�$        package Alien::Build::rc;

use strict;
use warnings;
use 5.008004;

# ABSTRACT: Alien::Build local config
our $VERSION = '2.83'; # VERSION


sub logx ($)
{
  unshift @_, 'Alien::Build';
  goto &Alien::Build::log;
}


sub preload_plugin
{
  my(@args) = @_;
  push @Alien::Build::rc::PRELOAD, sub {
    shift->apply_plugin(@args);
  };
}


sub postload_plugin
{
  my(@args) = @_;
  push @Alien::Build::rc::POSTLOAD, sub {
    shift->apply_plugin(@args);
  };
}


sub preload ($)
{
  push @Alien::Build::rc::PRELOAD, $_[0];
}


sub postload ($)
{
  push @Alien::Build::rc::POSTLOAD, $_[0];
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::rc - Alien::Build local config

=head1 VERSION

version 2.83

=head1 SYNOPSIS

in your C<~/.alienbuild/rc.pl>:

 preload 'Foo::Bar';
 postload 'Baz::Frooble';

=head1 DESCRIPTION

L<Alien::Build> will load your C<~/.alienbuild/rc.pl> file, if it exists
before running the L<alienfile> recipe.  This allows you to alter the
behavior of L<Alien::Build> based L<Alien>s if you have local configuration
requirements.  For example you can prompt before downloading remote content
or fetch from a local mirror.

=head1 FUNCTIONS

=head2 logx

 log $message;

Send a message to the L<Alien::Build> log.

=head2 preload_plugin

 preload_plugin $plugin, @args;

Preload the given plugin, with arguments.

=head2 postload_plugin

 postload_plugin $plugin, @args;

Postload the given plugin, with arguments.

=head2 preload

[deprecated]

 preload $plugin;

Preload the given plugin.

=head2 postload

[deprecated]

 postload $plugin;

Postload the given plugin.

=head1 SEE ALSO

=over 4

=item L<Alien::Build::Plugin::Fetch::Cache>

=item L<Alien::Build::Plugin::Fetch::Prompt>

=item L<Alien::Build::Plugin::Fetch::Rewrite>

=item L<Alien::Build::Plugin::Probe::Override>

=back

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! n����  �  "  perl5/Alien/Build/Version/Basic.pmnu ��6�$        package Alien::Build::Version::Basic;

use strict;
use warnings;
use 5.008004;
use Carp ();
use Exporter qw( import );
use overload
  '<=>'    => sub { shift->cmp(@_) },
  'cmp'    => sub { shift->cmp(@_) },
  '""'     => sub { shift->as_string },
  bool     => sub { 1 },
  fallback => 1;

our @EXPORT_OK = qw( version );

# ABSTRACT: Very basic version object for Alien::Build
our $VERSION = '2.83'; # VERSION


sub new
{
  my($class, $value) = @_;
  $value =~ s/\.$//;  # trim trailing dot
  Carp::croak("invalud version: $value")
    unless $value =~ /^[0-9]+(\.[0-9]+)*$/;
  bless \$value, $class;
}


sub version ($)
{
  my($value) = @_;
  __PACKAGE__->new($value);
}


sub as_string
{
  my($self) = @_;
  "@{[ $$self ]}";
}


sub cmp
{
  my @x = split /\./, ${$_[0]};
  my @y = split /\./, ${ref($_[1]) ? $_[1] : version($_[1])};

  while(@x or @y)
  {
    my $x = (shift @x) || 0;
    my $y = (shift @y) || 0;
    return $x <=> $y if $x <=> $y;
  }

  0;
}


1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Version::Basic - Very basic version object for Alien::Build

=head1 VERSION

version 2.83

=head1 SYNOPSIS

OO interface:

 use Alien::Build::Version::Basic;
 
 my $version = Alien::Build::Version::Basic->new('1.2.3');
 if($version > '1.2.2')  # true
 {
   ...
 }

Function interface:

 use Alien::Build::Version::Basic qw( version );
 
 if(version('1.2.3') > version('1.2.2')) # true
 {
   ...
 }
 
 my @sorted = sort map { version($_) } qw( 2.1 1.2.3 1.2.2 );
 # will come out in the order 1.2.2, 1.2.3, 2.1

=head1 DESCRIPTION

This module provides a very basic class for comparing versions.
This is already a crowded space on CPAN.  Parts of L<Alien::Build>
already use L<Sort::Versions>, which is fine for sorting versions.
Sometimes you need to compare to see if versions match exact I<values>,
and the best candidates (such as L<Sort::Versions> on CPAN compare
C<1.2.3.0> and C<1.2.3> as being different.  This class compares
those two as the same.

This class is also quite limited, in that it only works with version
schemes using a doted version numbers or real numbers with a fixed
number of digits.  Versions with: dashes, letters, hex digits, or
anything else are not supported.

This class overloads both C<E<lt>=E<gt>> and C<cmp> to compare the version in
the way that you would expect for version numbers.  This way you can
compare versions like numbers, or sort them using sort.

 if(version($v1) > version($v2))
 {
   ...
 }
 
 my @sorted = sort map { version($_) } @unsorted;

it also overloads C<""> to stringify as whatever string value you
passed to the constructor.

=head1 CONSTRUCTOR

=head2 new

 my $version = Alien::Build::Version::Basic->new($value);

This is the long form of the constructor, if you don't want to import
anything into your namespace.

=head2 version

 my $version = version($value);

This is the short form of the constructor, if you are sane.  It is
NOT exported by default so you will have to explicitly import it.

=head1 METHODS

=head2 as_string

 my $string = $version->as_string;
 my $string = "$version";

Returns the string representation of the version object.

=head2 cmp

 my $bool = $version->cmp($other);
 my $bool = $version <=> $other;
 my $bool = $version cmp $other;

Returns C<-1>, C<0> or C<1> just like the regular C<E<lt>=E<gt>> and C<cmp>
operators.  Although C<$version> must be a version object, C<$other> may
be either a version object, or a string that could be used to create a
valid version object.

=head1 SEE ALSO

=over 4

=item L<Sort::Versions>

Good, especially if you have to support rpm style versions (like C<1.2.3-2-b>)
or don't care if trailing zeros (C<1.2.3> vs C<1.2.3.0>) are treated as
different values.

=item L<version>

Problematic for historical reasons.

=back

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! �h���  �    perl5/Alien/Build/Plugin.pmnu ��6�$        package Alien::Build::Plugin;

use strict;
use warnings;
use 5.008004;
use Data::Dumper ();
use Carp ();
use Digest::SHA ();

our @CARP_NOT = qw( alienfile Alien::Build Alien::Build::Meta );

# ABSTRACT: Plugin base class for Alien::Build
our $VERSION = '2.83'; # VERSION


sub new
{
  my $class = shift;
  my %args = @_ == 1 ? ($class->meta->default => $_[0]) : @_;

  my $instance_id = Digest::SHA::sha1_hex(Data::Dumper->new([$class, \%args])->Sortkeys(1)->Dump);
  my $self = bless { instance_id => $instance_id }, $class;

  my $prop = $self->meta->prop;
  foreach my $name (keys %$prop)
  {
    $self->{$name} = defined $args{$name}
      ? delete $args{$name}
      : ref($prop->{$name}) eq 'CODE'
        ? $prop->{$name}->()
        : $prop->{$name};
  }

  foreach my $name (keys %args)
  {
    Carp::carp "$class has no $name property";
  }

  $self;
}


sub instance_id { shift->{instance_id} }


sub init
{
  my($self) = @_;
  $self;
}

sub import
{
  my($class) = @_;

  return if $class ne __PACKAGE__;

  my $caller = caller;
  { no strict 'refs'; @{ "${caller}::ISA" } = __PACKAGE__ }

  my $meta = $caller->meta;
  my $has = sub {
    my($name, $default) = @_;
    $meta->add_property($name, $default);
  };

  { no strict 'refs'; *{ "${caller}::has" } = $has }
}


my %meta;
sub meta
{
  my($class) = @_;
  $class = ref $class if ref $class;
  $meta{$class} ||= Alien::Build::PluginMeta->new( class => $class );
}

package Alien::Build::PluginMeta;

sub new
{
  my($class, %args) = @_;
  my $self = bless {
    prop => {},
    %args,
  }, $class;
}

sub default
{
  my($self) = @_;
  $self->{default} || do {
    Carp::croak "No default for @{[ $self->{class} ]}";
  };
}

sub add_property
{
  my($self, $name, $default) = @_;
  my $single = $name =~ s{^(\+)}{};
  $self->{default} = $name if $single;
  $self->{prop}->{$name} = $default;

  my $accessor = sub {
    my($self, $new) = @_;
    $self->{$name} = $new if defined $new;
    $self->{$name};
  };

  # add the accessor
  { no strict 'refs'; *{ $self->{class} . '::' . $name} = $accessor }

  $self;
}

sub prop
{
  shift->{prop};
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Plugin - Plugin base class for Alien::Build

=head1 VERSION

version 2.83

=head1 SYNOPSIS

Create your plugin:

 package Alien::Build::Plugin::Type::MyPlugin;
 
 use Alien::Build::Plugin;
 use Carp ();
 
 has prop1 => 'default value';
 has prop2 => sub { 'default value' };
 has prop3 => sub { Carp::croak 'prop3 is a required property' };
 
 sub init
 {
   my($self, $meta) = @_;
 
   my $prop1 = $self->prop1;
   my $prop2 = $self->prop2;
   my $prop3 = $self->prop3;
 
   $meta->register_hook(sub {
     build => [ '%{make}', '%{make} install' ],
   });
 }

From your L<alienfile>

 use alienfile;
 plugin 'Type::MyPlugin' => (
   prop2 => 'different value',
   prop3 => 'need to provide since it is required',
 );

=head1 DESCRIPTION

This document describes the L<Alien::Build> plugin base class.  For details
on how to write a plugin, see L<Alien::Build::Manual::PluginAuthor>.

Listed are some common types of plugins:

=over 4

=item L<Alien::Build::Plugin::Build>

Tools for building.

=item L<Alien::Build::Plugin::Core>

Tools already included.

=item L<Alien::Build::Plugin::Decode>

Normally use Download plugins which will pick the correct Decode plugins.

=item L<Alien::Build::Plugin::Digest>

Tools for checking cryptographic signatures during a C<share> install.

=item L<Alien::Build::Plugin::Download>

Methods for retrieving from the internet.

=item L<Alien::Build::Plugin::Extract>

Extract from archives that have been downloaded.

=item L<Alien::Build::Plugin::Fetch>

Normally use Download plugins which will pick the correct Fetch plugins.

=item L<Alien::Build::Plugin::Gather>

Plugins that modify or enhance the gather step.

=item L<Alien::Build::Plugin::PkgConfig>

Plugins that work with C<pkg-config> or libraries that provide the same
functionality.

=item L<Alien::Build::Plugin::Prefer>

Normally use Download plugins which will pick the correct Prefer plugins.

=item L<Alien::Build::Plugin::Probe>

Look for packages already installed on the system.

=item L<Alien::Build::Plugin::Probe>

Plugins useful for unit testing L<Alien::Build> itself, or plugins for it.

=back

=head1 CONSTRUCTOR

=head2 new

 my $plugin = Alien::Build::Plugin->new(%props);

=head2 PROPERTIES

=head2 instance_id

 my $id = $plugin->instance_id;

Returns an instance id for the plugin.  This is computed from the class and
arguments that are passed into the plugin constructor, so technically two
instances with the exact same arguments will have the same instance id, but
in practice you should never have two instances with the exact same arguments.

=head1 METHODS

=head2 init

 $plugin->init($ab_class->meta); # $ab is an Alien::Build class name

You provide the implementation for this.  The intent is to register
hooks and set meta properties on the L<Alien::Build> class.

=head2 has

 has $prop_name;
 has $prop_name => $default;

Specifies a property of the plugin.  You may provide a default value as either
a string scalar, or a code reference.  The code reference will be called to
compute the default value, and if you want the default to be a list or hash
reference, this is how you want to do it:

 has foo => sub { [1,2,3] };

=head2 meta

 my $meta = $plugin->meta;

Returns the plugin meta object.

=head1 SEE ALSO

L<Alien::Build>, L<alienfile>, L<Alien::Build::Manual::PluginAuthor>

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! �
�N�  �  $  perl5/Alien/Build/CommandSequence.pmnu ��6�$        package Alien::Build::CommandSequence;

use strict;
use warnings;
use 5.008004;
use Text::ParseWords qw( shellwords );
use Capture::Tiny qw( capture );

# ABSTRACT: Alien::Build command sequence
our $VERSION = '2.83'; # VERSION


sub new
{
  my($class, @commands) = @_;
  my $self = bless {
    commands => \@commands,
  }, $class;
  $self;
}


sub apply_requirements
{
  my($self, $meta, $phase) = @_;
  my $intr = $meta->interpolator;
  foreach my $command (@{ $self->{commands} })
  {
    next if ref $command eq 'CODE';
    if(ref $command eq 'ARRAY')
    {
      foreach my $arg (@$command)
      {
        next if ref $arg eq 'CODE';
        $meta->add_requires($phase, $intr->requires($arg))
      }
    }
    else
    {
      $meta->add_requires($phase, $intr->requires($command));
    }
  }
  $self;
}

my %built_in = (

  cd => sub {
    my(undef, $dir) = @_;
    if(!defined $dir)
    {
      die "undef passed to cd";
    }
    elsif(-d $dir)
    {
      chdir($dir) || die "unable to cd $dir $!";
    }
    else
    {
      die "unable to cd $dir, does not exist";
    }
  },

);

sub _run_list
{
  my($build, @cmd) = @_;
  $build->log("+ @cmd");
  return $built_in{$cmd[0]}->(@cmd) if $built_in{$cmd[0]};
  system @cmd;
  die "external command failed" if $?;
}

sub _run_string
{
  my($build, $cmd) = @_;
  $build->log("+ $cmd");

  {
    my $cmd = $cmd;
    $cmd =~ s{\\}{\\\\}g if $^O eq 'MSWin32';
    my @cmd = shellwords($cmd);
    return $built_in{$cmd[0]}->(@cmd) if $built_in{$cmd[0]};
  }

  system $cmd;
  die "external command failed" if $?;
}

sub _run_with_code
{
  my($build, @cmd) = @_;
  my $code = pop @cmd;
  $build->log("+ @cmd");
  my %args = ( command => \@cmd );

  if($built_in{$cmd[0]})
  {
    my $error;
    ($args{out}, $args{err}, $error) = capture {
      eval { $built_in{$cmd[0]}->(@cmd) };
      $@;
    };
    $args{exit} = $error eq '' ? 0 : 2;
    $args{builtin} = 1;
  }
  else
  {
    ($args{out}, $args{err}, $args{exit}) = capture {
      system @cmd; $?
    };
  }
  $build->log("[output consumed by Alien::Build recipe]");
  $code->($build, \%args);
}


sub _apply
{
  my($where, $prop, $value) = @_;
  if($where =~ /^(.*?)\.(.*?)$/)
  {
    _apply($2, $prop->{$1}, $value);
  }
  else
  {
    $prop->{$where} = $value;
  }
}

sub execute
{
  my($self, $build) = @_;
  my $intr = $build->meta->interpolator;

  foreach my $command (@{ $self->{commands} })
  {
    if(ref($command) eq 'CODE')
    {
      $command->($build);
    }
    elsif(ref($command) eq 'ARRAY')
    {
      my($command, @args) = @$command;
      my $code;
      $code = pop @args if $args[-1] && ref($args[-1]) eq 'CODE';

      if($args[-1] && ref($args[-1]) eq 'SCALAR')
      {
        my $dest = ${ pop @args };
        if($dest =~ /^\%\{((?:alien|)\.(?:install|runtime|hook)\.[a-z\.0-9_]+)\}$/)
        {
          $dest = $1;
          $dest =~ s/^\./alien./;
          $code = sub {
            my($build, $args) = @_;
            die "external command failed" if $args->{exit};
            my $out = $args->{out};
            chomp $out;
            _apply($dest, $build->_command_prop, $out);
          };
        }
        else
        {
          die "illegal destination: $dest";
        }
      }

      ($command, @args) = map { $intr->interpolate($_, $build) } ($command, @args);

      if($code)
      {
        _run_with_code $build, $command, @args, $code;
      }
      else
      {
        _run_list $build, $command, @args;
      }
    }
    else
    {
      my $command = $intr->interpolate($command, $build);
      _run_string $build, $command;
    }
  }
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::CommandSequence - Alien::Build command sequence

=head1 VERSION

version 2.83

=head1 CONSTRUCTOR

=head2 new

 my $seq = Alien::Build::CommandSequence->new(@commands);

=head1 METHODS

=head2 apply_requirements

 $seq->apply_requirements($meta, $phase);

=head2 execute

 $seq->execute($build);

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! �-�%t  t    perl5/Alien/Build/Temp.pmnu ��6�$        package Alien::Build::Temp;

use strict;
use warnings;
use 5.008004;
use Carp ();
use Path::Tiny ();
use File::Temp ();
use File::Spec ();

# ABSTRACT: Temp Dir support for Alien::Build
our $VERSION = '2.83'; # VERSION


# problem with vanilla File::Temp is that is often uses
# as /tmp that has noexec turned on.  Workaround is to
# create a temp directory in the build directory, but
# we have to be careful about cleanup.  This puts all that
# (attempted) carefulness in one place so that when we
# later discover it isn't so careful we can fix it in
# one place rather thabn alllll the places that we need
# temp directories.

# we also have a speical case for Windows, which often
# has problems with long paths if we try to use the
# current directory for temp files, so for those we
# use the system tmp directory.

my %root;

sub _root
{
  return File::Spec->tmpdir if $^O eq 'MSWin32';

  my $root = Path::Tiny->new(-d "_alien" ? "_alien/tmp" : ".tmp")->absolute;
  unless(-d $root)
  {
    mkdir $root or die "unable to create temp root $!";
  }

  # TODO: doesn't account for fork...
  my $lock = $root->child("l$$");
  unless(-f $lock)
  {
    open my $fh, '>', $lock;
    close $fh;
  }
  $root{"$root"} = 1;
  $root;
}

END {
  foreach my $root (keys %root)
  {
    my $lock = Path::Tiny->new($root)->child("l$$");
    unlink $lock;
    # try to delete if possible.
    # if not possible then punt
    rmdir $root if -d $root;
  }
}

sub newdir
{
  my $class = shift;
  Carp::croak "uneven" if @_ % 2;
  File::Temp->newdir(DIR => _root, @_);
}

sub new
{
  my $class = shift;
  Carp::croak "uneven" if @_ % 2;
  File::Temp->new(DIR => _root, @_);
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Temp - Temp Dir support for Alien::Build

=head1 VERSION

version 2.83

=head1 DESCRIPTION

This class is private to L<Alien::Build>.

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! mM���R  �R     perl5/Alien/Build/Manual/FAQ.podnu ��6�$        # PODNAME: Alien::Build::Manual::FAQ
# ABSTRACT: Frequently Asked Questions about Alien::Build
# VERSION

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Manual::FAQ - Frequently Asked Questions about Alien::Build

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 perldoc Alien::Build::Manual::FAQ

=head1 DESCRIPTION

This document serves to answer the most frequently asked questions made by developers
creating L<Alien> modules using L<Alien::Build>.

=head1 QUESTIONS

=head2 What is Alien, Alien::Base and Alien::Build?

Alien in a Perl namespace for defining dependencies in CPAN for libraries and tools which
are not "native" to CPAN.  For a manifesto style description of the Why, and How see
L<Alien>.  L<Alien::Base> is a base class for the L<Alien> runtime.  L<Alien::Build> is
a tool for probing the operating system for existing libraries and tools, and downloading, building
and installing packages.  L<alienfile> is a recipe format for describing how to probe,
download, build and install a package.

=head2 How do I build a package that uses I<build system>

=head3 autoconf

Use the autoconf plugin (L<Alien::Build::Plugin::Build::Autoconf>).  If your package
provides a pkg-config C<.pc> file, then you can also use the PkgConfig plugin
(L<Alien::Build::Plugin::PkgConfig::Negotiate>).

 use alienfile
 plugin PkgConfig => 'libfoo';
 share {
   start_url => 'http://example.org/dist';
   plugin Download => (
     version => qr/libfoo-([0-9\.])\.tar\.gz$/,
   );
   plugin Extract => 'tar.gz';
   plugin 'Build::Autoconf';
 };

If you need to provide custom flags to configure, you can do that too:

 share {
   plugin 'Build::Autoconf';
   build [
     '%{configure} --disable-shared --enable-foo',
     '%{make}',
     '%{make} install',
   ];
 };

If your package requires GNU Make, use C<%{gmake}> instead of C<%{make}>.

=head3 autoconf without configure script

A number of Open Source projects are using autotools, but do not provide the
C<configure> script.  When alienizing these types of packages you have a
few choices:

=over 4

=item build configure using autotools

The Alien L<Alien::Autotools> is designed to provide autotools for building
such packages from source.  The advantage is that this is how the upstream
developers intend on having their package built.  The downside is that it
is also adds more prereqs to your Alien.  The silver lining is that if you
require this Alien in the C<share> block (as you should), then these prereqs
will only be pulled in during a share install when they are needed.

Please see the L<Alien::Autotools> documentation for specifics on how it
can be used in your L<alienfile>.

=item patch the package locally before build

You can use the L<alienfile/patch> directive to patch the alienized package
locally before building.  This can sometimes be challenging because Autotools
uses timestamps in order to decide what needs to be rebuilt, and patching
can sometimes confuse it into thinking more needs to be rebuilt than what
actually does.

=item build configure and tarball

You can also build the configure script during development of your alien,
generate the tarball and provide it somewhere like GitHub and use that
as the source instead of the original source.  This should usually be
a last resort if the other two methods prove too difficult.

=back

=head3 autoconf-like

If you see an error like this:

 Unknown option "--with-pic".

It is because the autoconf plugin uses the C<--with-pic> option by default, since
it makes sense most of the time, and autoconf usually ignores options that it does
not recognize.  Some autoconf style build systems fail when they see an option that
they do not recognize.  You can turn this behavior off for these packages:

 plugin 'Build::Autoconf' => (
   with_pic => 0,
 );

Another thing about the autoconf plugin is that it uses C<DESTDIR> to do a double
staged install.  If you see an error like "nothing was installed into destdir", that
means that your package does not support C<DESTDIR>.  You should instead use the
MSYS plugin and use a command sequence to do the build like this:

 share {
   plugin 'Build::MSYS';
   build [
     # explicitly running configure with "sh" will make sure that
     # it works on windows as well as UNIX.
     'sh configure --prefix=%{.install.prefix} --disable-shared',
     '%{make}',
     '%{make} install',
   ];
 };

=head3 CMake

There is an alien L<Alien::cmake3> that provides C<cmake> 3.x or better (It is preferred to the
older L<Alien::CMake>).  Though it is recommended that you use the C<cmake>
(L<Alien::Build::Plugin::Build::CMake>) plugin instead of using L<Alien::cmake3>.

 use alienfile;
 
 share {
   plugin 'Build::CMake';
   build [
     # this is the default build step, if you do not specify one.
     [ '%{cmake}',
         @{ meta->prop->{plugin_build_cmake}->{args} },
         # ... put extra cmake args here ...
         '.'
     ],
     '%{make}',
     '%{make} install',
   ];
 };

=head3 vanilla Makefiles

L<Alien::Build> provides a helper (C<%{make}>) for the C<make> that is used by Perl and
L<ExtUtils::MakeMaker> (EUMM).  Unfortunately the C<make> supported by Perl and EUMM on
Windows (C<nmake> and C<dmake>) are not widely supported by most open source projects.
(Thankfully recent perls and EUMM support GNU Make on windows now).

You can use the C<make> plugin (L<Alien::Build::Plugin::Build::Make>) to tell the
L<Alien::Build> system which make the project that you are alienizing requires.

 plugin 'Build::Make' => 'umake';
 # umake makes %{make} either GNU Make or BSD Make on Unix and GNU Make on Windows.
 build {
   build [
     # You can use the Perl config compiler and cflags using the %{perl.config...} helper
     [ '%{make}', 'CC=%{perl.config.cc}', 'CFLAGS=%{perl.config.cccdlflags} %{perl.config.optimize}' ],
     [ '%{make}', 'install', 'PREFIX=%{.install.prefix}' ],
   ],
 };

Some open source projects require GNU Make, and you can specify that, and L<Alien::gmake>
will be pulled in on platforms that do not already have it.

 plugin 'Build::Make' => 'gmake';
 ...

=head2 How do I probe for a package that uses pkg-config?

Use the C<pkg-config> plugin (L<Alien::Build::Plugin::PkgConfig::Negotiate>):

 use alienfile;
 plugin 'PkgConfig' => (
   pkg_name => 'libfoo',
 );

It will probe for a system version of the library.  It will also add the appropriate C<version>
C<cflags> and C<libs> properties on either a C<system> or C<share> install.

=head2 How do I specify a minimum or exact version requirement for packages that use pkg-config?

The various pkg-config plugins all support atleast_version, exact_version and maximum_version
fields, which have the same meaning as the C<pkg-config> command line interface:

 use alienfile;
 
 plugin 'PkgConfig', pkg_name => 'foo', atleast_version => '1.2.3';

or

 use alienfile;
 
 plugin 'PkgConfig', pkg_name => foo, exact_version => '1.2.3';

=head2 How do I probe for a package that uses multiple .pc files?

Each of the C<PkgConfig> plugins will take an array reference instead of a string:

 use alienfile;
 
 plugin 'PkgConfig' => ( pkg_name => [ 'foo', 'bar', 'baz' ] );

The first C<pkg_name> given will be used by default once your alien is installed.
To get the configuration for C<foo> and C<bar> you can use the
L<Alien::Base alt method|Alien::Base/alt>:

 use Alien::libfoo;
 
 $cflags = Alien::libfoo->cflags;               # compiler flags for 'foo'
 $cflags = Alien::libfoo->alt('bar')->cflags ;  # compiler flags for 'bar'
 $cflags = Alien::libfoo->alt('baz')->cflags ;  # compiler flags for 'baz'

=head2 How to create an Alien module for packages that do not support pkg-config?

=head3 Packages that provide a configuration script

Many packages provide a command that you can use to get the appropriate version, compiler
and linker flags.  For those packages you can just use the commands in your L<alienfile>.
Something like this:

 use alienfile;
 
 probe [ 'foo-config --version' ];
 
 share {
   ...
 
   build [
     '%{make} PREFIX=%{.runtime.prefix}',
     '%{make} install PREFIX=%{.runtime.prefix}',
   ];
 };
 
 gather [
   [ 'foo-config', '--version', \'%{.runtime.version}' ],
   [ 'foo-config', '--cflags',  \'%{.runtime.cflags}'  ],
   [ 'foo-config', '--libs',    \'%{.runtime.libs}'    ],
 ];

=head3 Packages that require a compile test

Some packages just expect you do know that C<-lfoo> will work.  For those you can use
the C<cbuilder> plugin (L<Alien::Build::Plugin::Probe::CBuilder>).

 use alienfile;
 plugin 'Probe::CBuilder' => (
   cflags => '-I/opt/libfoo/include',
   libs   => '-L/opt/libfoo/lib -lfoo',
 );
 
 share {
   ...
   gather sub {
     my($build) = @_;
     my $prefix = $build->runtime_prop->{prefix};
     $build->runtime_prop->{cflags} = "-I$prefix/include ";
     $build->runtime_prop->{libs}   = "-L$prefix/lib -lfoo ";
   };
 }

This plugin will build a small program with these flags and test that it works.  (There
are also options to provide a program that can make simple tests to ensure the library
works).  If the probe works, it will set the compiler and linker flags.  (There are also
options for extracting the version from the test program).  If you do a share install
you will need to set the compiler and linker flags yourself in the gather step, if you
aren't using a build plugin that will do that for you.

=head2 Can/Should I write a tool oriented Alien module?

Certainly.  The original intent was to provide libraries, but tools are also quite doable using
the L<Alien::Build> toolset.  A good example of how to do this is L<Alien::nasm>.  You will want
to use the 'Probe::CommandLine':

 use alienfile;
 
 plugin 'Probe::CommandLine' => (
   command => 'gzip',
 );

=head2 How do I test my package once it is built (before it is installed)?

Use L<Test::Alien>.  It has extensive documentation, and integrates nicely with L<Alien::Base>.

=head2 How do I patch packages that need alterations?

If you have a diff file you can use patch:

 use alienfile;
 
 probe sub { 'share' }; # replace with appropriate probe
 
 share {
   ...
   patch [ '%{patch} -p1 < %{.install.patch}/mypatch.diff' ];
   build [ ... ] ;
 }
 
 ...

You can also patch using Perl if that is easier:

 use alienfile;
 
 probe sub { 'share' };
 
 share {
   ...
   patch sub {
     my($build) = @_;
     # make changes to source prior to build
   };
   build [ ... ];
 };

=head2 The flags that a plugin produces are wrong!

Sometimes, the compiler or linker flags that the PkgConfig plugin comes up with are not quite
right.  (Frequently this is actually because a package maintainer is providing a broken
C<.pc> file).  (Other plugins may also have problems).  You could replace the plugin's C<gather> step
but a better way is to provide a subroutine callback to be called after the gather stage
is complete.  You can do this with the L<alienfile> C<after> directive:

 use alienfile;
 
 plugin 'PkgConfig' => 'libfoo';
 
 share {
   ...
   after 'gather' => sub {
     my($build) = @_;
     $build->runtime_prop->{libs}        .= " -lbar";        # libfoo also requires libbar
     $build->runtime_prop->{libs_static} .= " -lbar -lbaz";  # libfoo also requires libbaz under static linkage
   };
 };

Sometimes you only need to do this on certain platforms.  You can adjust the logic based on C<$^O>
appropriately.

 use alienfile;
 
 plugin 'PkgConfig' => 'libfoo';
 
 share {
   ...
   after 'gather' => sub {
     my($build) = @_;
     if($^O eq 'MSWin32') {
       $build->runtime_prop->{libs} .= " -lpsapi";
     }
   };
 };

=head2 "cannot open shared object file" trying to load XS

The error looks something like this:

 t/acme_alien_dontpanic2.t ....... 1/?
 # Failed test 'xs'
 # at t/acme_alien_dontpanic2.t line 13.
 #   XSLoader failed
 #     Can't load '/home/cip/.cpanm/work/1581635869.456/Acme-Alien-DontPanic2-2.0401/_alien/tmp/test-alien-lyiQNX/auto/Test/Alien/XS/Mod0/Mod0.so' for module Test::Alien::XS::Mod0: libdontpanic.so.0: cannot open shared object file: No such file or directory at /opt/perl/5.30.1/lib/5.30.1/x86_64-linux/DynaLoader.pm line 193.
 #  at /home/cip/perl5/lib/perl5/Test/Alien.pm line 414.
 # Compilation failed in require at /home/cip/perl5/lib/perl5/Test/Alien.pm line 414.
 # BEGIN failed--compilation aborted at /home/cip/perl5/lib/perl5/Test/Alien.pm line 414.
 t/acme_alien_dontpanic2.t ....... Dubious, test returned 1 (wstat 256, 0x100)
 Failed 1/6 subtests
 t/acme_alien_dontpanic2__ffi.t .. ok

This error happened at test time for the Alien, but depending on your environment and Alien it might
happen later and the actual diagnostic wording might vary.

This is usually because your XS or Alien tries to use dynamic libraries instead of static ones.
Please consult the section about dynamic vs. static libraries in L<Alien::Build::Manual::AlienAuthor>.
The TL;DR is that L<Alien::Build::Plugin::Gather::IsolateDynamic> might help.
If you are the Alien author and the package you are alienizing doesn't have a static option you can
use L<Alien::Role::Dino>, but please note the extended set of caveats!

=head2 599 Internal Exception errors downloading packages from the internet

 Alien::Build::Plugin::Fetch::HTTPTiny> 599 Internal Exception fetching http://dist.libuv.org/dist/v1.15.0
 Alien::Build::Plugin::Fetch::HTTPTiny> exception: IO::Socket::SSL 1.42 must be installed for https support
 Alien::Build::Plugin::Fetch::HTTPTiny> exception: Net::SSLeay 1.49 must be installed for https support
 Alien::Build::Plugin::Fetch::HTTPTiny> An attempt at a SSL URL https was made, but your HTTP::Tiny does not appear to be able to use https.
 Alien::Build::Plugin::Fetch::HTTPTiny> Please see: https://metacpan.org/pod/Alien::Build::Manual::FAQ#599-Internal-Exception-errors-downloading-packages-from-the-internet
 error fetching http://dist.libuv.org/dist/v1.15.0: 599 Internal Exception at /Users/ollisg/.perlbrew/libs/perl-5.26.0@test1/lib/perl5/Alien/Build/Plugin/Fetch/HTTPTiny.pm line 68.

(Older versions of L<Alien::Build> produced a less verbose more confusing version of this diagnostic).

TL;DR, instead of this:

 share {
   start_url => 'http://example.org/dist';
   ...
 };

do this:

 share {
   start_url => 'https://example.org/dist';
 };

If the website is going to redirect to a secure URL anyway.

The "599 Internal Exception" indicates an "internal" exception from L<HTTP::Tiny> and is not a real
HTTP status code or error.  This could mean a number of different problems, but most frequently
indicates that a SSL request was made without the required modules (L<Net::SSLeay> and
L<IO::Socket::SSL>).  Normally the L<Alien::Build::Plugin::Download::Negotiate>
and L<Alien::Build::Plugin::Fetch::HTTPTiny> will make sure that the appropriate modules are added
to your prerequisites for you if you specify a C<https> URL.  Some websites allow an initial request
from C<http> but then redirect to C<https>.  If you can it is better to specify C<https>, if you
cannot, then you can instead use the C<ssl> property on either of those two plugins.

=head2 Does not detect system package even though it is installed

This could just be because the alien requires a more recent package that what is provided by your
operating system.

It could also be because you do not have the development package installed.  Many Linux vendors
in particular separate packages into runtime and development pages.  On RPM based systems these
development packages usually have C<-devel> suffix (example runtime: C<libffi> and development:
C<libffi-devel>).  On Debian based systems these development packages usually have a C<-dev>
suffix (example runtime: C<libffi> and development: C<libffi-dev>).

=head2 Network fetch is turned off

If you get an error like this:

 Alien::Build> install type share requested or detected, but network fetch is turned off
 Alien::Build> see see https://metacpan.org/pod/Alien::Build::Manual::FAQ#Network-fetch-is-turned-off

This is because your environment is setup not to install aliens that require the network.  You
can turn network fetch back on by setting C<ALIEN_INSTALL_NETWORK> to true, or by unsetting it.
This environment variable is designed for environments that don't ever want to install aliens that
require downloading source packages over the internet.

=head2 I would really prefer you not download stuff off the internet

The idea of L<Alien> is to download missing packages and build them automatically to make installing
easier.  Some people may not like this, or may even have security requirements that they not download
random package over the internet (caveat, downloading random stuff off of CPAN may not be any safer,
so make sure you audit all of the open source software that you use appropriately).  Another reason
you may not want to download from the internet is if you are packaging up an alien for an operating
system vendor, which will always want to use the system version of a library.  In that situation you
don't want L<Alien::Build> to go off and download something from the internet because the probe failed
for some reason.

This is easy to take care of, simply set C<ALIEN_INSTALL_TYPE> to C<system> and a build from source
code will never be attempted.  On systems that do not provide system versions of the library or tool
you will get an error, allowing you to install the library, and retry the alien install.  You can
also set the environment variable on just some aliens.

 % export ALIEN_INSTALL_TYPE=system  # for everyone
 
 % env ALIEN_INSTALL_TYPE=system cpanm -v Alien::libfoo

=head2 For testing I would like to test both system and share installs!

You can use the C<ALIEN_INSTALL_TYPE> environment variable.  It will force either a C<share> or
C<system> install depending on how it is set.  For travis you can do something like this:

 env:
   matrix:
     - ALIEN_INSTALL_TYPE=share
     - ALIEN_INSTALL_TYPE=system

=head2 How do I use Alien::Build from Dist::Zilla?

For creating L<Alien::Base> and L<Alien::Build> based dist from L<Dist::Zilla> you can use the
dzil plugin L<Dist::Zilla::Plugin::AlienBuild>.

=head2 Cannot find either a share directory or a ConfigData module

If you see an error like this:

 Cannot find either a share directory or a ConfigData module for Alien::libfoo.
 (Alien::libfoo loaded from lib/Alien/libfoo.pm)
 Please see https://metacpan.org/pod/distribution/Alien-Build/lib/Alien/Build/Manual/FAQ.pod#Cannot-find-either-a-share-directory-or-a-ConfigData-module
 Can't locate Alien/libfoo/ConfigData.pm in @INC (you may need to install the Alien::libfoo::ConfigData module) (@INC contains: ...)

it means you are trying to use an Alien that hasn't been properly installed.  An L<Alien::Base>
based Alien needs to have either the share directory build during the install process or for
older legacy L<Alien::Base::ModuleBuild> based Aliens, a ConfigData module generated by
L<Module::Build>.

This usually happens if you try to use an Alien module from the lib directory as part of the
Alien's distribution.  You need to build the alien and use C<blib/lib> instead of C<lib> or
install the alien and use the installed path.

It is also possible that your Alien installer is not set up correctly.  Make sure your
C<Makefile.PL> is using L<Alien::Build::MM> correctly.

=head2 I have a question not listed here!

There are a number of forums available to people working on L<Alien>, L<Alien::Base> and
L<Alien::Build> modules:

=over 4

=item C<#native> on irc.perl.org

This is intended for native interfaces in general so is a good place for questions about L<Alien>
generally or L<Alien::Base> and L<Alien::Build> specifically.

=item mailing list

The C<perl5-alien> google group is intended for L<Alien> issues generally, including L<Alien::Base>
and L<Alien::Build>.

L<https://groups.google.com/forum/#!forum/perl5-alien>

=item Open a support ticket

If you have an issue with L<Alien::Build> itself, then please open a support ticket on the project's GitHub issue
tracker.

L<https://github.com/PerlAlien/Alien-Build/issues>

=back

=head1 SEE ALSO

=over 4

=item L<Alien::Build::Manual>

Other L<Alien::Build> manuals.

=back

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! �v��jb  jb  (  perl5/Alien/Build/Manual/AlienAuthor.podnu ��6�$        # PODNAME: Alien::Build::Manual::AlienAuthor
# ABSTRACT: Alien author documentation
# VERSION

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Manual::AlienAuthor - Alien author documentation

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 perldoc Alien::Build::Manual::AlienAuthor

=head1 DESCRIPTION

B<Note>: Please read the entire document before you get started in
writing your own L<alienfile>.  The section on dynamic vs. static
libraries will likely save you a lot of grief if you read it now!

This document is intended to teach L<Alien> authors how to build their
own L<Alien> distribution using L<Alien::Build> and L<Alien::Base>.
Such an L<Alien> distribution consists of three essential parts:

=over 4

=item An L<alienfile>

This is a recipe for how to 1) detect an already installed version of
the library or tool you are alienizing 2) download and build the library
or tool that you are alienizing and 3) gather the configuration settings
necessary for the use of that library or tool.

=item An installer C<Makefile.PL> or C<Build.PL> or a C<dist.ini> if you are using L<Dist::Zilla>

This is a thin layer between your L<alienfile> recipe, and the Perl
installer (either L<ExtUtils::MakeMaker> or L<Module::Build>.

=item A Perl class (.pm file) that inherits from L<Alien::Base>

For most L<Alien>s this does not need to be customized at all, since
L<Alien::Base> usually does what you need.

=back

For example if you were alienizing a library called libfoo, you might
have these files:

 Alien-Libfoo-1.00/Makefile.PL
 Alien-Libfoo-1.00/alienfile
 Alien-Libfoo-1.00/lib/Alien/Libfoo.pm

This document will focus mainly on instructing you how to construct an
L<alienfile>, but we will also briefly cover making a simple
C<Makefile.PL> or C<dist.ini> to go along with it.  We will also touch
on when you might want to extend your subclass to add non-standard
functionality.

=head2 Using commands

Most software libraries and tools will come with instructions for how to
install them in the form of commands that you are intended to type into
a shell manually.  The easiest way to automate those instructions is to
just put the commands in your L<alienfile>.  For example, lets suppose
that libfoo is built using autoconf and provides a C<pkg-config> C<.pc>
file.

We will also later discuss plugins.  For common build systems like
autoconf or CMake, it is usually better to use the appropriate plugin
because they will handle corner cases better than a simple set of
commands.  We're going to take a look at commands first because it's
easier to understand the different phases with commands.

(Aside, autoconf is a series of tools and macros used to configure
(usually) a C or C++ library or tool by generating any number of
Makefiles.  It is the C equivalent to L<ExtUtils::MakeMaker>, if you
will.  Basically, if your library or tool instructions start with
'./configure' it is most likely an autoconf based library or tool).

(Aside2, C<pkg-config> is a standard-ish way to provide the compiler and
linker flags needed for compiling and linking against the library.  If
your tool installs a C<.pc> file, usually in C<$PREFIX/lib/pkgconfig>
then, your tool uses C<pkg-config>).

Here is the L<alienfile> that you might have:

 use alienfile;
 
 probe [ 'pkg-config --exists libfoo' ];
 
 share {
 
   start_url 'http://www.libfoo.org/src/libfoo-1.00.tar.gz';
 
   download [ 'wget %{.meta.start_url}' ];
 
   extract [ 'tar zxf %{.install.download}' ];
 
   build [
     [ './configure --prefix=%{.install.prefix} --disable-shared' ],
     [ '%{make}' ],
     [ '%{make} install' ],
   ];
 
 };
 
 gather [
   [ 'pkg-config --modversion libfoo', \'%{.runtime.version}' ],
   [ 'pkg-config --cflags     libfoo', \'%{.runtime.cflags}'  ],
   [ 'pkg-config --libs       libfoo', \'%{.runtime.libs}'    ],
 ];

There is a lot going on here, so lets decode it a little bit.  An
L<alienfile> is just some Perl with some alien specific sugar.  The
first line

 use alienfile;

imports the sugar into the L<alienfile>.  It also is a flag for the
reader to see that this is an L<alienfile> and not some other kind of
Perl script.

The second line is the probe directive:

 probe [ 'pkg-config --exists libfoo' ];

is used to see if the library is already installed on the target system.
If C<pkg-config> is in the path, and if libfoo is installed, this should
exit with a success (0) and tell L<Alien::Build> to use the system
library.  If either C<pkg-config> in the PATH, or if libfoo is not
installed, then it will exist with non-success (!= 0) and tells
L<Alien::Build> to download and build from source.

You can provide as many probe directives as you want.  This is useful if
there are different ways to probe for the system.  L<Alien::Build> will
stop on the first successfully found system library found.  Say our
library libfoo comes with a C<.pc> file for use with C<pkg-config> and
also provides a C<foo-config> program to find the same values.  You
could then specify this in your L<alienfile>

 probe [ 'pkg-config --exists libfoo' ];
 probe [ 'foo-config --version' ];

Other directives can be specified multiple times if there are different
methods that can be tried for the various steps.

Sometimes it is easier to probe for a library from Perl rather than with
a command.  For that you can use a code reference.  For example, another
way to call C<pkg-config> would be from Perl:

 probe sub {
   my($build) = @_;  # $build is the Alien::Build instance.
   system 'pkg-config --exists libfoo';
   $? == 0 ? 'system' : 'share';
 };

The Perl code should return 'system' if the library is installed, and
'share' if not.  (Other directives should return a true value on
success, and a false value on failure).  You can also throw an exception with
C<die> to indicate a failure.

The next part of the L<alienfile> is the C<share> block, which is used
to group the directives which are used to download and install the
library or tool in the event that it is not already installed.

 share {
   start_url 'http://www.libfoo.org/src/libfoo-1.00.tar.gz';
   download [ 'wget %{.meta.start_url}' ];
   extract [ 'tar zxf %{.install.download}' ];
   build [
     [ './configure --prefix=%{.install.prefix} --disable-shared' ],
     [ '%{make}' ],
     [ '%{make} install' ],
   ];
 };

The start_url specifies where to find the package that you are alienizing.
It should be either a tarball (or zip file, or what have you) or an
HTML index.  The download directive as you might imagine specifies how
to download  the library or tool.  The extract directive specifies how
to extract the archive once it is downloaded.  In the extract step, you
can use the variable C<%{.install.download}> as a placeholder for the archive
that was downloaded in the download step.  This is also accessible if
you use a code reference from the L<Alien::Build> instance:

 share {
   ...
   requires 'Archive::Extract';
   extract sub {
     my($build) = @_;
     my $tarball = $build->install_prop->{download};
     my $ae = Archive::Extract->new( archive => $tarball );
     $ae->extract;
     1;
   }
   ...
 };

The build directive specifies how to build the library or tool once it
has been downloaded and extracted.  Note the special variable
C<%{.install.prefix}> is the location where the library should be
installed.  C<%{make}> is a helper which will be replaced by the
appropriate C<make>, which may be called something different on some
platforms (on Windows for example, it frequently may be called C<nmake>
or C<dmake>).

The final part of the L<alienfile> has a gather directive which
specifies how to get the details on how to compile and link against the
library.  For this, once again we use the C<pkg-config> command:

 gather [
   [ 'pkg-config --modversion libfoo', \'%{.runtime.version}' ],
   [ 'pkg-config --cflags     libfoo', \'%{.runtime.cflags}'  ],
   [ 'pkg-config --libs       libfoo', \'%{.runtime.libs}'    ],
 ];

The scalar reference as the final item in the command list tells
L<Alien::Build> that the output from the command should be stored in the
given variable.  The runtime variables are the ones that will be
available to C<Alien::Libfoo> once it is installed.  (Install
properties, which are the ones that we have seen up till now are thrown
away once the L<Alien> distribution is installed.

You can also provide a C<sys> block for directives that should be used
when a system install is detected.  Normally you only need to do this if
the gather step is different between share and system installs.  For
example, the above is equivalent to:

 build {
   ...
   gather [
     [ 'pkg-config --modversion libfoo', \'%{.runtime.version}' ],
     [ 'pkg-config --cflags     libfoo', \'%{.runtime.cflags}'  ],
     [ 'pkg-config --libs       libfoo', \'%{.runtime.libs}'    ],
   ];
 };
 
 sys {
   gather [
     [ 'pkg-config --modversion libfoo', \'%{.runtime.version}' ],
     [ 'pkg-config --cflags     libfoo', \'%{.runtime.cflags}'  ],
     [ 'pkg-config --libs       libfoo', \'%{.runtime.libs}'    ],
   ];
 };

(Aside3, the reason it is called C<sys> and not C<system> is so that it
does not conflict with the built in C<system> function)!

=head2 Using plugins

The first example is a good way of showing the full manual path that you
can choose, but there is a lot of repetition, if you are doing many
L<Alien>s that use autoconf and C<pkg-config> (which are quite common.
L<alienfile> allows you to use plugins.  See L<Alien::Build::Plugin> for
a list of some of the plugin categories.

For now, I will just show you how to write the L<alienfile> for libfoo
above using L<Alien::Build::Plugin::Build::Autoconf>,
L<Alien::Build::Plugin::PkgConfig::Negotiate>,
L<Alien::Build::Plugin::Download::Negotiate>, and
L<Alien::Build::Plugin::Extract::Negotiate>

 use alienfile;
 
 plugin 'PkgConfig' => (
   pkg_name => 'libfoo',
 );
 
 share {
   start_url 'http://www.libfoo.org/src';
   plugin 'Download' => (
     filter => qr/^libfoo-[0-9\.]+\.tar\.gz$/,
     version => qr/^libfoo-([0-9\.]+)\.tar\.gz$/,
   );
   plugin 'Extract' => 'tar.gz';
   plugin 'Build::Autoconf';
   build [
     '%{configure} --disable-shared',
     '%{make}',
     '%{make} install',
   ];
 };

The first plugin that we use is the C<pkg-config> negotiation plugin.  A
negotiation plugin is one which doesn't do the actual work but selects
the best one from a set of plugins depending on your platform and
environment.  (In the case of
L<Alien::Build::Plugin::PkgConfig::Negotiate>, it may choose to use
command line tools, a pure Perl implementation (L<PkgConfig>), or
libpkgconf, depending on what is available).  When using negotiation
plugins you may omit the C<::Negotiate> suffix.  So as you can see using
the plugin here is an advantage because it is more reliable than just
specifying a command which may not be installed!

Next we use the download negotiation plugin.  This is also better than
the version above, because again, C<wget> my not be installed on the
target system.  Also you can specify a URL which will be scanned for
links, and use the most recent version.

We use the Extract negotiation plugin to use either command line tools,
or Perl libraries to extract from the archive once it is downloaded.

Finally we use the Autoconf plugin
(L<Alien::Build::Plugin::Build::Autoconf>).  This is a lot more
sophisticated and reliable than in the previous example, for a number of
reasons.  This version will even work on Windows assuming the library or
tool you are alienizing supports that platform!

Strictly speaking the build directive is not necessary, because the
autoconf plugin provides a default which is reasonable.  The only reason
that you would want to include it is if you need to provide additional
flags to the configure step.

 share {
   ...
   build [
     '%{configure} --enable-bar --enable-baz --disable-shared',
     '%{make}',
     '%{make} install',
   ];
 };

=head2 Multiple .pc files

Some packages come with multiple libraries paired with multiple C<.pc>
files.  In this case you want to provide the
L<Alien::Build::Plugin::PkgConfig::Negotiate> with an array reference
of package names.

 plugin 'PkgConfig' => (
   pkg_name => [ 'foo', 'bar', 'baz' ],
 );

All packages must be found in order for the C<system> install to succeed.
Once installed the first C<pkg_name> will be used by default (in this
example C<foo>), and you can retrieve any other C<pkg_name> using
the L<Alien::Base alt method|Alien::Base/alt>.

=head2 A note about dynamic vs. static libraries

If you are using your L<Alien> to build an XS module, it is important
that you use static libraries if possible.  If you have a package that
refuses to build a static library, then you can use L<Alien::Role::Dino>.

Actually let me back up a minute.  For a C<share> install it is best
to use static libraries to build your XS extension.  This is because
if your L<Alien> is ever upgraded to a new version it can break your
existing XS modules.  For a C<system> install shared libraries are
usually best because you can often get security patches without having
to re-build anything in perl land.

If you looked closely at the "Using commands" and "Using plugins"
sections above, you may notice that we went out of our way where
possible to tell Autotools to build only static libraries using the
C<--disable-shared> command.  The Autoconf plugin also does this by
default.

Sometimes though you will have a package that builds both, or maybe
you I<want> both static and dynamic libraries to work with XS and FFI.
For that case, there is the L<Alien::Build::Plugin::Gather::IsolateDynamic>
plugin.

 use alienfile;
 ...
 plugin 'Gather::IsolateDynamic';

What it does, is that it moves the dynamic libraries (usually .so on
Unix and .DLL on Windows) to a place where they can be found by FFI,
and where they won't be used by the compiler for building XS.  It usually
doesn't do any harm to include this plugin, so if you are just starting
out you might want to add it anyway.  Arguably it should have been the
default behavior from the beginning.

If you have already published an Alien that does not isolate its
dynamic libraries, then you might get some fails from old upgraded
aliens because the share directory isn't cleaned up by default (this is
perhaps a design bug in the way that share directories work, but it
is a long standing characteristic).  One work around for this is to
use the C<clean_install> property on L<Alien::Build::MM>, which will
clean out the share directory on upgrade, and possibly save you a lot
of grief.

=head2 Verifying and debugging your alienfile

You could feed your alienfile directly into L<Alien::Build>, or
L<Alien::Build::MM>, but it is sometimes useful to test your alienfile
using the C<af> command (it does not come with L<Alien::Build>, you need
to install L<App::af>).  By default C<af> will use the C<alienfile> in
the current directory (just as C<make> uses the C<Makefile> in the
current directory; just like C<make> you can use the C<-f> option to
specify a different L<alienfile>).

You can test your L<alienfile> in dry run mode:

 % af install --dry-run
 Alien::Build::Plugin::Core::Legacy> adding legacy hash to config
 Alien::Build::Plugin::Core::Gather> mkdir -p /tmp/I2YXRyxb0r/_alien
 ---
 cflags: ''
 cflags_static: ''
 install_type: system
 legacy:
   finished_installing: 1
   install_type: system
   name: libfoo
   original_prefix: /tmp/7RtAusykNN
   version: 1.2.3
 libs: '-lfoo '
 libs_static: '-lfoo '
 prefix: /tmp/7RtAusykNN
 version: 1.2.3

You can use the C<--type> option to force a share install (download and
build from source):

 % af install --type=share --dry-run
 Alien::Build::Plugin::Core::Download> decoding html
 Alien::Build::Plugin::Core::Download> candidate *https://www.libfoo.org/download/libfoo-1.2.4.tar.gz
 Alien::Build::Plugin::Core::Download> candidate  https://www.libfoo.org/download/libfoo-1.2.3.tar.gz
 Alien::Build::Plugin::Core::Download> candidate  https://www.libfoo.org/download/libfoo-1.2.2.tar.gz
 Alien::Build::Plugin::Core::Download> candidate  https://www.libfoo.org/download/libfoo-1.2.1.tar.gz
 Alien::Build::Plugin::Core::Download> candidate  https://www.libfoo.org/download/libfoo-1.2.0.tar.gz
 Alien::Build::Plugin::Core::Download> candidate  https://www.libfoo.org/download/libfoo-1.1.9.tar.gz
 Alien::Build::Plugin::Core::Download> candidate  https://www.libfoo.org/download/libfoo-1.1.8.tar.gz
 Alien::Build::Plugin::Core::Download> candidate  https://www.libfoo.org/download/libfoo-1.1.7.tar.gz
 Alien::Build::Plugin::Core::Download> candidate  ...
 Alien::Build::Plugin::Core::Download> setting version based on archive to 1.2.4
 Alien::Build::Plugin::Core::Download> downloaded libfoo-1.2.4.tar.gz
 Alien::Build::CommandSequence> + ./configure --prefix=/tmp/P22WEXj80r --with-pic --disable-shared
 ... snip ...
 Alien::Build::Plugin::Core::Gather> mkdir -p /tmp/WsoLAQ889w/_alien
 ---
 cflags: ''
 cflags_static: ''
 install_type: share
 legacy:
   finished_installing: 1
   install_type: share
   original_prefix: /tmp/P22WEXj80r
   version: 1.2.4
 libs: '-L/tmp/P22WEXj80r/lib -lfoo '
 libs_static: '-L/tmp/P22WEXj80r/lib -lfoo '
 prefix: /tmp/P22WEXj80r
 version: 1.2.4

You can also use the C<--before> and C<--after> options to take a peek
at what the build environment looks like at different stages as well,
which can sometimes be useful:

 % af install --dry-run --type=share --before build bash
 Alien::Build::Plugin::Core::Download> decoding html
 Alien::Build::Plugin::Core::Download> candidate *https://www.libfoo.org/download/libfoo-1.2.4.tar.gz
 Alien::Build::Plugin::Core::Download> candidate  https://www.libfoo.org/download/libfoo-1.2.3.tar.gz
 Alien::Build::Plugin::Core::Download> candidate  https://www.libfoo.org/download/libfoo-1.2.2.tar.gz
 Alien::Build::Plugin::Core::Download> candidate  https://www.libfoo.org/download/libfoo-1.2.1.tar.gz
 Alien::Build::Plugin::Core::Download> candidate  https://www.libfoo.org/download/libfoo-1.2.0.tar.gz
 Alien::Build::Plugin::Core::Download> candidate  https://www.libfoo.org/download/libfoo-1.1.9.tar.gz
 Alien::Build::Plugin::Core::Download> candidate  https://www.libfoo.org/download/libfoo-1.1.8.tar.gz
 Alien::Build::Plugin::Core::Download> candidate  https://www.libfoo.org/download/libfoo-1.1.7.tar.gz
 Alien::Build::Plugin::Core::Download> candidate  ...
 Alien::Build::Plugin::Core::Download> setting version based on archive to 1.2.4
 Alien::Build::Plugin::Core::Download> downloaded libfoo-1.2.4.tar.gz
 App::af::install>  [ before build ] + bash
 /tmp/fbVPu4LRTs/build_5AVn/libfoo-1.2.4$ ls
 CHANGES Makefile autoconf.ac lib
 /tmp/fbVPu4LRTs/build_5AVn/libfoo-1.2.4$

There are a lot of other useful things that you can do with the C<af>
command.  See L<af> for details.

=head2 Integrating with MakeMaker

Once you have a working L<alienfile> you can write your C<Makefile.PL>.

 use ExtUtils::MakeMaker;
 use Alien::Build::MM;
 
 my $abmm = Alien::Build::MM->new;
 
 WriteMakefile($abmm->mm_args(
   ABSTRACT           => 'Discover or download and install libfoo',
   DISTNAME           => 'Alien-Libfoo',
   NAME               => 'Alien::Libfoo',
   VERSION_FROM       => 'lib/Alien/Libfoo.pm',
   CONFIGURE_REQUIRES => {
     'Alien::Build::MM' => 0,
   },
   BUILD_REQUIRES => {
     'Alien::Build::MM' => 0,
   },
   PREREQ_PM => {
     'Alien::Base' => 0,
   },
   # If you are going to write the recommended
   # tests you will will want these:
   TEST_REQUIRES => {
     'Test::Alien' => 0,
     'Test2::V0'   => 0,
   },
 ));
 
 sub MY::postamble {
   $abmm->mm_postamble;
 }

The C<lib/Alien/Libfoo.pm> that goes along with it is very simple:

 package Alien::Libfoo;
 
 use strict;
 use warnings;
 use parent qw( Alien::Base );
 
 1;

You are done and can install it normally:

 % perl Makefile.PL
 % make
 % make test
 % make install

=head2 Integrating with Module::Build

Please don't!  Okay if you have to there is L<Alien::Build::MB>.

=head2 Non standard configuration

L<Alien::Base> support most of the things that your L<Alien> will need,
like compiler flags (cflags), linker flags (libs) and binary directory
(bin_dir).  Your library or tool may have other configuration items
which are not supported by default.  You can store the values in the
L<alienfile> into the runtime properties:

 gather [
   # standard:
   [ 'foo-config --version libfoo', \'%{.runtime.version}' ],
   [ 'foo-config --cflags  libfoo', \'%{.runtime.cflags}'  ],
   [ 'foo-config --libs    libfoo', \'%{.runtime.libs}'    ],
   # non-standard
   [ 'foo-config --bar-baz libfoo', \'%{.runtime.bar_baz}' ],
 ];

then you can expose them in your L<Alien::Base> subclass:

 package Alien::Libfoo;
 
 use strict;
 use warnings;
 use parent qw( Alien::Base );
 
 sub bar_baz {
   my($self) = @_;
   $self->runtime_prop->{bar_baz},
 };
 
 1;

=head2 Testing

(optional, but highly recommended)

You should write a test using L<Test::Alien> to make sure that your
alien will work with any XS modules that are going to use it:

 use Test2::V0;
 use Test::Alien;
 use Alien::Libfoo;
 
 alien_ok 'Alien::Libfoo';
 
 xs_ok do { local $/; <DATA> }, with_subtest {
   is Foo::something(), 1, 'Foo::something() returns 1';
 };
 
 done_testing;
 
 __DATA__
 #include "EXTERN.h"
 #include "perl.h"
 #include "XSUB.h"
 #include <foo.h>
 
 MODULE = Foo PACKAGE = Foo
 
 int something()

You can also use L<Test::Alien> to test tools instead of libraries:

 use Test2::V0;
 use Test::Alien;
 use Alien::Libfoo;
 
 alien_ok 'Alien::Libfoo';
 run_ok(['foo', '--version'])
   ->exit_is(0);
 
 done_testing;

You can also write tests specifically for L<FFI::Platypus>, if your
alien is going to be used to write FFI bindings.  (the test below
is the FFI equivalent to the XS example above).

 use Test2::V0;
 use Test::Alien;
 use Alien::Libfoo;
 
 alien_ok 'Alien::Libfoo';
 ffi_ok { symbols => [ 'something' ] }, with_subtest {
   # $ffi is an instance of FFI::Platypus with the lib
   # set appropriately.
   my($ffi) = @_;
   my $something = $ffi->function( something => [] => 'int' );
   is $something->call(), 1, 'Foo::something() returns 1';
 };

If you do use C<ffi_ok> you want to make sure that your alien reliably
produces dynamic libraries.  If it isn't consistent (if for example
some platforms tend not to provide or build dynamic libraries), you can
check that C<dynamic_libs> doesn't return an empty list.

 ...
 alien_ok 'Alien::Libfoo';
 SKIP: {
   skip "This test requires a dynamic library"
     unless Alien::Libfoo->dynamic_libs;
   ffi_ok { symbols [ 'something' ] }, with_subtest {
     ...
   };
 }

More details on testing L<Alien> modules can be found in the
L<Test::Alien> documentation.

You can also run the tests that come with the package that you are alienizing,
by using a C<test> block in your L<alienfile>.  Keep in mind that some packages
use testing tools or have other prerequisites that will not be available on your
users machines when they attempt to install your alien.  So you do not want to
blindly add a test block without checking what the prereqs are.  For Autoconf
style packages you typically test a package using the C<make check> command:

 use alienfile;
 
 plugin 'PkgConfig' => 'libfoo';
 
 share {
   ... # standard build steps.
   test [ '%{make} check' ];
 };

=head2 Dist::Zilla

(optional, mildly recommended)

You can also use the L<Alien::Build> L<Dist::Zilla> plugin
L<Dist::Zilla::Plugin::AlienBuild>:

 name    = Alien-Libfoo
 author  = E. Xavier Ample <example@cpan.org>
 license = Perl_5
 copyright_holder = E. Xavier Ample <example@cpan.org>
 copyright_year   = 2017
 version = 0.01
 
 [@Basic]
 [AlienBuild]

The plugin takes care of a lot of details like making sure that the
correct minimum versions of L<Alien::Build> and L<Alien::Base> are used.
See the plugin documentation for additional details.

=head2 Using your Alien

Once you have installed you can use your Alien.  See
L<Alien::Build::Manual::AlienUser> for guidance on that.

=head1 SEE ALSO

=over 4

=item L<Alien::Build::Manual>

Other L<Alien::Build> manuals.

=back

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! ����  �  &  perl5/Alien/Build/Manual/AlienUser.podnu ��6�$        # PODNAME: Alien::Build::Manual::AlienUser
# ABSTRACT: Alien user documentation
# VERSION

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Manual::AlienUser - Alien user documentation

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 perldoc Alien::Build::Manual::AlienUser

=head1 DESCRIPTION

This document is intended for a user of an L<Alien::Base> based L<Alien>
module's user.  Although specifically geared for L<Alien::Base>
subclasses, it may have some useful hints for L<Alien> in general.

Full working examples of how to use an L<Alien> module are also bundled
with L<Alien::Build> in the distribution's C<example/user> directory.
Those examples use L<Alien::xz>, which uses L<alienfile> + L<Alien::Build>
+ L<Alien::Base>.

The following documentation will assume you are trying to use an L<Alien>
called C<Alien::Foo> which provides the library C<libfoo> and the command
line tool C<foo>.  Many L<Alien>s will only provide one or the other.

The best interface to use for using L<Alien::Base> based aliens is
L<Alien::Base::Wrapper>.  This allows you to combine multiple aliens together
and handles a number of corner obscure corner cases that using L<Alien>s
directly does not.  Also as of 0.64, L<Alien::Base::Wrapper> comes bundled
with L<Alien::Build> and L<Alien::Base> anyway, so it is not an extra
dependency.

What follows are the main use cases.

=head2 ExtUtils::MakeMaker

 use ExtUtils::MakeMaker;
 use Alien::Base::Wrapper ();
 
 WriteMakefile(
   Alien::Base::Wrapper->new('Alien::Foo')->mm_args2(
     NAME => 'FOO::XS',
     ...
   ),
 );

L<Alien::Base::Wrapper> will take a hash of C<WriteMakefile> arguments
and insert the appropriate compiler and linker flags for you.  This
is recommended over doing this yourself as the exact incantation to
get EUMM to work is tricky to get right.

The C<mm_args2> method will also set your C<CONFIGURE_REQUIRES> for
L<Alien::Base::Wrapper>, L<ExtUtils::MakeMaker> and any aliens that
you specify.

=head2 Module::Build

 use Module::Build;
 use Alien::Base::Wrapper qw( Alien::Foo !export );
 use Alien::Foo;
 
 my $build = Module::Build->new(
   ...
   configure_requires => {
     'Alien::Base::Wrapper' => '0',
     'Alien::Foo'           => '0',
     ...
   },
   Alien::Base::Wrapper->mb_args,
   ...
 );
 
 $build->create_build_script;

For L<Module::Build> you can also use L<Alien::Base::Wrapper>, but
you will have to specify the C<configure_requires> yourself.

=head2 Inline::C / Inline::CPP

 use Inline 0.56 with => 'Alien::Foo';

L<Inline::C> and L<Inline::CPP> can be configured
to use an L<Alien::Base> based L<Alien> with the C<with> keyword.

=head2 ExtUtils::Depends

 use ExtUtils::MakeMaker;
 use ExtUtils::Depends;
 
 my $pkg = ExtUtils::Depends->new("Alien::Foo");
 
 WriteMakefile(
   ...
   $pkg->get_makefile_vars,
   ...
 );

L<ExtUtils::Depends> works similar to L<Alien::Base::Wrapper>, but uses
the L<Inline> interface under the covers.

=head2 Dist::Zilla

 [@Filter]
 -bundle = @Basic
 -remove = MakeMaker
 
 [Prereqs / ConfigureRequires]
 Alien::Foo = 0
 
 [MakeMaker::Awesome]
 header = use Alien::Base::Wrapper qw( Alien::Foo !export );
 WriteMakefile_arg = Alien::Base::Wrapper->mm_args

=head2 FFI::Platypus

Requires C<Alien::Foo> always:

 use FFI::Platypus;
 use Alien::Foo;
 
 my $ffi = FFI::Platypus->new(
   lib => [ Alien::Foo->dynamic_libs ],
 );

Use C<Alien::Foo> in fallback mode:

 use FFI::Platypus;
 use FFI::CheckLib 0.28 qw( find_lib_or_die );
 use Alien::Foo;
 
 my $ffi = FFI::Platypus->new(
   lib => [ find_lib_or_die lib => 'foo', alien => ['Alien::Foo'] ],
 );

If you are going to always require an L<Alien> you can just call C<dynamic_libs>
and pass it into L<FFI::Platypus>' lib method.  You should consider
using L<FFI::CheckLib> to use the L<Alien> in fallback mode instead.
This way you only need to install the L<Alien> if the system doesn't
provide it.

For fallback mode to work correctly you need to be using L<FFI::CheckLib>
0.28 or better.

=head2 Inline::C

 use Inline with => 'Alien::Foo';
 use Inline C => <<~'END';
   #include <foo.h>
 
   const char *my_foo_wrapper()
   {
     foo();
   }
   END
 
 sub exported_foo()
 {
   my_foo_wrapper();
 }

=head2 tool

 use Alien::Foo;
 use Env qw( @PATH );
 
 unshift @PATH, Alien::Foo->bin_dir;
 system 'foo', '--bar', '--baz';

Some L<Alien>s provide tools instead of or in addition to a library.
You need to add them to the C<PATH> environment variable though.
(Unless the tool is already provided by the system, in which case
it is already in the path and the C<bin_dir> method will return an
empty list).

=head1 ENVIRONMENT

=over 4

=item ALIEN_INSTALL_TYPE

Although the recommended way for a consumer to use an L<Alien::Base> based L<Alien>
is to declare it as a static configure and build-time dependency, some consumers
may prefer to fallback on using an L<Alien> only when the consumer itself cannot
detect the necessary package. In some cases the consumer may want the user to opt-in
to using an L<Alien> before requiring it.

To keep the interface consistent among Aliens, the consumer of the fallback opt-in
L<Alien> may fallback on the L<Alien> if the environment variable C<ALIEN_INSTALL_TYPE>
is set to any value. The rationale is that by setting this environment variable the
user is aware that L<Alien> modules may be installed and have indicated consent.
The actual implementation of this, by its nature would have to be in the consuming
CPAN module.

This behavior should be documented in the consumer's POD.

See L<Alien::Build/ENVIRONMENT> for more details on the usage of this environment
variable.

=back

=head1 SEE ALSO

=over 4

=item L<Alien::Build::Manual>

Other L<Alien::Build> manuals.

=back

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! ��N��#  �#  )  perl5/Alien/Build/Manual/Contributing.podnu ��6�$        # PODNAME: Alien::Build::Manual::Contributing
# ABSTRACT: Over-detailed contributing guide
# VERSION

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Manual::Contributing - Over-detailed contributing guide

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 perldoc Alien::Build::Manual::Contributing

=head1 DESCRIPTION

Thank you for considering to contribute to my open source project!  If
you have a small patch please consider just submitting it.  Doing so
through the project GitHub is probably the best way:

L<https://github.com/plicease/Alien-Build/issues>

If you have a more invasive enhancement or bugfix to contribute, please
take the time to review these guidelines.  In general it is good idea to
work closely with the L<Alien::Build> developers, and the best way to
contact them is on the C<#native> IRC channel on irc.perl.org.

=head2 History

Joel Berger wrote the original L<Alien::Base>.  This distribution
included the runtime code L<Alien::Base> and an installer class
L<Alien::Base::ModuleBuild>.  The significant thing about L<Alien::Base>
was that it provided tools to make it relatively easy for people to roll
their own L<Alien> distributions.  Over time, the PerlAlien (github
organization) or "Alien::Base team" has taken over development of
L<Alien::Base> with myself (Graham Ollis) being responsible for
integration and releases.  Joel Berger is still involved in the project.

Since the original development of L<Alien::Base>, L<Module::Build>, on
which L<Alien::Base::ModuleBuild> is based, has been removed from the
core of Perl.  It seemed worthwhile to write a replacement installer
that works with L<ExtUtils::MakeMaker> which IS still bundled with the
Perl core.  Because this is a significant undertaking it is my intention
to integrate the many lessons learned by Joel Berger, myself and the
"Alien::Base team" as possible.  If the interface seems good then it is
because I've stolen the ideas from some pretty good places.

=head2 Philosophy

=head3 Alien runtime should be as config-only as possible.

Ideally the code for an L<Alien::Base> based L<Alien> should simply
inherit from L<Alien::Base>, like so:

 package Alien::libfoo;
 
 use parent qw( Alien::Base );
 
 1;

The detection logic should be done by the installer code (L<alienfile>
and L<Alien::Build>) and saved into runtime properties (see
L<Alien::Build/runtime_prop>).  And as much as
possible the runtime should be implemented in the base class (L<Alien::Base>).
Where reasonable, the base class should be expanded to meet the needs
of this arrangement.

=head3 when downloading a package grab the latest version

If the maintainer of an L<Alien> disappears for a while, and if the
version downloaded during a "share" install is hardcoded in the
L<alienfile>, it can be problematic for end-users.

There are exceptions, of course, in particular when a package provides
a very unstable interface from version to version it makes sense
to hard code the version and for the Alien developer and Alien consumer
developer to coordinate closely.

=head3 when installing a package the operating system as a whole should not be affected

The convenience of using an L<Alien> is that a user of a CPAN module
that consumes an L<Alien> doesn't need to know the exact incantation
to install the libraries on which it depends (or indeed it may not be
easily installed through the package manager anyway).

As a corollary, a user of a CPAN module that consumes an L<Alien>
module shouldn't expect operating system level packages to be
installed, or for these packages to be installed in common system
level directories, like C</usr/local> or C</opt>.  Instead a "share"
directory associated with the Perl install and L<Alien> module
should be used.

Plugins that require user opt-in could be written to prompt a user
to automatically install operating system packages, but this should
never be done by default or without consent by the user.

=head3 avoid dependencies

One of the challenges with L<Alien> development is that you are by the
nature of the problem, trying to make everyone happy.  Developers
working out of CPAN just want stuff to work, and some build environments
can be hostile in terms of tool availability, so for reliability you end
up pulling a lot of dependencies.  On the other hand, operating system
vendors who are building Perl modules usually want to use the system
version of a library so that they do not have to patch libraries in
multiple places.  Such vendors have to package any extra dependencies
and having to do so for packages that the don't even use makes them
understandably unhappy.

As general policy the L<Alien::Build> core should have as few
dependencies as possible, and should only pull extra dependencies if
they are needed.  Where dependencies cannot be avoidable, popular and
reliable CPAN modules, which are already available as packages in the
major Linux vendors (Debian, Red Hat) should be preferred.

As such L<Alien::Build> is hyper aggressive at using dynamic
prerequisites.

=head3 interface agnostic

One of the challenges with L<Alien::Base::ModuleBuild> was that
L<Module::Build> was pulled from the core.  In addition, there is a
degree of hostility toward L<Module::Build> in some corners of the Perl
community.  I agree with Joel Berger's rationale for choosing
L<Module::Build> at the time, as I believe its interface more easily
lends itself to building L<Alien> distributions.

That said, an important feature of L<Alien::Build> is that it is
installer agnostic.  Although it is initially designed to work with
L<ExtUtils::MakeMaker>, it has been designed from the ground up to work
with any installer (Perl, or otherwise).

As an extension of this, although L<Alien::Build> may have external CPAN
dependencies, they should not be exposed to developers USING
L<Alien::Build>.  As an example, L<Path::Tiny> is used heavily
internally because it does what L<File::Spec> does, plus the things that
it doesn't, and uses forward slashes on Windows (backslashes are the
"correct separator on windows, but actually using them tends to break
everything).  However, there aren't any interfaces in L<Alien::Build>
that will return a L<Path::Tiny> object (or if there are, then this is a
bug).

This means that if we ever need to port L<Alien::Build> to a platform
that doesn't support L<Path::Tiny> (such as VMS), then it may require
some work to L<Alien::Build> itself, modules that USE L<Alien::Build>
shouldn't need to be modified.

=head3 plugable

The actual logic that probes the system, downloads source and builds it
should be as pluggable as possible.  One of the challenges with
L<Alien::Base::ModuleBuild> was that it was designed to work well with
software that works with C<autoconf> and C<pkg-config>.  While you can
build with other tools, you have to know a bit of how the installer
logic works, and which hooks need to be tweaked.

L<Alien::Build> has plugins for C<autoconf>, C<pkgconf> (successor of
C<pkg-config>), vanilla Makefiles, and CMake.  If your build system
doesn't have a plugin, then all you have to do is write one!  Plugins
that prove their worth may be merged into the L<Alien::Build> core.
Plugins that after a while feel like maybe not such a good idea may be
removed from the core, or even from CPAN itself.

In addition, L<Alien::Build> has a special type of plugin, called a
negotiator which picks the best plugin for the particular environment
that it is running in.  This way, as development of the negotiator and
plugins develop over time modules that use L<Alien::Build> will benefit,
without having to change the way they interface with L<Alien::Build>

=head1 ACKNOWLEDGEMENT

I would like to that Joel Berger for getting things running in the first
place.  Also important to thank other members of the "Alien::Base team":

Zaki Mughal (SIVOAIS)

Ed J (ETJ, mohawk)

Also kind thanks to all of the developers who have contributed to
L<Alien::Base> over the years:

L<https://metacpan.org/pod/Alien::Base#CONTRIBUTORS>

=head1 SEE ALSO

=over 4

=item L<Alien::Build::Manual>

Other L<Alien::Build> manuals.

=back

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! �4���"  �"  %  perl5/Alien/Build/Manual/Security.podnu ��6�$        # PODNAME: Alien::Build::Manual::Security
# ABSTRACT: General alien author documentation
# VERSION

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Manual::Security - General alien author documentation

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 perldoc Alien::Build::Manual::Security

=head1 DESCRIPTION

You are rightly concerned that an L<Alien> might be downloading something random
off the internet.  This manual will describe some of the real risks and go over
how you can mitigate them.

=head2 no warranty

L<Alien::Build> provides L<Alien> authors with tools to add external non-Perl
dependencies to CPAN modules.  It is open source software that is entirely
volunteer driven, meaning the people writing this software are not getting
compensated monetarily for the work.  As such, we do our best not to
intentionally introduce security vulnerabilities into our modules, or their
dependencies.  But it is also not our responsibility either.  If you are
operating in an environment where you need absolute security, you need to
carefully audit I<all> of the software that you use.

=head2 L<Alien::Build> vs. L<CPAN>

I suppose you could argue that L<Alien::Build> based L<Alien>s and L<Alien>s
in general are inherently less secure than the the Perl modules on L<CPAN>
that don't download random stuff off the internet.  Worse yet, L<Alien>s
might be downloading from insecure sources like C<http> or C<ftp>.

This argument falls apart pretty quickly when you realize that

=over 4

=item 1

Perl modules from L<CPAN> are in fact random stuff off the internet.
Most modules, when installed execute a C<Makefile.PL> which can execute
completely arbitrary Perl code.  Without a proper audit or firewalls
that L<CPAN> code could be making connections to insecure sources
like C<http> if they are not themselves doing something nefarious.

=item 2

By default, the most frequently used L<CPAN> client L<App::cpanminus|cpanm>
uses C<http> to fetch L<CPAN> modules.  So unless you have specifically
configured it to connect to a secure source you are downloading
even more random stuff than usual off the internet.

=back

The TL;DR is that if you are using a Perl module, whether it be
C<Foo::PP>, C<Foo::XS> or C<Alien::libfoo> and you are concerned about
security you need to audit all of your Perl modules, not just the L<Alien>
ones.

=head2 Restricting L<Alien::Build> by environment

Okay, granted you need to audit software for security regardless of
if it is L<Alien>, you still don't like the idea of downloading external
dependencies and you can't firewall just the L<CPAN> module installs.

L<Alien::Build> based L<Alien>s respect a number of environment variables
that at least give you some control over how aggresive L<Alien::Build>
will be at fetching random stuff off the internet.

=over 4

=item C<ALIEN_DOWNLOAD_RULE>

This environment variable configures how L<Alien::Build> will deal
with insecure protocols and files that do not include a cryptographic
signature.

Part of the design of the L<Alien::Build> system is that it typically
tries to download the latest version of a package instead of a fixed
version, so that the L<Alien> doesn't need to be updated when a new
alienized package is released.  This means that we frequently have
to rely on TLS or bundled alienized packages to ensure that the
alienized package is fetched securely.

Recently (as of L<Alien::Build> 2.59) we started supporting cryptographic
signatures defined in L<alienfile>s, but they are not yet very common,
and they only really work when a single alienized package URL is hard
coded into the L<alienfile> instead of the more typical mode of operation
where the latest version is downloaded.

=over 4

=item warn

This mode will warn you if an L<Alien::Build> based L<Alien> attempts
to fetch a alienized package insecurely.  It will also warn you if
a package doesn't have a cryptographic signature.  Neither of these
things wild stop the L<Alien> from being installed.

This is unfortunately currently the default mode of L<Alien::Build>,
for historical reasons.  Once plugins and L<Alien>s are updated to
either use secure fetch (TLS or bundled alienized packages), or
cryptographic signatures, the default will be changed to
C<digest_or_encrypt>.

=item digest_or_encrypt

This mode will require that before an alienized package is extracted
that it is either fetched via a secure protocol (C<http> or C<file>),
or the package matches a cryptographic signature.

This will likely be the default for L<Alien::Build> in the near future,
but it doesn't hurt to set it now, if you don't mind submitting
tickets to L<Alien>s or L<plugins|Alien::Build::Plugin> that don't
support this mode yet.

=back

=item C<ALIEN_INSTALL_NETWORK>

By design L<Alien>s should use local installs of libraries and tools
before downloading source from the internet.  Setting this environment
variable to false, will instruct L<Alien::Build> to not attempt to
fetch the alienized package off the internet if it is not available
locally or as a bundled package.

This is similar to setting C<ALIEN_INSTALL_TYPE> to C<system> (see
below), except it does allow L<Alien>s that bundle their alienized
package inside the L<CPAN> package tarball.

Some L<Alien>s will not install properly at first, but when they error
you can install the system package and try to re-install the L<Alien>.

=item C<ALIEN_INSTALL_TYPE>

Setting C<ALIEN_INSTALL_TYPE> to C<system> is similar to setting
C<ALIEN_INSTALL_NETWORK> to false, except that bundled alienized
packages will also be rejected.  This environment variable is really
intended for use by operating system vendors packaging L<Alien>s,
or for L<Alien> developer testing (in CI for example).  For some
who want to restrict how L<Alien>s install this might be the right
tool to reach for.

=back

Note that this is definitely best effort.  If the L<Alien> author makes
a mistake or is malicious they could override these environment variables
inside the C<Makefile.PL>, so you still need to audit any software to
ensure that it doesn't fetch source off the internet.

=head2 Security Related Plugins

There are a number of plugins that give the user or installer control
over how L<Alien::Build> behaves, and may be useful for rudimentary
security.

=over 4

=item L<Alien::Build::Plugin::Fetch::Prompt>

This plugin will prompt before fetching any remote files.  This only
really works when you are installing L<Alien>s interactively.

=item L<Alien::Build::Plugin::Fetch::HostAllowList>

This plugin will only allow fetching from hosts that are in an allow list.

=item L<Alien::Build::Plugin::Fetch::HostBlockList>

This plugin will not allow fetching from hosts that are in a block list.

=item L<Alien::Build::Plugin::Fetch::Rewrite>

This plugin can re-write fetched URLs before the request is made.  This
can be useful if you have a local mirror of certain sources that you
want to use instead of fetching from the wider internet.

=item L<Alien::Build::Plugin::Probe::Override>

This plugin can override the C<ALIEN_INSTALL_TYPE> on a perl-Alien basis.
This can be useful if you want to install some L<Alien>s in C<share>
mode, but generally want to enforce C<system> mode.

=back

=head2 local configuration

You can configure the way L<Alien::Build> based L<Alien>s are installed with the
local configuration file C<~/.alienbuild/rc.pl>.  See L<Alien::Build::rc> for
details.

=head1 CAVEATS

This whole document is caveats, but if you haven't gotten it by now then,
fundamentally if you need to use Perl modules securely then you need to
audit the code for security vulnerabilities.  If you think that the security
of L<Alien::Build> and the L<Alien>s that depend on it, then I<patches welcome>.

=head1 SEE ALSO

=over 4

=item L<Alien::Build::Manual>

Other L<Alien::Build> manuals.

=back

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! 9��r�T  �T  )  perl5/Alien/Build/Manual/PluginAuthor.podnu ��6�$        # PODNAME: Alien::Build::Manual::PluginAuthor
# ABSTRACT: Alien::Build plugin author documentation
# VERSION

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Manual::PluginAuthor - Alien::Build plugin author documentation

=head1 VERSION

version 2.83

=head1 SYNOPSIS

your plugin:

 package Alien::Build::Plugin::Build::MyPlugin;
 
 use strict;
 use warnings;
 use Alien::Build::Plugin;
 
 has arg1 => 'default_for arg1';
 has arg2 => sub { [ 'default', 'for', 'arg2' ] };
 
 sub init
 {
   my($self, $meta) = @_;
   ...
 }
 
 1;

and then from L<alienfile>:

 use alienfile;
 plugin 'Build::MyPlugin' => (
   arg1 => 'override for arg1',
   arg2 => [ 'something', 'else' ],
 );

=for html <p>flowchart</p>
<div style="display: flex"><div style="margin: 3px; flex: 1 1 50%">
<img src="image/PluginAuthor-flowchart.png" style="max-width: 100%">
</div></div>
<p><b>Notes</b>: The colored blocks indicate <tt>alienfile</tt> blocks.
Hooks are indicated as predefined process (rectangle with double struck
vertical edges).  Hooks that can easily be implemented from an
<tt>alienfile</tt> are indicated in blue (Note that <tt>[]</tt> is used
to indicate passing in an array reference, but a subroutine
reference can also be used).  For simplicity, the the flowchart does
not include when required modules are loaded.  Except for configure
time requirements, they are loaded when the corresponding <tt>alienfile</tt>
blocks are entered.  It is not shown, but generally any plugin can cause
a <b>Fail</b> by throwing an exception with <tt>die</tt>.</p>

Perlish pseudo code for how plugins are called:

 my $probe;
 my $override = override();
 
 if($override eq 'system') {
 
   $probe = probe();
 
   if($probe ne 'system') {
     die 'system tool or library not found';
   }
 
 }
 
 elsif($override eq 'default') {
   $probe = probe();
 
 } else { # $override eq 'share'
   # note that in this instance the
   # probe hook is never called
   $probe = 'share';
 }
 
 if($probe eq 'system') {
   gather_system();
 
 } else { # $probe eq 'share'
 
   download();
   extract();
   patch();
   build();
   gather_share();
 
   # Check to see if there isa build_ffi hook
   if(defined &build_ffi) {
     patch_ffi();
     build_ffi();
     gather_ffi();
   }
 }
 
 # By default this just returns the value of $ENV{ALIEN_INSTALL_TYPE}
 sub override {
   return $ENV{ALIEN_INSTALL_TYPE};
 }
 
 # Default download implementation; can be
 # replaced by specifying a different download
 # hook.  See Alien::Build::Plugin::Core::Download
 # for detailed implementation.
 sub download {
 
   my $response = fetch();
 
   if($response->{type} eq 'html' || $response->{type} eq 'dir_listing') {
     # decode will transform an HTML listing (html) or a FTP directory
     # listing (dir_listing) into a regular list
     $response = decode($response);
   }
 
   if($response->{type} eq 'list') {
 
     # prefer will filter bad entries in the list
     # and sort them so that the first one is
     # the one that we want
     $response = prefer($response);
 
     my $first_preferred = $res->{list}->[0];
 
     # prefer can sometimes infer the version from the
     # filename.
     if(defined $first_preferred->{version}) {
       # not a hook
       runtime_prop->{version} = $first_preferred->{version};
     }
 
     $response = fetch($first_preferred);
 
   }
 
   if($response->{type} eq 'file') {
     # not a hook
     write_file_to_disk $response;
   }
 
 }

=head1 DESCRIPTION

This document explains how to write L<Alien::Build> plugins using the
L<Alien::Build::Plugin> base class.

=head2 Writing plugins

Plugins use L<Alien::Build::Plugin>, which sets the appropriate base
class, and provides you with the C<has> property builder.  C<has> takes
two arguments, the name of the property and the default value.  (As
with L<Moose> and L<Moo>, you should use a code reference to specify
default values for non-string defaults).  No B<not> set this as your
plugin's base class directly:

 use parent qw( Alien::Build::Plugin );  # wrong
 use Alien::Build::Plugin;               # right

The only method that you need to implement is C<init>.  From this method
you can add hooks to change the behavior of the L<alienfile> recipe.
This is a very simple example of a probe hook, with the actual probe
logic removed:

 sub init
 {
   my($self, $meta) = @_;
   $meta->register_hook(
     probe => sub {
       my($build) = @_;
       if( ... )
       {
         return 'system';
       }
       else
       {
         return 'share';
       }
     },
   );
 }

Hooks get the L<Alien::Build> instance as their first argument, and depending
on the hook may get additional arguments.

=head2 Modifying hooks

You can also modify hooks using C<before_hook>, C<around_hook> and C<after_hook>,
similar to L<Moose> modifiers:

 sub init
 {
   my($self, $meta) = @_;
 
   $meta->before_hook(
     build => sub {
       my($build) = @_;
       $build->log('this runs before the build');
     },
   );
 
   $meta->after_hook(
     build => sub {
       my($build) = @_;
       $build->log('this runs after the build');
     },
   );
 
   $meta->around_hook(
     build => sub {
       my $orig = shift;
 
       # around hooks are useful for setting environment variables
       local $ENV{CPPFLAGS} = '-I/foo/include';
 
       $orig->(@_);
     },
   );
 }

=head2 Testing plugins

You can and should write tests for your plugin.  The best way to do
this is using L<Test::Alien::Build>, which allows you to write an
inline L<alienfile> in your test.  Here is an example:

 use Test::V0;
 use Test::Alien::Build;
 
 my $build = alienfile_ok q{
   use alienfile;
   plugin 'Build::MyPlugin' => (
     arg1 => 'override for arg1',
     arg2 => [ 'something', 'else' ],
   );
   ...
 };
 
 # you can interrogate $build, it is an instance of L<Alien::Build>.
 
 my $alien = alien_build_ok;
 
 # you can interrogate $alien, it is an instance of L<Alien::Base>.

=head2 Negotiator plugins

A Negotiator plugin doesn't itself typically implement anything on
its own, but picks the best plugin to achieve a particular goal.

The "best" plugin can in some cases vary depending on the platform
or tools that are available.  For example The
L<download negotiator|Alien::Build::Plugin::Download::Negotiate>
might choose to use the fetch plugin that relies on the command line
C<curl>, or it might choose the fetch plugin that relies on the Perl
module L<HTTP::Tiny> depending on the platform and what is already
installed.  (For either to be useful they have to support SSL).

The Negotiator plugin is by convention named something like
C<Alien::Build::Plugin::*::Negotiate>, but is typically invoked
without the C<::Negotiate> suffix.  For example:

 plugin 'Download'; # is short for Alien::Build::Plugin::Download::Negotiator

Here is a simple example of a negotiator which picks C<curl> if already
installed and L<HTTP::Tiny> otherwise.  (The actual download plugin
is a lot smarter and complicated than this, but this is a good
simplified example).

 package Alien::Build::Plugin::Download::Negotiate;
 
 use strict;
 use warnings;
 use Alien::Build::Plugin;
 use File::Which qw( which );
 
 sub init
 {
   my($self, $meta) = @_;
 
   if(which('curl')) {
     $meta->apply_plugin('Fetch::Curl');
   } else {
     $meta->apply_plugin('Fetch::HTTPTiny');
   }
 }

=head2 Hooks

The remainder of this document is a reference for the hooks that you
can register.  Generally speaking you can register any hook that you
like, but some care must be taken as some hooks have default behavior
that will be overridden when you register a hook.  The hooks are
presented in alphabetical order.  The execution order is shown
in the flowchart above (if you are browsing the HTML version of this
document), or the Perlish pseudo code in the synopsis section.

=head1 HOOKS

=head2 build hook

 $meta->register_hook( build => sub {
   my($build) = @_;
   ...
 });

This does the main build of the alienized project and installs it into
the staging area.  The current directory is the build root.  You need
to run whatever tools are necessary for the project, and install them
into C<$build->install_prop->{prefix}> (C<%{.install.prefix}>).

=head2 build_ffi hook

 $meta->register_hook( build_ffi => sub {
   my($build) = @_;
   ...
 });

This is the same as L<build|/"build hook">, except it fires only on a FFI build.

=head2 decode hook

 $meta->register_hook( decode => sub {
   my($build, $res) = @_;
   ...
 }

This hook takes a response hash reference from the C<fetch> hook above
with a type of C<html> or C<dir_listing> and converts it into a response
hash reference of type C<list>.  In short it takes an HTML or FTP file
listing response from a fetch hook and converts it into a list of filenames
and links that can be used by the prefer hook to choose the correct file to
download.  See the L<fetch hook|/"fetch hook"> for the specification of the
input and response hash references.

=head2 check_digest hook

 # implement the well known FOO-92 digest
 $meta->register_hook( check_digest => sub {
   my($build, $file, $algorithm, $digest) = @_;
   if($algorithm ne 'FOO92') {
     return 0;
   }
   my $actual = foo92_hex_digest($file);
   if($actual eq $digest) {
     return 1;
   } else {
     die "Digest FOO92 does not match: got $actual, expected $digest";
   }
 });

This hook should check the given C<$file> (the format is the same as used by
L<the fetch hook|/"fetch hook">) matches the given C<$digest> using the
given C<$algorithm>.  If the plugin does not support the given algorithm,
then it should return a false value.  If the digest does not match, it
should throw an exception.  If the digest matches, it should return a
true value.

=head2 clean_install

 $meta->register_hook( clean_install => sub {
   my($build) = @_;
 });

This hook allows you to remove files from the final install location before
the files are installed by the installer layer (examples: L<Alien::Build::MM>,
L<Alien::Build::MB> or L<App::af>).  This hook is not called by default,
and must be enabled via the interface to the installer layer
(example: L<Alien::Build::MM/clean_install>).

This hook SHOULD NOT remove the C<_alien> directory or its content from the
install location.

The default implementation removes all the files EXCEPT the C<_alien> directory
and its content.

=head2 download hook

 $meta->register_hook( download => sub {
   my($build) = @_;
   ...
 });

This hook is used to download from the internet the source.  Either as
an archive (like tar, zip, etc), or as a directory of files (C<git clone>,
etc).  When the hook is called, the current working directory will be a
new empty directory, so you can save the download to the current
directory.  If you store a single file in the directory, L<Alien::Build>
will assume that it is an archive, which will be processed by the
L<extract hook|/"extract hook">.  If you store multiple files, L<Alien::Build> will
assume the current directory is the source root.  If no files are stored
at all, an exception with an appropriate diagnostic will be thrown.

B<Note>: If you register this hook, then the fetch, decode and prefer
hooks will NOT be called, unless you call them yourself from this hook.

=head2 extract hook

 $meta->register_hook( extract => sub {
   my($build, $archive) = @_;
   ...
 });

This hook is used to extract an archive that has already been downloaded.
L<Alien::Build> already has plugins for the most common archive formats,
so you will likely only need this to add support for new or novel archive
formats.  When this hook is called, the current working directory will
be a new empty directory, so you can save the content of the archive to
the current directory.  If a single directory is written to the current
directory, L<Alien::Build> will assume that is the root directory of the
package.  If multiple files and/or directories are present, that will
indicate that the current working directory is the root of the package.
The logic typically handles correctly the default behavior for tar
(where packages are typically extracted to a subdirectory) and for
zip (where packages are typically extracted to the current directory).

=head2 fetch hook

 package Alien::Build::Plugin::MyPlugin;
 
 use strict;
 use warnings;
 use Alien::Build::Plugin;
 use Carp ();
 
 has '+url' => sub { Carp::croak "url is required property" };
 
 sub init
 {
   my($self, $meta) = @_;
 
   $meta->register_hook( fetch => sub {
     my($build, $url, %options) = @_;
     ...
   }
 }
 
 1;

Used to fetch a resource.  The first time it will be called without an
argument (or with C<$url> set to C<undef>, so the configuration used to
find the resource should be specified by the plugin's properties.  On
subsequent calls the first argument will be a URL.

The C<%options> hash may contain these options:

=over 4

=item http_headers

HTTP request headers, if an appropriate protocol is being used.  The
headers are provided as an array reference of key/value pairs, which
allows for duplicate header keys with multiple values.

If a non-HTTP protocol is used, or if the plugin cannot otherwise
send HTTP request headers, the plugin SHOULD issue a warning using
the C<< $build->log >> method, but because this option wasn't part
of the original spec, the plugin MAY no issue that warning while
ignoring it.

=back

Note that versions of L<Alien::Build> prior to 2.39 did not pass the
options hash into the fetch plugin.

Normally the first fetch will be to either a file or a directory listing.
If it is a file then the content should be returned as a hash reference
with the following keys:

 # content of file stored in Perl
 return {
   type     => 'file',
   filename => $filename,
   content  => $content,
   version  => $version,  # optional, if known
   protocol => $protocol, # AB 2.60 optional, but recommended
 };
 
 # content of file stored in the filesystem
 return {
   type     => 'file',
   filename => $filename,
   path     => $path,     # full file system path to file
   version  => $version,  # optional, if known
   tmp      => $tmp,      # optional
   protocol => $protocol, # AB 2.60 optional, but recommended
 };

C<$tmp> if set will indicate if the file is temporary or not, and can
be used by L<Alien::Build> to save a copy in some cases.  The default
is true, so L<Alien::Build> assumes the file or directory is temporary
if you don't tell it otherwise.  Probably the most common situation
when you would set C<tmp> to false, is when the file is bundled inside
the L<Alien> distribution.  See L<Alien::Build::Plugin::Fetch::Local>
for example.

If the URL points to a directory listing you should return it as either
a hash reference containing a list of files:

 return {
   type => 'list',
   list => [
     # filename: each filename should be just the
     #   filename portion, no path or url.
     # url: each url should be the complete url
     #   needed to fetch the file.
     # version: OPTIONAL, may be provided by some fetch or prefer
     { filename => $filename1, url => $url1, version => $version1 },
     { filename => $filename2, url => $url2, version => $version2 },
   ],
   protocol => $protocol, # AB 2.60 optional, but recommended
 };

or if the listing is in HTML format as a hash reference containing the
HTML information:

 return {
   type => 'html',
   charset  => $charset, # optional
   base     => $base,    # the base URL: used for computing relative URLs
   content  => $content, # the HTML content
   protocol => $protocol, # optional, but recommended
 };

or a directory listing (usually produced by an FTP servers) as a hash
reference:

 return {
   type     => 'dir_listing',
   base     => $base,
   content  => $content,
   protocol => $protocol, # AB 2.60 optional, but recommended
 };

[version 2.60]

For all of these responses C<$protocol> is optional, since it was not part
of the original spec, however it is strongly recommended that you include
this field, because future versions of L<Alien::Build> will use this to
determine if a file was downloaded securely (that is via a secure protocol
such as SSL).

Some plugins (like L<decode plugins |Alien::Build::Plugin::Decode>) trans
late a file hash from one type to another, they should maintain the
C<$protocol> from the old to the new representation of the file.

=head2 gather_ffi hook

 $meta->register_hook( gather_ffi => sub {
   my($build) = @_;
   $build->runtime_prop->{cflags}  = ...;
   $build->runtime_prop->{libs}    = ...;
   $build->runtime_prop->{version} = ...;
 });

This hook is called for a FFI build to determine the properties
necessary for using the library or tool.  These properties should be
stored in the L<runtime_prop|Alien::Build/runtime_prop> hash as shown above.
Typical properties that are needed for libraries are cflags and libs.
If at all possible you should also try to determine the version of the
library or tool.

=head2 gather_share hook

 $meta->register_hook( gather_share => sub {
   my($build) = @_;
   $build->runtime_prop->{cflags}  = ...;
   $build->runtime_prop->{libs}    = ...;
   $build->runtime_prop->{version} = ...;
 });

This hook is called for a share install to determine the properties
necessary for using the library or tool.  These properties should be
stored in the L<runtime_prop|Alien::Build/runtime_prop> hash as shown above.
Typical properties that are needed for libraries are cflags and libs.
If at all possible you should also try to determine the version of the
library or tool.

=head2 gather_system hook

 $meta->register_hook( gather_system => sub {
   my($build) = @_;
   $build->runtime_prop->{cflags}  = ...;
   $build->runtime_prop->{libs}    = ...;
   $build->runtime_prop->{version} = ...;
 });

This hook is called for a system install to determine the properties
necessary for using the library or tool.  These properties should be
stored in the L<runtime_prop|Alien::Build/runtime_prop> hash as shown above.
Typical properties that are needed for libraries are cflags and libs.
If at all possible you should also try to determine the version of the
library or tool.

=head2 override hook

 $meta->register_hook( override => sub {
   my($build) = @_;
   return $ENV{ALIEN_INSTALL_TYPE} || '';
 });

This allows you to alter the override logic.  It should return one of
C<share>, C<system>, C<default> or C<''>.  The default implementation
is shown above.  L<Alien::Build::Plugin::Probe::Override> and
L<Alien::Build::Plugin::Probe::OverrideCI> are examples of how you
can use this hook.

=head2 patch hook

 $meta->register_hook( patch => sub {
   my($build) = @_;
   ...
 });

This hook is completely optional.  If registered, it will be triggered after
extraction and before build.  It allows you to apply any patches or make any
modifications to the source if they are necessary.

=head2 patch_ffi hook

 $meta->register_hook( patch_ffi => sub {
   my($build) = @_;
   ...
 });

This hook is exactly like the L<patch hook|/"patch hook">, except it fires only on an
FFI build.

=head2 prefer hook

 $meta->register_hook( prefer => sub {
   my($build, $res) = @_;
   return {
     type => 'list',
     list => [sort @{ $res->{list} }],
   };
 }

This hook sorts candidates from a listing generated from either the C<fetch>
or C<decode> hooks.  It should return a new list hash reference with the
candidates sorted from best to worst.  It may also remove candidates
that are totally unacceptable.

=head2 probe hook

 $meta->register_hook( probe => sub {
   my($build) = @_;
   return 'system' if ...; # system install
   return 'share';         # otherwise
 });
 
 $meta->register_hook( probe => [ $command ] );

This hook should return the string C<system> if the operating
system provides the library or tool.  It should return C<share>
otherwise.

You can also use a command that returns true when the tool
or library is available.  For example for use with C<pkg-config>:

 $meta->register_hook( probe =>
   [ '%{pkgconf} --exists libfoo' ] );

Or if you needed a minimum version:

 $meta->register_hook( probe =>
   [ '%{pkgconf} --atleast-version=1.00 libfoo' ] );

Note that this hook SHOULD NOT gather system properties, such as
cflags, libs, versions, etc, because the probe hook will be skipped
in the event the environment variable C<ALIEN_INSTALL_TYPE> is set.
The detection of these properties should instead be done by the
L<gather_system|/"gather_system hook"> hook.

Multiple probe hooks can be given.  These will be used in sequence,
stopping at the first that detects a system installation.

=head1 SEE ALSO

=over 4

=item L<Alien::Build::Manual>

Other L<Alien::Build> manuals.

=back

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! �p��W  W  "  perl5/Alien/Build/Manual/Alien.podnu ��6�$        # PODNAME: Alien::Build::Manual::Alien
# ABSTRACT: General alien author documentation
# VERSION

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Manual::Alien - General alien author documentation

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 perldoc Alien::Build::Manual::Alien

=head1 DESCRIPTION

The goal of the L<Alien> namespace is to provide non-CPAN dependencies (so called "Alien" dependencies) for
CPAN modules. The history and intent of this idea is documented in the documentation-only L<Alien> module.
The C<Alien-Build> distribution provides a framework for building aliens. The intent is to fix bugs and
enhance the interface of a number of common tools so that all aliens may benefit. The distribution is broken
up into these parts:

=over 4

=item The Alien Installer (configure / build-time)

L<Alien::Build> and L<alienfile> are used to detect and install aliens. They are further documented in
L<Alien::Build::Manual::AlienAuthor>.

=item The Alien Runtime (runtime)

L<Alien::Base> is the base class for aliens in the C<Alien-Build> system. Its use by Alien consumers
is documented in L<Alien::Build::Manual::AlienUser>.

=item The Plugin system (configure / build-time)

Because many packages are implemented using different tools, the detection, build and install logic
for a particular L<Alien> can vary a lot.  As such, much of L<Alien::Build> is implemented as a
series of plugins that inherit from L<Alien::Build::Plugin>.  An overview of building your own
plugins is documented in L<Alien::Build::Manual::PluginAuthor>.

=back

Additional useful documentation may be found here:

=over 4

=item FAQ

L<Alien::Build::Manual::FAQ>

=item Contributing

L<Alien::Build::Manual::Contributing>

=back

=head1 SEE ALSO

=over 4

=item L<Alien::Build::Manual>

Other L<Alien::Build> manuals.

=back

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! �C�ċ	  �	    perl5/Alien/Build/Manual.podnu ��6�$        # PODNAME: Alien::Build::Manual
# ABSTRACT: The Alien::Build Manual
# VERSION

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Manual - The Alien::Build Manual

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 perldoc Alien::Build::Manual::Alien
 perldoc Alien::Build::Manual::AlienAuthor
 perldoc Alien::Build::Manual::AlienUser
 perldoc Alien::Build::Manual::Contributing
 perldoc Alien::Build::Manual::FAQ
 perldoc Alien::Build::Manual::PluginAuthor

=head1 DESCRIPTION

L<Alien::Build> comes with a number of manuals that are useful depending on how you
are using L<Alien>.

=over 4

=item L<Alien::Build::Manual::Alien>

General alien author documentation.

=item L<Alien::Build::Manual::AlienAuthor>

Alien author documentation.

=item L<Alien::Build::Manual::AlienUser>

Alien user documentation.

=item L<Alien::Build::Manual::Contributing>

Overly-detailed contributing guide.

=item L<Alien::Build::Manual::FAQ>

Frequently Asked Questions about L<Alien::Build>.

=item L<Alien::Build::Manual::PluginAuthor>

L<Alien::Build> plugin author documentation — or how to extend L<Alien::Build> with the plugin system.

=item L<Alien::Build::Manual::Security>

Documents some of the challenges and configuration tools related to security of L<Alien>s.

=back

=head1 SEE ALSO

=over 4

=item L<Alien::Base>

=item L<Alien::Build>

=item L<alienfile>

=back

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! ���<
  <
  #  perl5/Alien/Build/Log/Abbreviate.pmnu ��6�$        package Alien::Build::Log::Abbreviate;

use strict;
use warnings;
use 5.008004;
use Term::ANSIColor ();
use Path::Tiny qw( path );
use File::chdir;
use parent qw( Alien::Build::Log );

# ABSTRACT: Log class for Alien::Build which is less verbose
our $VERSION = '2.83'; # VERSION


sub _colored
{
  my($code, @out) = @_;
  -t STDOUT ? Term::ANSIColor::colored($code, @out) : @out;
}

my $root = path("$CWD");

sub log
{
  my(undef, %args) = @_;
  my($message) = $args{message};
  my ($package, $filename, $line) = @{ $args{caller} };

  my $source = $package;
  $source =~ s/^Alien::Build::Auto::[^:]+::Alienfile/alienfile/;

  my $expected = $package;
  $expected .= '.pm' unless $package eq 'alienfile';
  $expected =~ s/::/\//g;
  if($filename !~ /\Q$expected\E$/)
  {
    $source = path($filename)->relative($root);
  }
  else
  {
    $source =~ s/^Alien::Build::Plugin/ABP/;
    $source =~ s/^Alien::Build/AB/;
  }

  print _colored([ "bold on_black"          ], '[');
  print _colored([ "bright_green on_black"  ], $source);
  print _colored([ "on_black"               ], ' ');
  print _colored([ "bright_yellow on_black" ], $line);
  print _colored([ "bold on_black"          ], ']');
  print _colored([ "white on_black"         ], ' ', $message);
  print "\n";
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Log::Abbreviate - Log class for Alien::Build which is less verbose

=head1 VERSION

version 2.83

=head1 SYNOPSIS

=head1 DESCRIPTION

=head1 METHODS

=head2 log

 $log->log(%opts);

Send single log line to stdout.

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! ��T       perl5/Alien/Build/Log/Default.pmnu ��6�$        package Alien::Build::Log::Default;

use strict;
use warnings;
use 5.008004;
use parent qw( Alien::Build::Log );

# ABSTRACT: Default Alien::Build log class
our $VERSION = '2.83'; # VERSION


sub log
{
  my(undef, %args) = @_;
  my($message) = $args{message};
  my ($package, $filename, $line) = @{ $args{caller} };
  print "$package> $message\n";
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Log::Default - Default Alien::Build log class

=head1 VERSION

version 2.83

=head1 SYNOPSIS

 Alien::Build->log("message1");
 $build->log("message2");

=head1 DESCRIPTION

This is the default log class for L<Alien::Build>.  It does
the sensible thing of sending the message to stdout, along
with the class that made the log call.  For more details
about logging with L<Alien::Build>, see L<Alien::Build::Log>.

=head1 METHODS

=head2 log

 $log->log(%opts);

Send single log line to stdout.

=head1 SEE ALSO

=over 4

=item L<Alien::Build>

=item L<Alien::Build::Log>

=back

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! 5K�n�  �     perl5/Alien/Build/Interpolate.pmnu ��6�$        package Alien::Build::Interpolate;

use strict;
use warnings;
use 5.008004;

# ABSTRACT: Advanced interpolation engine for Alien builds
our $VERSION = '2.83'; # VERSION


sub new
{
  my($class) = @_;
  my $self = bless {
    helper  => {},
    classes => {},
  }, $class;
  $self;
}


sub add_helper
{
  my $self = shift;
  my $name = shift;
  my $code = shift;

  if(defined $self->{helper}->{$name})
  {
    require Carp;
    Carp::croak("duplicate implementation for interpolated key $name");
  }

  my $require;

  if(ref $_[0] eq 'CODE')
  {
    $require = shift;
  }
  else
  {
    $require = [];
    while(@_)
    {
      my $module = shift;
      my $version = shift;
      $version ||= 0;
      push @$require, $module => $version;
    }
  }

  $self->{helper}->{$name} = Alien::Build::Helper->new(
    $name,
    $code,
    $require,
  );
}


sub replace_helper
{
  my $self = shift;
  my($name) = @_;
  delete $self->{helper}->{$name};
  $self->add_helper(@_);
}


sub has_helper
{
  my($self, $name) = @_;

  return unless defined $self->{helper}->{$name};

  my @require = $self->{helper}->{$name}->require;

  while(@require)
  {
    my $module  = shift @require;
    my $version = shift @require;

    {
      my $pm = "$module.pm";
      $pm =~ s/::/\//g;
      require $pm;
      $module->VERSION($version) if $version;
    }

    unless($self->{classes}->{$module})
    {
      if($module->can('alien_helper'))
      {
        my $helpers = $module->alien_helper;
        foreach my $k (keys %$helpers)
        {
          $self->{helper}->{$k}->code($helpers->{$k});
        }
      }
      $self->{classes}->{$module} = 1;
    }
  }

  my $code = $self->{helper}->{$name}->code;

  return unless defined $code;

  if(ref($code) ne 'CODE')
  {
    my $perl = $code;
    package Alien::Build::Interpolate::Helper;
    $code = sub {
      ##  no critic
      my $value = eval $perl;
      ## use critic
      die $@ if $@;
      $value;
    };
  }

  $code;
}


sub execute_helper
{
  my($self, $name) = @_;

  my $code = $self->has_helper($name);
  die "no helper defined for $name" unless defined $code;

  $code->();
}


sub _get_prop
{
  my($name, $prop, $orig) = @_;

  $name =~ s/^\./alien./;

  if($name =~ /^(.*?)\.(.*)$/)
  {
    my($key,$rest) = ($1,$2);
    return _get_prop($rest, $prop->{$key}, $orig);
  }
  elsif(exists $prop->{$name})
  {
    return $prop->{$name};
  }
  else
  {
    require Carp;
    Carp::croak("No property $orig is defined");
  }
}

sub interpolate
{
  my($self, $string, $build) = @_;

  my $prop = defined $build && eval { $build->isa('Alien::Build') }
  ? $build->_command_prop
  : {};

  $string =~ s{(?<!\%)\%\{([a-zA-Z_][a-zA-Z_0-9]+)\}}{$self->execute_helper($1)}eg;
  $string =~ s{(?<!\%)\%\{([a-zA-Z_\.][a-zA-Z_0-9\.]+)\}}{_get_prop($1,$prop,$1)}eg;
  $string =~ s/\%(?=\%)//g;
  $string;
}


sub requires
{
  my($self, $string) = @_;
  map {
    my $helper = $self->{helper}->{$_};
    $helper ? $helper->require : ();
  } $string =~ m{(?<!\%)\%\{([a-zA-Z_][a-zA-Z_0-9]+)\}}g;
}


sub clone
{
  my($self) = @_;

  require Storable;

  my %helper;
  foreach my $name (keys %{ $self->{helper} })
  {
    $helper{$name} = $self->{helper}->{$name}->clone;
  }

  my $new = bless {
    helper => \%helper,
    classes => Storable::dclone($self->{classes}),
  }, ref $self;
}

package Alien::Build::Helper;

sub new
{
  my($class, $name, $code, $require) = @_;
  bless {
    name    => $name,
    code    => $code,
    require => $require,
  }, $class;
}

sub name { shift->{name} }

sub code
{
  my($self, $code) = @_;
  $self->{code} = $code if $code;
  $self->{code};
}

sub require
{
  my($self) = @_;
  if(ref $self->{require} eq 'CODE')
  {
    $self->{require} = [ $self->{require}->($self) ];
  }
  @{ $self->{require} };
}

sub clone
{
  my($self) = @_;
  my $class = ref $self;
  $class->new(
    $self->name,
    $self->code,
    [ $self->require ],
  );
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Interpolate - Advanced interpolation engine for Alien builds

=head1 VERSION

version 2.83

=head1 CONSTRUCTOR

=head2 new

 my $intr = Alien::Build::Interpolate->new;

=head2 add_helper

 $intr->add_helper($name => $code);
 $intr->add_helper($name => $code, %requirements);

=head2 replace_helper

 $intr->replace_helper($name => $code);
 $intr->replace_helper($name => $code, %requirements);

=head2 has_helper

 my $coderef = $intr->has_helper($name);

Used to discover if a helper exists with the given name.
Returns the code reference.

=head2 execute_helper

 my $value = $intr->execute_helper($name);

This evaluates the given helper and returns the result.

=head2 interpolate

 my $string = $intr->interpolate($template, $build);
 my $string = $intr->interpolate($template);

This takes a template and fills in the appropriate values of any helpers used
in the template.

[version 2.58]

If you pass in an L<Alien::Build> instance as the second argument, you can use
properties as well as helpers in the template.  Example:

 my $patch = $intr->template("%{.install.patch}/foo-%{.runtime.version}.patch", $build);

=head2 requires

 my %requires = $intr->requires($template);

This returns a hash of modules required in order to execute the given template.
The keys are the module names and the values are the versions.  Version will be
set to C<0> if any version is sufficient.

=head2 clone

 my $intr2 = $intr->clone;

This creates a clone of the interpolator.

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! f�7��  �    perl5/Alien/Build/Log.pmnu ��6�$        package Alien::Build::Log;

use strict;
use warnings;
use 5.008004;
use Carp ();

# ABSTRACT: Alien::Build logging
our $VERSION = '2.83'; # VERSION


my $log_class;
my $self;

sub new
{
  my($class) = @_;
  Carp::croak("Cannot instantiate base class") if $class eq 'Alien::Build::Log';
  return bless {}, $class;
}


sub default
{
  $self || do {
    my $class = $log_class || $ENV{ALIEN_BUILD_LOG} || 'Alien::Build::Log::Default';
    unless(eval { $class->can('new') })
    {
      my $pm = "$class.pm";
      $pm =~ s/::/\//g;
      require $pm;
    }
    $class->new;
  }
}


sub set_log_class
{
  my(undef, $class) = @_;
  return if defined $class && ($class eq ($log_class || ''));
  $log_class = $class;
  undef $self;
}


sub log
{
  Carp::croak("AB Log base class");
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Alien::Build::Log - Alien::Build logging

=head1 VERSION

version 2.83

=head1 SYNOPSIS

Create your custom log class:

 package Alien::Build::Log::MyLog;
 
 use parent qw( Alien::Build::Log );
 
 sub log
 {
   my(undef, %opt)  = @_;
   my($package, $filename, $line) = @{ $opt{caller} };
   my $message = $opt{message};
 
   ...;
 }

override log class:

 % env ALIEN_BUILD_LOG=Alien::Build::Log::MyLog cpanm Alien::libfoo

=head1 DESCRIPTION

=head1 CONSTRUCTORS

=head2 new

 my $log = Alien::Build::Log->new;

Create an instance of the log class.

=head2 default

 my $log = Alien::Build::Log->default;

Return singleton instance of log class used by L<Alien::Build>.

=head1 METHODS

=head2 set_log_class

 Alien::Build::Log->set_log_class($class);

Set the default log class used by L<Alien::Build>.  This method will also reset the
default instance used by L<Alien::Build>.  If not specified, L<Alien::Build::Log::Default>
will be used.

=head2 log

 $log->log(%options);

Overridable method which does the actual work of the log class.  Options:

=over 4

=item caller

Array references containing the package, file and line number of where the
log was called.

=item message

The message to log.

=back

=head1 ENVIRONMENT

=over 4

=item ALIEN_BUILD_LOG

The default log class used by L<Alien::Build>.

=back

=head1 AUTHOR

Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>

Contributors:

Diab Jerius (DJERIUS)

Roy Storey (KIWIROY)

Ilya Pavlov

David Mertens (run4flat)

Mark Nunberg (mordy, mnunberg)

Christian Walde (Mithaldu)

Brian Wightman (MidLifeXis)

Zaki Mughal (zmughal)

mohawk (mohawk2, ETJ)

Vikas N Kumar (vikasnkumar)

Flavio Poletti (polettix)

Salvador Fandiño (salva)

Gianni Ceccarelli (dakkar)

Pavel Shaydo (zwon, trinitum)

Kang-min Liu (劉康民, gugod)

Nicholas Shipp (nshp)

Juan Julián Merelo Guervós (JJ)

Joel Berger (JBERGER)

Petr Písař (ppisar)

Lance Wicks (LANCEW)

Ahmad Fatoum (a3f, ATHREEF)

José Joaquín Atria (JJATRIA)

Duke Leto (LETO)

Shoichi Kaji (SKAJI)

Shawn Laffan (SLAFFAN)

Paul Evans (leonerd, PEVANS)

Håkon Hægland (hakonhagland, HAKONH)

nick nauwelaerts (INPHOBIA)

Florian Weimer

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011-2022 by Graham Ollis.

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

=cut
PK       ! ��^�:  �:    perl5/IO/Scalar.pmnu ��6�$        package IO::Scalar;

use strict;

use Carp;
use IO::Handle;

### Stringification, courtesy of B. K. Oxley (binkley):  :-)
use overload '""'   => sub { ${*{$_[0]}->{SR}} };
use overload 'bool' => sub { 1 };      ### have to do this, so object is true!

### The package version, both in 1.23 style *and* usable by MakeMaker:
our $VERSION = '2.113';

### Inheritance:
our @ISA = qw(IO::Handle);

### This stuff should be got rid of ASAP.
require IO::WrapTie and push @ISA, 'IO::WrapTie::Slave' if ($] >= 5.004);

#==============================


=head1 NAME

IO::Scalar - IO:: interface for reading/writing a scalar


=head1 SYNOPSIS

Perform I/O on strings, using the basic OO interface...

    use 5.005;
    use IO::Scalar;
    $data = "My message:\n";

    ### Open a handle on a string, and append to it:
    $SH = new IO::Scalar \$data;
    $SH->print("Hello");
    $SH->print(", world!\nBye now!\n");
    print "The string is now: ", $data, "\n";

    ### Open a handle on a string, read it line-by-line, then close it:
    $SH = new IO::Scalar \$data;
    while (defined($_ = $SH->getline)) {
	print "Got line: $_";
    }
    $SH->close;

    ### Open a handle on a string, and slurp in all the lines:
    $SH = new IO::Scalar \$data;
    print "All lines:\n", $SH->getlines;

    ### Get the current position (either of two ways):
    $pos = $SH->getpos;
    $offset = $SH->tell;

    ### Set the current position (either of two ways):
    $SH->setpos($pos);
    $SH->seek($offset, 0);

    ### Open an anonymous temporary scalar:
    $SH = new IO::Scalar;
    $SH->print("Hi there!");
    print "I printed: ", ${$SH->sref}, "\n";      ### get at value


Don't like OO for your I/O?  No problem.
Thanks to the magic of an invisible tie(), the following now
works out of the box, just as it does with IO::Handle:

    use 5.005;
    use IO::Scalar;
    $data = "My message:\n";

    ### Open a handle on a string, and append to it:
    $SH = new IO::Scalar \$data;
    print $SH "Hello";
    print $SH ", world!\nBye now!\n";
    print "The string is now: ", $data, "\n";

    ### Open a handle on a string, read it line-by-line, then close it:
    $SH = new IO::Scalar \$data;
    while (<$SH>) {
	print "Got line: $_";
    }
    close $SH;

    ### Open a handle on a string, and slurp in all the lines:
    $SH = new IO::Scalar \$data;
    print "All lines:\n", <$SH>;

    ### Get the current position (WARNING: requires 5.6):
    $offset = tell $SH;

    ### Set the current position (WARNING: requires 5.6):
    seek $SH, $offset, 0;

    ### Open an anonymous temporary scalar:
    $SH = new IO::Scalar;
    print $SH "Hi there!";
    print "I printed: ", ${$SH->sref}, "\n";      ### get at value


And for you folks with 1.x code out there: the old tie() style still works,
though this is I<unnecessary and deprecated>:

    use IO::Scalar;

    ### Writing to a scalar...
    my $s;
    tie *OUT, 'IO::Scalar', \$s;
    print OUT "line 1\nline 2\n", "line 3\n";
    print "String is now: $s\n"

    ### Reading and writing an anonymous scalar...
    tie *OUT, 'IO::Scalar';
    print OUT "line 1\nline 2\n", "line 3\n";
    tied(OUT)->seek(0,0);
    while (<OUT>) {
        print "Got line: ", $_;
    }


Stringification works, too!

    my $SH = new IO::Scalar \$data;
    print $SH "Hello, ";
    print $SH "world!";
    print "I printed: $SH\n";


=head1 DESCRIPTION

This class is part of the IO::Stringy distribution;
see L<IO::Stringy> for change log and general information.

The IO::Scalar class implements objects which behave just like
IO::Handle (or FileHandle) objects, except that you may use them
to write to (or read from) scalars.  These handles are
automatically C<tiehandle>d (though please see L<"WARNINGS">
for information relevant to your Perl version).


Basically, this:

    my $s;
    $SH = new IO::Scalar \$s;
    $SH->print("Hel", "lo, ");         ### OO style
    $SH->print("world!\n");            ### ditto

Or this:

    my $s;
    $SH = tie *OUT, 'IO::Scalar', \$s;
    print OUT "Hel", "lo, ";           ### non-OO style
    print OUT "world!\n";              ### ditto

Causes $s to be set to:

    "Hello, world!\n"


=head1 PUBLIC INTERFACE

=head2 Construction

=over 4

=cut

#------------------------------

=item new [ARGS...]

I<Class method.>
Return a new, unattached scalar handle.
If any arguments are given, they're sent to open().

=cut

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self = bless \do { local *FH }, $class;
    tie *$self, $class, $self;
    $self->open(@_);   ### open on anonymous by default
    $self;
}
sub DESTROY {
    shift->close;
}

#------------------------------

=item open [SCALARREF]

I<Instance method.>
Open the scalar handle on a new scalar, pointed to by SCALARREF.
If no SCALARREF is given, a "private" scalar is created to hold
the file data.

Returns the self object on success, undefined on error.

=cut

sub open {
    my ($self, $sref) = @_;

    ### Sanity:
    defined($sref) or do {my $s = ''; $sref = \$s};
    (ref($sref) eq "SCALAR") or croak "open() needs a ref to a scalar";

    ### Setup:
    *$self->{Pos} = 0;          ### seek position
    *$self->{SR}  = $sref;      ### scalar reference
    $self;
}

#------------------------------

=item opened

I<Instance method.>
Is the scalar handle opened on something?

=cut

sub opened {
    *{shift()}->{SR};
}

#------------------------------

=item close

I<Instance method.>
Disassociate the scalar handle from its underlying scalar.
Done automatically on destroy.

=cut

sub close {
    my $self = shift;
    %{*$self} = ();
    1;
}

=back

=cut


#==============================

=head2 Input and output

=over 4

=cut


#------------------------------

=item flush

I<Instance method.>
No-op, provided for OO compatibility.

=cut

sub flush { "0 but true" }

#------------------------------

=item fileno

I<Instance method.>
No-op, returns undef

=cut

sub fileno { }

#------------------------------

=item getc

I<Instance method.>
Return the next character, or undef if none remain.

=cut

sub getc {
    my $self = shift;

    ### Return undef right away if at EOF; else, move pos forward:
    return undef if $self->eof;
    substr(${*$self->{SR}}, *$self->{Pos}++, 1);
}

#------------------------------

=item getline

I<Instance method.>
Return the next line, or undef on end of string.
Can safely be called in an array context.
Currently, lines are delimited by "\n".

=cut

sub getline {
    my $self = shift;

    ### Return undef right away if at EOF:
    return undef if $self->eof;

    ### Get next line:
    my $sr = *$self->{SR};
    my $i  = *$self->{Pos};	        ### Start matching at this point.

    ### Minimal impact implementation!
    ### We do the fast thing (no regexps) if using the
    ### classic input record separator.

    ### Case 1: $/ is undef: slurp all...
    if    (!defined($/)) {
	*$self->{Pos} = length $$sr;
        return substr($$sr, $i);
    }

    ### Case 2: $/ is "\n": zoom zoom zoom...
    elsif ($/ eq "\012") {

        ### Seek ahead for "\n"... yes, this really is faster than regexps.
        my $len = length($$sr);
        for (; $i < $len; ++$i) {
           last if ord (substr ($$sr, $i, 1)) == 10;
        }

        ### Extract the line:
        my $line;
        if ($i < $len) {                ### We found a "\n":
            $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos} + 1);
            *$self->{Pos} = $i+1;            ### Remember where we finished up.
        }
        else {                          ### No "\n"; slurp the remainder:
            $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos});
            *$self->{Pos} = $len;
        }
        return $line;
    }

    ### Case 3: $/ is ref to int. Do fixed-size records.
    ###        (Thanks to Dominique Quatravaux.)
    elsif (ref($/)) {
        my $len = length($$sr);
		my $i = ${$/} + 0;
		my $line = substr ($$sr, *$self->{Pos}, $i);
		*$self->{Pos} += $i;
        *$self->{Pos} = $len if (*$self->{Pos} > $len);
		return $line;
    }

    ### Case 4: $/ is either "" (paragraphs) or something weird...
    ###         This is Graham's general-purpose stuff, which might be
    ###         a tad slower than Case 2 for typical data, because
    ###         of the regexps.
    else {
        pos($$sr) = $i;

	### If in paragraph mode, skip leading lines (and update i!):
        length($/) or
	    (($$sr =~ m/\G\n*/g) and ($i = pos($$sr)));

        ### If we see the separator in the buffer ahead...
        if (length($/)
	    ?  $$sr =~ m,\Q$/\E,g          ###   (ordinary sep) TBD: precomp!
            :  $$sr =~ m,\n\n,g            ###   (a paragraph)
            ) {
            *$self->{Pos} = pos $$sr;
            return substr($$sr, $i, *$self->{Pos}-$i);
        }
        ### Else if no separator remains, just slurp the rest:
        else {
            *$self->{Pos} = length $$sr;
            return substr($$sr, $i);
        }
    }
}

#------------------------------

=item getlines

I<Instance method.>
Get all remaining lines.
It will croak() if accidentally called in a scalar context.

=cut

sub getlines {
    my $self = shift;
    wantarray or croak("can't call getlines in scalar context!");
    my ($line, @lines);
    push @lines, $line while (defined($line = $self->getline));
    @lines;
}

#------------------------------

=item print ARGS...

I<Instance method.>
Print ARGS to the underlying scalar.

B<Warning:> this continues to always cause a seek to the end
of the string, but if you perform seek()s and tell()s, it is
still safer to explicitly seek-to-end before subsequent print()s.

=cut

sub print {
    my $self = shift;
    *$self->{Pos} = length(${*$self->{SR}} .= join('', @_) . (defined($\) ? $\ : ""));
    1;
}
sub _unsafe_print {
    my $self = shift;
    my $append = join('', @_) . $\;
    ${*$self->{SR}} .= $append;
    *$self->{Pos}   += length($append);
    1;
}
sub _old_print {
    my $self = shift;
    ${*$self->{SR}} .= join('', @_) . $\;
    *$self->{Pos} = length(${*$self->{SR}});
    1;
}


#------------------------------

=item read BUF, NBYTES, [OFFSET]

I<Instance method.>
Read some bytes from the scalar.
Returns the number of bytes actually read, 0 on end-of-file, undef on error.

=cut

sub read {
    my $self = $_[0];
    my $n    = $_[2];
    my $off  = $_[3] || 0;

    my $read = substr(${*$self->{SR}}, *$self->{Pos}, $n);
    $n = length($read);
    *$self->{Pos} += $n;
    ($off ? substr($_[1], $off) : $_[1]) = $read;
    return $n;
}

#------------------------------

=item write BUF, NBYTES, [OFFSET]

I<Instance method.>
Write some bytes to the scalar.

=cut

sub write {
    my $self = $_[0];
    my $n    = $_[2];
    my $off  = $_[3] || 0;

    my $data = substr($_[1], $off, $n);
    $n = length($data);
    $self->print($data);
    return $n;
}

#------------------------------

=item sysread BUF, LEN, [OFFSET]

I<Instance method.>
Read some bytes from the scalar.
Returns the number of bytes actually read, 0 on end-of-file, undef on error.

=cut

sub sysread {
  my $self = shift;
  $self->read(@_);
}

#------------------------------

=item syswrite BUF, NBYTES, [OFFSET]

I<Instance method.>
Write some bytes to the scalar.

=cut

sub syswrite {
  my $self = shift;
  $self->write(@_);
}

=back

=cut


#==============================

=head2 Seeking/telling and other attributes

=over 4

=cut


#------------------------------

=item autoflush

I<Instance method.>
No-op, provided for OO compatibility.

=cut

sub autoflush {}

#------------------------------

=item binmode

I<Instance method.>
No-op, provided for OO compatibility.

=cut

sub binmode {}

#------------------------------

=item clearerr

I<Instance method.>  Clear the error and EOF flags.  A no-op.

=cut

sub clearerr { 1 }

#------------------------------

=item eof

I<Instance method.>  Are we at end of file?

=cut

sub eof {
    my $self = shift;
    (*$self->{Pos} >= length(${*$self->{SR}}));
}

#------------------------------

=item seek OFFSET, WHENCE

I<Instance method.>  Seek to a given position in the stream.

=cut

sub seek {
    my ($self, $pos, $whence) = @_;
    my $eofpos = length(${*$self->{SR}});

    ### Seek:
    if    ($whence == 0) { *$self->{Pos} = $pos }             ### SEEK_SET
    elsif ($whence == 1) { *$self->{Pos} += $pos }            ### SEEK_CUR
    elsif ($whence == 2) { *$self->{Pos} = $eofpos + $pos}    ### SEEK_END
    else                 { croak "bad seek whence ($whence)" }

    ### Fixup:
    if (*$self->{Pos} < 0)       { *$self->{Pos} = 0 }
    if (*$self->{Pos} > $eofpos) { *$self->{Pos} = $eofpos }
    return 1;
}

#------------------------------

=item sysseek OFFSET, WHENCE

I<Instance method.> Identical to C<seek OFFSET, WHENCE>, I<q.v.>

=cut

sub sysseek {
    my $self = shift;
    $self->seek (@_);
}

#------------------------------

=item tell

I<Instance method.>
Return the current position in the stream, as a numeric offset.

=cut

sub tell { *{shift()}->{Pos} }

#------------------------------
#
# use_RS [YESNO]
#
# I<Instance method.>
# Obey the current setting of $/, like IO::Handle does?
# Default is false in 1.x, but cold-welded true in 2.x and later.
#
sub use_RS {
    my ($self, $yesno) = @_;
    carp "use_RS is deprecated and ignored; \$/ is always consulted\n";
 }

#------------------------------

=item setpos POS

I<Instance method.>
Set the current position, using the opaque value returned by C<getpos()>.

=cut

sub setpos { shift->seek($_[0],0) }

#------------------------------

=item getpos

I<Instance method.>
Return the current position in the string, as an opaque object.

=cut

*getpos = \&tell;


#------------------------------

=item sref

I<Instance method.>
Return a reference to the underlying scalar.

=cut

sub sref { *{shift()}->{SR} }


#------------------------------
# Tied handle methods...
#------------------------------

# Conventional tiehandle interface:
sub TIEHANDLE {
    ((defined($_[1]) && UNIVERSAL::isa($_[1], "IO::Scalar"))
     ? $_[1]
     : shift->new(@_));
}
sub GETC      { shift->getc(@_) }
sub PRINT     { shift->print(@_) }
sub PRINTF    { shift->print(sprintf(shift, @_)) }
sub READ      { shift->read(@_) }
sub READLINE  { wantarray ? shift->getlines(@_) : shift->getline(@_) }
sub WRITE     { shift->write(@_); }
sub CLOSE     { shift->close(@_); }
sub SEEK      { shift->seek(@_); }
sub TELL      { shift->tell(@_); }
sub EOF       { shift->eof(@_); }
sub BINMODE   { 1; }

#------------------------------------------------------------

1;

__END__


=back

=cut


=head1 AUTHOR

Eryq (F<eryq@zeegee.com>).
President, ZeeGee Software Inc (F<http://www.zeegee.com>).

=head1 CONTRIBUTORS

Dianne Skoll (F<dfs@roaringpenguin.com>).

=head1 COPYRIGHT & LICENSE

Copyright (c) 1997 Erik (Eryq) Dorfman, ZeeGee Software, Inc. All rights reserved.

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

=cut
PK       ! ���r�  �    perl5/IO/AtomicFile.pmnu ��6�$        package IO::AtomicFile;

use strict;
use warnings;
use parent 'IO::File';

our $VERSION = '2.113';

#------------------------------
# new ARGS...
#------------------------------
# Class method, constructor.
# Any arguments are sent to open().
#
sub new {
    my $class = shift;
    my $self = $class->SUPER::new();
    ${*$self}{'io_atomicfile_suffix'} = '';
    $self->open(@_) if @_;
    $self;
}

#------------------------------
# DESTROY
#------------------------------
# Destructor.
#
sub DESTROY {
    shift->close(1);   ### like close, but raises fatal exception on failure
}

#------------------------------
# open PATH, MODE
#------------------------------
# Class/instance method.
#
sub open {
    my ($self, $path, $mode) = @_;
    ref($self) or $self = $self->new;    ### now we have an instance!

    ### Create tmp path, and remember this info:
    my $temp = "${path}..TMP" . ${*$self}{'io_atomicfile_suffix'};
    ${*$self}{'io_atomicfile_temp'} = $temp;
    ${*$self}{'io_atomicfile_path'} = $path;

    ### Open the file!  Returns filehandle on success, for use as a constructor:
    $self->SUPER::open($temp, $mode) ? $self : undef;
}

#------------------------------
# _closed [YESNO]
#------------------------------
# Instance method, private.
# Are we already closed?  Argument sets new value, returns previous one.
#
sub _closed {
    my $self = shift;
    my $oldval = ${*$self}{'io_atomicfile_closed'};
    ${*$self}{'io_atomicfile_closed'} = shift if @_;
    $oldval;
}

#------------------------------
# close
#------------------------------
# Instance method.
# Close the handle, and rename the temp file to its final name.
#
sub close {
    my ($self, $die) = @_;
    unless ($self->_closed(1)) {             ### sentinel...
	    if ($self->SUPER::close()) {
		    rename(${*$self}{'io_atomicfile_temp'},
			   ${*$self}{'io_atomicfile_path'})
			or ($die ? die "close (rename) atomic file: $!\n" : return undef);
	    } else {
		    ($die ? die "close atomic file: $!\n" : return undef);
	    }
    }
    1;
}

#------------------------------
# delete
#------------------------------
# Instance method.
# Close the handle, and delete the temp file.
#
sub delete {
    my $self = shift;
    unless ($self->_closed(1)) {             ### sentinel...
        $self->SUPER::close();
        return unlink(${*$self}{'io_atomicfile_temp'});
    }
    1;
}

#------------------------------
# detach
#------------------------------
# Instance method.
# Close the handle, but DO NOT delete the temp file.
#
sub detach {
    my $self = shift;
    $self->SUPER::close() unless ($self->_closed(1));
    1;
}

#------------------------------
1;
__END__


=head1 NAME

IO::AtomicFile - write a file which is updated atomically

=head1 SYNOPSIS

    use strict;
    use warnings;
    use feature 'say';
    use IO::AtomicFile;

    # Write a temp file, and have it install itself when closed:
    my $fh = IO::AtomicFile->open("bar.dat", "w");
    $fh->say("Hello!");
    $fh->close || die "couldn't install atomic file: $!";

    # Write a temp file, but delete it before it gets installed:
    my $fh = IO::AtomicFile->open("bar.dat", "w");
    $fh->say("Hello!");
    $fh->delete;

    # Write a temp file, but neither install it nor delete it:
    my $fh = IO::AtomicFile->open("bar.dat", "w");
    $fh->say("Hello!");
    $fh->detach;

=head1 DESCRIPTION

This module is intended for people who need to update files
reliably in the face of unexpected program termination.

For example, you generally don't want to be halfway in the middle of
writing I</etc/passwd> and have your program terminate!  Even
the act of writing a single scalar to a filehandle is I<not> atomic.

But this module gives you true atomic updates, via C<rename>.
When you open a file I</foo/bar.dat> via this module, you are I<actually>
opening a temporary file I</foo/bar.dat..TMP>, and writing your
output there. The act of closing this file (either explicitly
via C<close>, or implicitly via the destruction of the object)
will cause C<rename> to be called... therefore, from the point
of view of the outside world, the file's contents are updated
in a single time quantum.

To ensure that problems do not go undetected, the C<close> method
done by the destructor will raise a fatal exception if the C<rename>
fails.  The explicit C<close> just returns C<undef>.

You can also decide at any point to trash the file you've been
building.

=head1 METHODS

L<IO::AtomicFile> inherits all methods from L<IO::File> and
implements the following new ones.

=head2 close

    $fh->close();

This method calls its parent L<IO::File/"close"> and then renames its temporary file
as the original file name.

=head2 delete

    $fh->delete();

This method calls its parent L<IO::File/"close"> and then deletes the temporary file.

=head2 detach

    $fh->detach();

This method calls its parent L<IO::File/"close">. Unlike L<IO::AtomicFile/"delete"> it
does not then delete the temporary file.

=head1 AUTHOR

Eryq (F<eryq@zeegee.com>).
President, ZeeGee Software Inc (F<http://www.zeegee.com>).

=head1 CONTRIBUTORS

Dianne Skoll (F<dfs@roaringpenguin.com>).

=head1 COPYRIGHT & LICENSE

Copyright (c) 1997 Erik (Eryq) Dorfman, ZeeGee Software, Inc. All rights reserved.

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

=cut
PK       ! �h�      perl5/IO/Stringy.pmnu ��6�$        package IO::Stringy;
use strict;
use Exporter;

our $VERSION = '2.113';

1;
__END__

=head1 NAME

IO-stringy - I/O on in-core objects like strings and arrays

=head1 SYNOPSIS

    use strict;
    use warnings;

    use IO::AtomicFile; # Write a file which is updated atomically
    use IO::InnerFile; # define a file inside another file
    use IO::Lines; # I/O handle to read/write to array of lines
    use IO::Scalar; # I/O handle to read/write to a string
    use IO::ScalarArray; # I/O handle to read/write to array of scalars
    use IO::Wrap; # Wrap old-style FHs in standard OO interface
    use IO::WrapTie; # Tie your handles & retain full OO interface

    # ...

=head1 DESCRIPTION

This toolkit primarily provides modules for performing both traditional
and object-oriented i/o) on things I<other> than normal filehandles;
in particular, L<IO::Scalar|IO::Scalar>, L<IO::ScalarArray|IO::ScalarArray>,
and L<IO::Lines|IO::Lines>.

In the more-traditional IO::Handle front, we
have L<IO::AtomicFile|IO::AtomicFile>
which may be used to painlessly create files which are updated
atomically.

And in the "this-may-prove-useful" corner, we have L<IO::Wrap|IO::Wrap>,
whose exported wraphandle() function will clothe anything that's not
a blessed object in an IO::Handle-like wrapper... so you can just
use OO syntax and stop worrying about whether your function's caller
handed you a string, a globref, or a FileHandle.

=head1 AUTHOR

Eryq (F<eryq@zeegee.com>).
President, ZeeGee Software Inc (F<http://www.zeegee.com>).

=head1 CONTRIBUTORS

Dianne Skoll (F<dfs@roaringpenguin.com>).

=head1 COPYRIGHT & LICENSE

Copyright (c) 1997 Erik (Eryq) Dorfman, ZeeGee Software, Inc. All rights reserved.

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

=cut
PK       ! *�2U"  U"    perl5/IO/Wrap.pmnu ��6�$        package IO::Wrap;

use strict;
use Exporter;
use FileHandle;
use Carp;

our $VERSION = '2.113';
our @ISA = qw(Exporter);
our @EXPORT = qw(wraphandle);


#------------------------------
# wraphandle RAW
#------------------------------
sub wraphandle {
    my $raw = shift;
    new IO::Wrap $raw;
}

#------------------------------
# new STREAM
#------------------------------
sub new {
    my ($class, $stream) = @_;
    no strict 'refs';

    ### Convert raw scalar to globref:
    ref($stream) or $stream = \*$stream;

    ### Wrap globref and incomplete objects:
    if ((ref($stream) eq 'GLOB') or      ### globref
	(ref($stream) eq 'FileHandle') && !defined(&FileHandle::read)) {
	return bless \$stream, $class;
    }
    $stream;           ### already okay!
}

#------------------------------
# I/O methods...
#------------------------------
sub close {
    my $self = shift;
    return close($$self);
}
sub fileno {
    my $self = shift;
    my $fh = $$self;
    return fileno($fh);
}

sub getline {
    my $self = shift;
    my $fh = $$self;
    return scalar(<$fh>);
}
sub getlines {
    my $self = shift;
    wantarray or croak("Can't call getlines in scalar context!");
    my $fh = $$self;
    <$fh>;
}
sub print {
    my $self = shift;
    print { $$self } @_;
}
sub read {
    my $self = shift;
    return read($$self, $_[0], $_[1]);
}
sub seek {
    my $self = shift;
    return seek($$self, $_[0], $_[1]);
}
sub tell {
    my $self = shift;
    return tell($$self);
}

1;
__END__


=head1 NAME

IO::Wrap - Wrap raw filehandles in the IO::Handle interface

=head1 SYNOPSIS

    use strict;
    use warnings;
    use IO::Wrap;

    # this is a fairly senseless use case as IO::Handle already does this.
    my $wrap_fh = IO::Wrap->new(\*STDIN);
    my $line = $wrap_fh->getline();

    # Do stuff with any kind of filehandle (including a bare globref), or
    # any kind of blessed object that responds to a print() message.

    # already have a globref? a FileHandle? a scalar filehandle name?
    $wrap_fh = IO::Wrap->new($some_unknown_thing);

    # At this point, we know we have an IO::Handle-like object! YAY
    $wrap_fh->print("Hey there!");

You can also do this using a convenience wrapper function

    use strict;
    use warnings;
    use IO::Wrap qw(wraphandle);

    # this is a fairly senseless use case as IO::Handle already does this.
    my $wrap_fh = wraphandle(\*STDIN);
    my $line = $wrap_fh->getline();

    # Do stuff with any kind of filehandle (including a bare globref), or
    # any kind of blessed object that responds to a print() message.

    # already have a globref? a FileHandle? a scalar filehandle name?
    $wrap_fh = wraphandle($some_unknown_thing);

    # At this point, we know we have an IO::Handle-like object! YAY
    $wrap_fh->print("Hey there!");

=head1 DESCRIPTION

Let's say you want to write some code which does I/O, but you don't
want to force the caller to provide you with a L<FileHandle> or L<IO::Handle>
object.  You want them to be able to say:

    do_stuff(\*STDOUT);
    do_stuff('STDERR');
    do_stuff($some_FileHandle_object);
    do_stuff($some_IO_Handle_object);

And even:

    do_stuff($any_object_with_a_print_method);

Sure, one way to do it is to force the caller to use C<tiehandle()>.
But that puts the burden on them.  Another way to do it is to
use B<IO::Wrap>.

Clearly, when wrapping a raw external filehandle (like C<\*STDOUT>),
I didn't want to close the file descriptor when the wrapper object is
destroyed; the user might not appreciate that! Hence, there's no
C<DESTROY> method in this class.

When wrapping a L<FileHandle> object, however, I believe that Perl will
invoke the C<FileHandle::DESTROY> when the last reference goes away,
so in that case, the filehandle is closed if the wrapped L<FileHandle>
really was the last reference to it.

=head1 FUNCTIONS

L<IO::Wrap> makes the following functions available.

=head2 wraphandle

    # wrap a filehandle glob
    my $fh = wraphandle(\*STDIN);
    # wrap a raw filehandle glob by name
    $fh = wraphandle('STDIN');
    # wrap a handle in an object
    $fh = wraphandle('Class::HANDLE');

    # wrap a blessed FileHandle object
    use FileHandle;
    my $fho = FileHandle->new("/tmp/foo.txt", "r");
    $fh = wraphandle($fho);

    # wrap any other blessed object that shares IO::Handle's interface
    $fh = wraphandle($some_object);

This function is simply a wrapper to the L<IO::Wrap/"new"> constructor method.

=head1 METHODS

L<IO::Wrap> implements the following methods.

=head2 close

    $fh->close();

The C<close> method will attempt to close the system file descriptor. For a
more complete description, read L<perlfunc/close>.

=head2 fileno

    my $int = $fh->fileno();

The C<fileno> method returns the file descriptor for the wrapped filehandle.
See L<perlfunc/fileno> for more information.

=head2 getline

    my $data = $fh->getline();

The C<getline> method mimics the function by the same name in L<IO::Handle>.
It's like calling C<< my $data = <$fh>; >> but only in scalar context.

=head2 getlines

    my @data = $fh->getlines();

The C<getlines> method mimics the function by the same name in L<IO::Handle>.
It's like calling C<< my @data = <$fh>; >> but only in list context. Calling
this method in scalar context will result in a croak.

=head2 new

    # wrap a filehandle glob
    my $fh = IO::Wrap->new(\*STDIN);
    # wrap a raw filehandle glob by name
    $fh = IO::Wrap->new('STDIN');
    # wrap a handle in an object
    $fh = IO::Wrap->new('Class::HANDLE');

    # wrap a blessed FileHandle object
    use FileHandle;
    my $fho = FileHandle->new("/tmp/foo.txt", "r");
    $fh = IO::Wrap->new($fho);

    # wrap any other blessed object that shares IO::Handle's interface
    $fh = IO::Wrap->new($some_object);

The C<new> constructor method takes in a single argument and decides to wrap
it or not it based on what it seems to be.

A raw scalar file handle name, like C<"STDOUT"> or C<"Class::HANDLE"> can be
wrapped, returning an L<IO::Wrap> object instance.

A raw filehandle glob, like C<\*STDOUT> can also be wrapped, returning an
L<IO::Wrawp> object instance.

A blessed L<FileHandle> object can also be wrapped. This is a special case
where an L<IO::Wrap> object instance will only be returned in the case that
your L<FileHandle> object doesn't support the C<read> method.

Also, any other kind of blessed object that conforms to the
L<IO::Handle> interface can be passed in. In this case, you just get back
that object.

In other words, we only wrap it into an L<IO::Wrap> object when what you've
supplied doesn't already conform to the L<IO::Handle> interface.

If you get back an L<IO::Wrap> object, it will obey a basic subset of
the C<IO::> interface. It will do so with object B<methods>, not B<operators>.

=head3 CAVEATS

This module does not allow you to wrap filehandle names which are given
as strings that lack the package they were opened in. That is, if a user
opens FOO in package Foo, they must pass it to you either as C<\*FOO>
or as C<"Foo::FOO">.  However, C<"STDIN"> and friends will work just fine.

=head2 print

    $fh->print("Some string");
    $fh->print("more", " than one", " string");

The C<print> method will attempt to print a string or list of strings to the
filehandle. For a more complete description, read
L<perlfunc/print>.

=head2 read

    my $buffer;
    # try to read 30 chars into the buffer starting at the
    # current cursor position.
    my $num_chars_read = $fh->read($buffer, 30);

The L<read> method attempts to read a number of characters, starting at the
filehandle's current cursor position. It returns the number of characters
actually read. See L<perlfunc/read> for more information.

=head2 seek

    use Fcntl qw(:seek); # import the SEEK_CUR, SEEK_SET, SEEK_END constants
    # seek to the position in bytes
    $fh->seek(0, SEEK_SET);
    # seek to the position in bytes from the current position
    $fh->seek(22, SEEK_CUR);
    # seek to the EOF plus bytes
    $fh->seek(0, SEEK_END);

The C<seek> method will attempt to set the cursor to a given position in bytes
for the wrapped file handle. See L<perlfunc/seek> for more information.

=head2 tell

    my $bytes = $fh->tell();

The C<tell> method will attempt to return the current position of the cursor
in bytes for the wrapped file handle. See L<perlfunc/tell> for more
information.

=head1 AUTHOR

Eryq (F<eryq@zeegee.com>).
President, ZeeGee Software Inc (F<http://www.zeegee.com>).

=head1 CONTRIBUTORS

Dianne Skoll (F<dfs@roaringpenguin.com>).

=head1 COPYRIGHT & LICENSE

Copyright (c) 1997 Erik (Eryq) Dorfman, ZeeGee Software, Inc. All rights reserved.

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

=cut
PK       ! ��G�J  J    perl5/IO/Lines.pmnu ��6�$        package IO::Lines;

use strict;
use Carp;
use IO::ScalarArray;

# The package version, both in 1.23 style *and* usable by MakeMaker:
our $VERSION = '2.113';

# Inheritance:
our @ISA = qw(IO::ScalarArray);     ### also gets us new_tie  :-)


=head1 NAME

IO::Lines - IO:: interface for reading/writing an array of lines


=head1 SYNOPSIS

    use IO::Lines;

    ### See IO::ScalarArray for details


=head1 DESCRIPTION

This class implements objects which behave just like FileHandle
(or IO::Handle) objects, except that you may use them to write to
(or read from) an array of lines.  C<tiehandle> capable as well.

This is a subclass of L<IO::ScalarArray|IO::ScalarArray>
in which the underlying
array has its data stored in a line-oriented-format: that is,
every element ends in a C<"\n">, with the possible exception of the
final element.  This makes C<getline()> I<much> more efficient;
if you plan to do line-oriented reading/printing, you want this class.

The C<print()> method will enforce this rule, so you can print
arbitrary data to the line-array: it will break the data at
newlines appropriately.

See L<IO::ScalarArray> for full usage and warnings.

=cut


#------------------------------
#
# getline
#
# Instance method, override.
# Return the next line, or undef on end of data.
# Can safely be called in an array context.
# Currently, lines are delimited by "\n".
#
sub getline {
    my $self = shift;

    if (!defined $/) {
	return join( '', $self->_getlines_for_newlines );
    }
    elsif ($/ eq "\n") {
	if (!*$self->{Pos}) {      ### full line...
	    return *$self->{AR}[*$self->{Str}++];
	}
	else {                     ### partial line...
	    my $partial = substr(*$self->{AR}[*$self->{Str}++], *$self->{Pos});
	    *$self->{Pos} = 0;
	    return $partial;
	}
    }
    else {
	croak 'unsupported $/: must be "\n" or undef';
    }
}

#------------------------------
#
# getlines
#
# Instance method, override.
# Return an array comprised of the remaining lines, or () on end of data.
# Must be called in an array context.
# Currently, lines are delimited by "\n".
#
sub getlines {
    my $self = shift;
    wantarray or croak("can't call getlines in scalar context!");

    if ((defined $/) and ($/ eq "\n")) {
	return $self->_getlines_for_newlines(@_);
    }
    else {         ### slow but steady
	return $self->SUPER::getlines(@_);
    }
}

#------------------------------
#
# _getlines_for_newlines
#
# Instance method, private.
# If $/ is newline, do fast getlines.
# This CAN NOT invoke getline!
#
sub _getlines_for_newlines {
    my $self = shift;
    my ($rArray, $Str, $Pos) = @{*$self}{ qw( AR Str Pos ) };
    my @partial = ();

    if ($Pos) {				### partial line...
	@partial = (substr( $rArray->[ $Str++ ], $Pos ));
	*$self->{Pos} = 0;
    }
    *$self->{Str} = scalar @$rArray;	### about to exhaust @$rArray
    return (@partial,
	    @$rArray[ $Str .. $#$rArray ]);	### remaining full lines...
}

#------------------------------
#
# print ARGS...
#
# Instance method, override.
# Print ARGS to the underlying line array.
#
sub print {
    if (defined $\ && $\ ne "\n") {
	croak 'unsupported $\: must be "\n" or undef';
    }

    my $self = shift;
    ### print STDERR "\n[[ARRAY WAS...\n", @{*$self->{AR}}, "<<EOF>>\n";
    my @lines = split /^/, join('', @_); @lines or return 1;

    ### Did the previous print not end with a newline?
    ### If so, append first line:
    if (@{*$self->{AR}} and (*$self->{AR}[-1] !~ /\n\Z/)) {
	*$self->{AR}[-1] .= shift @lines;
    }
    push @{*$self->{AR}}, @lines;       ### add the remainder
    ### print STDERR "\n[[ARRAY IS NOW...\n", @{*$self->{AR}}, "<<EOF>>\n";
    1;
}

#------------------------------
1;

__END__


=head1 VERSION

$Id: Lines.pm,v 1.3 2005/02/10 21:21:53 dfs Exp $


=head1 AUTHOR

Eryq (F<eryq@zeegee.com>).
President, ZeeGee Software Inc (F<http://www.zeegee.com>).

=head1 CONTRIBUTORS

Dianne Skoll (F<dfs@roaringpenguin.com>).

=head1 COPYRIGHT & LICENSE

Copyright (c) 1997 Erik (Eryq) Dorfman, ZeeGee Software, Inc. All rights reserved.

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

=cut
PK       ! ��[|9  |9    perl5/IO/WrapTie.pmnu ��6�$        package IO::WrapTie;

use strict;
use Exporter;

# Inheritance, exporting, and package version:
our @ISA     = qw(Exporter);
our @EXPORT  = qw(wraptie);
our $VERSION = '2.113';

# Function, exported.
sub wraptie {
    IO::WrapTie::Master->new(@_);
}

# Class method; BACKWARDS-COMPATIBILITY ONLY!
sub new {
    shift;
    IO::WrapTie::Master->new(@_);
}


#------------------------------------------------------------
package # hide from pause
    IO::WrapTie::Master;
#------------------------------------------------------------

use strict;
use vars qw($AUTOLOAD);
use IO::Handle;

# We inherit from IO::Handle to get methods which invoke i/o operators,
# like print(), on our tied handle:
our @ISA = qw(IO::Handle);

#------------------------------
# new SLAVE, TIEARGS...
#------------------------------
# Create a new subclass of IO::Handle which...
#
#   (1) Handles i/o OPERATORS because it is tied to an instance of
#       an i/o-like class, like IO::Scalar.
#
#   (2) Handles i/o METHODS by delegating them to that same tied object!.
#
# Arguments are the slave class (e.g., IO::Scalar), followed by all
# the arguments normally sent into that class's C<TIEHANDLE> method.
# In other words, much like the arguments to tie().  :-)
#
# NOTE:
# The thing $x we return must be a BLESSED REF, for ($x->print()).
# The underlying symbol must be a FILEHANDLE, for (print $x "foo").
# It has to have a way of getting to the "real" back-end object...
#
sub new {
    my $master = shift;
    my $io = IO::Handle->new;   ### create a new handle
    my $slave = shift;
    tie *$io, $slave, @_;       ### tie: will invoke slave's TIEHANDLE
    bless $io, $master;         ### return a master
}

#------------------------------
# AUTOLOAD
#------------------------------
# Delegate method invocations on the master to the underlying slave.
#
sub AUTOLOAD {
    my $method = $AUTOLOAD;
    $method =~ s/.*:://;
    my $self = shift; tied(*$self)->$method(\@_);
}

#------------------------------
# PRELOAD
#------------------------------
# Utility.
#
# Most methods like print(), getline(), etc. which work on the tied object
# via Perl's i/o operators (like 'print') are inherited from IO::Handle.
#
# Other methods, like seek() and sref(), we must delegate ourselves.
# AUTOLOAD takes care of these.
#
# However, it may be necessary to preload delegators into your
# own class.  PRELOAD will do this.
#
sub PRELOAD {
    my $class = shift;
    foreach (@_) {
	eval "sub ${class}::$_ { my \$s = shift; tied(*\$s)->$_(\@_) }";
    }
}

# Preload delegators for some standard methods which we can't simply
# inherit from IO::Handle... for example, some IO::Handle methods
# assume that there is an underlying file descriptor.
#
PRELOAD IO::WrapTie::Master
    qw(open opened close read clearerr eof seek tell setpos getpos);


#------------------------------------------------------------
package # hide from pause
    IO::WrapTie::Slave;
#------------------------------------------------------------
# Teeny private class providing a new_tie constructor...
#
# HOW IT ALL WORKS:
#
# Slaves inherit from this class.
#
# When you send a new_tie() message to a tie-slave class (like IO::Scalar),
# it first determines what class should provide its master, via TIE_MASTER.
# In this case, IO::Scalar->TIE_MASTER would return IO::Scalar::Master.
# Then, we create a new master (an IO::Scalar::Master) with the same args
# sent to new_tie.
#
# In general, the new() method of the master is inherited directly
# from IO::WrapTie::Master.
#
sub new_tie {
    my $self = shift;
    $self->TIE_MASTER->new($self,@_);     ### e.g., IO::Scalar::Master->new(@_)
}

# Default class method for new_tie().
# All your tie-slave class (like IO::Scalar) has to do is override this
# method with a method that returns the name of an appropriate "master"
# class for tying that slave.
#
sub TIE_MASTER { 'IO::WrapTie::Master' }

#------------------------------
1;
__END__


package IO::WrapTie;      ### for doc generator


=head1 NAME

IO::WrapTie - wrap tieable objects in IO::Handle interface

I<This is currently Alpha code, released for comments.
  Please give me your feedback!>


=head1 SYNOPSIS

First of all, you'll need tie(), so:

   require 5.004;

I<Function interface (experimental).>
Use this with any existing class...

   use IO::WrapTie;
   use FooHandle;                  ### implements TIEHANDLE interface

   ### Suppose we want a "FooHandle->new(&FOO_RDWR, 2)".
   ### We can instead say...

   $FH = wraptie('FooHandle', &FOO_RDWR, 2);

   ### Now we can use...
   print $FH "Hello, ";            ### traditional operator syntax...
   $FH->print("world!\n");         ### ...and OO syntax as well!

I<OO interface (preferred).>
You can inherit from the L<IO::WrapTie/"Slave"> mixin to get a
nifty C<new_tie()> constructor...

   #------------------------------
   package FooHandle;                        ### a class which can TIEHANDLE

   use IO::WrapTie;
   @ISA = qw(IO::WrapTie::Slave);            ### inherit new_tie()
   ...


   #------------------------------
   package main;

   $FH = FooHandle->new_tie(&FOO_RDWR, 2);   ### $FH is an IO::WrapTie::Master
   print $FH "Hello, ";                      ### traditional operator syntax
   $FH->print("world!\n");                   ### OO syntax

See IO::Scalar as an example.  It also shows you how to create classes
which work both with and without 5.004.


=head1 DESCRIPTION

Suppose you have a class C<FooHandle>, where...

=over 4

=item *

C<FooHandle> does not inherit from L<IO::Handle>. That is, it performs
file handle-like I/O, but to something other than an underlying
file descriptor. Good examples are L<IO::Scalar> (for printing to a
string) and L<IO::Lines> (for printing to an array of lines).

=item *

C<FooHandle> implements the C<TIEHANDLE> interface (see L<perltie>).
That is, it provides methods C<TIEHANDLE>, C<GETC>, C<PRINT>, C<PRINTF>,
C<READ>, and C<READLINE>.

=item *

C<FooHandle> implements the traditional OO interface of
L<FileHandle> and L<IO::Handle>. i.e., it contains methods like C<getline>,
C<read>, C<print>, C<seek>, C<tell>, C<eof>, etc.

=back


Normally, users of your class would have two options:


=over 4

=item *

B<Use only OO syntax,> and forsake named I/O operators like C<print>.

=item *

B<Use with tie,> and forsake treating it as a first-class object
(i.e., class-specific methods can only be invoked through the underlying
object via C<tied>... giving the object a "split personality").

=back


But now with L<IO::WrapTie>, you can say:

    $WT = wraptie('FooHandle', &FOO_RDWR, 2);
    $WT->print("Hello, world\n");   ### OO syntax
    print $WT "Yes!\n";             ### Named operator syntax too!
    $WT->weird_stuff;               ### Other methods!

And if you're authoring a class like C<FooHandle>, just have it inherit
from C<IO::WrapTie::Slave> and that first line becomes even prettier:

    $WT = FooHandle->new_tie(&FOO_RDWR, 2);

B<The bottom line:> now, almost any class can look and work exactly like
an L<IO::Handle> and be used both with OO and non-OO file handle syntax.


=head1 HOW IT ALL WORKS


=head2 The data structures

Consider this example code, using classes in this distribution:

    use IO::Scalar;
    use IO::WrapTie;

    $WT = wraptie('IO::Scalar',\$s);
    print $WT "Hello, ";
    $WT->print("world!\n");

In it, the C<wraptie> function creates a data structure as follows:

                          * $WT is a blessed reference to a tied filehandle
              $WT           glob; that glob is tied to the "Slave" object.
               |          * You would do all your i/o with $WT directly.
               |
               |
               |     ,---isa--> IO::WrapTie::Master >--isa--> IO::Handle
               V    /
        .-------------.
        |             |
        |             |   * Perl i/o operators work on the tied object,
        |  "Master"   |     invoking the C<TIEHANDLE> methods.
        |             |   * Method invocations are delegated to the tied
        |             |     slave.
        `-------------'
               |
    tied(*$WT) |     .---isa--> IO::WrapTie::Slave
               V    /
        .-------------.
        |             |
        |   "Slave"   |   * Instance of FileHandle-like class which doesn't
        |             |     actually use file descriptors, like IO::Scalar.
        |  IO::Scalar |   * The slave can be any kind of object.
        |             |   * Must implement the C<TIEHANDLE> interface.
        `-------------'


I<NOTE:> just as an L<IO::Handle> is really just a blessed reference to a
I<traditional> file handle glob. So also, an C<IO::WrapTie::Master>
is really just a blessed reference to a file handle
glob I<which has been tied to some "slave" class.>


=head2 How C<wraptie> works

=over 4

=item 1.

The call to function C<wraptie(SLAVECLASS, TIEARGS...)> is
passed onto C<IO::WrapTie::Master::new()>.
Note that class C<IO::WrapTie::Master> is a subclass of L<IO::Handle>.

=item 2.

The C<< IO::WrapTie::Master->new >> method creates a new L<IO::Handle> object,
re-blessed into class C<IO::WrapTie::Master>. This object is the I<master>,
which will be returned from the constructor. At the same time...

=item 3.

The C<new> method also creates the I<slave>: this is an instance
of C<SLAVECLASS> which is created by tying the master's L<IO::Handle>
to C<SLAVECLASS> via C<tie>.
This call to C<tie> creates the slave in the following manner:

=item 4.

Class C<SLAVECLASS> is sent the message C<TIEHANDLE>; it
will usually delegate this to C<< SLAVECLASS->new(TIEARGS) >>, resulting
in a new instance of C<SLAVECLASS> being created and returned.

=item 5.

Once both master and slave have been created, the master is returned
to the caller.

=back


=head2 How I/O operators work (on the master)

Consider using an i/o operator on the master:

    print $WT "Hello, world!\n";

Since the master C<$WT> is really a C<blessed> reference to a glob,
the normal Perl I/O operators like C<print> may be used on it.
They will just operate on the symbol part of the glob.

Since the glob is tied to the slave, the slave's C<PRINT> method
(part of the C<TIEHANDLE> interface) will be automatically invoked.

If the slave is an L<IO::Scalar>, that means L<IO::Scalar/"PRINT"> will be
invoked, and that method happens to delegate to the C<print> method
of the same class.  So the I<real> work is ultimately done by
L<IO::Scalar/"print">.


=head2 How methods work (on the master)

Consider using a method on the master:

    $WT->print("Hello, world!\n");

Since the master C<$WT> is blessed into the class C<IO::WrapTie::Master>,
Perl first attempts to find a C<print> method there.  Failing that,
Perl next attempts to find a C<print> method in the super class,
L<IO::Handle>.  It just so happens that there I<is> such a method;
that method merely invokes the C<print> I/O operator on the self object...
and for that, see above!

But let's suppose we're dealing with a method which I<isn't> part
of L<IO::Handle>... for example:

    my $sref = $WT->sref;

In this case, the intuitive behavior is to have the master delegate the
method invocation to the slave (now do you see where the designations
come from?).  This is indeed what happens: C<IO::WrapTie::Master> contains
an C<AUTOLOAD> method which performs the delegation.

So: when C<sref> can't be found in L<IO::Handle>, the C<AUTOLOAD> method
of C<IO::WrapTie::Master> is invoked, and the standard behavior of
delegating the method to the underlying slave (here, an L<IO::Scalar>)
is done.

Sometimes, to get this to work properly, you may need to create
a subclass of C<IO::WrapTie::Master> which is an effective master for
I<your> class, and do the delegation there.

=head1 NOTES

B<Why not simply use the object's OO interface?>

Because that means forsaking the use of named operators
like C<print>, and you may need to pass the object to a subroutine
which will attempt to use those operators:

    $O = FooHandle->new(&FOO_RDWR, 2);
    $O->print("Hello, world\n");  ### OO syntax is okay, BUT....

    sub nope { print $_[0] "Nope!\n" }
 X  nope($O);                     ### ERROR!!! (not a glob ref)


B<Why not simply use tie()?>
    Because (1) you have to use C<tied> to invoke methods in the
object's public interface (yuck), and (2) you may need to pass
the tied symbol to another subroutine which will attempt to treat
it in an OO-way... and that will break it:

    tie *T, 'FooHandle', &FOO_RDWR, 2;
    print T "Hello, world\n";   ### Operator is okay, BUT...

    tied(*T)->other_stuff;      ### yuck! AND...

    sub nope { shift->print("Nope!\n") }
 X  nope(\*T);                  ### ERROR!!! (method "print" on unblessed ref)


B<Why a master and slave?>

    Why not simply write C<FooHandle> to inherit from L<IO::Handle?>
I tried this, with an implementation similar to that of L<IO::Socket>.
The problem is that I<the whole point is to use this with objects
that don't have an underlying file/socket descriptor.>.
Subclassing L<IO::Handle> will work fine for the OO stuff, and fine with
named operators I<if> you C<tie>... but if you just attempt to say:

    $IO = FooHandle->new(&FOO_RDWR, 2);
    print $IO "Hello!\n";

you get a warning from Perl like:

    Filehandle GEN001 never opened

because it's trying to do system-level I/O on an (unopened) file
descriptor.  To avoid this, you apparently have to C<tie> the handle...
which brings us right back to where we started!  At least the
L<IO::WrapTie> mixin lets us say:

    $IO = FooHandle->new_tie(&FOO_RDWR, 2);
    print $IO "Hello!\n";

and so is not I<too> bad.  C<:-)>


=head1 WARNINGS

Remember: this stuff is for doing L<FileHandle>-like I/O on things
I<without underlying file descriptors>.  If you have an underlying
file descriptor, you're better off just inheriting from L<IO::Handle>.

B<Be aware that new_tie() always returns an instance of a
kind of IO::WrapTie::Master...> it does B<not> return an instance
of the I/O class you're tying to!

Invoking some methods on the master object causes C<AUTOLOAD> to delegate
them to the slave object... so it I<looks> like you're manipulating a
C<FooHandle> object directly, but you're not.

I have not explored all the ramifications of this use of C<tie>.
I<Here there be dragons>.

=head1 AUTHOR

Eryq (F<eryq@zeegee.com>).
President, ZeeGee Software Inc (F<http://www.zeegee.com>).

=head1 CONTRIBUTORS

Dianne Skoll (F<dfs@roaringpenguin.com>).

=head1 COPYRIGHT & LICENSE

Copyright (c) 1997 Erik (Eryq) Dorfman, ZeeGee Software, Inc. All rights reserved.

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

=cut
PK       ! &��'�   �     perl5/IO/Tee.pmnu ��6�$        package IO::Tee;

require 5.006;
use strict;
use warnings;

use parent 'IO::Handle';

use Carp;
use Symbol;
use IO::Handle;
use IO::File;

our $VERSION = '0.65';

# Constructor -- bless array reference into our class

sub new
{
    my $class = shift;
    my $self = gensym;
    @{*$self} = map {
        ! ref($_) ? IO::File->new($_)
        : ref($_) eq 'ARRAY' ? IO::File->new(@$_)
        : ref($_) eq 'GLOB' ? bless $_, 'IO::Handle'
        : $_ or return undef } @_;
    bless $self, $class;
    tie *$self, $class, $self;
    return $self;
}

# Return a list of all associated handles

sub handles
{
    @{*{$_[0]}};
}

# Proxy routines for various IO::Handle and IO::File operations

sub _method_return_success
{
    my $method = (caller(1))[3];
    $method =~ s/.*:://;

    my $self = shift;
    my $ret = 1;
    foreach my $fh (@{*$self}) { undef $ret unless $fh->$method(@_) }
    return $ret;
}

sub close        { _method_return_success(@_) }
sub truncate     { _method_return_success(@_) }
sub write        { _method_return_success(@_) }
sub syswrite     { _method_return_success(@_) }
sub format_write { _method_return_success(@_) }
sub fcntl        { _method_return_success(@_) }
sub ioctl        { _method_return_success(@_) }
sub flush        { _method_return_success(@_) }
sub clearerr     { _method_return_success(@_) }
sub seek         { _method_return_success(@_) }

sub formline
{
    my $self = shift;
    my $picture = shift;
    local($^A) = $^A;
    local($\) = "";
    formline($picture, @_);

    my $ret = 1;
    foreach my $fh (@{*$self}) { undef $ret unless print $fh $^A }
    return $ret;
}

sub _state_modify
{
    my $method = (caller(1))[3];
    $method =~ s/.*:://;
    croak "$method values cannot be retrieved collectively" if @_ <= 1;

    my $self = shift;
    if (ref $self)
    {
        foreach my $fh (@{*$self}) { $fh->$method(@_) }
    }
    else
    {
        IO::Handle->$method(@_);
    }
    # Note that we do not return any "previous value" here
}

sub autoflush                    { _state_modify(@_) }
sub output_field_separator       { _state_modify(@_) }
sub output_record_separator      { _state_modify(@_) }
sub format_page_number           { _state_modify(@_) }
sub format_lines_per_page        { _state_modify(@_) }
sub format_lines_left            { _state_modify(@_) }
sub format_name                  { _state_modify(@_) }
sub format_top_name              { _state_modify(@_) }
sub format_line_break_characters { _state_modify(@_) }
sub format_formfeed              { _state_modify(@_) }

sub input_record_separator
{
    my $self = shift;
    my $ret = (ref $self ? ${*$self}[0] : 'IO::Handle')
        ->input_record_separator(@_);
    $ret; # This works around an apparent bug in Perl 5.004_04
}

sub input_line_number
{
    my $self = shift;
    my $ret = ${*$self}[0]->input_line_number(@_);
    $ret; # This works around an apparent bug in Perl 5.004_04
}

# File handle tying interface

sub TIEHANDLE
{
    my ($class, $self) = @_;
    return bless *$self{ARRAY}, $class;
}

sub PRINT
{
    my $self = shift;
    my $ret = 1;
    foreach my $fh (@$self) { undef $ret unless print $fh @_ }
    return $ret;
}

sub PRINTF
{
    my $self = shift;
    my $fmt = shift;
    my $ret = 1;
    foreach my $fh (@$self) { undef $ret unless printf $fh $fmt, @_ }
    return $ret;
}

sub _multiplex_input
{
    my ($self, $input) = @_;
    my $ret = 1;
    if (length $input)
    {
        for (my $i = 1; $i < @$self; ++$i)
        {
            undef $ret unless print {$self->[$i]} $input;
        }
    }
    $ret;
}

sub READ
{
    my $self = shift;
    my $bytes = $self->[0]->read(@_);
    $bytes and $self->_multiplex_input(substr($_[0], $_[2], $bytes));
    $bytes;
}

sub READLINE
{
    my $self = shift;
    my $infh = $self->[0];
    if (wantarray)
    {
        my @data;
        my $data;
        while (defined($data = <$infh>) and length($data))
        {
            push @data, $data;
            $self->_multiplex_input($data);
        }
        @data;
    }
    else
    {
        my $data = <$infh>;
        defined $data and $self->_multiplex_input($data);
        $data;
    }
}

sub GETC
{
    my $self = shift;
    my $data = getc($self->[0]);
    defined $data and $self->_multiplex_input($data);
    $data;
}

sub sysread
{
    my $self = shift;
    my $bytes = ${*$self}[0]->sysread(@_);
    $bytes and (\@{*$self})->
        _multiplex_input(substr($_[0], $_[2] || 0, $bytes));
    $bytes;
}

sub EOF
{
    my $self = shift;
    return $self->[0]->eof;
}

1;
__END__

=head1 NAME

IO::Tee - Multiplex output to multiple output handles

=head1 SYNOPSIS

    use IO::Tee;

    $tee = IO::Tee->new($handle1, $handle2);
    print $tee "foo", "bar";
    my $input = <$tee>;

=head1 DESCRIPTION

C<IO::Tee> objects can be used to multiplex input and output in two
different ways.  The first way is to multiplex output to zero or more
output handles.  The C<IO::Tee> constructor, given a list of output
handles, returns a tied handle that can be written to.  When written
to (using print or printf), the C<IO::Tee> object multiplexes the
output to the list of handles originally passed to the constructor.
As a shortcut, you can also directly pass a string or an array
reference to the constructor, in which case C<IO::File::new> is called
for you with the specified argument or arguments.

The second way is to multiplex input from one input handle to zero or
more output handles as it is being read.  The C<IO::Tee> constructor,
given an input handle followed by a list of output handles, returns a
tied handle that can be read from as well as written to.  When written
to, the C<IO::Tee> object multiplexes the output to all handles passed
to the constructor, as described in the previous paragraph.  When read
from, the C<IO::Tee> object reads from the input handle given as the
first argument to the C<IO::Tee> constructor, then writes any data
read to the output handles given as the remaining arguments to the
constructor.

The C<IO::Tee> class supports certain C<IO::Handle> and C<IO::File>
methods related to input and output.  In particular, the following
methods will iterate themselves over all handles associated with the
C<IO::Tee> object, and return TRUE indicating success if and only if
all associated handles returned TRUE indicating success:

=over 4

=item close

=item truncate

=item write

=item syswrite

=item format_write

=item formline

=item fcntl

=item ioctl

=item flush

=item clearerr

=item seek

=back

The following methods perform input multiplexing as described above:

=over 4

=item read

=item sysread

=item readline

=item getc

=item gets

=item eof

=item getline

=item getlines

=back

The following methods can be used to set (but not retrieve) the
current values of output-related state variables on all associated
handles:

=over 4

=item autoflush

=item output_field_separator

=item output_record_separator

=item format_page_number

=item format_lines_per_page

=item format_lines_left

=item format_name

=item format_top_name

=item format_line_break_characters

=item format_formfeed

=back

The following methods are directly passed on to the input handle given
as the first argument to the C<IO::Tee> constructor:

=over 4

=item input_record_separator

=item input_line_number

=back

Note that the return value of input multiplexing methods (such as
C<print>) is always the return value of the input action, not the
return value of subsequent output actions.  In particular, no error is
indicated by the return value if the input action itself succeeds but
subsequent output multiplexing fails.

=head1 EXAMPLE

    use IO::Tee;
    use IO::File;

    my $tee = new IO::Tee(\*STDOUT,
        new IO::File(">tt1.out"), ">tt2.out");

    print join(' ', $tee->handles), "\n";

    for (1..10) { print $tee $_, "\n" }
    for (1..10) { $tee->print($_, "\n") }
    $tee->flush;

    $tee = new IO::Tee('</etc/passwd', \*STDOUT);
    my @lines = <$tee>;
    print scalar(@lines);

=head1 REPOSITORY

L<https://github.com/neilb/IO-Tee>

=head1 AUTHOR

Chung-chieh Shan, ken@digitas.harvard.edu

As of August 2017, now being maintained by Neil Bowers.

=head1 COPYRIGHT

Copyright (c) 1998-2017 Chung-chieh Shan.  All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=head1 SEE ALSO

L<perlfunc>, L<IO::Handle>, L<IO::File>.

=cut
PK       ! ���  �    perl5/IO/InnerFile.pmnu ��6�$        package IO::InnerFile;

use strict;
use warnings;
use Symbol;

our $VERSION = '2.113';

sub new {
   my ($class, $fh, $start, $lg) = @_;
   $start = 0 if (!$start or ($start < 0));
   $lg    = 0 if (!$lg    or ($lg    < 0));

   ### Create the underlying "object":
   my $a = {
      FH 	=> 	$fh,
      CRPOS 	=> 	0,
      START	=>	$start,
      LG	=>	$lg,
   };

   ### Create a new filehandle tied to this object:
   $fh = gensym;
   tie(*$fh, $class, $a);
   return bless($fh, $class);
}

sub TIEHANDLE {
   my ($class, $data) = @_;
   return bless($data, $class);
}

sub DESTROY {
   my ($self) = @_;
   $self->close() if (ref($self) eq 'SCALAR');
}

sub set_length { tied(${$_[0]})->{LG} = $_[1]; }
sub get_length { tied(${$_[0]})->{LG}; }
sub add_length { tied(${$_[0]})->{LG} += $_[1]; }

sub set_start  { tied(${$_[0]})->{START} = $_[1]; }
sub get_start  { tied(${$_[0]})->{START}; }
sub set_end    { tied(${$_[0]})->{LG} =  $_[1] - tied(${$_[0]})->{START}; }
sub get_end    { tied(${$_[0]})->{LG} + tied(${$_[0]})->{START}; }

sub write    { shift->WRITE(@_) }
sub print    { shift->PRINT(@_) }
sub printf   { shift->PRINTF(@_) }
sub flush    { "0 but true"; }
sub fileno   { }
sub binmode  { 1; }
sub getc     { return GETC(tied(${$_[0]}) ); }
sub read     { return READ(     tied(${$_[0]}), @_[1,2,3] ); }
sub readline { return READLINE( tied(${$_[0]}) ); }

sub getline  { return READLINE( tied(${$_[0]}) ); }
sub close    { return CLOSE(tied(${$_[0]}) ); }

sub seek {
   my ($self, $ofs, $whence) = @_;
   $self = tied( $$self );

   $self->{CRPOS} = $ofs if ($whence == 0);
   $self->{CRPOS}+= $ofs if ($whence == 1);
   $self->{CRPOS} = $self->{LG} + $ofs if ($whence == 2);

   $self->{CRPOS} = 0 if ($self->{CRPOS} < 0);
   $self->{CRPOS} = $self->{LG} if ($self->{CRPOS} > $self->{LG});
   return 1;
}

sub tell {
    return tied(${$_[0]})->{CRPOS};
}

sub WRITE  {
    die "inner files can only open for reading\n";
}

sub PRINT  {
    die "inner files can only open for reading\n";
}

sub PRINTF {
    die "inner files can only open for reading\n";
}

sub GETC   {
    my ($self) = @_;
    return 0 if ($self->{CRPOS} >= $self->{LG});

    my $data;

    ### Save and seek...
    my $old_pos = $self->{FH}->tell;
    $self->{FH}->seek($self->{CRPOS}+$self->{START}, 0);

    ### ...read...
    my $lg = $self->{FH}->read($data, 1);
    $self->{CRPOS} += $lg;

    ### ...and restore:
    $self->{FH}->seek($old_pos, 0);

    $self->{LG} = $self->{CRPOS} unless ($lg);
    return ($lg ? $data : undef);
}

sub READ   {
    my ($self, $undefined, $lg, $ofs) = @_;
    $undefined = undef;

    return 0 if ($self->{CRPOS} >= $self->{LG});
    $lg = $self->{LG} - $self->{CRPOS} if ($self->{CRPOS} + $lg > $self->{LG});
    return 0 unless ($lg);

    ### Save and seek...
    my $old_pos = $self->{FH}->tell;
    $self->{FH}->seek($self->{CRPOS}+$self->{START}, 0);

    ### ...read...
    $lg = $self->{FH}->read($_[1], $lg, $_[3] );
    $self->{CRPOS} += $lg;

    ### ...and restore:
    $self->{FH}->seek($old_pos, 0);

    $self->{LG} = $self->{CRPOS} unless ($lg);
    return $lg;
}

sub READLINE {
    my ($self) = @_;
    return $self->_readline_helper() unless wantarray;
    my @arr;
    while(defined(my $line = $self->_readline_helper())) {
	    push(@arr, $line);
    }
    return @arr;
}

sub _readline_helper {
    my ($self) = @_;
    return undef if ($self->{CRPOS} >= $self->{LG});

    # Handle slurp mode (CPAN ticket #72710)
    if (! defined($/)) {
	    my $text;
	    $self->READ($text, $self->{LG} - $self->{CRPOS});
	    return $text;
    }

    ### Save and seek...
    my $old_pos = $self->{FH}->tell;
    $self->{FH}->seek($self->{CRPOS}+$self->{START}, 0);

    ### ...read...
    my $text = $self->{FH}->getline;

    ### ...and restore:
    $self->{FH}->seek($old_pos, 0);

    #### If we detected a new EOF ...
    unless (defined $text) {
       $self->{LG} = $self->{CRPOS};
       return undef;
    }

    my $lg=length($text);

    $lg = $self->{LG} - $self->{CRPOS} if ($self->{CRPOS} + $lg > $self->{LG});
    $self->{CRPOS} += $lg;

    return substr($text, 0,$lg);
}

sub CLOSE { %{$_[0]}=(); }


1;
__END__

__END__


=head1 NAME

IO::InnerFile - define a file inside another file

=head1 SYNOPSIS

    use strict;
    use warnings;
    use IO::InnerFile;

    # Read a subset of a file:
    my $fh = _some_file_handle;
    my $start = 10;
    my $length = 50;
    my $inner = IO::InnerFile->new($fh, $start, $length);
    while (my $line = <$inner>) {
        # ...
    }


=head1 DESCRIPTION

If you have a file handle that can C<seek> and C<tell>, then you
can open an L<IO::InnerFile> on a range of the underlying file.

=head1 CONSTRUCTORS

L<IO::InnerFile> implements the following constructors.

=head2 new

    my $inner = IO::InnerFile->new($fh);
    $inner = IO::InnerFile->new($fh, 10);
    $inner = IO::InnerFile->new($fh, 10, 50);

Create a new L<IO::InnerFile> opened on the given file handle.
The file handle supplied B<MUST> be able to both C<seek> and C<tell>.

The second and third parameters are start and length. Both are defaulted
to zero (C<0>). Negative values are silently coerced to zero.

=head1 METHODS

L<IO::InnerFile> implements the following methods.

=head2 add_length

    $inner->add_length(30);

Add to the virtual length of the inner file by the number given in bytes.

=head2 add_start

    $inner->add_start(30);

Add to the virtual position of the inner file by the number given in bytes.

=head2 binmode

    $inner->binmode();

This is a NOOP method just to satisfy the normal L<IO::File> interface.

=head2 close

=head2 fileno

    $inner->fileno();

This is a NOOP method just to satisfy the normal L<IO::File> interface.

=head2 flush

    $inner->flush();

This is a NOOP method just to satisfy the normal L<IO::File> interface.

=head2 get_end

    my $num_bytes = $inner->get_end();

Get the virtual end position of the inner file in bytes.

=head2 get_length

    my $num_bytes = $inner->get_length();

Get the virtual length of the inner file in bytes.

=head2 get_start

    my $num_bytes = $inner->get_start();

Get the virtual position of the inner file in bytes.

=head2 getc

=head2 getline

=head2 print LIST

=head2 printf

=head2 read

=head2 readline

=head2 seek

=head2 set_end

    $inner->set_end(30);

Set the virtual end of the inner file in bytes (this basically just alters the length).

=head2 set_length

    $inner->set_length(30);

Set the virtual length of the inner file in bytes.

=head2 set_start

    $inner->set_start(30);

Set the virtual start position of the inner file in bytes.

=head2 tell

=head2 write

=head1 AUTHOR

Eryq (F<eryq@zeegee.com>).
President, ZeeGee Software Inc (F<http://www.zeegee.com>).

=head1 CONTRIBUTORS

Dianne Skoll (F<dfs@roaringpenguin.com>).

=head1 COPYRIGHT & LICENSE

Copyright (c) 1997 Erik (Eryq) Dorfman, ZeeGee Software, Inc. All rights reserved.

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

=cut
PK       ! l��]?@  ?@    perl5/IO/ScalarArray.pmnu ��6�$        package IO::ScalarArray;

use strict;
use Carp;
use IO::Handle;

# The package version, both in 1.23 style *and* usable by MakeMaker:
our $VERSION = '2.113';

# Inheritance:
our @ISA = qw(IO::Handle);
require IO::WrapTie and push @ISA, 'IO::WrapTie::Slave' if ($] >= 5.004);

=head1 NAME

IO::ScalarArray - IO:: interface for reading/writing an array of scalars


=head1 SYNOPSIS

Perform I/O on strings, using the basic OO interface...

    use IO::ScalarArray;
    @data = ("My mes", "sage:\n");

    ### Open a handle on an array, and append to it:
    $AH = new IO::ScalarArray \@data;
    $AH->print("Hello");
    $AH->print(", world!\nBye now!\n");
    print "The array is now: ", @data, "\n";

    ### Open a handle on an array, read it line-by-line, then close it:
    $AH = new IO::ScalarArray \@data;
    while (defined($_ = $AH->getline)) {
	print "Got line: $_";
    }
    $AH->close;

    ### Open a handle on an array, and slurp in all the lines:
    $AH = new IO::ScalarArray \@data;
    print "All lines:\n", $AH->getlines;

    ### Get the current position (either of two ways):
    $pos = $AH->getpos;
    $offset = $AH->tell;

    ### Set the current position (either of two ways):
    $AH->setpos($pos);
    $AH->seek($offset, 0);

    ### Open an anonymous temporary array:
    $AH = new IO::ScalarArray;
    $AH->print("Hi there!");
    print "I printed: ", @{$AH->aref}, "\n";      ### get at value


Don't like OO for your I/O?  No problem.
Thanks to the magic of an invisible tie(), the following now
works out of the box, just as it does with IO::Handle:

    use IO::ScalarArray;
    @data = ("My mes", "sage:\n");

    ### Open a handle on an array, and append to it:
    $AH = new IO::ScalarArray \@data;
    print $AH "Hello";
    print $AH ", world!\nBye now!\n";
    print "The array is now: ", @data, "\n";

    ### Open a handle on a string, read it line-by-line, then close it:
    $AH = new IO::ScalarArray \@data;
    while (<$AH>) {
	print "Got line: $_";
    }
    close $AH;

    ### Open a handle on a string, and slurp in all the lines:
    $AH = new IO::ScalarArray \@data;
    print "All lines:\n", <$AH>;

    ### Get the current position (WARNING: requires 5.6):
    $offset = tell $AH;

    ### Set the current position (WARNING: requires 5.6):
    seek $AH, $offset, 0;

    ### Open an anonymous temporary scalar:
    $AH = new IO::ScalarArray;
    print $AH "Hi there!";
    print "I printed: ", @{$AH->aref}, "\n";      ### get at value


And for you folks with 1.x code out there: the old tie() style still works,
though this is I<unnecessary and deprecated>:

    use IO::ScalarArray;

    ### Writing to a scalar...
    my @a;
    tie *OUT, 'IO::ScalarArray', \@a;
    print OUT "line 1\nline 2\n", "line 3\n";
    print "Array is now: ", @a, "\n"

    ### Reading and writing an anonymous scalar...
    tie *OUT, 'IO::ScalarArray';
    print OUT "line 1\nline 2\n", "line 3\n";
    tied(OUT)->seek(0,0);
    while (<OUT>) {
        print "Got line: ", $_;
    }


=head1 DESCRIPTION

This class is part of the IO::Stringy distribution;
see L<IO::Stringy> for change log and general information.

The IO::ScalarArray class implements objects which behave just like
IO::Handle (or FileHandle) objects, except that you may use them
to write to (or read from) arrays of scalars.  Logically, an
array of scalars defines an in-core "file" whose contents are
the concatenation of the scalars in the array.  The handles created by
this class are automatically C<tiehandle>d (though please see L<"WARNINGS">
for information relevant to your Perl version).

For writing large amounts of data with individual print() statements,
this class is likely to be more efficient than IO::Scalar.

Basically, this:

    my @a;
    $AH = new IO::ScalarArray \@a;
    $AH->print("Hel", "lo, ");         ### OO style
    $AH->print("world!\n");            ### ditto

Or this:

    my @a;
    $AH = new IO::ScalarArray \@a;
    print $AH "Hel", "lo, ";           ### non-OO style
    print $AH "world!\n";              ### ditto

Causes @a to be set to the following array of 3 strings:

    ( "Hel" ,
      "lo, " ,
      "world!\n" )

See L<IO::Scalar> and compare with this class.


=head1 PUBLIC INTERFACE

=head2 Construction

=over 4

=cut

#------------------------------

=item new [ARGS...]

I<Class method.>
Return a new, unattached array handle.
If any arguments are given, they're sent to open().

=cut

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self = bless \do { local *FH }, $class;
    tie *$self, $class, $self;
    $self->open(@_);  ### open on anonymous by default
    $self;
}
sub DESTROY {
    shift->close;
}


#------------------------------

=item open [ARRAYREF]

I<Instance method.>
Open the array handle on a new array, pointed to by ARRAYREF.
If no ARRAYREF is given, a "private" array is created to hold
the file data.

Returns the self object on success, undefined on error.

=cut

sub open {
    my ($self, $aref) = @_;

    ### Sanity:
    defined($aref) or do {my @a; $aref = \@a};
    (ref($aref) eq "ARRAY") or croak "open needs a ref to a array";

    ### Setup:
    $self->setpos([0,0]);
    *$self->{AR} = $aref;
    $self;
}

#------------------------------

=item opened

I<Instance method.>
Is the array handle opened on something?

=cut

sub opened {
    *{shift()}->{AR};
}

#------------------------------

=item close

I<Instance method.>
Disassociate the array handle from its underlying array.
Done automatically on destroy.

=cut

sub close {
    my $self = shift;
    %{*$self} = ();
    1;
}

=back

=cut


#==============================

=head2 Input and output

=over 4

=cut

#------------------------------

=item flush

I<Instance method.>
No-op, provided for OO compatibility.

=cut

sub flush { "0 but true" }

#------------------------------

=item fileno

I<Instance method.>
No-op, returns undef

=cut

sub fileno { }

#------------------------------

=item getc

I<Instance method.>
Return the next character, or undef if none remain.
This does a read(1), which is somewhat costly.

=cut

sub getc {
    my $buf = '';
    ($_[0]->read($buf, 1) ? $buf : undef);
}

#------------------------------

=item getline

I<Instance method.>
Return the next line, or undef on end of data.
Can safely be called in an array context.
Currently, lines are delimited by "\n".

=cut

sub getline {
    my $self = shift;
    my ($str, $line) = (undef, '');


    ### Minimal impact implementation!
    ### We do the fast thing (no regexps) if using the
    ### classic input record separator.

    ### Case 1: $/ is undef: slurp all...
    if    (!defined($/)) {

        return undef if ($self->eof);

	### Get the rest of the current string, followed by remaining strings:
	my $ar = *$self->{AR};
	my @slurp = (
		     substr($ar->[*$self->{Str}], *$self->{Pos}),
		     @$ar[(1 + *$self->{Str}) .. $#$ar ]
		     );

	### Seek to end:
	$self->_setpos_to_eof;
	return join('', @slurp);
    }

    ### Case 2: $/ is "\n":
    elsif ($/ eq "\012") {

	### Until we hit EOF (or exited because of a found line):
	until ($self->eof) {
	    ### If at end of current string, go fwd to next one (won't be EOF):
	    if ($self->_eos) {++*$self->{Str}, *$self->{Pos}=0};

	    ### Get ref to current string in array, and set internal pos mark:
	    $str = \(*$self->{AR}[*$self->{Str}]); ### get current string
	    pos($$str) = *$self->{Pos};            ### start matching from here

	    ### Get from here to either \n or end of string, and add to line:
	    $$str =~ m/\G(.*?)((\n)|\Z)/g;         ### match to 1st \n or EOS
	    $line .= $1.$2;                        ### add it
	    *$self->{Pos} += length($1.$2);        ### move fwd by len matched
	    return $line if $3;                    ### done, got line with "\n"
        }
        return ($line eq '') ? undef : $line;  ### return undef if EOF
    }

    ### Case 3: $/ is ref to int.  Bail out.
    elsif (ref($/)) {
        croak '$/ given as a ref to int; currently unsupported';
    }

    ### Case 4: $/ is either "" (paragraphs) or something weird...
    ###         Bail for now.
    else {
        croak '$/ as given is currently unsupported';
    }
}

#------------------------------

=item getlines

I<Instance method.>
Get all remaining lines.
It will croak() if accidentally called in a scalar context.

=cut

sub getlines {
    my $self = shift;
    wantarray or croak("can't call getlines in scalar context!");
    my ($line, @lines);
    push @lines, $line while (defined($line = $self->getline));
    @lines;
}

#------------------------------

=item print ARGS...

I<Instance method.>
Print ARGS to the underlying array.

Currently, this always causes a "seek to the end of the array"
and generates a new array entry.  This may change in the future.

=cut

sub print {
    my $self = shift;
    push @{*$self->{AR}}, join('', @_) . (defined($\) ? $\ : "");      ### add the data
    $self->_setpos_to_eof;
    1;
}

#------------------------------

=item read BUF, NBYTES, [OFFSET];

I<Instance method.>
Read some bytes from the array.
Returns the number of bytes actually read, 0 on end-of-file, undef on error.

=cut

sub read {
    my $self = $_[0];
    ### we must use $_[1] as a ref
    my $n    = $_[2];
    my $off  = $_[3] || 0;

    ### print "getline\n";
    my $justread;
    my $len;
    ($off ? substr($_[1], $off) : $_[1]) = '';

    ### Stop when we have zero bytes to go, or when we hit EOF:
    my @got;
    until (!$n or $self->eof) {
        ### If at end of current string, go forward to next one (won't be EOF):
        if ($self->_eos) {
            ++*$self->{Str};
            *$self->{Pos} = 0;
        }

        ### Get longest possible desired substring of current string:
        $justread = substr(*$self->{AR}[*$self->{Str}], *$self->{Pos}, $n);
        $len = length($justread);
        push @got, $justread;
        $n            -= $len;
        *$self->{Pos} += $len;
    }
    $_[1] .= join('', @got);
    return length($_[1])-$off;
}

#------------------------------

=item write BUF, NBYTES, [OFFSET];

I<Instance method.>
Write some bytes into the array.

=cut

sub write {
    my $self = $_[0];
    my $n    = $_[2];
    my $off  = $_[3] || 0;

    my $data = substr($_[1], $n, $off);
    $n = length($data);
    $self->print($data);
    return $n;
}


=back

=cut


#==============================

=head2 Seeking/telling and other attributes

=over 4

=cut

#------------------------------

=item autoflush

I<Instance method.>
No-op, provided for OO compatibility.

=cut

sub autoflush {}

#------------------------------

=item binmode

I<Instance method.>
No-op, provided for OO compatibility.

=cut

sub binmode {}

#------------------------------

=item clearerr

I<Instance method.>  Clear the error and EOF flags.  A no-op.

=cut

sub clearerr { 1 }

#------------------------------

=item eof

I<Instance method.>  Are we at end of file?

=cut

sub eof {
    ### print "checking EOF [*$self->{Str}, *$self->{Pos}]\n";
    ### print "SR = ", $#{*$self->{AR}}, "\n";

    return 0 if (*{$_[0]}->{Str} < $#{*{$_[0]}->{AR}});  ### before EOA
    return 1 if (*{$_[0]}->{Str} > $#{*{$_[0]}->{AR}});  ### after EOA
    ###                                                  ### at EOA, past EOS:
    ((*{$_[0]}->{Str} == $#{*{$_[0]}->{AR}}) && ($_[0]->_eos));
}

#------------------------------
#
# _eos
#
# I<Instance method, private.>  Are we at end of the CURRENT string?
#
sub _eos {
    (*{$_[0]}->{Pos} >= length(*{$_[0]}->{AR}[*{$_[0]}->{Str}])); ### past last char
}

#------------------------------

=item seek POS,WHENCE

I<Instance method.>
Seek to a given position in the stream.
Only a WHENCE of 0 (SEEK_SET) is supported.

=cut

sub seek {
    my ($self, $pos, $whence) = @_;

    ### Seek:
    if    ($whence == 0) { $self->_seek_set($pos); }
    elsif ($whence == 1) { $self->_seek_cur($pos); }
    elsif ($whence == 2) { $self->_seek_end($pos); }
    else                 { croak "bad seek whence ($whence)" }
    return 1;
}

#------------------------------
#
# _seek_set POS
#
# Instance method, private.
# Seek to $pos relative to start:
#
sub _seek_set {
    my ($self, $pos) = @_;

    ### Advance through array until done:
    my $istr = 0;
    while (($pos >= 0) && ($istr < scalar(@{*$self->{AR}}))) {
	if (length(*$self->{AR}[$istr]) > $pos) {   ### it's in this string!
	    return $self->setpos([$istr, $pos]);
	}
	else {                                      ### it's in next string
	    $pos -= length(*$self->{AR}[$istr++]);  ### move forward one string
	}
    }
    ### If we reached this point, pos is at or past end; zoom to EOF:
    return $self->_setpos_to_eof;
}

#------------------------------
#
# _seek_cur POS
#
# Instance method, private.
# Seek to $pos relative to current position.
#
sub _seek_cur {
    my ($self, $pos) = @_;
    $self->_seek_set($self->tell + $pos);
}

#------------------------------
#
# _seek_end POS
#
# Instance method, private.
# Seek to $pos relative to end.
# We actually seek relative to beginning, which is simple.
#
sub _seek_end {
    my ($self, $pos) = @_;
    $self->_seek_set($self->_tell_eof + $pos);
}

#------------------------------

=item tell

I<Instance method.>
Return the current position in the stream, as a numeric offset.

=cut

sub tell {
    my $self = shift;
    my $off = 0;
    my ($s, $str_s);
    for ($s = 0; $s < *$self->{Str}; $s++) {   ### count all "whole" scalars
	defined($str_s = *$self->{AR}[$s]) or $str_s = '';
	###print STDERR "COUNTING STRING $s (". length($str_s) . ")\n";
	$off += length($str_s);
    }
    ###print STDERR "COUNTING POS ($self->{Pos})\n";
    return ($off += *$self->{Pos});            ### plus the final, partial one
}

#------------------------------
#
# _tell_eof
#
# Instance method, private.
# Get position of EOF, as a numeric offset.
# This is identical to the size of the stream - 1.
#
sub _tell_eof {
    my $self = shift;
    my $len = 0;
    foreach (@{*$self->{AR}}) { $len += length($_) }
    $len;
}

#------------------------------

=item setpos POS

I<Instance method.>
Seek to a given position in the array, using the opaque getpos() value.
Don't expect this to be a number.

=cut

sub setpos {
    my ($self, $pos) = @_;
    (ref($pos) eq 'ARRAY') or
	die "setpos: only use a value returned by getpos!\n";
    (*$self->{Str}, *$self->{Pos}) = @$pos;
}

#------------------------------
#
# _setpos_to_eof
#
# Fast-forward to EOF.
#
sub _setpos_to_eof {
    my $self = shift;
    $self->setpos([scalar(@{*$self->{AR}}), 0]);
}

#------------------------------

=item getpos

I<Instance method.>
Return the current position in the array, as an opaque value.
Don't expect this to be a number.

=cut

sub getpos {
    [*{$_[0]}->{Str}, *{$_[0]}->{Pos}];
}

#------------------------------

=item aref

I<Instance method.>
Return a reference to the underlying array.

=cut

sub aref {
    *{shift()}->{AR};
}

=back

=cut

#------------------------------
# Tied handle methods...
#------------------------------

### Conventional tiehandle interface:
sub TIEHANDLE { (defined($_[1]) && UNIVERSAL::isa($_[1],"IO::ScalarArray"))
		    ? $_[1]
		    : shift->new(@_) }
sub GETC      { shift->getc(@_) }
sub PRINT     { shift->print(@_) }
sub PRINTF    { shift->print(sprintf(shift, @_)) }
sub READ      { shift->read(@_) }
sub READLINE  { wantarray ? shift->getlines(@_) : shift->getline(@_) }
sub WRITE     { shift->write(@_); }
sub CLOSE     { shift->close(@_); }
sub SEEK      { shift->seek(@_); }
sub TELL      { shift->tell(@_); }
sub EOF       { shift->eof(@_); }
sub BINMODE   { 1; }

#------------------------------------------------------------

1;
__END__

# SOME PRIVATE NOTES:
#
#     * The "current position" is the position before the next
#       character to be read/written.
#
#     * Str gives the string index of the current position, 0-based
#
#     * Pos gives the offset within AR[Str], 0-based.
#
#     * Inital pos is [0,0].  After print("Hello"), it is [1,0].

=head1 AUTHOR

Eryq (F<eryq@zeegee.com>).
President, ZeeGee Software Inc (F<http://www.zeegee.com>).

=head1 CONTRIBUTORS

Dianne Skoll (F<dfs@roaringpenguin.com>).

=head1 COPYRIGHT & LICENSE

Copyright (c) 1997 Erik (Eryq) Dorfman, ZeeGee Software, Inc. All rights reserved.

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

=cut
PK       ! q�߁�  �    perl5/HDB/MOD/oracle.pmnu ��6�$        #############################################################################
## Name:        oracle.pm
## Purpose:     HDB::MOD::oracle -> for DBD::Oracle
## Author:      Graciliano M. P.
## Modified by:
## Created:     14/01/2003
## RCS-ID:      
## Copyright:   (c) 2004 Graciliano M. P.
## Licence:     This program is free software; you can redistribute it and/or
##              modify it under the same terms as Perl itself
#############################################################################

package HDB::MOD::oracle ;
use DBD::Oracle ;

use strict qw(vars) ;
no warnings ;

our $VERSION = '1.0' ;
our @ISA = qw(HDB::MOD) ;

  my (%OPENED_DBH) ;

  my %SQL = (
  LIKE => 1 ,
  REGEXP => 0 ,
  LOCK_TABLE => 0 ,
  SHOW => 0 ,
  LIMIT => 0 ,
  TYPES => [qw(NUMBER VARCHAR VARCHAR2 BOOLEAN)] ,
  TYPES_MASK => {
                'BOOLEAN' => 'NUMBER(1)' ,
                } ,
  ) ;

#######
# NEW #
#######

sub new {
  my $this = shift ;

  $this->{SQL} = \%SQL ;
  $this->{name} = 'HDB::Oracle' ;
  
  bless($this , __PACKAGE__) ;
  return( $this ) ;
}

###########
# CONNECT #
###########

sub MOD_connect {
  my $this = shift ;
  my ( $pass ) = @_ ;
  
  my $db = $this->{db} ;
  my $host = $this->{host} ;
  
  $this->{dbh} = DBI->connect("DBI:Oracle:host=$host;sid=$db", $this->{user} , $pass , { RaiseError => 0 , PrintError => 1 , AutoCommit => 1 }) ;
  
  if (! $this->{dbh} ) { return $this->Error("Can't connect to db $db\@$host!") ;}
  
  return( $this->{dbh} ) ;
}

##############
# PRIMARYKEY #
##############

sub PRIMARYKEY { return "PRIMARY KEY" ;}

#################
# AUTOINCREMENT #
#################

sub AUTOINCREMENT { return "NUMBER PRIMARY KEY" ;}

#########
# LIMIT #
#########

sub LIMIT {
  my $this = shift ;
  my ( $sz , $offset ) = @_ ;
  
  my $into_where = $offset ? "rownum >= $offset && $offset <= " . ($offset+$sz) : "rownum <= $sz" ;
  
  return( undef , $into_where) ;
}

#############
# TYPE_TEXT #
#############

sub Type_TEXT {
  my $this = shift ;
  my ( $sz ) = @_ ;
  
  if ( $sz eq '0' ) { return $this->Type_INTEGER() ;}
  
  $sz = 65535 if $sz <= 0 ;
  
  my $ret = $sz <= 250 ? "VARCHAR($sz)" :
           ($sz <= 4000 ? "VARCHAR2($sz)" : "LONG") ;
  
  return $ret ;
}

################
# TYPE_INTEGER #
################

sub Type_INTEGER {
  my $this = shift ;
  my ( $sz ) = @_ ;
  
  $sz =~ s/\D+//g ;
  $sz = 10 if $sz <= 0 ;
  $sz = 38 if $sz > 38 ;
  
  return "NUMBER($sz)" ;
}

##############
# TYPE_FLOAT #
##############

sub Type_FLOAT {
  my $this = shift ;
  my ( $type , $args ) = @_ ;
  
  if ( $args !~ /\d/ ) { return "NUMBER(38)" ;}
  
  my $tp_arg ;
  if    ( $args =~ /(\d+)\D+(\d+)/ ) { $tp_arg = "($1,$2)" ;}
  elsif ( $args =~ /(\d+)/ ) { $tp_arg = "($1)" ;}
  
  return "NUMBER$tp_arg" ;
}

##########
# TABLES #
##########

sub tables {
  my $this = shift ;
  
  $this->{sql} = "SELECT TABLE_NAME FROM user_tables ORDER BY TABLE_NAME" ;
  
  eval{
    $this->_undef_sth ;
    $this->{sth} = $this->dbh->prepare( $this->{sql} ) ;
    $this->{sth}->execute ;
  };
  if ( $@ ) { $this->Error("SQL error: $this->{sql}") ;}
  
  my @tables = $this->Return('$') ;
  
  $this->_undef_sth ;
 
  return( sort @tables ) ;
}

#########
# NAMES #
#########

sub names {
  my $this = shift ;
  my ( $table ) = @_ ;
  
  $table = HDB::CMDS::_format_table_name($table) ;
  
  if (! $table) { return $this->Error('Invalid table!') ;}
  elsif ( $this->{CACHE}{names}{$table} ) { return @{ $this->{CACHE}{names}{$table} } ;}
  
  $this->{sql} = "SELECT * FROM $table WHERE(rownum <= 1)" ;
  
  $this->_undef_sth ;
  eval{
    $this->{sth} = $this->dbh->prepare( $this->{sql} ) ;
    $this->{sth}->execute ;
  };

  return $this->Error("SQL error: $this->{sql}") if $@ ;

  my @names ;
  eval { @names = map { substr($_ , 0) } @{ $this->{sth}->{'NAME'} } };
  
  $this->_undef_sth ;

  return () if !@names ;
  
  if ( $this->{cache} ) { $this->{CACHE}{names}{$table} = \@names ;}
  
  return @names ;
}

#############
# ON_CREATE #
#############

sub ON_CREATE {
  my $this = shift ;
  my ( $table , $cols , $order ) = @_ ;
  
  $this->dbh->do(qq`
    create sequence HDBseq_$table
      start with 1 
      increment by 1 
      nomaxvalue
  `);
  
  $this->dbh->do(qq`
    create trigger HDBtrigger_$table
      before insert on $table
      for each row begin
        select HDBseq_$table.nextval into :new.ID from dual;
      end;
  `);
  
}

###########
# ON_DROP #
###########

sub ON_DROP {
  my $this = shift ;
  my ( $table ) = @_ ;

  $this->dbh->do(qq` drop sequence HDBseq_$table `);
}

##############
# LOCK_TABLE #
##############

sub lock_table { $_[0]->dbh->do("LOCK TABLE $_[1] IN EXCLUSIVE MODE") ;}

################
# UNLOCK_TABLE #
################

sub unlock_table { $_[0]->dbh->do("COMMIT") ;}

#######
# END #
#######

1;


PK       ! '����  �    perl5/HDB/MOD/sqlite.pmnu ��6�$        #############################################################################
## Name:        sqlite.pm
## Purpose:     HDB::MOD::sqlite -> for DBD::SQLite
## Author:      Graciliano M. P.
## Modified by:
## Created:     14/01/2003
## RCS-ID:      
## Copyright:   (c) 2002 Graciliano M. P.
## Licence:     This program is free software; you can redistribute it and/or
##              modify it under the same terms as Perl itself
#############################################################################

# TESTED WITH DBD::SQLite 0.21 on Win32|Linux

package HDB::MOD::sqlite ;
use DBD::SQLite ;

use strict qw(vars) ;
no warnings ;

our $VERSION = '1.0' ;
our @ISA = qw(HDB::MOD) ;

  my (%OPENED_DBH) ;

  my %SQL = (
  LIKE => 1 ,
  REGEXP => 0 ,
  LOCK_TABLE => 0 ,
  SHOW => 0 ,
  LIMIT => 1 ,
  TYPES => [qw(VARCHAR TEXT INTEGER FLOAT BOOLEAN CLOB BLOB TIMESTAMP NUMERIC)] ,
  ) ;
  
  my %HPL = (
  UNLINK_DISCONNECT => 1 ,
  ) ;

#######
# NEW #
#######

sub new {
  my $this = shift ;

  $this->{SQL} = \%SQL ;
  $this->{HPL} = \%HPL ;
  $this->{name} = 'HDB::SQLite' ;
  
  bless($this , __PACKAGE__) ;
  return( $this ) ;
}

###########
# CONNECT #
###########

sub MOD_connect {
  my $this = shift ;
  my ( $pass ) = @_ ;
  
  my $file = $this->{file} ;
  
  if ( $OPENED_DBH{$file}{db} ) {
    $this->{dbh} = $OPENED_DBH{$file}{db} ;
    $OPENED_DBH{$file}{x}++ ;
  }
  else {
    $this->{dbh} = DBI->connect("dbi:SQLite:dbname=$file", $this->{user} , $pass , { RaiseError => 0 , PrintError => 1 , AutoCommit => 1 }) ;
  
    if (! $this->{dbh} ) { return $this->Error("Can't connect to db $file!") ;}
    else {
      $OPENED_DBH{$file}{db} = $this->{dbh} ;
      $OPENED_DBH{$file}{x}++ ;
    }
  }
  
  return $this->{dbh} ;
}

##################
# MOD_DISCONNECT #
##################

sub MOD_disconnect {
  my $this = shift ;
  my $file = $this->{file} ;
  $this->{dbh}->disconnect if ( $OPENED_DBH{$file} && !$OPENED_DBH{$file}{x} ) ;
}

##############
# DISCONNECT #
##############

sub disconnect {
  my $this = shift ;

  my $file = $this->{file} ;
  $OPENED_DBH{$file}{x}-- ;
  
  if ( $OPENED_DBH{$file}{x} <= 0 ) {
    $OPENED_DBH{$file}{db} = undef ;
    delete $OPENED_DBH{$file} ;
  }
    
  $this->SUPER::disconnect(@_) ;
}

##########
# TABLES #
##########

sub tables {
  my $this = shift ;
  
  $this->{sql} = "SELECT name FROM sqlite_master WHERE type='table' ORDER BY name" ;
  
  eval{
    $this->_undef_sth ;
    $this->{sth} = $this->dbh->prepare( $this->{sql} ) ;
    $this->{sth}->execute ;
  };
  if ( $@ ) { $this->Error("SQL error: $this->{sql}") ;}
  
  my @tables = $this->Return('$') ;
  
  $this->_undef_sth ;
 
  return( sort @tables ) ;
}

#################
# TABLE_COLUMNS #
#################

sub table_columns {
  my $this = shift ;
  my ( $table ) = @_ ;
  
  $table = HDB::CMDS::_format_table_name($table) ;
  
  if (! $table) { $this->Error('Invalid table!') ; return ;}
  
  my $sql = $this->select( "sqlite_master" , "name = $table" , cols => 'sql' , '$' ) ;
  
  my ($cols) = ( $sql =~ /^\s*CREATE\s+TABLE\s+\S+\s*.*?\(\s*(.*?)\s*\)/gs );
  $cols .= ' ,' ;
  my (%cols) = ( $cols =~ /(\w+)\s*(.*?)\s*,/gs );
  
  foreach my $Key (sort keys %cols ) {
    $cols{$Key} =~ s/\s+/ /gs ;
    $cols{$Key} = "\U$cols{$Key}\E" ;
  }

  return( %cols ) ;
}

#################
# AUTOINCREMENT #
#################

sub AUTOINCREMENT { return "INTEGER PRIMARY KEY" ;}

#########
# LIMIT #
#########

sub LIMIT {
  my $this = shift ;
  my ( $sz , $offset ) = @_ ;
  my $limit = $offset > 0 ? "$offset,$sz" : $sz ;
  return( "LIMIT $limit" ) ;
}

#######
# END #
#######

1;


PK       ! `���        perl5/HDB/MOD/mysql.pmnu ��6�$        #############################################################################
## Name:        mysql.pm
## Purpose:     HDB::MOD::mysql -> for DBD::MySQL
## Author:      Graciliano M. P.
## Modified by:
## Created:     15/01/2003
## RCS-ID:      
## Copyright:   (c) 2002 Graciliano M. P.
## Licence:     This program is free software; you can redistribute it and/or
##              modify it under the same terms as Perl itself
#############################################################################

package HDB::MOD::mysql ;

my $DRIVER = 'mysql' ;

BEGIN {
  eval { require DBD::mysql } ;
  
  if ( $@ ) {
    ## Try a pure Perl version of MySQL client.
    eval { require DBD::mysqlPP } ;
    if ( !$@ ) { $DRIVER = 'mysqlPP' ;}
    else {
      die("Can't load DBD::mysql or DBD::mysqlPP") ;
    }
  }
}

use strict qw(vars) ;
no warnings ;

our $VERSION = '1.0' ;
our @ISA = qw(HDB::MOD) ;

  my %SQL = (
  REGEXP => 1 ,
  LOCK_TABLE => 1 ,
  SHOW => 1 ,
  LIMIT => 1 ,
  TYPES => ['*'] ,
  TYPES_MASK => {
                'BOOLEAN' => 'BOOL' ,
                } ,
  ) ;

#######
# NEW #
#######

sub new {
  my $this = shift ;

  $this->{SQL} = \%SQL ;
  $this->{name} = 'HDB::MySQL' ;
  
  bless($this , __PACKAGE__) ;
  return( $this ) ;
}

###########
# CONNECT #
###########

sub MOD_connect {
  my $this = shift ;
  my ( $pass ) = @_ ;
  
  my $db = $this->{db} ;
  my $host = $this->{host} ;
  
  $this->{dbh} = DBI->connect("DBI:$DRIVER:database=$db;host=$host", $this->{user} , $pass , { RaiseError => 0 , PrintError => 1 , AutoCommit => 1 }) ;
  
  if (! $this->{dbh} ) { return $this->Error("Can't connect to db $db\@$host!") ;}
  
  return( $this->{dbh} ) ;
}

#################
# TABLE_COLUMNS #
#################

sub table_columns {
  my $this = shift ;
  my ( $table ) = @_ ;
  
  $table = HDB::CMDS::_format_table_name($table) ;
  
  if (! $table) { $this->Error('Invalid table!') ; return ;}
  
  my @cols = $this->cmd( "show columns from $table" , '@' ) ;
  
  my %cols ;
  
  foreach my $cols_i ( @cols ) {
    my ( $col , $type ) = @$cols_i ;
    $cols{$col} = $type ;
  }

  return %cols ;
}

##############
# TYPE_FLOAT #
##############

sub Type_FLOAT {
  my $this = shift ;
  my ( $type , $args ) = @_ ;
  
  my $plus_minus ;
  
  if ( $type =~ /^\s*([\+\-])\s*(\w+)/s) { $plus_minus = $1 ; $type = $2 ;}
  
  $type =~ s/\W//gs ;
  
  if    ($type =~ /^f/i) { $type = 'FLOAT' ;}
  elsif ($type =~ /^d/i) { $type = 'DOUBLE' ;}
  
  my $unsigned ;
  
  if ($plus_minus eq '+') { $unsigned = ' UNSIGNED' ;}
  
  if ( $args !~ /\d/ ) { return($type . $unsigned) ;}
  
  my $tp_arg ;
  
  if    ( $args =~ /(\d+)\D+(\d+)/ ) { $tp_arg = "($1,$2)" ;}
  elsif ( $args =~ /(\d+)/ ) { $tp_arg = "($1)" ;}
  
  return($type . $tp_arg . $unsigned) ;
}

#################
# AUTOINCREMENT #
#################

sub AUTOINCREMENT { return( "INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY" ) ;}

##############
# LOCK_TABLE #
##############

sub lock_table { $_[0]->dbh->do("LOCK TABLES $_[1] WRITE , $_[1] READ") ;}

################
# UNLOCK_TABLE #
################

sub unlock_table { $_[0]->dbh->do("UNLOCK TABLES") ;}

#######
# END #
#######

1;

PK       ! ���ʑ  ʑ    perl5/HDB/CMDS.pmnu ��6�$        #############################################################################
## Name:        CMDS.pm
## Purpose:     HDB::CMDS
## Author:      Graciliano M. P.
## Modified by:
## Created:     14/01/2003
## RCS-ID:      
## Copyright:   (c) 2002 Graciliano M. P.
## Licence:     This program is free software; you can redistribute it and/or
##              modify it under the same terms as Perl itself
#############################################################################

package HDB::CMDS ;
use HDB::Parser ;

use strict qw(vars);
no warnings ;

our $VERSION = '1.0' ;

########
# VARS #
########

  my %args_select = (
  table  =>  [qw(table)] ,
  where  =>  [qw(where w)] ,
  limit  =>  [qw(limit limite)] ,
  sort   =>  [qw(sort order)] ,
  group  =>  [qw(group grop)] ,
  return =>  [qw(return ret r)] ,
  col    =>  [qw(col cols)] ,
  cache  => [[qw(cache)],1] ,
  );
  
  my %DEFAULT_COLS = (
  'address'      => 200 ,
  'age'          => 'INTEGER' ,
  'bairro'       => 30 ,
  'cep'          => 9 ,
  'cidade'       => 40 ,
  'city'         => 40 ,
  'country'      => 4 ,
  'data'         => 'int(9999999999)' ,
  'date'         => 'int(9999999999)' ,
  'descricao'    => 'TEXT' ,
  'email'        => 50 ,
  'endereco'     => 200 ,
  'estado'       => 3 ,
  'fax'          => 'INTEGER' ,
  'hits'         => 'INTEGER' ,
  'hora'         => 8 ,
  'id'           => 'INTEGER' ,
  'idade'        => 'INTEGER' ,
  'mail'         => 50 ,
  'message'      => 'TEXT' ,
  'msg'          => 'TEXT' ,
  'mensagem'     => 'TEXT' ,
  'name'         => 40 ,
  'nick'         => 16 ,
  'nome'         => 40 ,
  'pais'         => 4 ,
  'pass'         => 16 ,
  'password'     => 16 ,
  'phone'        => 'INTEGER' ,
  'preco'        => 15 ,
  'price'        => 15 ,
  'senha'        => 16 ,
  'sex'          => 1 ,
  'sexo'         => 1 ,
  'size'         => 5 ,
  'state'        => 3 ,
  'tamanho'      => 5 ,
  'tel'          => 'INTEGER' ,
  'telefone'     => 'INTEGER' ,
  'temperatura'  => 4 ,
  'time'         => 10 ,
  'titulo'       => 250 ,
  'title'        => 250 ,
  'uf'           => 3 ,
  'uid'          => 8 ,
  'url'          => 250 ,
  'username'     => 16 ,
  'user'         => 16 ,
  'zip'          => 9 ,
  );
  
  
  my @DEFAULT_TYPES = qw(* TEXT INT FLOAT BOOL) ;
  
  my %DEFAULT_MOD = (
  'MySQL'    => 'mysql' ,
  'SQLite'   => 'sqlite' ,
  'Oracle'   => 'Oracle' ,
  ) ;

  
###################
# PREDEFINED_COLS #
###################

sub predefined_columns { return( %DEFAULT_COLS ) ;}

#################
# DEFAULT_TYPES #
#################

sub default_types { return( @DEFAULT_TYPES ) ;}

###############
# DEFAULT_MOD #
###############

sub default_mod { return( %DEFAULT_MOD ) ;}

###########
# ALIASES #
###########

sub sel { &select ;}
sub cols { &names ;}
sub creat { &create ;}
sub create_table { &create ;}
sub predefined_cols { &predefined_columns ;}
sub sql { $_[0]->{sql} ;}

##########
# SELECT #
##########

sub select {
  my $this = shift ;
  my (undef , $where , @args) = @_ ;
  
  if ($_[0] =~ /^table$/i) { @args = @_ ; $where = undef ;}
  elsif ($#_ >= 2 && $#_ <= 3 && ( ref $_[2] || $_[2] =~ /^(?:(?:n|names?|c|cols?|columns?)\s*[,;]*\s*)?(?:\$?[\$\@\%]{1,2}|<[\$\@\%]>)$/i ) ) {
    if (ref $_[2]) { @args = HDB::CORE::parse_ref($_[2]) ;}
    elsif ($#_ == 2) { @args = ('return' , $_[2]) ;}
  }
  elsif ($#_ == 1 && $_[1] =~ /^(?:(?:n|names?|c|cols?|columns?)\s*[,;]*\s*)?(?:\$?[\$\@\%]{1,2}|<[\$\@\%]>)$/i ) {
    @args = ('return' , $_[1]) ;
    $where = undef ;
  }
  
  if ($#_ >= 2 && $where =~ /^(?:cache|col|cols|grop|group|limit|limite|order|r|ret|return|sort|table|w|where)$/si) {
    unshift (@args, $where) ;
    $where = undef ;
  }
  
  my %args ;
  &HDB::CORE::parse_args(\%args , \%args_select , @args) ;
  
  $args{table} = $_[0] if !defined $args{table} ;
  $args{where} = $where if !defined $args{where} ;
  
  $args{table} = _format_table_name($args{table}) ;
  
  if (! defined $args{return}) {
    if ( $_[-1] =~ /^(?:(?:n|names?|c|cols?|columns?)\s*[,;]*\s*)?(?:\$?[\$\@\%]{1,2}|<[\$\@\%]>)$/i ) { $args{return} = $_[-1] ;}
  }
  
  $this->{return} = $args{return} ;
  
  $this->{sql} = undef ;

  {
    my ($cols , $db_max) ;
      
    if ($args{col} =~ /^\s*([<>])\s*([\w\.]+)/) {
      $db_max = $1 ; 
      $cols = $2 ;
    }
    else { $cols = $args{col} ;}

    if ($db_max) {
      if ($db_max eq '>') { $db_max = 'max' ;}
      elsif ($db_max eq '<') { $db_max = 'min' ;}
      if ($cols eq '') { $cols = "$db_max(ID) as ID" ;}
      else { $cols = "$db_max($cols) as $cols" ;}
    }
    elsif ($cols eq "") { $cols = '*' ;}
    else {
      $cols =~ s/^\s*,//s ;
      $cols =~ s/,\s*$//s ;
    }
    
    my $where = &HDB::Parser::Parse_Where($args{where},$this) ;
    
    my $group ;
    if ( $args{group} ) { $group = "GROUP BY $args{group}" ;}
    
    my $sort ;
    
    if ( $args{sort} ) {
      ($sort) = ( $args{sort} =~ /([\w\.]+)/gs ) ;
      $sort = "ORDER BY $sort" ;
      if ($args{sort} =~ /</s) { $sort .= ' DESC' ;}
    }
    #elsif (! defined $args{sort} ) { $sort = "ORDER BY ID" ;}
    
    my $limit ;
    if ($args{limit} ne '') {
      my ($sz,$init) = ( $args{limit} =~ /(\d+)(?:\D+(\d+)|)/ );
      my $into_where ;
      ($limit , $into_where) = $this->LIMIT($sz,$init) ;
      if ( $into_where ) { $where = "$where AND ($into_where)" ;}
    }
    
    $this->{sql} = "SELECT $cols FROM $args{table}" ;
    $this->{sql} .= " $where" if $where ne '' ;
    $this->{sql} .= " $group" if $group ne '' ;
    $this->{sql} .= " $sort" if $sort ne '' ;
    $this->{sql} .= " $limit" if $limit ne '' ;
  }

 $this->_undef_sth ;
 
 eval{
    $this->{sth} = $this->dbh->prepare( $this->{sql} ) ;
    $this->{sth}->{ShowErrorStatement} = 1 ;
    $this->{sth}->execute ;
    $this->{sth}->err ;
  };

  return $this->Error("SQL error: $this->{sql}") if $@ ;
  
  return $this->Return( $args{return} ) ;
}

##########
# INSERT #
##########

sub insert {
  my $this = shift ;
  
  my ($table , @up) = @_ ;
  
  $table = _format_table_name($table) ;
  
  if ($#_ == 1) { @up = HDB::CORE::parse_ref($_[1]) ;}
  
  return $this->Error('Invalid table!') if !$table ;
  return $this->Error('Nothing to insert!') if !@up ;
  
  my @names = $this->names($table) ;

  my @cols ;
  if (ref($_[1]) eq 'HASH') {
    my %up = @up ;
    @up = () ;
    
    foreach my $names_i ( @names ) {
      if    (defined $up{$names_i})     { push(@up , $up{$names_i}) ; push(@cols , $names_i) ;}
      elsif (defined $up{uc($names_i)}) { push(@up , $up{uc($names_i)}) ; push(@cols , $names_i) ;}
      elsif (defined $up{lc($names_i)}) { push(@up , $up{lc($names_i)}) ; push(@cols , $names_i) ;}
      elsif (defined $up{"\u\L$names_i\E"}) { push(@up , $up{"\u\L$names_i\E"}) ; push(@cols , $names_i) ;}
    }
  }
  else { @cols = @names ;}
  
  foreach my $up_i ( @up ) {
    if (ref($up_i) eq 'HASH') { $up_i = &HDB::Encode::Pack_HASH($up_i) ;}
    elsif (ref($up_i) eq 'ARRAY') { $up_i = &HDB::Encode::Pack_ARRAY($up_i) ;}
    &HDB::Parser::filter_null_bytes($up_i) ;
  }
  
  $this->_undef_sth ;

  {
    my @ins_pnt = ('?') x @up ;
    $this->{sql} = "INSERT INTO $table (". join(',',@cols) .") VALUES (". join(',',@ins_pnt) .")" ;
    eval { $this->{sth} = $this->dbh->prepare( $this->{sql} ) };
  }
  
  $this->{sth}->{ShowErrorStatement} = 1 ;
  
  eval {
    $this->lock_table($table) if $this->{SQL}{LOCK_TABLE} ;
    $this->{sth}->execute(@up) ;
    $this->unlock_table($table) if $this->{SQL}{LOCK_TABLE} ;
    $this->{sth}->err ;
  };
  
  $this->_undef_sth ;
  
  return $this->Error("SQL error: $this->{sql}\nERROR MSG:\n$@") if $@ ;
  
  $this->ON_INSERT(\@cols,\@up) if $this->can('ON_INSERT') ;
  
  return 1 ;
}

##########
# UPDATE #
##########

sub update {
  my $this = shift ;
  my ($table , $where , %up) = @_ ;
  
  $table = _format_table_name($table) ;
  
  if ($#_ == 2) { %up = HDB::CORE::parse_ref($_[2]) ;}
  
  if (! $table) { $this->Error('Invalid table!') ;}
  if (! %up) { $this->Error('Nothing to update!') ;}
  
  $where = &HDB::Parser::Parse_Where($where,$this) ;
  
  my ($set_cols,@up) ;
  
  my @names = $this->names($table) ;
    
  foreach my $names_i ( @names ) {
    if    (defined $up{$names_i})     { push(@up , $up{$names_i}) ; $set_cols .= "$names_i = ? , " ;}
    elsif (defined $up{uc($names_i)}) { push(@up , $up{uc($names_i)}) ; $set_cols .= "\U$names_i\E = ? , " ;}
    elsif (defined $up{lc($names_i)}) { push(@up , $up{lc($names_i)}) ; $set_cols .= "\L$names_i\E = ? , " ;}
    elsif (defined $up{"\u\L$names_i\E"}) { push(@up , $up{"\u\L$names_i\E"}) ; $set_cols .= "\u\L$names_i\E = ? , " ;}
  }

  return if !@up ;
  
  foreach my $up_i ( @up ) {
    if (ref($up_i) eq 'HASH') { $up_i = &HDB::Encode::Pack_HASH($up_i) ;}
    elsif (ref($up_i) eq 'ARRAY') { $up_i = &HDB::Encode::Pack_ARRAY($up_i) ;}
    &HDB::Parser::filter_null_bytes($up_i) ;
  }
  
  $set_cols =~ s/ , $// ;
  
  $this->{sql} = "UPDATE $table SET $set_cols $where" ;

  $this->_undef_sth ;
  eval { $this->{sth} = $this->dbh->prepare( $this->{sql} ) };  
  
  eval {
    $this->lock_table($table) if $this->{SQL}{LOCK_TABLE} ;
    $this->{sth}->execute(@up) ;
    $this->unlock_table($table) if $this->{SQL}{LOCK_TABLE} ;
  };
  
  $this->_undef_sth ;
  
  return $this->Error("SQL error: $this->{sql}\nERROR MSG:\n$@") if $@ ;
  return 1 ;
}

##########
# DELETE #
##########

sub delete {
  my $this = shift ;
  my ($table , $where) = @_ ;
  
  $table = _format_table_name($table) ;
  
  if (! $table) { $this->Error('Invalid table!') ;}
  
  $where = &HDB::Parser::Parse_Where($where,$this) ;
  
  $this->{sql} = "DELETE FROM $table $where" ;
  
  eval {
    $this->lock_table($table) if $this->{SQL}{LOCK_TABLE} ;
    $this->dbh->do( $this->{sql} ) ;
    $this->unlock_table($table) if $this->{SQL}{LOCK_TABLE} ;
  };

  return $this->Error("SQL error: $this->{sql}\nERROR MSG:\n$@") if $@ ;
  return 1 ;
}

##########
# CREATE #
##########

sub create {
  my $this = shift ;
  my ($table , @cols) = @_ ;
  
  $table = _format_table_name($table) ;
  
  if ($#_ == 1) { @cols = HDB::CORE::parse_ref($_[1]) ;}
  
  if (! $table) { $this->Error('Invalid table!') ;}
  if (! @cols) { $this->Error('Cols not paste!') ;}
  
  my %tables = map { ("\L$_\E") => 1 } ($this->tables) ;
  if ( $tables{"\L$table\E"} ) { return ;}
  
  my (%cols,@order) ;
  
  for (my $i = 0 ; $i <= $#cols ; $i+=1) {
    my $name = $cols[$i] ;
    my $type ;
    
    if (ref($name)) {
      $name = HDB::CORE::parse_ref($name) ;
      $type = 'DEFAULT' ;
    }
    else { $type = $cols[$i+1] ; $i++ ;}
    
    my $is_primary ;
    if ($name =~ /^\s*\*/) { $name =~ s/^\s*\*\s*//gs ; $is_primary = 1 ;}
    
    $name =~ s/^\s+//gs ;
    $name =~ s/\s+$//gs ;
    
    $type = $this->get_type( $type , $name ) ;

    if ($is_primary) { $type = $this->Set_PRIMARYKEY($type) ;}
    
    push(@order , $name) ;
    $cols{$name} = $type ;
  }
  
  if (ref($_[1]) eq 'HASH') { @order = sort @order ;}
  
  if (! $cols{id}) {
    push(@order , 'id') ;
    $cols{id} = $this->AUTOINCREMENT() ;
    if ($cols{id} !~ /PRIMARY[\s_-]*KEY/si) { $cols{id} .= ' PRIMARY KEY' ;}
  }
  
  $this->{sql} = "CREATE TABLE $table (" ;
  
  my $c ;
  foreach my $order_i ( @order ) {
    if (++$c > 1) { $this->{sql} .= " , " ;}
    $this->{sql} .= "$order_i $cols{$order_i}" ;
  }
  
  $this->{sql} .= ")" ;
  
  eval { $this->dbh->do( $this->{sql} ) };

  return $this->Error("SQL error: $this->{sql}\nERROR MSG:\n$@") if $@ ;
  
  $this->ON_CREATE($table,\%cols,\@order) if $this->can('ON_CREATE') ;
  
  return 1 ;
}

#######
# CMD #
#######

sub cmd {
  my $this = shift ;
  
  $this->{sql} = $_[0] ;
  my $return = $_[1] ;
  
  $this->_undef_sth ;
  
  eval{
    $this->{sth} = $this->dbh->prepare( $this->{sql} ) ;
    $this->{sth}->execute ;
  };

  return $this->Error("SQL error: $this->{sql}") if $@ ;
  
  return $this->Return( $return ) ;
}

#########
# NAMES #
#########

sub names {
  my $this = shift ;
  my ( $table ) = @_ ;
  
  $table = _format_table_name($table) ;
  
  if (! $table) { return $this->Error('Invalid table!') ;}
  elsif ( $this->{CACHE}{names}{$table} ) { return @{ $this->{CACHE}{names}{$table} } ;}
  
  if ( $this->{SQL}{SHOW} ) { $this->{sql} = "SHOW COLUMNS FROM $table" ;}
  elsif ( $this->{SQL}{LIMIT} ) { $this->{sql} = "SELECT * FROM $table LIMIT 1" ;}
  else { $this->{sql} = "SELECT * FROM $table" ;}
  
  $this->_undef_sth ;
  eval{
    $this->{sth} = $this->dbh->prepare( $this->{sql} ) ;
    $this->{sth}->execute ;
  };

  return $this->Error("SQL error: $this->{sql}") if $@ ;

  my @names ;
  
  if (  $this->{SQL}{SHOW}  ) {
    while (my $ref = $this->{sth}->fetchrow_arrayref) { push(@names , @$ref[0]) ;}
  }
  else {
    ## substr() to make a copy of the value and avoid DBI bug!
    eval { @names = map { substr($_ , 0) } @{ $this->{sth}->{'NAME'} } };
    #eval { @names = @{ $this->{sth}->{'NAME'} } };
  }
  
  $this->_undef_sth ;

  return () if !@names ;
  
  if ( $this->{cache} ) {
    $this->{CACHE}{names}{$table} = \@names ;
  }
  
  return @names ;
}

##########
# TABLES #
##########

sub tables {
  my $this = shift ;

  my @tables = map {
    $_ =~ s/.*\.//;
    $_ =~ s/(['"`])(.*)\1/$2/gs; ## some DB return quoted.
    $_
  } $this->dbh->tables() ;
 
  return( sort @tables ) ;
}

###############
# TABLES_HASH #
###############

sub tables_hash {
  return map { $_ => 1 } $_[0]->tables ;
}

################
# TABLE_EXISTS #
################

sub table_exists {
  my %tables = $_[0]->tables ;
  return 1 if $tables{$_[1]} ;
  return ;
}

#################
# TABLE_COLUMNS #
#################

sub table_columns {
  my $this = shift ;
  my ( $table ) = @_ ;

  if (! $table) { $this->Error('Invalid table!') ; return ;}
  
  return $this->dbh->table_info($table) ;
}

########
# DROP #
########

sub drop {
  my $this = shift ;
  my ( $table ) = @_ ;
  
  $table = _format_table_name($table) ;
  
  if (! $table) { $this->Error('Invalid table!') ; return ;}
  
  my %tables = map { ("\L$_\E") => 1 } ($this->tables) ;
  if (! $tables{"\L$table\E"} ) { return ;}
  
  $this->flush_table_cache($table) ;
  
  eval{ $this->dbh->do("DROP TABLE $table") };

  return $this->Error("DROP ERROR: table $table") if $@ ;
  
  $this->ON_DROP($table) if $this->can('ON_DROP') ;
  
  return 1 ;
}

##############
# DUMP_TABLE #
##############

sub dump_table {
  my $this = shift ;
  my ( $table ) = @_ ;
  
  $table = _format_table_name($table) ;
  
  if (!$table) { $this->Error('Invalid table!') ; return ;}
  
  my $dump ;

  $dump .= "TABLE $table:\n\n" ;
      
  my %cols = $this->table_columns($table) ;
  my @cols = $this->names($table) ;
  
  foreach my $Key (@cols) {
    $dump .= "  $Key = $cols{$Key}\n" ;
  }
  
  $dump .= "\nROWS:\n\n" ;
  
  my @sel = $this->select( $table , '@$' ) ;
  foreach my $sel_i ( @sel ) {
    $dump .= "$sel_i\n" ;
  }
  
  return $dump ;
}

###############
# FLUSH_CACHE #
###############

sub flush_cache {
  if ( !$_[0]->{CACHE} ) { return ;}
  my @sth = $_[0]->_get_cache_sth ;
  delete $_[0]->{CACHE} ;
  foreach my $sth_i ( @sth ) { $sth_i->finish if $sth_i ;}
  return 1 ;
}

#####################
# FLUSH_TABLE_CACHE #
#####################

sub flush_table_cache {
  my $this = shift ;
  my ( $table ) = @_ ;
  
  $table = _format_table_name($table) ;
  
  if ( !$this->{CACHE} ) { return ;}

  my @sth = $this->_get_cache_table_sth($table) ;

  delete $this->{CACHE}{names}{$table} ;
  delete $this->{CACHE}{insert}{$table} ;
  delete $this->{CACHE}{update}{$table} ;
  
  foreach my $sth_i ( @sth ) { $sth_i->finish if $sth_i ;}
  
  return 1 ;
}

######################
# _FORMAT_TABLE_NAME #
######################

sub _format_table_name {
  my ( $table ) = @_ ;
  $table =~ s/(?:\.|::)/_/gs ;
  $table =~ s/[^\w\.]//gs ;
  return $table ;
}

#######################
# _FORMAT_COLUMN_NAME #
#######################

sub _format_column_name {
  my ( $col ) = @_ ;
  $col =~ s/(?:\.|::)/_/gs ;
  $col =~ s/[^\w\.]//gs ;
  return $col ;
}

##################
# _GET_CACHE_STH #
##################

sub _get_cache_sth {
  my $cache = $_[0]->{CACHE} ;
  my @types = qw(insert update) ;
  
  my @sth ;
  
  foreach my $types_i ( @types ) {
    foreach my $Key ( keys %{$$cache{$types_i}} ) {
      push(@sth , $$cache{$types_i}{$Key}{sth} ) ;
    }
  }
  
  return @sth ;
}

########################
# _GET_CACHE_TABLE_STH #
########################

sub _get_cache_table_sth {
  my $cache = $_[0]->{CACHE} ;
  my $table = $_[1] ;
  my @types = qw(insert update) ;
  
  my @sth ;
  
  foreach my $types_i ( @types ) {
    push(@sth , $$cache{$types_i}{$table}{sth} ) ;
  }
  
  return @sth ;
}

##############
# _UNDEF_STH #
##############

sub _undef_sth {
  if ( $_[0]->{sth} ) {
    $_[0]->{sth}->finish ;
    $_[0]->{sth} = undef ;
  }
}

##########
# RETURN #
##########

sub Return {
  my $this = shift ;
  my ( $return ) = @_ ;

  my $ret_names ;

  $return =~ s/\s//gs ;
  if ($return =~ /^(?:n|c)/si ) {
    $ret_names = 1 ;
    $return =~ s/[^\$\@\%<>]//gs ;
  }

  if ($return !~ /^(?:\$?[\$\@\%]{1,2}|<[\$\@\%]>)$/ ) { $return = '$' ;}

  $return =~ s/^\$\$\%$/\$\$\@/ ;
  $return =~ s/^\%\%$/\$\%/ ;
  
  my $sth = $_[1] || $this->{sth} ;
  return undef if !$sth ;
  
  if ($return =~ /<\s*([\$\@\%])\s*>\s*$/) {
    my $type = $1 ;
    local(*HANDLE);
    tie(*HANDLE, 'HDB::CMDS::TieHandle',$sth,$type) ;
    return( \*HANDLE ) ;
  }
  
  my $ret_type ;
  if    ($return =~ /\@$/) { $ret_type = 1 ;}
  elsif ($return =~ /\%$/) { $ret_type = 2 ;}

  my @names ;
  
  eval{
    my $names = $sth->{'NAME'} ;
    @names = @{$names} ;
  };
  
  if (! @names) { $this->_undef_sth ; return undef ;}
  
  my @rows ;
  while (my $ref = $sth->fetchrow_arrayref) {
    foreach my $ref_i ( @$ref ) {
      &HDB::Parser::unfilter_null_bytes($ref_i) ;
      
      if    ( &HDB::Encode::Is_Packed_HASH($ref_i) ) { $ref_i = &HDB::Encode::UnPack_HASH($ref_i) ;}
      elsif ( &HDB::Encode::Is_Packed_ARRAY($ref_i) ) { $ref_i = &HDB::Encode::UnPack_ARRAY($ref_i) ;}
    }
    if ($ret_type == 1) { push(@rows , [@$ref]) ;}
    elsif ($ret_type == 2) {
      my %hash ;
      for my $i (0..$#names) { $hash{ $names[$i] } = $$ref[$i] ;}
      push(@rows , \%hash) ;
    }
    else { push(@rows , join("::" , @$ref ) ) ;}
  }
  
  $this->_undef_sth ;
  
  my @ret_names ;
  
  if ($ret_names) { @ret_names = \@names ;}
  
  if ($return =~ /^[\@\%\$]$/) {
    if (wantarray) { return( @ret_names , @rows ) ;}
    else { return( $rows[0] ) ;}
  }
  elsif ($return =~ /^\$\$$/) { return( @ret_names , $rows[0] ) ;}
  elsif ($return =~ /^\$\@$/) { return( @ret_names , @{ $rows[0] } ) ;}
  elsif ($return =~ /^\$\%$/) { return( @ret_names , %{ $rows[0] } ) ;}
  elsif ($return =~ /^\$\$\@$/) {
    if    ( ref( @{$rows[0]}[0] ) eq 'HASH' )  { return( @ret_names , %{@{$rows[0]}[0]} ) ;}
    elsif ( ref( @{$rows[0]}[0] ) eq 'ARRAY' ) { return( @ret_names , @{@{$rows[0]}[0]} ) ;}
    else                                       { return( @ret_names , @{ $rows[0] } ) ;}
  }
  elsif ($return =~ /^\@[\@\%\$]$/) { return( @ret_names , @rows ) ;}
}

# $
# @
# %
# @@
# @%
# %%

############
# GET_TYPE #
############

sub get_type {
  my $this = shift ;
  my ( $type , $name ) = @_ ;
  
  $type =~ s/^\s+//gs ;
  $type =~ s/\s+$//gs ;

  ## *
  
  if ($type =~ /^(?:\*|)$/s) { $type = 'TEXT' ;}


  ## TEXT

  if ($type eq 'TEXT' || $type =~ /^(?:TEXT\s*)?(\d+|\(\s*\d+\s*\))$/s) {
    my $sz = $1 ; $sz =~ s/\D//gs ;
    $sz = 65535 if $sz eq '' ;
    
    if ( !$this->Accept_Type('TEXT') ) { $type = $this->Type_TEXT($sz) ;}
    else {
      if    ($sz == 0)           { $type = "INTEGER" ;}
      elsif ($sz <= 255)         { $type = "VARCHAR($sz)" ;}
      elsif ($sz <= 65535 )      { $type = 'TEXT' ;}
      elsif ($sz <= 16777215 )   { $type = 'MEDIUMTEXT' ;}
      elsif ($sz <= 4294967295 ) { $type = 'LONGTEXT ' ;}
      if ( !$this->Accept_Type($type) ) { $type = $this->Type_TEXT($sz) ;}
    }
  }
  
  ## INTEGER
  
  if ($type =~ /^(?:INTEGER|INT)\s*(?:\(?([\+\-]?\d+|\w+)\)?|)$/si) {
    my $sz = $1 ;
    
    if ( !$this->Accept_Type('INTEGER') ) { $type = $this->Type_INTEGER($sz) ;}
    else {
      if (!$sz) { $type = "INTEGER" ;}
      elsif ($sz =~ /^(?:t|tin|shor)/i) { $type = "TINYINT" ;}
      elsif ($sz =~ /^(?:s|sma)/i) { $type = "SMALLINT" ;}
      elsif ($sz =~ /^(?:m|med)/i) { $type = "MEDIUMINT" ;}
      elsif ($sz =~ /^(?:b|big)/i) { $type = "BIGINT" ;}
      elsif ($sz =~ /^[\+\-]?\d+$/) {
        if    ($sz >= -127 && $sz <= 127)               { $type = "TINYINT" ;}
        elsif ($sz >= -32768 && $sz <= 32767)           { $type = "SMALLINT" ;}
        elsif ($sz >= -8388608 && $sz <= 8388607)       { $type = "MEDIUMINT" ;}
        elsif ($sz >= -2147483648 && $sz <= 2147483647) { $type = "INTEGER" ;}
        elsif ($sz < -2147483648 || $sz > 2147483647)   { $type = "BIGINT" ;}
      }
      if (! $this->Accept_Type($type)) { $type = $this->Type_INTEGER($sz) ;}
    }
  }
  
  ## FLOAT
  
  elsif ($type =~ /^(\s*[\+\-]\s*(?:FLOATING|FLOAT|DOUBLE))\s*(?:\((.*?)\)|())$/si) {
    $type = $this->Type_FLOAT($1,$2) ;
  }
  
  ## INT
  
  elsif ($type =~ /\w+INT$/si) {
    if (! $this->Accept_Type($type)) { $type = 'INTEGER' ;}
  }
  
  ## BOOLEAN
  
  elsif ($type =~ /^(?:boolean|boo?l)$/si) { $type = 'BOOLEAN' ;}
  
  ## AUTO
  
  elsif ($type =~ /^(?:AUTOINCREMENT|AUTO)$/si) { $type = $this->AUTOINCREMENT() ;}
  
  ## DEF
  
  elsif ($type =~ /^(?:DEFAULT|DEF)$/si) {
    $type = $DEFAULT_COLS{$name} || 'TEXT' ;
    $type = $this->get_type($type) ;
  }
  
  ## TYPE MASK:
  
  if ( $this->{SQL}{TYPES_MASK} && $this->{SQL}{TYPES_MASK}{$type} ) {
    $type = $this->{SQL}{TYPES_MASK}{$type} ;
  }
  
  return( $type ) ;
}

##################
# SET_PRIMARYKEY #
##################

sub Set_PRIMARYKEY {
  my $this = shift ;
  my ( $type ) = @_ ;
  
  my $primarykey = $this->PRIMARYKEY() ;
  my $primarykey_re = $primarykey ;
  $primarykey_re =~ s/\s+/\\s\+/gs ;
  
  if ($type !~ /$primarykey_re/si) { $type .= " $primarykey" ;}
  
  return( $type ) ;
}

###############
# ACCEPT_TYPE #
###############

sub Accept_Type {
  my $this = shift ;
  my $type = "\L$_[0]\E" ;
  
  if (ref($this->{SQL}{TYPES}) eq 'ARRAY') {
    my %types = map { ("\L$_\E") => 1 } @{ $this->{SQL}{TYPES} } ;
    $this->{SQL}{TYPES} = \%types ;
  }
  
  if ( $this->{SQL}{TYPES}{$type} || $this->{SQL}{TYPES}{'*'} ) { return( 1 ) ;}
  return( undef ) ;
}

########################
# HDB::CMDS::TIEHANDLE #
########################

package HDB::CMDS::TieHandle ;

sub TIEHANDLE {
  my $class = shift ;
  my $this = { sth => $_[0] , type => $_[1] } ;
  bless($this , $class) ;
}

sub READLINE  {
  my $this = shift ;
  my $sth = $this->{sth} ;

  if ($this->{type} eq "\$") {
    my $ref = $sth->fetchrow_arrayref ; return if !$ref ;
    return( join("::" , @$ref ) ) ;
  }
  elsif ($this->{type} eq "\@") {
    my $ref = $sth->fetchrow_arrayref ; return if !$ref ;
    foreach my $ref_i ( @$ref ) {
      &HDB::Parser::unfilter_null_bytes($ref_i) ;
      
      if    ( &HDB::Encode::Is_Packed_HASH($ref_i) ) { $ref_i = &HDB::Encode::UnPack_HASH($ref_i) ;}
      elsif ( &HDB::Encode::Is_Packed_ARRAY($ref_i) ) { $ref_i = &HDB::Encode::UnPack_ARRAY($ref_i) ;}
    }
    return( @$ref ) ;
  }
  elsif ($this->{type} eq "\%") {
    my $ref = $sth->fetchrow_hashref ; return if !$ref ;
    foreach my $Key ( keys %$ref ) {
      &HDB::Parser::unfilter_null_bytes($$ref{$Key}) ;
      
      if    ( &HDB::Encode::Is_Packed_HASH($$ref{$Key}) ) { $$ref{$Key} = &HDB::Encode::UnPack_HASH($$ref{$Key}) ;}
      elsif ( &HDB::Encode::Is_Packed_ARRAY($$ref{$Key}) ) { $$ref{$Key} = &HDB::Encode::UnPack_ARRAY($$ref{$Key}) ;}
    }
    return( %$ref ) ;
  }

  return ;
}

sub DESTROY  {

}

#######
# END #
#######

1;

__END__

=head1 NAME

HDB::CMDS - Hybrid DataBase Commands

=head1 DESCRIPTION

This are the commands/methods to access/manage the databases.

=head1 select

Make a SQL select query.

Example:

  my @sel = $HDB->select('users' , 'name =~ joe' , '@%') ; ## table , where , return
  
  ## ... or ...
  
  my @sel = $HDB->select('users' , 'name =~ joe' , cols => 'name,user,id' , limit => 1 , '@%') ;
  
  ## ... or ...
  
  my @sel = $HDB->select(
  table  => 'users' ,           ## Need to start with 'table' to paste a full HASH of arguments!
  where  => 'name == joe' ,
  col    => 'name, user , id' ,
  limit  => '1' ,
  sort   => 'id' ,
  group  => 'name' ,
  cache  => '0' ,
  return => '@%' ,  
  ) ;
  

B<Arguments:>

=over 10

=item TABLE

The table name.

=item WHERE

Where condintion. See the topic 'WHERE' for format.

=item COL

Columns to return and order, separated by ','.

Example:

  col => 'city'        # Return only the column city.
  col => 'city,state'  # Return the column city and state in this order.
  col => '>ID'         # Return the max ID.
  col => '<ID'         # Return the min ID.


=item LIMIT

Limit of return or/and start of returns.

Example:

  limit => '10'    # Make the limit of returns to 10.
  limit => '10,2'  # Make the limit of returns to 10 and the returns will start from 2.
  limit => '0,2'   # Returns will start from 2.

=item SORT

Column to use for sort (order). If > or < is used in the beggin set the ascending or descending sort.

Example:

  sort => 'ID'   # Sort by ID in the ascending order.
  sort => '>ID'  # Sort by ID in the ascending order.
  sort => '<ID'  # Sort by ID in the *descending order.

=item GROUP

Column(s) to group.

Example:

  group => 'city'          # Group only the col city
  group => 'city , state'  # Group the col city and state.


=item CACHE

Turn on/off the cache of sth and col names.

=item RETURN

The return type. See the topic L</RETURN> for format.

=back

=head1 insert ( table , data )

Insert data inside a table.

You can call it sending the data by column order or hash (by column name):

  # Cols of table users: name , email , id

  $HDB->insert( 'users' , 'joe' , 'joe@mail.com' , 1 );
  
  # Or with a hash:
  
  $HDB->insert( 'users' , {
  'name' => 'joe' ,
  'email' => 'joe@mail.com' ,
  'id' => 1 ,
  } );

=head1 update ( table , where , data )

Update a table. The data need to be a HASH or a ref to a HASH:

  $HDB->update( 'users' , 'user == joe' , {
  name => 'Joe Tribiany' ,
  email => 'foo@mail.com' ,
  } );
  
  # Or:
  
  $HDB->update( 'users' , 'user == joe' , name => 'Joe Tribiany' , email => 'foo@mail.com' );

=head1 delete ( table , where )

Delete entrys of a table:

  $HDB->delete( 'users' , 'user == joe' );

=head1 create ( table , columns )

Create a new tables. You send the columns in the order that they will be in the table, and the TYPES are based in the size:

  $HDB->create( 'users' ,
  user  => 100 ,            # A col for strings, with the max size 100.
  name  => 150 ,            # A col for strings, with the max size 150.
  more  => 4096 ,           # A col for strings, with the max size 4Kb.
  more2 => 1048576          # A col for strings, with the max size 1Mb.
  more3 => '*'              # A col for strings.
  age   => 'int(200)' ,     # A col for numbers, with the max number 200.
  numb  => 'float' ,        # A floating point with normal precision.
  numb1 => 'double' ,       # A floating point with big precision.
  numb2 => 'float(10)' ,    # A floating point with precision 10.
  numb3 => '+float(10,4)' , # for floating points. This will be unsigned (only positive values).
                            # 10 is the max digit size (including decimal).
                            # 4 is the precision (number digits after decimal point).
  adm   => bool ,           # For boolean entrys.
  );
  
  ** FLOAT is not enable in any database, and can be changed to INTEGER. The precision and UNSIGNED options are not enabled for all too.
  ** Use FLOAT for normal precision, and DOUBLE for big precision for portable way.
  
In MySQL the cols type will be:

  $HDB->create( 'users' ,
  user  => 100 ,            # VARCHAR(100)
  name  => 150 ,            # VARCHAR(150)
  more  => 4096 ,           # TEXT
  more2 => 1048576          # MEDIUMTEXT
  more3 => '*'              # TEXT
  age   => 'int(200)' ,     # SMALLINT
  numb  => 'float' ,        # FLOAT
  numb1 => 'double' ,       # DOUBLE
  numb2 => 'float(10)' ,    # FLOAT(10)
  numb3 => '+float(10,4)' , # FLOAT(10,4) UNSIGNED
  adm   => bool ,           # BOOLEAN
  );
  
In SQLite the cols type will be:

  $HDB->create( 'users' ,
  user  => 100 ,            # VARCHAR(100)
  name  => 150 ,            # VARCHAR(150)
  more  => 4096 ,           # TEXT
  more2 => 1048576          # TEXT
  more3 => '*'              # TEXT
  age   => 'int(200)' ,     # INTEGER
  numb  => 'float' ,        # FLOAT
  numb1 => 'double' ,       # FLOAT
  numb2 => 'float(10)' ,    # FLOAT
  numb3 => '+float(10,4)' , # FLOAT
  adm   => bool ,           # BOOLEAN  
  );

B<** Note that the column ID will be always created and will be AUTOINCREMENT, unless you set the type by your self.>

You can use predefined col names (templates) for the columns. This is good if you don't want to think in the size that the type of data can have:

  $HDB->create( 'users' ,
  user  => 100 ,
  ['email'] ,      # The predefined col name. Same as:   email => 50
  name  => 150 ,
  );

=head1 drop ( table )

Drop (remove) a table:

  $HDB->drop( 'users' );

=head1 cmd ( SQL , RETURN )

Send a SQL query to the database. The return will be in the format of the argument RETURN:

  my @sel = $HDB->cmd('select * from users','@%');


=head1 dump_table

Return a string with the table dumped.

=head1 tables

Return an ARRAY with tables of the database.

=head1 table_exists ( TABLE )

Return TRUE if TABLE exists.

=head1 tables_hash

Same as tables(), but return a HASH, with the tables as keys and 1 as values.
Good if you want to make: if ($tables{users}) {...}

=head1 table_columns

Return a HASH with the columns and respective type (based in the DB type).

=head1 names

Return an ARRAY with the names of the columns in the table, with the respective order.

=head1 sql

Return the last SQL command sent to the DB.

=head1 flush_cache

Clean the HDB cache (in the HDB object, not in the database).

=head1 flush_table_cache

Clean the HDB cache of a table (in the HDB object, not in the database).

=head1 get_type

Convert the HDB type to the database type:

  my $db_col_type = $HDB->get_type( 1000 );
  
  ...
  
  my $db_col_type = $HDB->get_type( 'int(200)' );

=head1 default_types

Return a list of the default types of HDB.

=head1 predefined_columns

Return a HASH with the predefined columns and sets.

=head1 default_mod

Return a HASH with the HDB::MOD installed by default in this version.

The HASH:

  keys   => full name.
  values => id for HDB.

=head1 RETURN

Commands like select has a return argument, that will tell how to format the results and the type of the variable.

The return has 2 parts.

First, the type of the variable (@|$):

  @ >> Will return an array.
  $ >> Will return the first line of the results (row), or the parsed reference of the 2nd part.
  
  ** If the first part is omitted, @ will be used.

Second, the format ($|@|%):

  $ >> The rows will have the columns separated by '::', like:  joe::joe@mail.com::1
  @ >> The cols of each row will be inside an ARRAY.
  % >> The cols of each row will be inside a HASH.

Examples:

  return => '@$'   # Will return an ARRAY, with the cols in each line of the array separated by '::'.
  return => '@@'   # Will return an ARRAY of ARRAYS (with the cols in the SUB-ARRAY).
  return => '@%'   # Will return an ARRAY of HASHES (with the cols in the HASH).

  return => '$$'   # Will return the cols of the first result (row) separated by '::'. (return a sinlge SCALAR)
  return => '$@'   # Will return the cols of the first result (row) inside an ARRAY. (return a sinlge ARRAY)
  return => '$%'   # Will return the cols of the first result (row) inside a HASH. (return a sinlge HASH)
  
  return => '$$@'  # Special case: Parse the encoded ref of the first col in the first row. See HDB::Encode.
  return => '$$%'  # Same as $$@.

  return => '<$>'  # Special: Parse sth row by row, returning a SCALAR, with the columns separated by '::'.
  return => '<@>'  # Special: Parse sth row by row, returning a ARRAY with the values of the columns.
  return => '<%>'  # Special: Parse sth row by row, returning a HASH of columns and values.
  
  return => '$'    # Like @$
  return => '@'    # Like @@
  return => '%'    # Like @%

  return => '%%'   # Like $%

If you want the list of columns returned, put NAMES in the begin of return:

  return => 'NAMES,@@'  # Will return the reference to an ARRAY with the columns names and the ARRAY of ARRAYS.
  
  ## USAGE:
  my ($cols_names , @sel) = $HDB->select('users','NAMES,@%') ;
  my @cols_names = @$cols_names ;

The best way to think in the I<RETURN> type is to think in what variable type will receive the result,
and in what type you want the informations inside the result.

  ## For an ARRAY receiveing and for informations in HASH type: @%
  my @sel = $HDB->select('users','@%') ;
  print "$sel[0]{name}\n" ;
  
  ## For a SCALAR receiveing and for informations in ARRAY type: $@
  my $name = $HDB->select('users', col => 'name' , '$@') ;
  
  ## For a HASH receiveing and for informations in HASH type: %%
  my %user = $HDB->select('users', "id == 1" '%%') ; ## return only 1 row!
  print "$user{name}\n" ;

=head2 RETURN USAGE (Code Examples):

  my @sel = $HDB->select( table => users , return => '@$' );
  
  foreach my $sel_i ( @sel ) {
    my @cols = split("::" , $sel_i) ;
    ...
  }
  
  ##########################################################

  my @sel = $HDB->select( table => users , return => '@@' );
  
  foreach my $sel_i ( @sel ) {
    my @cols = @$sel_i ;
    ...
  }
  
  ##########################################################

  my @sel = $HDB->select( table => users , return => '@%' );
  
  foreach my $sel_i ( @sel ) {
    my %cols = %$sel_i ;
    ...
  }
  
  ##########################################################

  my ($names,@sel) = $HDB->select( table => users , return => 'NAMES,@%' );
  my @names = @$names ;

  foreach my $sel_i ( @sel ) {
    my %cols = %$sel_i ;
    ...
  }
  
  ##########################################################

  my %hash = $HDB->select( table => users , col => 'encoded' , return => '$$@' );
  
  foreach my $Key ( keys %hash ) {
    my $Value = $hash{$Key} ;
    print "$Key = $Value\n" ;
  }
  
  ##########################################################
  
  my $hdbhandle = $HDB->select( table => users , return => '<$>' );
  
  while( my $row = <$hdbhandle> ) {
    my @cols = split("::" , $row) ;
    ...
  }
  
  ##########################################################
  
  my $hdbhandle = $HDB->select( table => users , return => '<@>' );
  
  while( my @cols = <$hdbhandle> ) {
    ...
  }
  
  ##########################################################
  
  my $hdbhandle = $HDB->select( table => users , return => '<%>' );
  
  while( my %cols = <$hdbhandle> ) {
    foreach my $Key ( keys %cols ) { print "$Key = $cols{$Key}\n" ;}
    ...
  }
  
  ##########################################################

  my $sel_row_0 = $HDB->select( table => users , return => '$$' );
  my @cols = split("::" , $sel_row_0) ;
  
  ##########################################################

  my @cols = $HDB->select( table => users , return => '$@' ); ## Return ROW 0.
  
  ##########################################################

  my %cols = $HDB->select( table => users , return => '$%' ); ## Return ROW 0.
  

=head1 SEE ALSO

L<HDB>, L<HDB::Encode>, L<HDB::sqlite>, L<HDB::mysql>.

=head1 AUTHOR

Graciliano M. P. <gm@virtuasites.com.br>

=head1 COPYRIGHT

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

PK       ! @� fRl  Rl    perl5/HDB/Object.hploonu ��6�$        #############################################################################
## Name:        Object.pm
## Purpose:     HDB::Object - Base class for persistent Class::HPLOO objects.
## Author:      Graciliano M. P.
## Modified by:
## Created:     21/09/2004
## RCS-ID:      
## Copyright:   (c) 2004 Graciliano M. P.
## Licence:     This program is free software; you can redistribute it and/or
##              modify it under the same terms as Perl itself
#############################################################################

use Class::HPLOO qw(alloo base) ;

class HDB::Object[0.02] {

  use HDB ;
  
  *WITH_HPL = \&HDB::WITH_HPL ;
  *HPL_MAIN = \&HDB::HPL_MAIN ;
  
  my ( %NEW_IDS , %OBJ_TABLE , %OBJ_TABLE_LOADER , $DID_REQUIRED ) ;
  

  use overload (
  'bool' => '_OVER_bool' ,
  '""' => '_OVER_string' ,
  'fallback' => 1 ,
  ) ;
  
  sub _OVER_bool { 1 ;}
  
  sub _OVER_string {
    my $class = $this->__CLASS__ ;
    my $id = $this->__ID__ ;
    
    if ( !$id ) {
      $this->hdb_save ;
      $id = $this->__ID__ ;
    }
    
    my $ident = "hdbobj__$class\__$id" ;
    $ident =~ s/::/_/gs ;

    return $ident ;
  }

  sub do_require {
    return if $DID_REQUIRED ;
    $DID_REQUIRED = 1 ;
    
    my $hpl = &HPL_MAIN() ;
    
    if ( $hpl ) {
      $hpl->use_cached('Hash::NoRef') ;
    }
    else {
      eval(" use Hash::NoRef ") ;
    }
    
    tie( %OBJ_TABLE , 'Hash::NoRef' ) ;
  }
  
  sub RESET {
    %OBJ_TABLE_LOADER = () ;
    %OBJ_TABLE = () ;
    %NEW_IDS = () ;
    return 1 ;
  }
   
  sub load {
    $CLASS = $this ? ref $this : shift(@_) ;

    my @where ;
    
    foreach my $i ( @_ ) {
      if ( $i =~ /^\d+$/s ) { push(@where , "id == $i") ;}
      else { push(@where , $i) ;}
    }
    
    return if !$CLASS->hdb_table_exists() ;
    
    my $hdb_obj = $CLASS->hdb ;
    
    my @sel = $hdb_obj->select( $CLASS , (@where ? ['?',@where] : ()) , (!wantarray ? (limit => '1') : () ) , '@%' ) ;
    return if !@sel ;
    
    do_require() ;
    
    my @obj ;
    foreach my $sel_i ( @sel ) {
      next if !$sel_i ;
      
      push(@obj , _build_obj($CLASS , $sel_i , $hdb_obj) ) ;
      next ;
      
      if ( $OBJ_TABLE{"$CLASS/$$sel_i{id}"} ) {
        delete $OBJ_TABLE_LOADER{"$CLASS/$$sel_i{id}"} ;
        push(@obj , $OBJ_TABLE{"$CLASS/$$sel_i{id}"} ) ;
      }
      else {
        my $loader ;
        if ( $OBJ_TABLE_LOADER{"$CLASS/$$sel_i{id}"} ) {
          $loader = $OBJ_TABLE_LOADER{"$CLASS/$$sel_i{id}"} ;
        }
        else {
          $loader = HDB::Object::Loader::create_loader($CLASS , $sel_i , $hdb_obj) ;
          $OBJ_TABLE_LOADER{"$CLASS/$$sel_i{id}"} = $loader ;
        }
        push(@obj , $loader) ;
      }
    }
    
    return if !@obj ;
    
    return @obj if wantarray ;
    return $obj[0] ;
  }
  
  sub select {
    my ( @list , $attr , $id ) ;
    if ( $#_ == 0 ) { ( $attr ) = @_ ;}
    elsif ( $#_ == 1 ) { ( $attr , $id ) = @_ ;}
    elsif ( $#_ > 1 ) { ( $id , @list ) = @_ ;}
    
    my $ret ;
    
    if ( @list ) {
      foreach my $list_i ( @list ) {
        if ( (UNIVERSAL::isa($list_i , 'HDB::Object') && $list_i->{__ID__} == $id) || (ref($list_i) eq 'HDB::Object::Loader' && $list_i->__ID__ == $id) ) {
          $ret = $list_i ;
          last ;
        }
      }
    }
    else {
      if ( ref( $this->{$attr} ) eq 'ARRAY' ) {
        foreach my $list_i ( @{ $this->{$attr} } ) {
          if ( (UNIVERSAL::isa($list_i , 'HDB::Object') && $list_i->{__ID__} == $id) || (ref($list_i) eq 'HDB::Object::Loader' && $list_i->__ID__ == $id) ) {
            $ret = $list_i ;
            last ;
          }
        }
      }
      elsif ( (UNIVERSAL::isa($this->{$attr} , 'HDB::Object') && $this->{$attr}->{__ID__} == $id) || (ref($this->{$attr}) eq 'HDB::Object::Loader' && $this->{$attr}->__ID__ == $id) ) {
        $ret = $this->{$attr} ;
      }
    }
    
    return $ret ;
  }
  
  sub _build_obj ($CLASS , $sel , $hdb_obj) {
    my $obj_ident = "$CLASS/$$sel{id}" ;
    
    ##print "BUILD OBJ>> $CLASS , $sel , $hdb_obj [$OBJ_TABLE{$obj_ident}]\n" ;
    
    return $OBJ_TABLE{$obj_ident} if $OBJ_TABLE{$obj_ident} ;
    
    my $this = bless({} , $CLASS) ;
    
    $hdb_obj ||= $CLASS->hdb ;
    
    &{"$CLASS\::CLASS_HPLOO_TIE_KEYS"}($this) ;
    
    foreach my $Key ( keys %$sel ) {
      if ( $Key =~ /^hdbobj__(\w*?)__(\w+)/ ) {
        my ( $class_obj , $attr , $id ) = ($1,$2 , $$sel{$Key}) ;
        $this->{CLASS_HPLOO_ATTR}{$attr} = $this->_build_ref_obj($class_obj,$id) ;
      }
      elsif ( $Key =~ /^hdbstore__(\w*?)__(\w+)/ ) {
        my ( $class_obj , $attr , $freeze ) = ($1,$2 , $$sel{$Key}) ;
        eval('use Storable qw()') ;
        if ( !$@ ) {
          eval {
            my $thaw = Storable::thaw($freeze) ;
            $this->{CLASS_HPLOO_ATTR}{$attr} = ref($thaw) eq 'ARRAY' ? $$thaw[0] : undef ;
          };
        }
      }
      elsif ( exists $this->{CLASS_HPLOO_ATTR}{$Key} ) { $this->{CLASS_HPLOO_ATTR}{$Key} = $$sel{$Key} ;}
    }
    
    $this->{__ID__} = $$sel{id} ;
    $this->{__HDB_OBJ__} = $hdb_obj ;
    
    my @ref_tables = $this->hdb_ref_tables ;
    
    foreach my $ref_tables_i ( @ref_tables ) {
      my ($class_main , $class_obj , $attr) = ( $ref_tables_i =~ /^hdbref__(\w*?)__(\w*?)__(\w+)/ );
      $class_obj .= '_' if $class_main eq $class_obj ;
      
      my @sel = $this->hdb->select( $ref_tables_i , "$class_main == $this->{__ID__}" , cols => "$class_obj" , '@$') ;

      $this->{CLASS_HPLOO_ATTR}{$attr} = [] ;
      foreach my $sel_i ( @sel ) {
        push( @{ $this->{CLASS_HPLOO_ATTR}{$attr} } , $this->_build_ref_obj($class_obj,$sel_i) ) ;
      }
    }
    
    foreach my $Key ( keys %OBJ_TABLE ) {
      delete $OBJ_TABLE{$Key} if !defined $OBJ_TABLE{$Key} ;
    }
    
    delete $OBJ_TABLE_LOADER{$obj_ident} ;
    $OBJ_TABLE{$obj_ident} = $this ;

    return $this ;
  }
  
  sub hdb_refresh {
    return if !$this || !$this->{__ID__} ;
    my $hdb_obj = $this->hdb ;
    return if !$hdb_obj ;
        
    my $sel = $hdb_obj->select( $this->__CLASS__ , "id == $this->{__ID__}" , '$%' ) ;
    
    print "REF>> $sel\n" ;
  }
  
  sub _build_ref_obj ($class_obj , $id){
    $class_obj =~ s/_$// ;
    $class_obj =~ s/_/::/gs ;
    if ( UNIVERSAL::isa($class_obj,'HDB::Object') ) {
      return $class_obj->load($id) ;
    }
    return ;
  }
  
  sub __ID__ {
    return $this->{__ID__} ;
  }
  
  sub hdb_obj_changed {
    return 1 if ( exists $this->{CLASS_HPLOO_CHANGED} && $this->{CLASS_HPLOO_CHANGED} && ref $this->{CLASS_HPLOO_CHANGED} eq 'HASH' && %{ $this->{CLASS_HPLOO_CHANGED} }) ;
    return ;
  }
  
  sub hdb {
    my $dbobj = UNIVERSAL::isa($this , 'HASH') ? $this->{__HDB_OBJ__} : undef ;
    
    if ( !$dbobj ) { $dbobj = HDB->HPLOO ;}
    
    if ( !$dbobj && WITH_HPL() ) {
      my $hpl = HPL_MAIN() ;
      if ( defined $hpl->env->{DOCUMENT_ROOT} ) {
        my $db_dir = $hpl->env->{DOCUMENT_ROOT} . '/db' ;
        my $db_file = "$db_dir/hploo.db" ;
        $dbobj = HDB->new(
        type => 'sqlite' ,
        db   => $db_file ,
        ) if -d $db_dir && -w $db_dir && (!-e $db_file || -w $db_file) ;
      }
    }
    
    if ( !$dbobj ) {
      warn("Can't find the predefined HPLOO database connection!") ;
      return ;
    }
    
    if ( UNIVERSAL::isa($this , 'HASH') && !$this->{__HDB_OBJ__} ) {
      $this->{__HDB_OBJ__} = $dbobj ;
    }
    
    return $dbobj ;
  }
  
  sub hdb_table_exists {
    $CLASS = $this ? ref $this : shift(@_) ;
    my $CLASS_HPLOO_HASH = $CLASS->GET_CLASS_HPLOO_HASH ;
    
    return 1 if ( (time - $CLASS_HPLOO_HASH->{HDB_TABLE_CHK}) < 2 ) ;

    my %table_hash = $this ? $this->hdb->tables_hash : $CLASS->hdb->tables_hash ;
    
    my $table = $this ? $this->__CLASS__ : $CLASS ;
    $table = HDB::CMDS::_format_table_name($table) ;
    
    if ( $table_hash{$table} ) {
      $CLASS_HPLOO_HASH->{HDB_TABLE_CHK} = time ;
      return 1 ;
    }
    $CLASS_HPLOO_HASH->{HDB_TABLE_CHK} = undef ;

    return ;
  }
  
  sub hdb_create_table {
    my $class_hploo = $this->GET_CLASS_HPLOO_HASH ;
    my $CLASS = $this->__CLASS__ ;
    
    if ( $CLASS !~ /^\w+(?:::\w+)*$/ ) {
      warn("Can't use class name '$CLASS' as a table name!!!\n") ;
    }
    
    $CLASS =~ s/:+/_/gs ;
      
    my @cols ;
    foreach my $order_i ( @{$class_hploo->{ATTR_ORDER}} ) {
      my $tp = $class_hploo->{ATTR}{$order_i}{tp} ;
      
      my ( $col_name , $tp , $table_ref , @cols_ref ) = $this->_hdb_attr_type($order_i , $tp) ;
            
      if ( $table_ref ) {
        $this->hdb->create( $table_ref , @cols_ref ) ;
        #print $this->hdb->sql . "\n" ;
      }
      else {
        push(@cols , $col_name , $this->_hdb_col_type_hploo_2_hdb($tp) ) ;
      }
    }
    
    warn("Can't store in the DB class $CLASS since the class doesn't have attributes!") if !@cols ;

    $this->hdb->create( $CLASS , @cols ) ;
    #print $this->hdb->sql . "\n" ;
  }
  
  sub hdb_ref_tables {
    my $CLASS = $this ? $this->__CLASS__ : shift(@_) ;
    my @tables = $this ? $this->hdb->tables : $CLASS->hdb->tables ;

    $CLASS =~ s/:+/_/gs ;
    my @ref ;
    foreach my $tables_i ( @tables ) {
      push(@ref , $tables_i) if $tables_i =~ /hdbref__$CLASS\__/ ;
    }

    return @ref ;
  }
  
  sub hdb_ref_to_me_tables {
    my $CLASS = $this ? $this->__CLASS__ : shift(@_) ;
    my @tables = $this ? $this->hdb->tables : $CLASS->hdb->tables ;

    $CLASS =~ s/:+/_/gs ;
    my @ref ;
    foreach my $tables_i ( @tables ) {
      push(@ref , $tables_i) if $tables_i =~ /hdbref__(\w+?)__$CLASS\__/ ;
    }

    return @ref ;
  }
  
  sub hdb_referenced_ids {
    my $CLASS = $this ? $this->__CLASS__ : shift(@_) ;
    my $this_or_class = $this || $CLASS ;
    
    my $hdb_obj = shift(@_) || $this_or_class->hdb ;

    my $class_obj = $CLASS ;
    $class_obj =~ s/:+/_/gs ;

    my $can_have_ref ;

    my @ref_tables = $this_or_class->hdb_ref_to_me_tables ;
    
    $can_have_ref = 1 if @ref_tables ;

    my %ids_ok ;

    foreach my $ref_tables_i ( @ref_tables ) {
      my @sel = $hdb_obj->select( $ref_tables_i , cols => "$class_obj" , '@$') ;
      @ids_ok{@sel} = (1) x @sel ;
    }
    
    foreach my $tables_i ( $hdb_obj->tables ) {
      foreach my $cols_i ( $hdb_obj->names($class_obj) ) {
        if ( $cols_i =~ /^hdbobj__$class_obj\__/ ) {
          my @sel = $hdb_obj->select( $tables_i , cols => $cols_i , '@$') ;
          @ids_ok{@sel} = (1) x @sel ;
          $can_have_ref = 1 ;
        }
      }
    }
    
    return \%ids_ok if $can_have_ref ;
    return ;
  }
  
  sub hdb_clean_unref {
    my $CLASS = $this ? $this->__CLASS__ : shift(@_) ;
    my $this_or_class = $this || $CLASS ;
    
    my $hdb_obj = shift(@_) || $this_or_class->hdb ;
    
    my $class_obj = $CLASS ;
    $class_obj =~ s/:+/_/gs ;

    my $ids_ok = $this_or_class->hdb_referenced_ids($hdb_obj) ;
    
    $hdb_obj->delete( $class_obj , ["id != ?", ['AND'] , keys %$ids_ok]) if $ids_ok ;
  }
  
  sub _hdb_attr_type ( $attr , $tp ) {
    my $CLASS = $this->__CLASS__ ;
        
    $CLASS =~ s/:+/_/gs ;

    my ( $tp1 ,$tp2 ) ;
    
    if ( $tp =~ /(?:ref\s*)?(array\s*|hash\s*)?(&\w+|\w+(?:::\w+)*)/ ) { ( $tp1 ,$tp2 ) = ($1,$2) ;}
    else { $tp2 = $tp ;}
    
    my $is_hdbobj = UNIVERSAL::isa($tp2 , 'HDB::Object') ;
    
    $tp2 =~ s/:+/_/gs ;
    $tp = $tp2 ;
    
    my $is_obj = ($tp =~ /^(?:boolean|integer|floating|string|sub_\w+|any|&\w+)$/ ) ? 0 : 1 ;
    
    my $col_name ;
    
    if ( !$is_hdbobj && $is_obj ) {
      return( "hdbstore__$tp2\__$attr" , '*' ) ;
    }
    elsif ( $is_obj ) {
      $col_name = "hdbobj__$tp2\__$attr" ;
      $tp = 'integer' ;
    }
    else { $col_name = $attr ;}
    
    my ($table_ref , @cols_ref) ;
    if ( $tp1 eq 'array' ) {
      $table_ref = "hdbref__$CLASS\__$tp2\__$attr" ;
      $tp2 .= '_' if $CLASS eq $tp2 ;
      @cols_ref = (
      $CLASS => 'integer' ,
      $tp2 => 'integer' ,
      ) ;
    }
    
    return( $col_name , $tp , $table_ref , @cols_ref ) ;
  }
  
  sub _hdb_col_type_hploo_2_hdb ( $hploo_type ) {
    if    ( $hploo_type =~ /(?:any|string)/i ) { return '*' ;}
    elsif ( $hploo_type =~ /bool/i ) { return 'boolean' ;}
    elsif ( $hploo_type =~ /int/i ) { return 'int' ;}
    elsif ( $hploo_type =~ /float/i ) { return 'float' ;}
    else { return '*' ;}
  }
  
  sub hdb_max_id {
    my $max_id = $this->hdb->select( $this->__CLASS__ , cols => '>id' , '$' ) ;
    return $max_id ;
  }
  
  sub hdb_delete {
    return if !$this->hdb_table_exists ;
    my $id = $this->{__ID__} ;
    
    return if ( $id eq '' || !$this->hdb->select( $this->__CLASS__ , "id == $id" , cols => 'id' , '$' ) ) ;
    
    $this->hdb->delete( $this->__CLASS__ , "id == $id" ) ;
    
    %$this = () ;
    
    return 1 ;
  }
  
  sub hdb_new_id {
    my $id = $this->hdb_max_id + 1 ;
    my $class = $this->__CLASS__ ;
    while( $NEW_IDS{$class}{$id} ) { ++$id ;}
    $NEW_IDS{$class}{$id} = 1 ;
    return $id ;
  }

  sub hdb_save (%args) {
    $this->hdb_create_table if !$this->hdb_table_exists ;

    return if !$args{save_all} && !$this->hdb_obj_changed ;
    
    my $class_hploo = $this->GET_CLASS_HPLOO_HASH ;

    my $class_hploo_changed = $this->{CLASS_HPLOO_CHANGED} ;
    $this->{CLASS_HPLOO_CHANGED} = undef ;
    
    my $id = $this->{__ID__} ;
    my $insert ;
    
    if ( $id eq '' || ($id && !$this->hdb->select( $this->__CLASS__ , "id == $id" , cols => 'id' , '$' )) ) {
      $id = $this->hdb_new_id ;
      $insert = 1 ;
    }
        
    my @del_attr_keys ;
    
    my $saved_classes = $args{saved_classes} || {} ;

    foreach my $order_i ( @{$class_hploo->{ATTR_ORDER}} ) {
      my $tp = $class_hploo->{ATTR}{$order_i}{tp} ;
      my ( $col_name , $tp , $table_ref , @cols_ref ) = $this->_hdb_attr_type($order_i , $tp) ;
      
      ##print ">> $col_name , $tp , $table_ref , @cols_ref \n" ;
            
      if ( $table_ref ) {
        if ( ref $this->{$order_i} eq 'ARRAY' ) {
          my (@ids , %ids , $c) ; 
          
          foreach my $attr_i ( @{$this->{$order_i}} ) {
            if ( ref($attr_i) eq 'HDB::Object::Loader' ) {
              my $id = $attr_i->[1]{id} ;
              push(@ids , $id) ;
              $ids{$id} = ++$c ;
            }
            elsif ( UNIVERSAL::isa($attr_i , 'HDB::Object') ) {
              $attr_i->hdb_save( no_auto_clean_unref => 1 , saved_classes => $saved_classes ) ;
              $$saved_classes{ $attr_i->__CLASS__ } = 1 ;
              push(@ids , $attr_i->{__ID__}) ;
              $ids{$attr_i->{__ID__}} = ++$c ;
            }
          }

          my @sel = $this->hdb->select( $table_ref , "$cols_ref[0] == $id" , cols => "$cols_ref[2],id" , '@@') ;
          
          my (@del_ids , %sel_ids , %sel_pos ) ;
          
          #print "IDS[$this]>> @ids\n" ;
          
          $c = 0 ;
          foreach my $sel_i ( @sel ) {
            $sel_ids{$$sel_i[0]} = ++$c ;
            $sel_pos{$c} = $$sel_i[1] ;
            push(@del_ids , $$sel_i[1]) if $ids{$$sel_i[0]} != $c ;
            #print "SEL>> $$sel_i[0] , $$sel_i[1] [$c] >> $ids{$$sel_i[0]}\n" ;
          }
          
          my @dels = @del_ids[($#ids+1)..$#del_ids] ;
          #print "DEL>> @dels\n" ;
          
          $this->hdb->delete( $table_ref , ["$cols_ref[2] == ?" , @dels] ) if @dels ;
          #print $this->hdb->sql . "\n" if @dels ;

          foreach my $ids_i ( @ids ) {
            if ( $ids{$ids_i} != $sel_ids{$ids_i} ) {
              my $pos = $sel_pos{ $ids{$ids_i} } ;
              if ( $pos ) {
                $this->hdb->update( $table_ref , "id == $pos" , {$cols_ref[0] => $id , $cols_ref[2] => $ids_i}) ;
                #print $this->hdb->sql . "\n" ;
              }
              else {
                $this->hdb->insert( $table_ref , {$cols_ref[0] => $id , $cols_ref[2] => $ids_i}) ;
                #print $this->hdb->sql . "\n" ;
              }
            }
          }

        }
        elsif ( UNIVERSAL::isa($this->{$order_i} , 'HDB::Object') ) {
          $this->{$order_i}->hdb_save( no_auto_clean_unref => 1 , , saved_classes => $saved_classes ) ;
          $$saved_classes{ $this->{$order_i}->__CLASS__ } = 1 ;
        }
      }
      elsif ( $col_name =~ /^hdbobj/ ) {
        if ( ref($this->{$order_i}) eq 'HDB::Object::Loader' ) {
          my $id = $this->{$order_i}->[1]{id} ;
          $this->{CLASS_HPLOO_ATTR}{$col_name} = $id ;
        }
        elsif ( UNIVERSAL::isa($this->{$order_i} , 'HDB::Object') ) {
          $this->{$order_i}->hdb_save( no_auto_clean_unref => 1 , saved_classes => $saved_classes , save_all => $args{save_all} ) ;
          $$saved_classes{ $this->{$order_i}->__CLASS__ } = 1 ;
          $this->{CLASS_HPLOO_ATTR}{$col_name} = $this->{$order_i}->{__ID__} ;
        }
        push(@del_attr_keys , $col_name) ;
      }
      elsif ( $col_name =~ /^hdbstore/ ) {
        eval('use Storable qw()') ;
        if ( !$@ ) {
          eval {
            $this->{CLASS_HPLOO_ATTR}{$col_name} = Storable::freeze( [$this->{$order_i}] ) ;
          };
          push(@del_attr_keys , $col_name) ;
        }
      }
    }

    my $ret ;
    if ( $insert ) {
      $this->{CLASS_HPLOO_ATTR}{id} = $this->{__ID__} = $id ;
      push(@del_attr_keys , 'id') ;
      $ret = $this->hdb->insert( $this->__CLASS__ , $this->{CLASS_HPLOO_ATTR} ) ;
    }
    else {
      my %changeds ;
      if ( $args{save_all} ) { %changeds = %{ $this->{CLASS_HPLOO_ATTR} } ;}
      else {
        foreach my $Key ( keys %$class_hploo_changed ) {
          $changeds{$Key} = $this->{CLASS_HPLOO_ATTR}{$Key} ;
        }
      }

      $ret = $this->hdb->update( $this->__CLASS__ , "id == $id" , \%changeds ) ;
    }
    
    foreach my $del_keys_i ( @del_attr_keys ) { delete $this->{CLASS_HPLOO_ATTR}{$del_keys_i} ;}
    
    $$saved_classes{ $this->__CLASS__ } = 1 ;
    
    if ( !$args{no_auto_clean_unref} ) {
      foreach my $Key ( keys %$saved_classes ) {
        if ( defined &{ $Key . '::AUTO_CLEAN_UNREF'} && &{ $Key . '::AUTO_CLEAN_UNREF'}() && (time - $class_hploo->{HDB_TABLE_AUTOCLS}{$Key}) > 2 ) {
          $Key->hdb_clean_unref( $this->hdb ) ;
          $class_hploo->{HDB_TABLE_AUTOCLS}{$Key} = time ;
        }
      }
    }
    
    return $ret ;
  }
  
  sub hdb_dump_table ($table) {
    if ( !$this ) {
      $this = $table || $_[0] ;
      $table = $_[0] if $_[0] ;
    }
    
    return '' if !$this->hdb_table_exists ;
    return $this->hdb->dump_table($table) ;
  }
  
  sub STORABLE_freeze ($cloning) {
    return(
      $this ,
      {
        (ref $this->{CLASS_HPLOO_ATTR} eq 'HASH' ? %{$this->{CLASS_HPLOO_ATTR}} : ()) ,
        id => $this->{__ID__} ,
      }
    ) ;
  }
  
  sub STORABLE_thaw ($cloning , $serial , $attrs) {
    my $class = ref $this ;
    
    $this->{__ID__} = delete $attrs->{id} ;

    $this->{CLASS_HPLOO_ATTR} = {} ;
    %{ $this->{CLASS_HPLOO_ATTR} } = %$attrs ;
    
    &{"$class\::CLASS_HPLOO_TIE_KEYS"}($this) ;
    
    $this->hdb ;
    return ;
  }

  sub DESTROY {
    return if !%$this ;
    $this->hdb_save ;
  }
  

}

################################################################################

{ package HDB::Object::Loader ;

  use strict qw(vars) ;

  use vars qw($AUTOLOAD) ;
  
  use overload (
    'bool' => \&HDB::Object::_OVER_bool ,
    '""' => \&HDB::Object::_OVER_string ,
    '%{}' => '_OVER_hash' ,
    'fallback' => 1 ,
  );
  
  sub _OVER_hash {
    _build($_[0]) ; return $_[0] ;
  
    if ( !$_[0][3] ) {
      my %hash = (1) ;
      $_[0][3] = \%hash ;
      $_[0][4] = tie( %hash , 'HDB::Object::Loader::TieHandler' ,  @{$_[0]}[0..2] ) ;
    }
    
    if ( $_[0][4] && $_[0][4]->[3] ) {
      $_[0] = $_[0][4]->[3] ;
      return $_[0] ;
    }
    
    return $_[0][3] ;
  }
  
  sub create_loader { bless [ @_ ] ;}
  
  sub _build {
    my @args = @{$_[0]} ;
    $_[0] = HDB::Object::_build_obj(@args) ;

    die "INTERNAL ERROR: Cannot build instance of '$args[0]'\n" unless defined $_[0] ;
    # This can occur if the class wasn't loaded correctly.
    die "INTERNAL ERROR: _build() failed to build a new object\n" if ref($_[0]) eq __PACKAGE__;

    return $_[0] ;
  }
  
  sub __CLASS__ {
    return $_[0][0] ;
  }
  
  sub __ID__ {
    return $_[0][1]{id} ;
  }
  
  sub can {
    _build($_[0]);
    $_[0]->can($_[1]);
  }

  sub isa {
    $_[0][0]->isa($_[1]) ;
  }

  sub AUTOLOAD {
    my ($subname) = $AUTOLOAD =~ /([^:]+)$/ ;

    my $realclass = $_[0][0] ;
    _build( $_[0] ) ;

    my $func = $_[0]->can( $subname );

    die "Cannot call '$subname' on an instance of '$realclass'\n" unless ref( $func ) eq 'CODE';

    goto &$func ;
  }
  
  ## Don't need to save if we haven't changed attributes:  
  sub DESTROY {
    ##_build($_[0]);
    ##$_[0]->DESTROY(@_[1..$#_]);
  }
  
}

################################################################################

{ package HDB::Object::Loader::TieHandler ;

  use strict qw(vars) ;
  no warnings ;
  
  sub TIEHASH { shift ; bless [ @_ ] ;}
  
  my $val ;
  
  sub FETCH { #print STDOUT "FETCH>> @_\n" ;
    my $this = shift ;
    my $key = shift ;
    
    return $this->[1]{id} if $key eq '__ID__' ;
    
    $this->[3] = HDB::Object::_build_obj( @{$this}[0..2] ) if !defined $this->[3] ;
    
    return $this->[3]{$key} ;
  }  
  
  sub STORE { #print STDOUT "STORE>> @_\n" ;
    my $this = shift ;
    my $key = shift ;
  
    $this->[3] = HDB::Object::_build_obj( @{$this}[0..2] ) if !defined $this->[3] ;
    
    return $this->[3]{$key} ;
  }
   
  sub DELETE   { #print STDOUT "DELETE>> @_\n" ;
    my $this = shift ;
    my $key = shift ;
    
    $this->[3] = HDB::Object::_build_obj( @{$this}[0..2] ) if !defined $this->[3] ;
    
    return delete $this->[3]{$key} ;
  }
  
  sub EXISTS   { #print STDOUT "EXISTS>> @_\n" ;
    my $this = shift ;
    my $key = shift ;
    
    $this->[3] = HDB::Object::_build_obj( @{$this}[0..2] ) if !defined $this->[3] ;
    
    return exists $this->[3]{$key} ;
  }
  
  sub FIRSTKEY { #print STDOUT "FIRSTKEY>> @_\n" ;
    my $this = shift ;
    
    $this->[3] = HDB::Object::_build_obj( @{$this}[0..2] ) if !defined $this->[3] ;
    
    return (keys %{$this->[3]})[0] ;
  }
  
  sub NEXTKEY  { #print STDOUT "NEXTKEY>> @_\n" ;
    my $this = shift ;
    my $keylast = shift ;
    
    $this->[3] = HDB::Object::_build_obj( @{$this}[0..2] ) if !defined $this->[3] ;
    
    my $ret_next ;
    foreach my $keys_i ( keys %{$this->[3]} ) {
      if ($ret_next) { return $keys_i ;}
      if ($keys_i eq $keylast || !defined $keylast) { $ret_next = 1 ;}
    }
  
    return undef ;
  }
  
  sub CLEAR { #print STDOUT "CLEAR>> @_\n" ;
    my $this = shift ;
    
    $this->[3] = HDB::Object::_build_obj( @{$this}[0..2] ) if !defined $this->[3] ;
    %{$this->[3]} = () ;
    
    return ;
  }
  
  sub UNTIE {}
  sub DESTROY {}

}

1 ;


__END__

=> NAME

HDB::Object - Base class for persistent Class::HPLOO objects.

=> DESCRIPTION

This is the base class for persistent Class::HPLOO objects.

This will automaticallt make Class::HPLOO classes persistent in any DB
handled by L<HDB>.

This persistence framework was built by a group of modules that handles specific
parts of the problem:

*> L<Class::HPLOO>

The class declaration and attribute handler.

*> L<HDB::Object>

The object persistence and class proxy.

*> L<HDB>

The DB connection and SQL communication for each DB type.

/*>

All of this will create a very automatic way to create persistent objects over a
relational DB, what is perfect for fast and easy creation of good systems.
For Web Systems this framework is automatically embeded into L<HPL>,
where you can count with a lot of resources for fast and powerful creations for
the Web.

=> USAGE

Here's an example of a class built with HDB::Object persistence.

  use Class::HPLOO ;
  
  class User extends HDB::Object {
  
    use HDB::Object ;
  
    attr( user , pass , name , int age ) ;
    
    sub User( $user , $pass , $name , $age ) {
      $this->{user} = $user ;
      $this->{pass} = $pass ;
      $this->{name} = $name ;
      $this->{age} = time ;
    }
  
  }

B<You can see that is completly automatic and you don't need to care about the
serialization or even about the DB connection, tables and column types.>

=> METHODS

==> load (CONDITIONS)

Loads an object that exists in the database.

I<CONDITIONS> can be a sequence of WHERE conditions for HDB:

  my $users_x = load User('id == 123') ;
  
  my @users = load User('id <= 10' , 'id == 123' , 'name eq "joe"') ;

If I<CONDITIONS> is NOT paste, if wantarray it will return all the objects in the table, or it will return only the 1st:

  my $user1 = load User() ;
  
  my @all_users = load User() ;

==> hdb

Return the HDB object that handles the DB connection.

==> hdb_dump_table

Dump all the table content, returning that as a string.

==> hdb_table_exists

Retrun TRUE if the table for the HDB::Object was already created.

==> hdb_create_table

Create the table for the HDB::Object if it doesn't exists.

==> hdb_obj_changed

Return TRUE when the object was changed and need to be updated in the DB.

==> hdb_max_id

Return the max id in the object table.

==> hdb_delete

Delete the object from the database.

==> hdb_save

Save the object in the database.

I<** Note that you don't need to call this method directly, since when
the object is destroied from the memory it will be saved automatically.>

==> hdb_clean_unref

This will automatically clean objects from this table if they doesn't have
references in the database from another object. So, only call this if
you have a colection of objects that are referenced by others or you
will lose all the objects from the table:

  Users::Level->hdb_clean_unref ;

You also can define the constant I<AUTO_CLEAN_UNREF> to automatically clean
unreferenced objects:

  class Users::Level extends HDB::Object {
    use constant AUTO_CLEAN_UNREF => 1 ;
    ...
  }

==> hdb_referenced_ids

Return the IDs that have a reference to it.

=> DESTROY and AUTO SAVE OBJECT

The object will be automatically saved when the object is destroied.

So if you want to use this automatically save resource you can't overload the
sub DESTROY, or at least should call the super method:
  
  class User extends HDB::Object {
    ...
    
    sub DESTROY {
      $this->SUPER::DESTROY ;
      ... # your destroy stuffs.
    }
  }

=> OBJECT REFERENCES

I<HDB::Object> will try to handle automatically attributes that make references
to other objects or list of objects.

When an atribute make a reference to an object that extends I<HDB::Object>,
only the ID to the object will be saved, making a reference to the ID
of the object table.

If an object doesn't extends I<HDB::Object> it will be serialized, using L<Storable>,
and stored in the coloumn value.

When an attribute have a list of objects, a reference table is created automatically:

  attr( array Date::OBject dates )

=> OBJECT PROXY

The Object Proxy mechanism was inspirated on L<Class::LazyLoad>. The main idea
is that the object won't be created unless it's accessed. The proxy will be used only
when the object is loaded from the DB, not when you create a new object. So, when
you load an object from the DB, actually the DB will be accessed only when you use the
object.

An Object Proxy is very important to save memory and DB access, since if we don't
use a proxy is possible to have an object that loads all the DB in the memory due
it's object tree.

=> SEE ALSO

L<HPL>, L<HDB>, L<Class::HPLOO>, L<Class::LazyLoad>.

=> AUTHOR

Graciliano M. P. <gm@virtuasites.com.br>

I will appreciate any type of feedback (include your opinions and/or suggestions). ;-P

=> COPYRIGHT

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


PK       ! )G2{�
  �
    perl5/HDB/MOD.pmnu ��6�$        #############################################################################
## Name:        MOD.pm
## Purpose:     HDB::MOD - Common things for HDB modules.
## Author:      Graciliano M. P.
## Modified by:
## Created:     15/01/2003
## RCS-ID:      
## Copyright:   (c) 2002 Graciliano M. P.
## Licence:     This program is free software; you can redistribute it and/or
##              modify it under the same terms as Perl itself
#############################################################################

package HDB::MOD ;

use DBI ;

use strict qw(vars) ;
no warnings ;

our $VERSION = '1.0' ;
our @ISA = qw(HDB::CMDS HDB) ;

###############
# VAR ALIASES #
###############

sub dbi { $_[0]->{dbh} ;}
sub dbh { $_[0]->{dbh} ;}
sub sth { $_[0]->{sth} ;}
sub sql { $_[0]->{sql} ;}

#############
# CONNECTED #
#############

sub connected {
  if ( !$_[0]->dbh ) { return undef ;}
  if ( $_[0]->dbh->{Active} ) { return 1 ;}
  return undef ;
}

##############
# DISCONNECT #
##############

sub disconnect {
  my $this = shift ;

  $this->{sth}->finish if $this->{sth} ;
  $this->{sth} = undef ;
  
  $this->flush_cache ;
  
  if ( $this->{dbh} ) {
    $this->{dbh}->commit if !$this->{dbh}->{AutoCommit} ;
    $this->MOD_disconnect if !$this->{dbh}->{Kids} ;  
  }

  $this->{dbh} = undef ;

  return ;
}

##################
# MOD_DISCONNECT #
##################

sub MOD_disconnect {
  my $this = shift ;
  $this->{dbh}->disconnect ;
}

########
# LINK #
########

sub LINK {
  if ( $_[0]->{HPL}{UNLINK_DISCONNECT} ) { $_[0]->connect ;}
}

##########
# UNLINK #
##########

sub UNLINK {
  $_[0]->flush_cache ;
  if ( $_[0]->{sth} ) { $_[0]->{sth}->finish ; $_[0]->{sth} = undef ;}
  if ( $_[0]->{HPL}{UNLINK_DISCONNECT} ) { $_[0]->disconnect ;}
}

######
# DO #
######

sub do { $_[0]->{dbh}->do(@_[1..$#_]) ;}

###########
# PREPARE #
###########

sub prepare { $_[0]->{dbh}->prepare(@_[1..$#_]) ;}

###########
# EXECUTE #
###########

sub execute { $_[0]->{sth}->execute(@_[1..$#_]) ;}

#############
# TYPE_TEXT #
#############

sub Type_TEXT { return 'TEXT' ;}

################
# TYPE_INTEGER #
################

sub Type_INTEGER { return 'INTEGER' ;}

##############
# TYPE_FLOAT #
##############

sub Type_FLOAT { return 'FLOAT' ;}

##############
# PRIMARYKEY #
##############

sub PRIMARYKEY { return "PRIMARY KEY" ;}

#################
# AUTOINCREMENT #
#################

sub AUTOINCREMENT { return "INTEGER NOT NULL AUTO_INCREMENT" ;}

#########
# LIMIT #
#########

sub LIMIT {
  my $this = shift ;
  my ( $sz , $offset ) = @_ ;
  my $limit = $offset > 0 ? "$sz,$offset" : $sz ;
  return( "LIMIT $limit" ) ;
}

#######
# DBD #
#######

package DBI ;
package DBD ;
use vars qw(%HDB) ;

#######
# END #
#######

1;

PK       ! �퓠Z-  Z-    perl5/HDB/Parser.pmnu ��6�$        #############################################################################
## Name:        Parser.pm
## Purpose:     HDB::Parser
## Author:      Graciliano M. P.
## Modified by:
## Created:     15/01/2003
## RCS-ID:      
## Copyright:   (c) 2002 Graciliano M. P.
## Licence:     This program is free software; you can redistribute it and/or
##              modify it under the same terms as Perl itself
#############################################################################

package HDB::Parser ;
our $VERSION = '1.0' ;

use strict qw(vars) ;
no warnings ;

my %CACHE ;

my @STR_LYB = qw(a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z) ;

###############
# PARSE_WHERE #
###############

#use HDB::CORE ;
#print Parse_Where(['id == ?' , \'or' , qw(1 2 3)] , {} , 1) ;

sub Parse_Where {
  my ( $where , $this , $nowhere ) = @_ ;
  
  if ($where eq '') { return ;}
  
  my @where = &HDB::CORE::parse_ref($where) ;
  
  if (ref($where) && $#where <= 1 && $where[1] eq '') { return( $nowhere ? $where[0] : "WHERE( $where[0] )" ) ;}
  elsif (ref($where) eq 'ARRAY' && $#where >= 1) {
    my $cond = shift @where ;
    
    my $op = ref $where[0] eq 'ARRAY' ? @{ shift(@where) }[0] : (ref $where[0] eq 'SCALAR' ? ${ shift(@where) } : 'OR' ) ;

    $op =~ s/\s+//gs ;
    $op =~ s/^(?:&&?|and)$/AND/i ;
    $op =~ s/^(?:\|\|?|or)$/OR/i ;
    $op = 'OR' if $op !~ /^(?:AND|OR)$/ ;
    
    my $parser ;
          
    if ( $cond =~ /^\s*\(?\s*\?\s*\)?\s*$/s ) {
      foreach my $where_i ( @where ) {
        $where_i = Parse_Where($where_i,$this,1) ;
      }
      $parser = '(' . join(") $op (", @where) . ')' ;
    }
    else {
      $cond = '('. &Parse_Where($cond,$this,1) . ')' ;
      
      foreach my $where_i ( @where ) {
        my $val = &Value_Quote($where_i) ;
        $parser .= " $op " if $parser ne '' ;
        my $cond_new = $cond ;
        $cond_new =~ s/["']\?["']/$val/gs ;
        $parser .= $cond_new ;
      }
    }

    if ($nowhere) { return($parser) ;}
    else { return( "WHERE( $parser )" ) ;}
  }
  
  my $sql_id = $this ? "$this->{SQL}{REGEXP},$this->{SQL}{LIKE}" : '' ;
  my $where_id = "$sql_id#$where" ;
  
  if ( defined $CACHE{$where_id} ) { return( $nowhere ? $CACHE{$where_id} : "WHERE( $CACHE{$where_id} )" ) ;}
  
  my ($syntax,@quotes) = &Parse_Quotes($where) ;
  
  my @blocks = &Parse_Blocks($syntax) ;
  &Filter_Blocks( \@blocks , \@quotes , $this ) ;
  
  my ($parse,$lnk_last) ;
  
  foreach my $blocks_i ( @blocks ) {
    my @cond = @$blocks_i ;
    $parse .= " " if $parse =~ /\S$/s ;
    
    if ( $cond[0] =~ /^(?:AND|OR)$/ ) {
      my $add = shift @cond ;
      $parse .= $add ; $lnk_last = $add ;
    }
    
    my $cond = join(" ", @cond) ;
    
    $parse .= " " if ($cond ne '' && $parse =~ /\S$/s) ;
    
    if ($cond =~ /^\s*(?:AND|OR)\s*$/i) { $parse .= $cond ; $lnk_last = $cond ;}
    elsif ($cond =~ /\S/s) {
      if ($lnk_last !~ /\w/ && $parse =~ /\S/) { $parse .= "AND " ;}
      if ($cond =~ /\s(?:AND|OR)\s/) { $parse .= "($cond)" ;}
      else { $parse .= $cond ;}
      $lnk_last = undef ;
    }
  }

  $parse =~ s/%q_(\d+)%/$quotes[$1]/gs ;

  CLEAN_CACHE() ;

  $CACHE{$where_id} = $parse ;

  $parse = "WHERE( $parse )" if !$nowhere ;
  return( $parse ) ;
}

####################
# FILTER_CONDITION #
####################

sub Filter_Condition {
  my ( $string , $quotes , $this ) = @_ ;
  
  $string =~ s/\s+/ /gs ;
  $string =~ s/^\s+//g ;
  $string =~ s/\s+$//g ;
  
  my $split_mark = '%x%' ;
  while($string =~ /\Q$split_mark\E/s) { substr($split_mark,-2,1) .= &Rand_Str ;}
  
  $string .= ' ' ;
  $string =~ s/([^\w&]|^)(\|\||&&?|and|or)([^\w&])/$1$split_mark$2$split_mark$3/gi ;
  
  my @conds = split(/\Q$split_mark\E/s , $string) ;
  my @conds_ok ;
  
  foreach my $conds_i ( @conds ) {
    if ($conds_i !~ /\S/s) { next ;}
    if    ($conds_i =~ /^\s*(?:and|&&?)\s*$/s) { $conds_i = 'AND' ;}
    elsif ($conds_i =~ /^\s*(?:or|\|\|)\s*$/s) { $conds_i = 'OR' ;}
    else {
      my ($col,$cond,$val) = ( $conds_i =~ /^\s*(.*?)\s*(<>|!=|!~|=~|<=|>=|=>|=<|==?|>|<|\s+(?:eq|ne))\s*(.*)/ ) ;
      $cond =~ s/\s//s ;
      $val =~ s/\s*$//s ;

      if    ($cond =~ /^(?:!=|<>|ne)$/s) { $cond = '<>' ;}
      elsif ($cond =~ /^(?:<=|=<)$/s)    { $cond = '<=' ;}
      elsif ($cond =~ /^(?:>=|=>)$/s)    { $cond = '>=' ;}
      elsif ($cond =~ /^>$/s)            { $cond = '>' ;}
      elsif ($cond =~ /^<$/s)            { $cond = '<' ;}
      elsif ($cond =~ /^=~$/s)           { $cond = 'REGEXP' ;}
      elsif ($cond =~ /^!~$/s)           { $cond = 'NOT REGEXP' ;}
      elsif ($cond =~ /^(?:==?|eq)$/s)   { $cond = '=' ;}
      
      if ($cond =~ /REGEXP/ && $this && !$this->{SQL}{REGEXP} ) {
        if ( $this->{SQL}{LIKE} ) {
          ($cond , $val) = &Parse_REGEX_2_LIKE($cond , $val , $quotes) ;
          $this->Error("Can't use REGEXP on SQL syntax on module $this->{name}!!! Changing 'REGEXP' to 'LIKE' on syntax." , 1) ;
        }
        else {
          $this->Error("Can't use REGEXP on SQL syntax on module $this->{name}!!! Changing 'REGEXP' to '=' on syntax." , 1) ;
          $cond = '=' ;
        }
      }
      
      $val = &Value_Quote($val,$quotes) ;
      
      $conds_i = "$col $cond $val" ;
    }
    
    push(@conds_ok , $conds_i) ;
  }
  
  if ( wantarray ) { return( @conds_ok ) ;}
  else { return( join (" ", @conds_ok) ) ;}
}

#################
# FILTER_BLOCKS #
#################

sub Filter_Blocks {
  my ( $blk_ref , $quotes , $this ) = @_ ;
  
  for my $i (0..$#$blk_ref) {
    if ( ref( $$blk_ref[$i] ) eq 'ARRAY' ) { &Filter_Blocks( $$blk_ref[$i] ) ; next ;}
    my @cond = Filter_Condition( $$blk_ref[$i] , $quotes , $this ) ;
    $$blk_ref[$i] = \@cond ;
    #print ">> $$blk_ref[$i]\n" ;
  }
  
  return( $blk_ref ) ;
}

#print Parse_Blocks(q`aaa (bbb) ccc ( ddd (eee) fff ) ggg `) ;
#@blks = Parse_Blocks(q`col = and (col = x && col != y)`) ;
#print join ("\n", @blks) ;

################
# PARSE_BLOCKS #
################

sub Parse_Blocks {
  my ( $string ) = @_ ;

  my (@blocks,%b) ;
  
  while( $string =~ /(.*?)([\(\)])/gs ) {
    my $init .= $1 ;
    my $blk = $2 ;
    
    if ($blk eq '(') {
      if (! $b{o}) {
        my ($cond,$lnk) = ( $init =~ /(.*?[^\w&\|])\s*(\|\||&&?|and|or|)\s*$/gsi );
        push(@blocks , $cond) ;
        push(@blocks , $lnk) ;
      }
      $b{o}++ ;
      if ($b{o} > 1) { $b{d} .= $init ;}
      $b{d} .= $blk ;
    }
    elsif ($blk eq ')') {
      $b{d} .= $init . $blk ;
      $b{o}-- ;
      if ($b{o} <= 0) {
        $b{d} =~ s/^\(//gs ;
        $b{d} =~ s/\)$//gs ;
        
        my $block ;
        if ($b{d} =~ /\(.*?\)/s) {
          $block = [&Parse_Blocks( $b{d} )] ;
        }
        else { $block = $b{d} ;}
        
        push(@blocks , $block) ;
        $b{d} = undef ;        
      }
    }
  }
  
  if ( $string =~ /.*[\(\)](.*?)$/s ) { push(@blocks , $1) ;}
  else { push(@blocks , $string) ;}

  return( @blocks ) ;
}

#Parse_Quotes(q`aaa "b b b" ccc "\\\\" ddd \\\\ eee "f 'f' \"f\" f" ggg %bb`) ;
#Parse_Quotes(q`'x"x\''`) ;

################
# PARSE_QUOTES #
################

sub Parse_Quotes {
  my $string = $_[0] ;
  
  my ($string_ok,@quotes,%q) ;

  my $bb_mark = '%bb' ;
  while($string =~ /\Q$bb_mark\E/s) { $bb_mark .= &Rand_Str ;}

  $string =~ s/\\\\/$bb_mark/gs ;
  
  while( $string =~ /^(.*?(?:(?!\\).|))(['"])(.*)/s ) {
    my $init .= $1 ;
    my $quote = $2 ;
    $string = $3 ;
    
    if ($init =~ /\\$/) {
      $init .= $quote ;
      $quote = '' ;
    }
    
    if (! $q{o}) {
      $q{o}++ ;
      $q{q} = $quote ;
      $q{d} = undef ;
      $string_ok .= $init ;
      
      if (substr($string,0,1) eq $quote) {
        $q{o} = 0 ;
        push(@quotes , "$q{q}$q{q}") ;
        $string_ok .= "%q_$#quotes%" ;
        substr($string,0,1) = '' ;
      }
    }
    else {
      $q{d} .= $init ;
      if ($quote eq $q{q}) {
        $q{o} = 0 ;
        push(@quotes , "$q{q}$q{d}$q{q}") ;
        $string_ok .= "%q_$#quotes%" ;
      }
      else { $q{d} .= $quote ;}
    }
  }
  
  $string_ok .= $string ;
  $string_ok =~ s/$bb_mark/\\\\/gs ;
  
  #substr($string_ok,0,1) = '' ;
  #substr($string_ok,-1) = '' ;
  
  foreach my $quotes_i ( @quotes ) { $quotes_i =~ s/$bb_mark/\\\\/gs ;}
  
  #$string_ok =~ s/%q_(\d+)%/$quotes[$1]/gs ;
  
  #print "$string_ok <<@quotes>>\n" ;
  
  return( $string_ok , @quotes ) ;
}

###############
# VALUE_QUOTE #
###############

sub Value_Quote {
  my ( $val , $quotes ) = @_ ;
  
  $val =~ s/^\s+//gs ;
  $val =~ s/\s+$//gs ;
  
  if ($val !~ /^[\-\+]?(\d+|\d+\.\d+)$/s && (!$quotes || $val !~ /^%q_\d+%$/s) && $val !~ /^(?:NULL)$/si && $val ne '') {
    $val =~ s/%q_(\d+)%/$$quotes[$1]/gs if $quotes ;

    substr($val , 0 , 0) = ' ' ;
            
    $val = &Parse_REGEXP($val) ;

    $val =~ s/(?!\\)(.)"/$1\\"/gs ;
    substr($val , 0 , 1) = '' ;
    
    $val = qq`"$val"` ;
  }
  
  if ($val eq '') { $val = 'NULL' ;}

  return( $val ) ;
}

################
# PARSE_REGEXP #
################

sub Parse_REGEXP {
  my ( $string ) = @_ ;
  
  my $mark1 = '%box_o%' ;
  while($string =~ /\Q$mark1\E/s) { substr($mark1,-2,1) .= &Rand_Str ;}
  
  my $mark2 = '%box_c%' ;
  while($string =~ /\Q$mark2\E/s) { substr($mark2,-2,1) .= &Rand_Str ;}
  
  $string =~ s/\\\[/$mark1/gs ;
  $string =~ s/\\\]/$mark2/gs ;
  
  $string =~ s/(?!\\)(.)\\w/$1\[a-zA-Z0-9]/gs ;
  $string =~ s/(?!\\)(.)\\W/$1\[^a-zA-Z0-9]/gs ;
  $string =~ s/(?!\\)(.)\\d/$1\[0-9]/gs ;
  $string =~ s/(?!\\)(.)\\D/$1\[^0-9]/gs ;
  $string =~ s/(?!\\)(.)\\s/$1\[ \t\n\r]/gs ;
  $string =~ s/(?!\\)(.)\\S/$1\[^ \t\n\r]/gs ;

  while($string =~ /\[([^\[]*)\[([^\]]*)\]/gs) { $string =~ s/\[([^\[]*)\[([^\]]*)\]/\[$1$2/gs ;}

  $string =~ s/$mark1/\\\[/gs ;
  $string =~ s/$mark2/\\\]/gs ;

  return( $string ) ;
}

######################
# PARSE_REGEX_2_LIKE #
######################

sub Parse_REGEX_2_LIKE {
  my ( $cond , $regex , $quotes) = @_ ;
  
  $regex =~ s/%q_(\d+)%/$$quotes[$1]/gs if $quotes ;
  
  if    ($regex =~ /^"(.*?)"$/) { $regex = $1 ;}
  elsif ($regex =~ /^'(.*?)'$/) { $regex = $1 ;}
  
  if ($cond =~ /not/i ) { $cond = 'NOT LIKE' ;}
  else { $cond = 'LIKE' ;}
  
  if ( $regex =~ /^\^/ && $regex =~ /\$$/) {
    $regex =~ s/^\^// ;
    $regex =~ s/\$$// ;
  }
  elsif ( $regex =~ /^\^/) {
    $regex =~ s/^\^// ;
    $regex .= '%' ;
  }
  elsif ( $regex =~ /\$$/) {
    $regex =~ s/\$$// ;
    $regex = "%$regex" ;
  }
  else { $regex = "%$regex%" ;}
  
  $regex =~ s/\./_/gs ;
  
  return( $cond , $regex ) ;
}

############
# RAND_STR #
############

sub Rand_Str {
  return( @STR_LYB[rand(@STR_LYB)] ) ;
}

#####################
# FILTER_NULL_BYTES #
#####################

sub filter_null_bytes {
  return if $_[0] !~ /\0/s ;
  
  my $place_holder = "\1\2\1" ;
  my $x = 1 ;
  while( $_[0] =~ /\Q$place_holder\E/s ) {
    $place_holder = "\1" . ("\2" x ++$x) . "\1" ;
  }
  
  $_[0] =~ s/\0/$place_holder/gs ;
  $_[0] =~ s/^/$place_holder:/s ;
}

#######################
# UNFILTER_NULL_BYTES #
#######################

sub unfilter_null_bytes {
  my $b1 = "\1" ;
  my $b2 = "\2" ;
  return if $_[0] !~ /^($b1$b2+$b1):/s ;
  my $place_holder = $1 ;
  
  $_[0] =~ s/^\Q$place_holder\E://s ;
  $_[0] =~ s/\Q$place_holder\E/\0/gs ;
}

###############
# CLEAN_CACHE #
###############

sub CLEAN_CACHE {
  my @keys = keys %CACHE ;
  
  if ( @keys > 1000 ) {
    while( @keys > 500 ) {
      for(1..100) {
        delete $CACHE{ $keys[ rand(@keys) ] } ;
      }
      @keys = keys %CACHE ;
    }
  }
  
}

#########
# RESET #
#########

sub RESET {
  %CACHE = () ;
}

#######
# END #
#######

1;


PK       ! ����  �    perl5/HDB/CORE.pmnu ��6�$        #############################################################################
## Name:        CORE.pm
## Purpose:     HDB::CORE
## Author:      Graciliano M. P.
## Modified by:
## Created:     06/01/2003
## RCS-ID:      
## Copyright:   (c) 2002 Graciliano M. P.
## Licence:     This program is free software; you can redistribute it and/or
##              modify it under the same terms as Perl itself
#############################################################################

package HDB::CORE ;

use strict qw(vars) ;
no warnings ;

our $VERSION = '1.0' ;

##############
# PARSE_ARGS #
##############

sub parse_args {
  my ( $set , $types ) = @_ ;
  my %args = &lower_keys(@_[2..$#_]) ;
  
  foreach my $Key ( keys %$types ) {
    my @aliases = @{ $$types{$Key} } ;
    my $def ;
    if (ref $aliases[0] eq 'ARRAY') {
      $def = $aliases[-1] ;
      @aliases = @{ $aliases[0] } ;
    }
    
    my $was_set ;
    foreach my $aliases_i ( @aliases ) {
      if ( defined $args{$aliases_i} ) { $$set{$Key} = $args{$aliases_i} ; $was_set = 1 ; last ;}
    }
    
    if (! $was_set && defined $def) { $$set{$Key} = $def ;}
    
  }
}

############# (SCALAR|ARRAY|HASH REF \[$%@]var)
# PARSE_REF # Parse the reference of a var.
############# (@ARRAY)

sub parse_ref {
  my $ref = ref($_[0]) ;
  if ($ref eq '') {
    if (! wantarray) { return( $_[0] ) }
    return( @_ )
  }
  elsif ($ref eq 'ARRAY') {
    if (! wantarray) { return( (@{$_[0]})[0] ) }
    return( @{$_[0]} )
  }
  elsif ($ref eq 'HASH') {
    if (! wantarray) { return( (%{$_[0]})[0] ) }
    return( %{$_[0]} )
  }
  elsif ($ref eq 'SCALAR') {
    return( ${$_[0]} )
  }
  else {
    if (! wantarray) { return( $_[0] ) }
    return( @_ )
  }
}

##############
# LOWER_KEYS #
##############

sub lower_keys {
  my @hash = parse_ref(@_) ;
  
  for(my $i = 0 ; $i <= $#hash ; $i +=2) {
    $hash[$i] = lc($hash[$i]) ;
    $hash[$i] =~ s/[\W_]//gs ;
  }
  
  if ( @hash % 2 ) { push(@hash , undef) ;}
  
  return( @hash ) ;
}

########
# PATH #
########

sub path {
  my ( $path ) = @_ ;
  $path =~ s/[\\]/\//gs ;
  $path =~ s/(?:^(\/)\/([^\/])|\/+)/$1\/$2/gs ;
  return( $path ) ;
}

#######
# END #
#######

1;

PK       ! ƚ��~  �~    perl5/HDB/Object.pmnu ��6�$        #############################################################################
## This file was generated automatically by Class::HPLOO/0.21
##
## Original file:    ./lib/HDB/Object.hploo
## Generation date:  2005-01-23 18:30:36
##
## ** Do not change this file, use the original HPLOO source! **
#############################################################################

#############################################################################
## Name:        Object.pm
## Purpose:     HDB::Object - Base class for persistent Class::HPLOO objects.
## Author:      Graciliano M. P.
## Modified by:
## Created:     21/09/2004
## RCS-ID:      
## Copyright:   (c) 2004 Graciliano M. P.
## Licence:     This program is free software; you can redistribute it and/or
##              modify it under the same terms as Perl itself
#############################################################################


{ package HDB::Object ;

  use strict qw(vars) ; no warnings ;

  use vars qw(%CLASS_HPLOO @ISA $VERSION) ;

  $VERSION = '0.02' ;

  @ISA = qw(Class::HPLOO::Base UNIVERSAL) ;

  my $CLASS = 'HDB::Object' ; sub __CLASS__ { 'HDB::Object' } ;

  use Class::HPLOO::Base ;

  use HDB ;
  
  *WITH_HPL = \&HDB::WITH_HPL ;
  *HPL_MAIN = \&HDB::HPL_MAIN ;
  
  my ( %NEW_IDS , %OBJ_TABLE , %OBJ_TABLE_LOADER , $DID_REQUIRED ) ;
  

  use overload (
  'bool' => '_OVER_bool' ,
  '""' => '_OVER_string' ,
  'fallback' => 1 ,
  ) ;
  
  sub _OVER_bool { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; 1 ;}
  
  sub _OVER_string { 
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    
    my $class = $this->__CLASS__ ;
    my $id = $this->__ID__ ;
    
    if ( !$id ) {
      $this->hdb_save ;
      $id = $this->__ID__ ;
    }
    
    my $ident = "hdbobj__$class\__$id" ;
    $ident =~ s/::/_/gs ;

    return $ident ;
  }

  sub do_require { 
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    
    return if $DID_REQUIRED ;
    $DID_REQUIRED = 1 ;
    
    my $hpl = &HPL_MAIN() ;
    
    if ( $hpl ) {
      $hpl->use_cached('Hash::NoRef') ;
    }
    else {
      eval(" use Hash::NoRef ") ;
    }
    
    tie( %OBJ_TABLE , 'Hash::NoRef' ) ;
  }
  
  sub RESET { 
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    
    %OBJ_TABLE_LOADER = () ;
    %OBJ_TABLE = () ;
    %NEW_IDS = () ;
    return 1 ;
  }
   
  sub load { 
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    
    $CLASS = $this ? ref $this : shift(@_) ;

    my @where ;
    
    foreach my $i ( @_ ) {
      if ( $i =~ /^\d+$/s ) { push(@where , "id == $i") ;}
      else { push(@where , $i) ;}
    }
    
    return if !$CLASS->hdb_table_exists() ;
    
    my $hdb_obj = $CLASS->hdb ;
    
    my @sel = $hdb_obj->select( $CLASS , (@where ? ['?',@where] : ()) , (!wantarray ? (limit => '1') : () ) , '@%' ) ;
    return if !@sel ;
    
    do_require() ;
    
    my @obj ;
    foreach my $sel_i ( @sel ) {
      next if !$sel_i ;
      
      push(@obj , _build_obj($CLASS , $sel_i , $hdb_obj) ) ;
      next ;
      
      if ( $OBJ_TABLE{"$CLASS/$$sel_i{id}"} ) {
        delete $OBJ_TABLE_LOADER{"$CLASS/$$sel_i{id}"} ;
        push(@obj , $OBJ_TABLE{"$CLASS/$$sel_i{id}"} ) ;
      }
      else {
        my $loader ;
        if ( $OBJ_TABLE_LOADER{"$CLASS/$$sel_i{id}"} ) {
          $loader = $OBJ_TABLE_LOADER{"$CLASS/$$sel_i{id}"} ;
        }
        else {
          $loader = HDB::Object::Loader::create_loader($CLASS , $sel_i , $hdb_obj) ;
          $OBJ_TABLE_LOADER{"$CLASS/$$sel_i{id}"} = $loader ;
        }
        push(@obj , $loader) ;
      }
    }
    
    return if !@obj ;
    
    return @obj if wantarray ;
    return $obj[0] ;
  }
  
  sub select { 
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    
    my ( @list , $attr , $id ) ;
    if ( $#_ == 0 ) { ( $attr ) = @_ ;}
    elsif ( $#_ == 1 ) { ( $attr , $id ) = @_ ;}
    elsif ( $#_ > 1 ) { ( $id , @list ) = @_ ;}
    
    my $ret ;
    
    if ( @list ) {
      foreach my $list_i ( @list ) {
        if ( (UNIVERSAL::isa($list_i , 'HDB::Object') && $list_i->{__ID__} == $id) || (ref($list_i) eq 'HDB::Object::Loader' && $list_i->__ID__ == $id) ) {
          $ret = $list_i ;
          last ;
        }
      }
    }
    else {
      if ( ref( $this->{$attr} ) eq 'ARRAY' ) {
        foreach my $list_i ( @{ $this->{$attr} } ) {
          if ( (UNIVERSAL::isa($list_i , 'HDB::Object') && $list_i->{__ID__} == $id) || (ref($list_i) eq 'HDB::Object::Loader' && $list_i->__ID__ == $id) ) {
            $ret = $list_i ;
            last ;
          }
        }
      }
      elsif ( (UNIVERSAL::isa($this->{$attr} , 'HDB::Object') && $this->{$attr}->{__ID__} == $id) || (ref($this->{$attr}) eq 'HDB::Object::Loader' && $this->{$attr}->__ID__ == $id) ) {
        $ret = $this->{$attr} ;
      }
    }
    
    return $ret ;
  }
  
  sub _build_obj { 
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    my $CLASS = shift(@_) ;
    my $sel = shift(@_) ;
    my $hdb_obj = shift(@_) ;
    
    my $obj_ident = "$CLASS/$$sel{id}" ;
    
    ##print "BUILD OBJ>> $CLASS , $sel , $hdb_obj [$OBJ_TABLE{$obj_ident}]\n" ;
    
    return $OBJ_TABLE{$obj_ident} if $OBJ_TABLE{$obj_ident} ;
    
    my $this = bless({} , $CLASS) ;
    
    $hdb_obj ||= $CLASS->hdb ;
    
    &{"$CLASS\::CLASS_HPLOO_TIE_KEYS"}($this) ;
    
    foreach my $Key ( keys %$sel ) {
      if ( $Key =~ /^hdbobj__(\w*?)__(\w+)/ ) {
        my ( $class_obj , $attr , $id ) = ($1,$2 , $$sel{$Key}) ;
        $this->{CLASS_HPLOO_ATTR}{$attr} = $this->_build_ref_obj($class_obj,$id) ;
      }
      elsif ( $Key =~ /^hdbstore__(\w*?)__(\w+)/ ) {
        my ( $class_obj , $attr , $freeze ) = ($1,$2 , $$sel{$Key}) ;
        eval('use Storable qw()') ;
        if ( !$@ ) {
          eval {
            my $thaw = Storable::thaw($freeze) ;
            $this->{CLASS_HPLOO_ATTR}{$attr} = ref($thaw) eq 'ARRAY' ? $$thaw[0] : undef ;
          };
        }
      }
      elsif ( exists $this->{CLASS_HPLOO_ATTR}{$Key} ) { $this->{CLASS_HPLOO_ATTR}{$Key} = $$sel{$Key} ;}
    }
    
    $this->{__ID__} = $$sel{id} ;
    $this->{__HDB_OBJ__} = $hdb_obj ;
    
    my @ref_tables = $this->hdb_ref_tables ;
    
    foreach my $ref_tables_i ( @ref_tables ) {
      my ($class_main , $class_obj , $attr) = ( $ref_tables_i =~ /^hdbref__(\w*?)__(\w*?)__(\w+)/ );
      $class_obj .= '_' if $class_main eq $class_obj ;
      
      my @sel = $this->hdb->select( $ref_tables_i , "$class_main == $this->{__ID__}" , cols => "$class_obj" , '@$') ;

      $this->{CLASS_HPLOO_ATTR}{$attr} = [] ;
      foreach my $sel_i ( @sel ) {
        push( @{ $this->{CLASS_HPLOO_ATTR}{$attr} } , $this->_build_ref_obj($class_obj,$sel_i) ) ;
      }
    }
    
    foreach my $Key ( keys %OBJ_TABLE ) {
      delete $OBJ_TABLE{$Key} if !defined $OBJ_TABLE{$Key} ;
    }
    
    delete $OBJ_TABLE_LOADER{$obj_ident} ;
    $OBJ_TABLE{$obj_ident} = $this ;

    return $this ;
  }
  
  sub hdb_refresh { 
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    
    return if !$this || !$this->{__ID__} ;
    my $hdb_obj = $this->hdb ;
    return if !$hdb_obj ;
        
    my $sel = $hdb_obj->select( $this->__CLASS__ , "id == $this->{__ID__}" , '$%' ) ;
    
    print "REF>> $sel\n" ;
  }
  
  sub _build_ref_obj { 
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    my $class_obj = shift(@_) ;
    my $id = shift(@_) ;
    
    $class_obj =~ s/_$// ;
    $class_obj =~ s/_/::/gs ;
    if ( UNIVERSAL::isa($class_obj,'HDB::Object') ) {
      return $class_obj->load($id) ;
    }
    return ;
  }
  
  sub __ID__ { 
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    
    return $this->{__ID__} ;
  }
  
  sub hdb_obj_changed { 
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    
    return 1 if ( exists $this->{CLASS_HPLOO_CHANGED} && $this->{CLASS_HPLOO_CHANGED} && ref $this->{CLASS_HPLOO_CHANGED} eq 'HASH' && %{ $this->{CLASS_HPLOO_CHANGED} }) ;
    return ;
  }
  
  sub hdb { 
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    
    my $dbobj = UNIVERSAL::isa($this , 'HASH') ? $this->{__HDB_OBJ__} : undef ;
    
    if ( !$dbobj ) { $dbobj = HDB->HPLOO ;}
    
    if ( !$dbobj && WITH_HPL() ) {
      my $hpl = HPL_MAIN() ;
      if ( defined $hpl->env->{DOCUMENT_ROOT} ) {
        my $db_dir = $hpl->env->{DOCUMENT_ROOT} . '/db' ;
        my $db_file = "$db_dir/hploo.db" ;
        $dbobj = HDB->new(
        type => 'sqlite' ,
        db   => $db_file ,
        ) if -d $db_dir && -w $db_dir && (!-e $db_file || -w $db_file) ;
      }
    }
    
    if ( !$dbobj ) {
      warn("Can't find the predefined HPLOO database connection!") ;
      return ;
    }
    
    if ( UNIVERSAL::isa($this , 'HASH') && !$this->{__HDB_OBJ__} ) {
      $this->{__HDB_OBJ__} = $dbobj ;
    }
    
    return $dbobj ;
  }
  
  sub hdb_table_exists { 
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    
    $CLASS = $this ? ref $this : shift(@_) ;
    my $CLASS_HPLOO_HASH = $CLASS->GET_CLASS_HPLOO_HASH ;
    
    return 1 if ( (time - $CLASS_HPLOO_HASH->{HDB_TABLE_CHK}) < 2 ) ;

    my %table_hash = $this ? $this->hdb->tables_hash : $CLASS->hdb->tables_hash ;
    
    my $table = $this ? $this->__CLASS__ : $CLASS ;
    $table = HDB::CMDS::_format_table_name($table) ;
    
    if ( $table_hash{$table} ) {
      $CLASS_HPLOO_HASH->{HDB_TABLE_CHK} = time ;
      return 1 ;
    }
    $CLASS_HPLOO_HASH->{HDB_TABLE_CHK} = undef ;

    return ;
  }
  
  sub hdb_create_table { 
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    
    my $class_hploo = $this->GET_CLASS_HPLOO_HASH ;
    my $CLASS = $this->__CLASS__ ;
    
    if ( $CLASS !~ /^\w+(?:::\w+)*$/ ) {
      warn("Can't use class name '$CLASS' as a table name!!!\n") ;
    }
    
    $CLASS =~ s/:+/_/gs ;
      
    my @cols ;
    foreach my $order_i ( @{$class_hploo->{ATTR_ORDER}} ) {
      my $tp = $class_hploo->{ATTR}{$order_i}{tp} ;
      
      my ( $col_name , $tp , $table_ref , @cols_ref ) = $this->_hdb_attr_type($order_i , $tp) ;
            
      if ( $table_ref ) {
        $this->hdb->create( $table_ref , @cols_ref ) ;
        #print $this->hdb->sql . "\n" ;
      }
      else {
        push(@cols , $col_name , $this->_hdb_col_type_hploo_2_hdb($tp) ) ;
      }
    }
    
    warn("Can't store in the DB class $CLASS since the class doesn't have attributes!") if !@cols ;

    $this->hdb->create( $CLASS , @cols ) ;
    #print $this->hdb->sql . "\n" ;
  }
  
  sub hdb_ref_tables { 
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    
    my $CLASS = $this ? $this->__CLASS__ : shift(@_) ;
    my @tables = $this ? $this->hdb->tables : $CLASS->hdb->tables ;

    $CLASS =~ s/:+/_/gs ;
    my @ref ;
    foreach my $tables_i ( @tables ) {
      push(@ref , $tables_i) if $tables_i =~ /hdbref__$CLASS\__/ ;
    }

    return @ref ;
  }
  
  sub hdb_ref_to_me_tables { 
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    
    my $CLASS = $this ? $this->__CLASS__ : shift(@_) ;
    my @tables = $this ? $this->hdb->tables : $CLASS->hdb->tables ;

    $CLASS =~ s/:+/_/gs ;
    my @ref ;
    foreach my $tables_i ( @tables ) {
      push(@ref , $tables_i) if $tables_i =~ /hdbref__(\w+?)__$CLASS\__/ ;
    }

    return @ref ;
  }
  
  sub hdb_referenced_ids { 
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    
    my $CLASS = $this ? $this->__CLASS__ : shift(@_) ;
    my $this_or_class = $this || $CLASS ;
    
    my $hdb_obj = shift(@_) || $this_or_class->hdb ;

    my $class_obj = $CLASS ;
    $class_obj =~ s/:+/_/gs ;

    my $can_have_ref ;

    my @ref_tables = $this_or_class->hdb_ref_to_me_tables ;
    
    $can_have_ref = 1 if @ref_tables ;

    my %ids_ok ;

    foreach my $ref_tables_i ( @ref_tables ) {
      my @sel = $hdb_obj->select( $ref_tables_i , cols => "$class_obj" , '@$') ;
      @ids_ok{@sel} = (1) x @sel ;
    }
    
    foreach my $tables_i ( $hdb_obj->tables ) {
      foreach my $cols_i ( $hdb_obj->names($class_obj) ) {
        if ( $cols_i =~ /^hdbobj__$class_obj\__/ ) {
          my @sel = $hdb_obj->select( $tables_i , cols => $cols_i , '@$') ;
          @ids_ok{@sel} = (1) x @sel ;
          $can_have_ref = 1 ;
        }
      }
    }
    
    return \%ids_ok if $can_have_ref ;
    return ;
  }
  
  sub hdb_clean_unref { 
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    
    my $CLASS = $this ? $this->__CLASS__ : shift(@_) ;
    my $this_or_class = $this || $CLASS ;
    
    my $hdb_obj = shift(@_) || $this_or_class->hdb ;
    
    my $class_obj = $CLASS ;
    $class_obj =~ s/:+/_/gs ;

    my $ids_ok = $this_or_class->hdb_referenced_ids($hdb_obj) ;
    
    $hdb_obj->delete( $class_obj , ["id != ?", ['AND'] , keys %$ids_ok]) if $ids_ok ;
  }
  
  sub _hdb_attr_type { 
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    my  $attr = shift(@_) ;
    my $tp  = shift(@_) ;
    
    my $CLASS = $this->__CLASS__ ;
        
    $CLASS =~ s/:+/_/gs ;

    my ( $tp1 ,$tp2 ) ;
    
    if ( $tp =~ /(?:ref\s*)?(array\s*|hash\s*)?(&\w+|\w+(?:::\w+)*)/ ) { ( $tp1 ,$tp2 ) = ($1,$2) ;}
    else { $tp2 = $tp ;}
    
    my $is_hdbobj = UNIVERSAL::isa($tp2 , 'HDB::Object') ;
    
    $tp2 =~ s/:+/_/gs ;
    $tp = $tp2 ;
    
    my $is_obj = ($tp =~ /^(?:boolean|integer|floating|string|sub_\w+|any|&\w+)$/ ) ? 0 : 1 ;
    
    my $col_name ;
    
    if ( !$is_hdbobj && $is_obj ) {
      return( "hdbstore__$tp2\__$attr" , '*' ) ;
    }
    elsif ( $is_obj ) {
      $col_name = "hdbobj__$tp2\__$attr" ;
      $tp = 'integer' ;
    }
    else { $col_name = $attr ;}
    
    my ($table_ref , @cols_ref) ;
    if ( $tp1 eq 'array' ) {
      $table_ref = "hdbref__$CLASS\__$tp2\__$attr" ;
      $tp2 .= '_' if $CLASS eq $tp2 ;
      @cols_ref = (
      $CLASS => 'integer' ,
      $tp2 => 'integer' ,
      ) ;
    }
    
    return( $col_name , $tp , $table_ref , @cols_ref ) ;
  }
  
  sub _hdb_col_type_hploo_2_hdb { 
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    my  $hploo_type  = shift(@_) ;
    
    if    ( $hploo_type =~ /(?:any|string)/i ) { return '*' ;}
    elsif ( $hploo_type =~ /bool/i ) { return 'boolean' ;}
    elsif ( $hploo_type =~ /int/i ) { return 'int' ;}
    elsif ( $hploo_type =~ /float/i ) { return 'float' ;}
    else { return '*' ;}
  }
  
  sub hdb_max_id { 
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    
    my $max_id = $this->hdb->select( $this->__CLASS__ , cols => '>id' , '$' ) ;
    return $max_id ;
  }
  
  sub hdb_delete { 
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    
    return if !$this->hdb_table_exists ;
    my $id = $this->{__ID__} ;
    
    return if ( $id eq '' || !$this->hdb->select( $this->__CLASS__ , "id == $id" , cols => 'id' , '$' ) ) ;
    
    $this->hdb->delete( $this->__CLASS__ , "id == $id" ) ;
    
    %$this = () ;
    
    return 1 ;
  }
  
  sub hdb_new_id { 
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    
    my $id = $this->hdb_max_id + 1 ;
    my $class = $this->__CLASS__ ;
    while( $NEW_IDS{$class}{$id} ) { ++$id ;}
    $NEW_IDS{$class}{$id} = 1 ;
    return $id ;
  }

  sub hdb_save { 
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    my %args = @_ ;
    @_ = () ;
    
    $this->hdb_create_table if !$this->hdb_table_exists ;

    return if !$args{save_all} && !$this->hdb_obj_changed ;
    
    my $class_hploo = $this->GET_CLASS_HPLOO_HASH ;

    my $class_hploo_changed = $this->{CLASS_HPLOO_CHANGED} ;
    $this->{CLASS_HPLOO_CHANGED} = undef ;
    
    my $id = $this->{__ID__} ;
    my $insert ;
    
    if ( $id eq '' || ($id && !$this->hdb->select( $this->__CLASS__ , "id == $id" , cols => 'id' , '$' )) ) {
      $id = $this->hdb_new_id ;
      $insert = 1 ;
    }
        
    my @del_attr_keys ;
    
    my $saved_classes = $args{saved_classes} || {} ;

    foreach my $order_i ( @{$class_hploo->{ATTR_ORDER}} ) {
      my $tp = $class_hploo->{ATTR}{$order_i}{tp} ;
      my ( $col_name , $tp , $table_ref , @cols_ref ) = $this->_hdb_attr_type($order_i , $tp) ;
      
      ##print ">> $col_name , $tp , $table_ref , @cols_ref \n" ;
            
      if ( $table_ref ) {
        if ( ref $this->{$order_i} eq 'ARRAY' ) {
          my (@ids , %ids , $c) ; 
          
          foreach my $attr_i ( @{$this->{$order_i}} ) {
            if ( ref($attr_i) eq 'HDB::Object::Loader' ) {
              my $id = $attr_i->[1]{id} ;
              push(@ids , $id) ;
              $ids{$id} = ++$c ;
            }
            elsif ( UNIVERSAL::isa($attr_i , 'HDB::Object') ) {
              $attr_i->hdb_save( no_auto_clean_unref => 1 , saved_classes => $saved_classes ) ;
              $$saved_classes{ $attr_i->__CLASS__ } = 1 ;
              push(@ids , $attr_i->{__ID__}) ;
              $ids{$attr_i->{__ID__}} = ++$c ;
            }
          }

          my @sel = $this->hdb->select( $table_ref , "$cols_ref[0] == $id" , cols => "$cols_ref[2],id" , '@@') ;
          
          my (@del_ids , %sel_ids , %sel_pos ) ;
          
          #print "IDS[$this]>> @ids\n" ;
          
          $c = 0 ;
          foreach my $sel_i ( @sel ) {
            $sel_ids{$$sel_i[0]} = ++$c ;
            $sel_pos{$c} = $$sel_i[1] ;
            push(@del_ids , $$sel_i[1]) if $ids{$$sel_i[0]} != $c ;
            #print "SEL>> $$sel_i[0] , $$sel_i[1] [$c] >> $ids{$$sel_i[0]}\n" ;
          }
          
          my @dels = @del_ids[($#ids+1)..$#del_ids] ;
          #print "DEL>> @dels\n" ;
          
          $this->hdb->delete( $table_ref , ["$cols_ref[2] == ?" , @dels] ) if @dels ;
          #print $this->hdb->sql . "\n" if @dels ;

          foreach my $ids_i ( @ids ) {
            if ( $ids{$ids_i} != $sel_ids{$ids_i} ) {
              my $pos = $sel_pos{ $ids{$ids_i} } ;
              if ( $pos ) {
                $this->hdb->update( $table_ref , "id == $pos" , {$cols_ref[0] => $id , $cols_ref[2] => $ids_i}) ;
                #print $this->hdb->sql . "\n" ;
              }
              else {
                $this->hdb->insert( $table_ref , {$cols_ref[0] => $id , $cols_ref[2] => $ids_i}) ;
                #print $this->hdb->sql . "\n" ;
              }
            }
          }

        }
        elsif ( UNIVERSAL::isa($this->{$order_i} , 'HDB::Object') ) {
          $this->{$order_i}->hdb_save( no_auto_clean_unref => 1 , , saved_classes => $saved_classes ) ;
          $$saved_classes{ $this->{$order_i}->__CLASS__ } = 1 ;
        }
      }
      elsif ( $col_name =~ /^hdbobj/ ) {
        if ( ref($this->{$order_i}) eq 'HDB::Object::Loader' ) {
          my $id = $this->{$order_i}->[1]{id} ;
          $this->{CLASS_HPLOO_ATTR}{$col_name} = $id ;
        }
        elsif ( UNIVERSAL::isa($this->{$order_i} , 'HDB::Object') ) {
          $this->{$order_i}->hdb_save( no_auto_clean_unref => 1 , saved_classes => $saved_classes , save_all => $args{save_all} ) ;
          $$saved_classes{ $this->{$order_i}->__CLASS__ } = 1 ;
          $this->{CLASS_HPLOO_ATTR}{$col_name} = $this->{$order_i}->{__ID__} ;
        }
        push(@del_attr_keys , $col_name) ;
      }
      elsif ( $col_name =~ /^hdbstore/ ) {
        eval('use Storable qw()') ;
        if ( !$@ ) {
          eval {
            $this->{CLASS_HPLOO_ATTR}{$col_name} = Storable::freeze( [$this->{$order_i}] ) ;
          };
          push(@del_attr_keys , $col_name) ;
        }
      }
    }

    my $ret ;
    if ( $insert ) {
      $this->{CLASS_HPLOO_ATTR}{id} = $this->{__ID__} = $id ;
      push(@del_attr_keys , 'id') ;
      $ret = $this->hdb->insert( $this->__CLASS__ , $this->{CLASS_HPLOO_ATTR} ) ;
    }
    else {
      my %changeds ;
      if ( $args{save_all} ) { %changeds = %{ $this->{CLASS_HPLOO_ATTR} } ;}
      else {
        foreach my $Key ( keys %$class_hploo_changed ) {
          $changeds{$Key} = $this->{CLASS_HPLOO_ATTR}{$Key} ;
        }
      }

      $ret = $this->hdb->update( $this->__CLASS__ , "id == $id" , \%changeds ) ;
    }
    
    foreach my $del_keys_i ( @del_attr_keys ) { delete $this->{CLASS_HPLOO_ATTR}{$del_keys_i} ;}
    
    $$saved_classes{ $this->__CLASS__ } = 1 ;
    
    if ( !$args{no_auto_clean_unref} ) {
      foreach my $Key ( keys %$saved_classes ) {
        if ( defined &{ $Key . '::AUTO_CLEAN_UNREF'} && &{ $Key . '::AUTO_CLEAN_UNREF'}() && (time - $class_hploo->{HDB_TABLE_AUTOCLS}{$Key}) > 2 ) {
          $Key->hdb_clean_unref( $this->hdb ) ;
          $class_hploo->{HDB_TABLE_AUTOCLS}{$Key} = time ;
        }
      }
    }
    
    return $ret ;
  }
  
  sub hdb_dump_table { 
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    my $table = shift(@_) ;
    
    if ( !$this ) {
      $this = $table || $_[0] ;
      $table = $_[0] if $_[0] ;
    }
    
    return '' if !$this->hdb_table_exists ;
    return $this->hdb->dump_table($table) ;
  }
  
  sub STORABLE_freeze { 
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    my $cloning = shift(@_) ;
    
    return(
      $this ,
      {
        (ref $this->{CLASS_HPLOO_ATTR} eq 'HASH' ? %{$this->{CLASS_HPLOO_ATTR}} : ()) ,
        id => $this->{__ID__} ,
      }
    ) ;
  }
  
  sub STORABLE_thaw { 
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    my $cloning = shift(@_) ;
    my $serial = shift(@_) ;
    my $attrs = shift(@_) ;
    
    my $class = ref $this ;
    
    $this->{__ID__} = delete $attrs->{id} ;

    $this->{CLASS_HPLOO_ATTR} = {} ;
    %{ $this->{CLASS_HPLOO_ATTR} } = %$attrs ;
    
    &{"$class\::CLASS_HPLOO_TIE_KEYS"}($this) ;
    
    $this->hdb ;
    return ;
  }

  sub DESTROY { 
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    
    return if !%$this ;
    $this->hdb_save ;
  }
  

}


################################################################################

{ package HDB::Object::Loader ;

  use strict qw(vars) ;

  use vars qw($AUTOLOAD) ;
  
  use overload (
    'bool' => \&HDB::Object::_OVER_bool ,
    '""' => \&HDB::Object::_OVER_string ,
    '%{}' => '_OVER_hash' ,
    'fallback' => 1 ,
  );
  
  sub _OVER_hash {
    _build($_[0]) ; return $_[0] ;
  
    if ( !$_[0][3] ) {
      my %hash = (1) ;
      $_[0][3] = \%hash ;
      $_[0][4] = tie( %hash , 'HDB::Object::Loader::TieHandler' ,  @{$_[0]}[0..2] ) ;
    }
    
    if ( $_[0][4] && $_[0][4]->[3] ) {
      $_[0] = $_[0][4]->[3] ;
      return $_[0] ;
    }
    
    return $_[0][3] ;
  }
  
  sub create_loader { bless [ @_ ] ;}
  
  sub _build {
    my @args = @{$_[0]} ;
    $_[0] = HDB::Object::_build_obj(@args) ;

    die "INTERNAL ERROR: Cannot build instance of '$args[0]'\n" unless defined $_[0] ;
    # This can occur if the class wasn't loaded correctly.
    die "INTERNAL ERROR: _build() failed to build a new object\n" if ref($_[0]) eq __PACKAGE__;

    return $_[0] ;
  }
  
  sub __CLASS__ {
    return $_[0][0] ;
  }
  
  sub __ID__ {
    return $_[0][1]{id} ;
  }
  
  sub can {
    _build($_[0]);
    $_[0]->can($_[1]);
  }

  sub isa {
    $_[0][0]->isa($_[1]) ;
  }

  sub AUTOLOAD {
    my ($subname) = $AUTOLOAD =~ /([^:]+)$/ ;

    my $realclass = $_[0][0] ;
    _build( $_[0] ) ;

    my $func = $_[0]->can( $subname );

    die "Cannot call '$subname' on an instance of '$realclass'\n" unless ref( $func ) eq 'CODE';

    goto &$func ;
  }
  
  ## Don't need to save if we haven't changed attributes:  
  sub DESTROY {
    ##_build($_[0]);
    ##$_[0]->DESTROY(@_[1..$#_]);
  }
  
}

################################################################################

{ package HDB::Object::Loader::TieHandler ;

  use strict qw(vars) ;
  no warnings ;
  
  sub TIEHASH { shift ; bless [ @_ ] ;}
  
  my $val ;
  
  sub FETCH { #print STDOUT "FETCH>> @_\n" ;
    my $this = shift ;
    my $key = shift ;
    
    return $this->[1]{id} if $key eq '__ID__' ;
    
    $this->[3] = HDB::Object::_build_obj( @{$this}[0..2] ) if !defined $this->[3] ;
    
    return $this->[3]{$key} ;
  }  
  
  sub STORE { #print STDOUT "STORE>> @_\n" ;
    my $this = shift ;
    my $key = shift ;
  
    $this->[3] = HDB::Object::_build_obj( @{$this}[0..2] ) if !defined $this->[3] ;
    
    return $this->[3]{$key} ;
  }
   
  sub DELETE   { #print STDOUT "DELETE>> @_\n" ;
    my $this = shift ;
    my $key = shift ;
    
    $this->[3] = HDB::Object::_build_obj( @{$this}[0..2] ) if !defined $this->[3] ;
    
    return delete $this->[3]{$key} ;
  }
  
  sub EXISTS   { #print STDOUT "EXISTS>> @_\n" ;
    my $this = shift ;
    my $key = shift ;
    
    $this->[3] = HDB::Object::_build_obj( @{$this}[0..2] ) if !defined $this->[3] ;
    
    return exists $this->[3]{$key} ;
  }
  
  sub FIRSTKEY { #print STDOUT "FIRSTKEY>> @_\n" ;
    my $this = shift ;
    
    $this->[3] = HDB::Object::_build_obj( @{$this}[0..2] ) if !defined $this->[3] ;
    
    return (keys %{$this->[3]})[0] ;
  }
  
  sub NEXTKEY  { #print STDOUT "NEXTKEY>> @_\n" ;
    my $this = shift ;
    my $keylast = shift ;
    
    $this->[3] = HDB::Object::_build_obj( @{$this}[0..2] ) if !defined $this->[3] ;
    
    my $ret_next ;
    foreach my $keys_i ( keys %{$this->[3]} ) {
      if ($ret_next) { return $keys_i ;}
      if ($keys_i eq $keylast || !defined $keylast) { $ret_next = 1 ;}
    }
  
    return undef ;
  }
  
  sub CLEAR { #print STDOUT "CLEAR>> @_\n" ;
    my $this = shift ;
    
    $this->[3] = HDB::Object::_build_obj( @{$this}[0..2] ) if !defined $this->[3] ;
    %{$this->[3]} = () ;
    
    return ;
  }
  
  sub UNTIE {}
  sub DESTROY {}

}

1 ;


__END__

=head1 NAME

HDB::Object - Base class for persistent Class::HPLOO objects.

=head1 DESCRIPTION

This is the base class for persistent Class::HPLOO objects.

This will automaticallt make Class::HPLOO classes persistent in any DB
handled by L<HDB>.

This persistence framework was built by a group of modules that handles specific
parts of the problem:

=over 4

=item L<Class::HPLOO>

The class declaration and attribute handler.

=item L<HDB::Object>

The object persistence and class proxy.

=item L<HDB>

The DB connection and SQL communication for each DB type.

=back

All of this will create a very automatic way to create persistent objects over a
relational DB, what is perfect for fast and easy creation of good systems.
For Web Systems this framework is automatically embeded into L<HPL>,
where you can count with a lot of resources for fast and powerful creations for
the Web.

=head1 USAGE

Here's an example of a class built with HDB::Object persistence.

  use Class::HPLOO ;
  
  class User extends HDB::Object {
  
    use HDB::Object ;
  
    attr( user , pass , name , int age ) ;
    
    sub User( $user , $pass , $name , $age ) {
      $this->{user} = $user ;
      $this->{pass} = $pass ;
      $this->{name} = $name ;
      $this->{age} = time ;
    }
  
  }

B<You can see that is completly automatic and you don't need to care about the
serialization or even about the DB connection, tables and column types.>

=head1 METHODS

=head2 load (CONDITIONS)

Loads an object that exists in the database.

I<CONDITIONS> can be a sequence of WHERE conditions for HDB:

  my $users_x = load User('id == 123') ;
  
  my @users = load User('id <= 10' , 'id == 123' , 'name eq "joe"') ;

If I<CONDITIONS> is NOT paste, if wantarray it will return all the objects in the table, or it will return only the 1st:

  my $user1 = load User() ;
  
  my @all_users = load User() ;

=head2 hdb

Return the HDB object that handles the DB connection.

=head2 hdb_dump_table

Dump all the table content, returning that as a string.

=head2 hdb_table_exists

Retrun TRUE if the table for the HDB::Object was already created.

=head2 hdb_create_table

Create the table for the HDB::Object if it doesn't exists.

=head2 hdb_obj_changed

Return TRUE when the object was changed and need to be updated in the DB.

=head2 hdb_max_id

Return the max id in the object table.

=head2 hdb_delete

Delete the object from the database.

=head2 hdb_save

Save the object in the database.

I<** Note that you don't need to call this method directly, since when
the object is destroied from the memory it will be saved automatically.>

=head2 hdb_clean_unref

This will automatically clean objects from this table if they doesn't have
references in the database from another object. So, only call this if
you have a colection of objects that are referenced by others or you
will lose all the objects from the table:

  Users::Level->hdb_clean_unref ;

You also can define the constant I<AUTO_CLEAN_UNREF> to automatically clean
unreferenced objects:

  class Users::Level extends HDB::Object {
    use constant AUTO_CLEAN_UNREF => 1 ;
    ...
  }

=head2 hdb_referenced_ids

Return the IDs that have a reference to it.

=head1 DESTROY and AUTO SAVE OBJECT

The object will be automatically saved when the object is destroied.

So if you want to use this automatically save resource you can't overload the
sub DESTROY, or at least should call the super method:

  class User extends HDB::Object {
    ...
    
    sub DESTROY {
      $this->SUPER::DESTROY ;
      ... # your destroy stuffs.
    }
  }

=head1 OBJECT REFERENCES

I<HDB::Object> will try to handle automatically attributes that make references
to other objects or list of objects.

When an atribute make a reference to an object that extends I<HDB::Object>,
only the ID to the object will be saved, making a reference to the ID
of the object table.

If an object doesn't extends I<HDB::Object> it will be serialized, using L<Storable>,
and stored in the coloumn value.

When an attribute have a list of objects, a reference table is created automatically:

  attr( array Date::OBject dates )

=head1 OBJECT PROXY

The Object Proxy mechanism was inspirated on L<Class::LazyLoad>. The main idea
is that the object won't be created unless it's accessed. The proxy will be used only
when the object is loaded from the DB, not when you create a new object. So, when
you load an object from the DB, actually the DB will be accessed only when you use the
object.

An Object Proxy is very important to save memory and DB access, since if we don't
use a proxy is possible to have an object that loads all the DB in the memory due
it's object tree.

=head1 SEE ALSO

L<HPL>, L<HDB>, L<Class::HPLOO>, L<Class::LazyLoad>.

=head1 AUTHOR

Graciliano M. P. <gm@virtuasites.com.br>

I will appreciate any type of feedback (include your opinions and/or suggestions). ;-P

=head1 COPYRIGHT

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

PK       ! ��(�(  �(    perl5/HDB/Encode.pmnu ��6�$        #############################################################################
## Name:        Encode.pm
## Purpose:     HDB::Encode - Common things for HDB modules.
## Author:      Graciliano M. P.
## Modified by:
## Created:     15/01/2003
## RCS-ID:      
## Copyright:   (c) 2002 Graciliano M. P.
## Licence:     This program is free software; you can redistribute it and/or
##              modify it under the same terms as Perl itself
#############################################################################

package HDB::Encode ;

use strict qw(vars);
no warnings ;

our $VERSION = '1.0' ;

########
# VARS #
########

  my %VER = (
  PACKED_HASH => '1.0' ,
  PACKED_ARRAY => '1.0' ,
  ) ;
  
########
# PACK #
########

sub Pack {
  if ( ref($_[0]) eq 'HASH' ) { return &Pack_HASH($_[0]) ;}
  if ( ref($_[0]) eq 'ARRAY' ) { return &Pack_ARRAY($_[0]) ;}
}

#############
# PACK_HASH #
#############

sub Pack_HASH {
  my ( $hash ) = @_ ;
  
  if (ref($hash) ne 'HASH') { return( undef ) ;}
  
  my ($pack_init,$pack) ;
  
  $pack_init = "%HDB_PACKED_HASH%[$VER{PACKED_HASH}]{0}:" if !$_[1] ;
  
  foreach my $key ( keys %$hash ) {
    my ($blk,$tp,$value) ;
    if    ( ref( $$hash{$key} ) eq 'HASH' ) { $tp = 1 ; $value = &Pack_HASH( $$hash{$key} , 1 ) }
    elsif ( ref( $$hash{$key} ) eq 'ARRAY' ) { $tp = 2 ; $value = &Pack_ARRAY( $$hash{$key} , 1 ) ;}
    elsif ( UNIVERSAL::isa($$hash{$key} ,'UNIVERSAL') ) { next ;} ## ignore objects.
    else { $tp = 0 ; $value = $$hash{$key} ;}
    
    $blk .= $tp ;
    $blk .= length($key) . ":" ;
    $blk .= $key ;
    $blk .= length($value) . ":" ;
    $blk .= $value ;
    
    $pack .= $blk ;
  }
  
  if ( !$_[1] ) {
    my $sz = length($pack) ;
    $pack_init =~ s/\{0}/\{$sz}/s ;
  }
  
  return( $pack_init . $pack ) ;
}

##############
# PACK_ARRAY #
##############

sub Pack_ARRAY {
  my ( $array ) = @_ ;
  
  if (ref($array) ne 'ARRAY') { return( undef ) ;}
  
  my ($pack_init,$pack) ;
  
  $pack_init = "%HDB_PACKED_ARRAY%[$VER{PACKED_ARRAY}]{0}:" if !$_[1] ;
  
  foreach my $array_i ( @$array ) {
    my ($blk,$tp,$value) ;
    if    ( ref( $array_i ) eq 'HASH' ) { $tp = 1 ; $value = &Pack_HASH( $array_i , 1 ) ;}
    elsif ( ref( $array_i ) eq 'ARRAY' ) { $tp = 2 ; $value = &Pack_ARRAY( $array_i , 1 ) ;}
    elsif ( UNIVERSAL::isa($array_i ,'UNIVERSAL') ) { next ;} ## ignore objects.
    else { $tp = 0 ; $value = $array_i ;}
    
    $blk .= $tp ;
    $blk .= length($value) . ":" ;
    $blk .= $value ;
    
    $pack .= $blk ;
  }
  
  if ( !$_[1] ) {
    my $sz = length($pack) ;
    $pack_init =~ s/\{0}/\{$sz}/s ;
  }
  
  return( $pack_init . $pack ) ;
}

##########
# UNPACK #
##########

sub UnPack {
  if ( &Is_Packed_HASH($_[0]) ) { return &UnPack_HASH($_[0]) ;}
  if ( &Is_Packed_ARRAY($_[0]) ) { return &UnPack_ARRAY($_[0]) ;}
  return( $_[0] ) ;
}

###############
# UNPACK_HASH #
###############

sub UnPack_HASH {
  my %hash ;
  
  my $pos = 0 ;
  
  if ( !$_[1] ) {
    if ( !&Is_Packed_HASH($_[0]) ) { return() ;}
    elsif ( !&Check_Pack_Size($_[0]) ) { return("SIZE_ERROR: $_[0]") ;}
    else { $pos = index($_[0],':') + 1 ;}
  }
  
  my $lng = length($_[0]) ;
  
  while( $pos < $lng ) {
    my $tp = substr($_[0],$pos++,1) ;
    my $key = &blk_read($_[0],$pos) ;
    my $val = &blk_read($_[0],$pos) ;
    
    if ($tp == 1) {
      my %val = &UnPack_HASH($val,1) ;
      $val = \%val ;
    }
    elsif ($tp == 2) {
      my @val = &UnPack_ARRAY($val,1) ;
      $val = \@val ;
    }
    
    $hash{$key} = $val ;
  }

  if ( wantarray ) { return( %hash ) ;}
  else { return( \%hash ) ;}
}

################
# UNPACK_ARRAY #
################

sub UnPack_ARRAY {
  my @array ;
  
  my $pos = 0 ;
  
  if ( !$_[1] ) {
    if ( !&Is_Packed_ARRAY($_[0]) ) { return() ;}
    elsif ( !&Check_Pack_Size($_[0]) ) { return("SIZE_ERROR: $_[0]") ;}
    else { $pos = index($_[0],':') + 1 ;}
  }
  
  my $lng = length($_[0]) ;
  
  while( $pos < $lng ) {
    my $tp = substr($_[0],$pos++,1) ;
    my $val = &blk_read($_[0],$pos) ;
    
    if ($tp == 1) {
      my %val = &UnPack_HASH($val,1) ;
      $val = \%val ;
    }
    elsif ($tp == 2) {
      my @val = &UnPack_ARRAY($val,1) ;
      $val = \@val ;
    }
    
    push(@array , $val) ;
  }
  
  if ( wantarray ) { return( @array ) ;}
  else { return( \@array ) ;}
}

############
# BLK_READ #
############

sub blk_read {
  my ( undef , undef , $lng ) = @_ ;
  
  if (!$lng) { $lng = length( $_[0] ) ;}
  
  my ($s,$sz) ;
  
  while( $_[1] <= $lng ) {
    $s = substr( $_[0]  , $_[1] , 1) ;
    $_[1]++ ;
    if ($s eq ':') { last ;}
    $sz .= $s ;
  }
  
  my $blk = substr( $_[0] , $_[1] , $sz) ;
  
  $_[1] += $sz ;

  return( $blk ) ;
}

##################
# IS_PACKED_HASH #
##################

sub Is_Packed_HASH {
  if ( $_[0] =~ /^\s*\%HDB_PACKED_HASH%\[[\d\.]+]\{\d+}:/ ) { return( 1 ) ;}
  return( undef ) ;
}

###################
# IS_PACKED_ARRAY #
###################

sub Is_Packed_ARRAY {
  if ( $_[0] =~ /^\s*\%HDB_PACKED_ARRAY%\[[\d\.]+]\{\d+}:/ ) { return( 1 ) ;}
  return( undef ) ;
}

###################
# CHECK_PACK_SIZE #
###################

sub Check_Pack_Size {
  if ( $_[0] =~ /^(\s*\%HDB_PACKED_(?:HASH|ARRAY)%\[[\d\.]+]\{)(\d+)(}:)/s ) {
    my $lng = length($1) + length($3) ;
    my $sz = $2 ;
    $lng += length($sz) + $sz ;
    if ( length($_[0]) == $lng ) { return( 1 ) ;}
  }
  return( undef ) ;
}

###############
# PACKED_SIZE #
###############

sub Packed_SIZE {
  my ( $ref ) = @_ ;
  if ( ref($ref) eq 'HASH' ) { return &Packed_SIZE_HASH($ref) ;}
  if ( ref($ref) eq 'ARRAY' ) { return &Packed_SIZE_ARRAY($ref) ;}
}

####################
# PACKED_SIZE_HASH #
####################

sub Packed_SIZE_HASH {
  my ( $hash ) = @_ ;
  
  if (ref($hash) ne 'HASH') { return( undef ) ;}
  
  my ($pack_init,$size) ;
  
  $pack_init = "%HDB_PACKED_HASH%[$VER{PACKED_HASH}]{0}:" if !$_[1] ;
  
  foreach my $key ( keys %$hash ) {
    my ($blk_sz,$value_sz) ;
    if    ( ref( $$hash{$key} ) eq 'HASH' ) { $value_sz = &Packed_SIZE_HASH( $$hash{$key} , 1 ) }
    elsif ( ref( $$hash{$key} ) eq 'ARRAY' ) { $value_sz = &Packed_SIZE_ARRAY( $$hash{$key} , 1 ) ;}
    elsif ( UNIVERSAL::isa($$hash{$key} ,'UNIVERSAL') ) { next ;} ## ignore objects.
    else { $value_sz = length( $$hash{$key} ) ;}
    
    $blk_sz += 1 ;
    $blk_sz += length(length($key)) + 1 ;
    $blk_sz += length($key) ;
    $blk_sz += length($value_sz) + 1 ;
    $blk_sz += $value_sz ;
    
    $size += $blk_sz ;
  }
  
  if ( !$_[1] ) { $pack_init =~ s/\{0}/\{$size}/s ;}
  
  $size += length($pack_init) if !$_[1] ;
  
  return( $size ) ;
}

#####################
# PACKED_SIZE_ARRAY #
#####################

sub Packed_SIZE_ARRAY {
  my ( $array ) = @_ ;
  
  if (ref($array) ne 'ARRAY') { return( undef ) ;}
  
  my ($pack_init,$size) ;
  
  $pack_init = "%HDB_PACKED_ARRAY%[$VER{PACKED_ARRAY}]{0}:" if !$_[1] ;
  
  foreach my $array_i ( @$array ) {
    my ($blk_sz,$value_sz) ;
    if    ( ref( $array_i ) eq 'HASH' ) { $value_sz = &Packed_SIZE_HASH( $array_i , 1 ) ;}
    elsif ( ref( $array_i ) eq 'ARRAY' ) { $value_sz = &Packed_SIZE_ARRAY( $array_i , 1 ) ;}
    elsif ( UNIVERSAL::isa($array_i ,'UNIVERSAL') ) { next ;} ## ignore objects.
    else { $value_sz = length($array_i) ;}
    
    $blk_sz += 1 ;
    $blk_sz += length($value_sz) + 1 ;
    $blk_sz += $value_sz ;
    
    $size += $blk_sz ;
  }
  
  if ( !$_[1] ) { $pack_init =~ s/\{0}/\{$size}/s ;}
  
  $size += length($pack_init) if !$_[1] ;
  
  return( $size ) ;
}

#######
# END #
#######

# 0 => key & val || line
# 1 => hash ref
# 2 => array ref

1; 

__END__

=head1 NAME

HDB::Encode - Hybrid DataBase - HASH/ARRAY enconding.

=head1 DESCRIPTION

You can save HASH and ARRAY structures inside columns of a table in the database.

** The column that will receive the encoded data need to have a good size for the encoded HASH/ARRAY!

=head1 USAGE

  my %HASH = (
  'a' => 1 ,
  'b' => 2 ,
  'c' => 3 ,
  'd' => { 'da' => 41 , 'db' => 42 } ,
  'e' => [qw(x y z)] ,
  ) ;
  
  $HDB->insert( 'users' , {
  user => 'joe' ,
  name => 'joe tribianny' ,
  more => \%HASH ,
  } ) ;
  
  ...
  
  $HDB->insert( 'users' , {
  user => 'joe' ,
  name => 'joe tribianny' ,
  more => { a => 1 , b => 2 } ,
  } ) ;
  
  ...
  
  my %hash = $HDB->select( 'users' , 'user == joe' , col => 'more' , '$$@' ) ; # $$@ to return directly the HASH.

=head1 METHODS

B<** You don't need to use this methods, HDB will make everything automatically.>

=head2 Pack (\%HASH or \@ARRAY)

Encode a HASH/ARRAY.
Will use Pack_HASH & Pack_ARRAY.

=head2 Pack_HASH (\%HASH)

Encode a HASH.

=head2 Pack_ARRAY (\@ARRAY)

Encode an ARRAY.

=head2 UnPack (ENCODED_HASH or ENCODED_ARRAY)

Decode a HASH/ARRAY.
Will use UnPack_HASH & UnPack_ARRAY.

=head2 UnPack_HASH (ENCODED_HASH)

Decode a HASH.

=head2 UnPack_ARRAY (ENCODED_ARRAY)

Decode an ARRAY.

=head2 Is_Packed_HASH (DATA)

Check if the encoded data is a HASH.

=head2 Is_Packed_ARRAY (DATA)

Check if the encoded data is an ARRAY.

=head2 Check_Pack_Size (DATA)

Check if the encoded data is ok.

=head2 Packed_SIZE (\%HASH or \@ARRAY)

Return the size of the HASH/ARRAY encoded.
This will calculate the size without generate the encoded data.

Will use Packed_SIZE_HASH & Packed_SIZE_ARRAY.

=head2 Packed_SIZE_HASH (\%HASH)

Return the size of the HASH encoded without generate it.

=head2 Packed_SIZE_ARRAY (\@ARRAY)

Return the size of the ARRAY encoded without generate it.

=head1 ENCODED DATA

The encoded HASH/ARRAY are very similar:

  %HDB_PACKED_HASH%[1.0]{50}:DATA

  1.0  >> Format version.
  50   >> DATA size.
  DATA >> The encoded data.
  
  # For ARRAY is:
  %HDB_PACKED_ARRAY%...
  
  ** The data has this begin to identify the encoded data in the database.
  ** The size is used to check if the data is crashed.
  
  DATA for HASH:
  
  02:aa4:bbbb
  
  0    >> normal value. 1 for HASH in the value. 2 for ARRAY in the value.
  2    >> size of key.
  aa   >> key
  4    >> size of value.  
  bbbb >> value
  
  DATA for ARRAY:
  
  02:aa
  
  0  >> normal value. 1 for HASH in the value. 2 for ARRAY in the value.
  2  >> size of value.
  aa >> value

=head1 SEE ALSO

L<HDB>, L<HDB::CMDS>, L<HDB::sqlite>, L<HDB::mysql>.

=head1 AUTHOR

Graciliano M. P. <gm@virtuasites.com.br>

=head1 COPYRIGHT

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

=cut

PK         ! �ßA)  )                  perl5/ExtUtils/MM_DOS.pmnu ��6�$        PK         ! �!�u!  u!              q  perl5/ExtUtils/Packlist.pmnu ��6�$        PK         ! t2�i�  �              0&  perl5/ExtUtils/MM_VOS.pmnu ��6�$        PK         ! 	���  �              r)  perl5/ExtUtils/MM_OS2.pmnu ��6�$        PK         ! �8�                W6  perl5/ExtUtils/Command/MM.pmnu ��6�$        PK         ! 6�FN�C �C             �T  perl5/ExtUtils/MM_Any.pmnu ��6�$        PK         ! �'�  �              �� perl5/ExtUtils/testlib.pmnu ��6�$        PK         ! �Yq��  �              v� perl5/ExtUtils/MM_UWIN.pmnu ��6�$        PK         ! X���  �              �� perl5/ExtUtils/Mkbootstrap.pmnu ��6�$        PK         ! �"�  �              �� perl5/ExtUtils/MM_AIX.pmnu ��6�$        PK         ! o���8  8              س perl5/ExtUtils/Installed.pmnu ��6�$        PK         ! ��_� _�             >� perl5/ExtUtils/MakeMaker.pmnu ��6�$        PK         ! ��݅  �              � perl5/ExtUtils/MM_MacOS.pmnu ��6�$        PK         ! х׃  �              �� perl5/ExtUtils/Command.pmnu ��6�$        PK         ! ���^L  L  $            �� perl5/ExtUtils/Typemaps/OutputMap.pmnu ��6�$        PK         ! �����  �  #            #� perl5/ExtUtils/Typemaps/InputMap.pmnu ��6�$        PK         ! H��X%  %              � perl5/ExtUtils/Typemaps/Type.pmnu ��6�$        PK         ! ��B%  %              �� perl5/ExtUtils/Typemaps/Cmd.pmnu ��6�$        PK         ! ��Ht�
 �
             �� perl5/ExtUtils/MM_VMS.pmnu ��6�$        PK         ! !�[  �[              �� perl5/ExtUtils/Manifest.pmnu ��6�$        PK         ! �h,�  �              �R perl5/ExtUtils/MM.pmnu ��6�$        PK         ! Z�X��  �              �[ perl5/ExtUtils/MM_OS390.pmnu ��6�$        PK         !  ���  �              �d perl5/ExtUtils/MANIFEST.SKIPnu ��6�$        PK         ! آ~<&  &              �h perl5/ExtUtils/MM_BeOS.pmnu ��6�$        PK         ! ђ�C6  6              Pm perl5/ExtUtils/ParseXS.podnu ��6�$        PK         ! 3^�h  �h              �~ perl5/ExtUtils/Typemaps.pmnu ��6�$        PK         ! $�=��  �              �� perl5/ExtUtils/MM_QNX.pmnu ��6�$        PK         ! ���� ��             �� perl5/ExtUtils/MM_Unix.pmnu ��6�$        PK         ! b?o^+  +              ׭ perl5/ExtUtils/Mksymlists.pmnu ��6�$        PK         ! ��S                (� perl5/ExtUtils/MM_Win95.pmnu ��6�$        PK         ! ^�sX                � perl5/ExtUtils/MM_Cygwin.pmnu ��6�$        PK         ! 8�A�  �  )            �� perl5/ExtUtils/MakeMaker/version/regex.pmnu ��6�$        PK         ! d+�~Z  Z  '            �  perl5/ExtUtils/MakeMaker/version/vpp.pmnu ��6�$        PK         ! �E�$4  $4  "            X[ perl5/ExtUtils/MakeMaker/Locale.pmnu ��6�$        PK         ! oL��Z  Z  "            Ώ perl5/ExtUtils/MakeMaker/Config.pmnu ��6�$        PK         ! �?�JO  JO               z� perl5/ExtUtils/MakeMaker/FAQ.podnu ��6�$        PK         ! &�ƛU	  U	  #            � perl5/ExtUtils/MakeMaker/version.pmnu ��6�$        PK         ! �~��s  s  %            �� perl5/ExtUtils/MakeMaker/Tutorial.podnu ��6�$        PK         ! �6�&b  &b              �	 perl5/ExtUtils/Liblist/Kid.pmnu ��6�$        PK         ! �:���  ��              �c	 perl5/ExtUtils/Install.pmnu ��6�$        PK         ! p^�  �              �
 perl5/ExtUtils/MM_Darwin.pmnu ��6�$        PK         ! �rWh  h              �
 perl5/ExtUtils/MM_NW5.pmnu ��6�$        PK         ! ����:  �:              a
 perl5/ExtUtils/MM_Win32.pmnu ��6�$        PK         ! ���              �X
 perl5/ExtUtils/ParseXS.pmnu ��6�$        PK         ! ����  �              �\ perl5/ExtUtils/MY.pmnu ��6�$        PK         ! yE�V%%  %%              �_ perl5/ExtUtils/Liblist.pmnu ��6�$        PK         ! C@��F	  F	              ,� perl5/ExtUtils/ParseXS/Eval.pmnu ��6�$        PK         ! ��ڠC  C  #            �� perl5/ExtUtils/ParseXS/Utilities.pmnu ��6�$        PK         ! ��"��  �  $            &� perl5/ExtUtils/ParseXS/CountLines.pmnu ��6�$        PK         ! q9��x  x  #            E� perl5/ExtUtils/ParseXS/Constants.pmnu ��6�$        PK         ! �f�y�  �              � perl5/ExtUtils/xsubppnu ��6�$        PK         ! ��+dP  P              $� perl5/Test/use/ok.pmnu ��6�$        PK         ! h�/�Z�  Z�              �� perl5/Test/Builder.pmnu ��6�$        PK         ! z{�9��  ��              W� perl5/Test/Deep.pmnu ��6�$        PK         ! �Ի    "            f� perl5/Test/Tester/CaptureRunner.pmnu ��6�$        PK         ! ���>H  H              μ perl5/Test/Tester/Capture.pmnu ��6�$        PK         ! ��uY;  ;              b� perl5/Test/Tester/Delegate.pmnu ��6�$        PK         ! ���\  \              �� perl5/Test/Simple.pmnu ��6�$        PK         ! O����)  �)              �� perl5/Test/utf8.pmnu ��6�$        PK         ! (죸ќ  ќ              � perl5/Test/File.pmnu ��6�$        PK         ! ӿ�                  �� perl5/Test/Deep/ListMethods.pmnu ��6�$        PK         ! ���i�  �              � perl5/Test/Deep/Cmp.pmnu ��6�$        PK         ! b�w�                 ҷ perl5/Test/Deep/RegexpVersion.pmnu ��6�$        PK         ! y�׀  �               :� perl5/Test/Deep/ScalarRefOnly.pmnu ��6�$        PK         ! �L�                
� perl5/Test/Deep/ArrayEach.pmnu ��6�$        PK         ! _���   �               [� perl5/Test/Deep/Ignore.pmnu ��6�$        PK         ! H)T��  �              ^� perl5/Test/Deep/Any.pmnu ��6�$        PK         ! ��                0� perl5/Test/Deep/HashKeysOnly.pmnu ��6�$        PK         ! �K��  �              �� perl5/Test/Deep/HashKeys.pmnu ��6�$        PK         ! �l�C�  �  "            �� perl5/Test/Deep/ArrayLengthOnly.pmnu ��6�$        PK         ! ��Dm.  .              �� perl5/Test/Deep/Boolean.pmnu ��6�$        PK         ! �0S[#  #              � perl5/Test/Deep/RefType.pmnu ��6�$        PK         ! ��} �  �              {� perl5/Test/Deep/ScalarRef.pmnu ��6�$        PK         ! �j~q  q              w� perl5/Test/Deep/String.pmnu ��6�$        PK         ! !`���  �              1� perl5/Test/Deep/Ref.pmnu ��6�$        PK         ! �l�	�  �              a� perl5/Test/Deep/HashElements.pmnu ��6�$        PK         !  �u~p  p              �� perl5/Test/Deep/Set.pmnu ��6�$        PK         ! vì��  �              Y� perl5/Test/Deep/All.pmnu ��6�$        PK         ! @���  �              ]� perl5/Test/Deep/MM.pmnu ��6�$        PK         ! J8�@  @              <� perl5/Test/Deep/Number.pmnu ��6�$        PK         ! r N34  4              �� perl5/Test/Deep/Stack.pmnu ��6�$        PK         ! ��r                A� perl5/Test/Deep/Cache.pmnu ��6�$        PK         ! J�b�U  U              � perl5/Test/Deep/Shallow.pmnu ��6�$        PK         ! Aݤ�4  4              0 perl5/Test/Deep/Blessed.pmnu ��6�$        PK         ! �D�                � perl5/Test/Deep/Isa.pmnu ��6�$        PK         ! 8<`�k  k              
 perl5/Test/Deep/Class.pmnu ��6�$        PK         ! n��΀  �              � perl5/Test/Deep/Regexp.pmnu ��6�$        PK         ! =�?�                  � perl5/Test/Deep/Methods.pmnu ��6�$        PK         ! �1��  �              � perl5/Test/Deep/Code.pmnu ��6�$        PK         ! �ԭ�                � perl5/Test/Deep/NoTest.pmnu ��6�$        PK         ! ���ѵ  �              Y perl5/Test/Deep/Cache/Simple.pmnu ��6�$        PK         ! �C�"v  v              ]" perl5/Test/Deep/ArrayLength.pmnu ��6�$        PK         ! ���ݥ  �  $            !$ perl5/Test/Deep/ArrayElementsOnly.pmnu ��6�$        PK         ! x^6	  	              ' perl5/Test/Deep/RegexpOnly.pmnu ��6�$        PK         ! j`��  �              p) perl5/Test/Deep/Hash.pmnu ��6�$        PK         ! �)�  �               </ perl5/Test/Deep/RegexpRefOnly.pmnu ��6�$        PK         ! �u�  �              31 perl5/Test/Deep/Array.pmnu ��6�$        PK         ! NNk#�  �               X3 perl5/Test/Deep/RegexpMatches.pmnu ��6�$        PK         ! ��ƈ                >6 perl5/Test/Deep/RegexpRef.pmnu ��6�$        PK         ! J��[F  F              	9 perl5/Test/Deep/HashEach.pmnu ��6�$        PK         ! ��[*e  e              �: perl5/Test/Deep/None.pmnu ��6�$        PK         ! ��|�
  
              F> perl5/Test/Deep/Obj.pmnu ��6�$        PK         ! �%��:  :              �@ perl5/Test/Fatal.pmnu ��6�$        PK         ! 	]&C�t  �t              �z perl5/Test/Alien.pmnu ��6�$        PK         ! /p5��K  �K              $� perl5/Test/Tutorial.podnu ��6�$        PK         ! vB~��  �              �; perl5/Test/Pod.pmnu ��6�$        PK         ! �e��G  �G              4Y perl5/Test/Tester.pmnu ��6�$        PK         ! Tm����  ��              � perl5/Test/More.pmnu ��6�$        PK         ! �+��  �              0o perl5/Test/Builder/Module.pmnu ��6�$        PK         ! ��u�9  9              k perl5/Test/Builder/TodoDiag.pmnu ��6�$        PK         ! �+w�  �  "            � perl5/Test/Builder/Tester/Color.pmnu ��6�$        PK         ! �i�J  J              � perl5/Test/Builder/Formatter.pmnu ��6�$        PK         ! Iz2sF  sF              �� perl5/Test/Builder/Tester.pmnu ��6�$        PK         ! ���H5  H5              i� perl5/Test/Builder/IO/Scalar.pmnu ��6�$        PK         ! uB��,9  ,9                perl5/Test/Warnings.pmnu ��6�$        PK         ! �M��E  E              rF perl5/Test/Alien/Build.pmnu ��6�$        PK         ! �KHp  p              ʋ perl5/Test/Alien/Synthetic.pmnu ��6�$        PK         ! Z�_�  �              �� perl5/Test/Alien/CanPlatypus.pmnu ��6�$        PK         ! ���<                r� perl5/Test/Alien/Diag.pmnu ��6�$        PK         ! �қd  d              Ҷ perl5/Test/Alien/Run.pmnu ��6�$        PK         ! t6F�  �              }� perl5/Test/Alien/CanCompile.pmnu ��6�$        PK         ! �<,P�/  �/              d� perl5/Authen/NTLM.pmnu ��6�$        PK         ! ,c�+�  �              � perl5/Authen/NTLM/MD4.pmnu ��6�$        PK         ! +�rM[  [              � perl5/Authen/NTLM/DES.pmnu ��6�$        PK         ! 0���Q4  Q4              P6 perl5/HTTP/Status.pmnu ��6�$        PK         ! ��Ѥ�"  �"              �j perl5/HTTP/Request.pmnu ��6�$        PK         ! #�kx  x              � perl5/HTTP/Message.pmnu ��6�$        PK         ! ��Pd�-  �-              s perl5/HTTP/Config.pmnu ��6�$        PK         ! ި��  �              B4 perl5/HTTP/Headers/Util.pmnu ��6�$        PK         ! ��+~�	  �	              [H perl5/HTTP/Headers/ETag.pmnu ��6�$        PK         ! �PT.	  .	              �R perl5/HTTP/Headers/Auth.pmnu ��6�$        PK         ! ��
RB?  B?              \ perl5/HTTP/Request/Common.pmnu ��6�$        PK         ! �b�SB  B              �� perl5/HTTP/Response.pmnu ��6�$        PK         ! ��L= =             � perl5/HTTP/Tiny.pmnu ��6�$        PK         ! ��?dBb  Bb              W perl5/HTTP/Headers.pmnu ��6�$        PK         ! 	���� ��             �} perl5/Expect.pmnu �7��m        PK         ! �~� "   "              �	 perl5/Parse/CPAN/Meta.pmnu ��6�$        PK         ! �sI�C  �C              ), perl5/Net/HTTP/Methods.pmnu ��6�$        PK         ! �c�	  �	              'p perl5/Net/HTTP/NB.pmnu ��6�$        PK         ! �Y�f�'  �'              Dz perl5/Net/HTTP.pmnu ��6�$        PK         ! %��9! 9!             #� perl5/Net/IP.pmnu ��6�$        PK         ! �1��  �              �� perl5/Net/HTTPS.pmnu ��6�$        PK         ! 4;{g�  �              �� perl5/lib/core/only.pmnu ��6�$        PK         ! |����@  �@              �� perl5/FFI/CheckLib.pmnu ��6�$        PK         ! ����L  �L              � perl5/XML/SAX/Expat.pmnu �7��m        PK         ! �q�i� �             �l perl5/XML/Simple.pmnu ��6�$        PK         ! ʛ��Q  �Q              � perl5/XML/Simple/FAQ.podnu ��6�$        PK         ! b���  �              J perl5/Data/Uniqid.pmnu ��6�$        PK         ! r�TK�  �              
S perl5/ok.pmnu ��6�$        PK         ! -��*  *              W perl5/Canary/Stability.pmnu ��6�$        PK         ! F R��  �              r perl5/JSON/PP/Boolean.pmnu ��6�$        PK         ! ݄�M@ M@             pt perl5/JSON/PP.pmnu ��6�$        PK         ! �����  �              �� perl5/Test2.pmnu ��6�$        PK         ! ԋ͘�G �G             4� perl5/Getopt/Long.pmnu ��6�$        PK         ! ~�Լ�5  �5              1 perl5/Test2/Formatter/TAP.pmnu ��6�$        PK         ! ��.)  )              !L perl5/Test2/Util.pmnu ��6�$        PK         ! �5�z  z              hu perl5/Test2/IPC/Driver.pmnu ��6�$        PK         ! U�\�4  �4              +� perl5/Test2/IPC/Driver/Files.pmnu ��6�$        PK         ! ��Ry�  �              v� perl5/Test2/Event/Waiting.pmnu ��6�$        PK         ! �#���  �              �� perl5/Test2/Event/Bail.pmnu ��6�$        PK         ! 8���  �              �� perl5/Test2/Event/Encoding.pmnu ��6�$        PK         ! Dڑ��  �              �� perl5/Test2/Event/Exception.pmnu ��6�$        PK         ! H9��                �� perl5/Test2/Event/Generic.pmnu ��6�$        PK         ! v]_�<  <              [� perl5/Test2/Event/Plan.pmnu ��6�$        PK         ! +��~�  �              �  perl5/Test2/Event/Skip.pmnu ��6�$        PK         ! ���U�  �                perl5/Test2/Event/Pass.pmnu ��6�$        PK         ! ���Ll  l               �  perl5/Test2/Event/TAP/Version.pmnu ��6�$        PK         ! QAx�  �              �  perl5/Test2/Event/Diag.pmnu ��6�$        PK         ! [����  �              �   perl5/Test2/Event/Fail.pmnu ��6�$        PK         ! ���}  }              �(  perl5/Test2/Event/Subtest.pmnu ��6�$        PK         ! 7øډ  �              �5  perl5/Test2/Event/Note.pmnu ��6�$        PK         ! p�i�Z  Z              T;  perl5/Test2/Event/Ok.pmnu ��6�$        PK         ! ���H+  +              �G  perl5/Test2/Event/V2.pmnu ��6�$        PK         ! �?0q�  �              g[  perl5/Test2/EventFacet.pmnu ��6�$        PK         ! �E�ص  �              �a  perl5/Test2/EventFacet/Trace.pmnu ��6�$        PK         ! :vO�'  '  $            �|  perl5/Test2/EventFacet/Info/Table.pmnu ��6�$        PK         ! JF�                �  perl5/Test2/EventFacet/Error.pmnu ��6�$        PK         ! �
�^  ^              _�  perl5/Test2/EventFacet/Plan.pmnu ��6�$        PK         ! �O9h�  �               �  perl5/Test2/EventFacet/Render.pmnu ��6�$        PK         ! ~$��F  F              Z�  perl5/Test2/EventFacet/Meta.pmnu ��6�$        PK         ! �D�O�  �              �  perl5/Test2/EventFacet/About.pmnu ��6�$        PK         ! 19�6  6              	�  perl5/Test2/EventFacet/Info.pmnu ��6�$        PK         ! �&���  �  !            ��  perl5/Test2/EventFacet/Control.pmnu ��6�$        PK         ! ,��U  U              ��  perl5/Test2/EventFacet/Hub.pmnu ��6�$        PK         ! n�*�  �               X�  perl5/Test2/EventFacet/Assert.pmnu ��6�$        PK         ! ]zՑ�  �               X�  perl5/Test2/EventFacet/Parent.pmnu ��6�$        PK         ! Ј�Pk  k  !            ~�  perl5/Test2/EventFacet/Amnesty.pmnu ��6�$        PK         ! �a��#  �#              :�  perl5/Test2/Tools/Tiny.pmnu ��6�$        PK         ! g�s  s              8! perl5/Test2/Util/Trace.pmnu ��6�$        PK         ! �z5��  �               �! perl5/Test2/Util/ExternalMeta.pmnu ��6�$        PK         ! �%�d�3  �3              ! perl5/Test2/Util/HashBase.pmnu ��6�$        PK         ! }��  �  !            �H! perl5/Test2/Util/Facets2Legacy.pmnu ��6�$        PK         ! ^>��4  �4              Dd! perl5/Test2/Transition.podnu ��6�$        PK         ! ag�o�  �              E�! perl5/Test2/API.pmnu ��6�$        PK         ! ���q  q              �V" perl5/Test2/Formatter.pmnu ��6�$        PK         ! ��Tݦ
  �
              Nf" perl5/Test2/Hub/Interceptor.pmnu ��6�$        PK         ! .4�=P
  P
              Bq" perl5/Test2/Hub/Subtest.pmnu ��6�$        PK         ! Cd�I�  �  )            �{" perl5/Test2/Hub/Interceptor/Terminator.pmnu ��6�$        PK         ! �Xv�,Y  ,Y              " perl5/Test2/Hub.pmnu ��6�$        PK         ! c�.�oX  oX              ��" perl5/Test2/Event.pmnu ��6�$        PK         ! R�SH�k  �k              61# perl5/Test2/API/Context.pmnu ��6�$        PK         ! u��S�S  �S              �# perl5/Test2/API/Instance.pmnu ��6�$        PK         ! BV3�  �              E�# perl5/Test2/API/Breakage.pmnu ��6�$        PK         ! �U�  �              j$ perl5/Test2/API/Stack.pmnu ��6�$        PK         ! u�ge�F  �F  "            �$ perl5/Test2/API/InterceptResult.pmnu ��6�$        PK         ! ��:`Z  Z  +            �^$ perl5/Test2/API/InterceptResult/Squasher.pmnu ��6�$        PK         ! �����  �  &            �m$ perl5/Test2/API/InterceptResult/Hub.pmnu ��6�$        PK         ! ��o��o  �o  (            �q$ perl5/Test2/API/InterceptResult/Event.pmnu ��6�$        PK         ! &RI|  |  (            ��$ perl5/Test2/API/InterceptResult/Facet.pmnu ��6�$        PK         ! �r�f  f              ��$ perl5/Test2/IPC.pmnu ��6�$        PK         ! ��!G�s  �s              m�$ perl5/Capture/Tiny.pmnu ��6�$        PK         ! uP`y7  y7              �d% perl5/HDB.pmnu ��6�$        PK         ! ���O�  O�              ?�% perl5/local/lib.pmnu ��6�$        PK         ! ��E�1$  1$              �>& perl5/libwww/lwpcook.podnu ��6�$        PK         ! ���va  va              Ic& perl5/libwww/lwptut.podnu ��6�$        PK         ! !	M}�A  �A              �& perl5/alienfile.pmnu ��6�$        PK         ! ���|1  1              1' perl5/cPanelUserConfig.pmnu �[���        PK         ! X6q��R  �R              �	' perl5/Try/Tiny.pmnu ��6�$        PK         ! ��-}  }  @            �\' perl5/x86_64-linux-thread-multi/.meta/Net-HTTP-6.19/install.jsonnu ��6�$        PK         ! �+tH8k  8k  ?            p^' perl5/x86_64-linux-thread-multi/.meta/Net-HTTP-6.19/MYMETA.jsonnu ��6�$        PK         ! |����  �  A            �' perl5/x86_64-linux-thread-multi/.meta/HTML-Form-6.07/install.jsonnu ��6�$        PK         ! Q�e��s  �s  @            ~�' perl5/x86_64-linux-thread-multi/.meta/HTML-Form-6.07/MYMETA.jsonnu ��6�$        PK         ! 	Ɖ8U  U  I            �A( perl5/x86_64-linux-thread-multi/.meta/Template-Toolkit-3.102/install.jsonnu ��6�$        PK         ! ��D�  �  H            |R( perl5/x86_64-linux-thread-multi/.meta/Template-Toolkit-3.102/MYMETA.jsonnu ��6�$        PK         ! �~�'�   �   E            �X( perl5/x86_64-linux-thread-multi/.meta/File-Slurp-9999.32/install.jsonnu ��6�$        PK         ! ��F7	  	  D            8Z( perl5/x86_64-linux-thread-multi/.meta/File-Slurp-9999.32/MYMETA.jsonnu ��6�$        PK         ! ��:��   �   >            �c( perl5/x86_64-linux-thread-multi/.meta/Expect-1.35/install.jsonnu ��6�$        PK         ! c LM`  `  =            �d( perl5/x86_64-linux-thread-multi/.meta/Expect-1.35/MYMETA.jsonnu ��6�$        PK         ! ���m  m  A            �k( perl5/x86_64-linux-thread-multi/.meta/YAML-Syck-1.34/install.jsonnu ��6�$        PK         ! {��+    @            ym( perl5/x86_64-linux-thread-multi/.meta/YAML-Syck-1.34/MYMETA.jsonnu ��6�$        PK         ! �"�y�  �  C            �r( perl5/x86_64-linux-thread-multi/.meta/libwww-perl-6.49/install.jsonnu ��6�$        PK         ! ���^�  ^�  B            gz( perl5/x86_64-linux-thread-multi/.meta/libwww-perl-6.49/MYMETA.jsonnu ��6�$        PK         ! Bg�   �   >            7) perl5/x86_64-linux-thread-multi/.meta/Expect-1.38/install.jsonnu ��6�$        PK         ! ve�0]  ]  =            V) perl5/x86_64-linux-thread-multi/.meta/Expect-1.38/MYMETA.jsonnu ��6�$        PK         ! �j�!�  �  C             	) perl5/x86_64-linux-thread-multi/.meta/Alien-Build-2.33/install.jsonnu ��6�$        PK         ! 	X�m�  �  B            �%) perl5/x86_64-linux-thread-multi/.meta/Alien-Build-2.33/MYMETA.jsonnu ��6�$        PK         ! �:�c
  c
  D            �5) perl5/x86_64-linux-thread-multi/.meta/XML-LibXML-2.0206/install.jsonnu ��6�$        PK         ! CP���	  �	  C            �@) perl5/x86_64-linux-thread-multi/.meta/XML-LibXML-2.0206/MYMETA.jsonnu ��6�$        PK         ! |�F��  �  O            �J) perl5/x86_64-linux-thread-multi/.meta/CPAN-Meta-Requirements-2.143/install.jsonnu ��6�$        PK         ! s*��  �  N            �L) perl5/x86_64-linux-thread-multi/.meta/CPAN-Meta-Requirements-2.143/MYMETA.jsonnu ��6�$        PK         ! 5)��   �   D            g) perl5/x86_64-linux-thread-multi/.meta/Data-Dumper-2.173/install.jsonnu ��6�$        PK         ! ��Qۇ  �  C            Gh) perl5/x86_64-linux-thread-multi/.meta/Data-Dumper-2.173/MYMETA.jsonnu ��6�$        PK         ! E�kc
  c
  D            Al) perl5/x86_64-linux-thread-multi/.meta/XML-LibXML-2.0208/install.jsonnu ��6�$        PK         ! SEXA�	  �	  C            w) perl5/x86_64-linux-thread-multi/.meta/XML-LibXML-2.0208/MYMETA.jsonnu ��6�$        PK         ! �ҥK�  �  >            f�) perl5/x86_64-linux-thread-multi/.meta/Encode-3.07/install.jsonnu ��6�$        PK         ! T�;  ;  =            Z�) perl5/x86_64-linux-thread-multi/.meta/Encode-3.07/MYMETA.jsonnu ��6�$        PK         ! ���6    I            �) perl5/x86_64-linux-thread-multi/.meta/Template-Toolkit-3.100/install.jsonnu ��6�$        PK         ! `AѦ�  �  H            ��) perl5/x86_64-linux-thread-multi/.meta/Template-Toolkit-3.100/MYMETA.jsonnu ��6�$        PK         ! :hg  g  Z            ��) perl5/x86_64-linux-thread-multi/.meta/Alien-Build-Plugin-Download-GitLab-0.01/install.jsonnu ��6�$        PK         ! �,���  �  Y            ��) perl5/x86_64-linux-thread-multi/.meta/Alien-Build-Plugin-Download-GitLab-0.01/MYMETA.jsonnu ��6�$        PK         ! ��   �   B            ��) perl5/x86_64-linux-thread-multi/.meta/HTTP-Tiny-0.088/install.jsonnu ��6�$        PK         ! p)���  �  A            ��) perl5/x86_64-linux-thread-multi/.meta/HTTP-Tiny-0.088/MYMETA.jsonnu ��6�$        PK         ! ��7�   �   G            4�) perl5/x86_64-linux-thread-multi/.meta/CPAN-Meta-YAML-0.018/install.jsonnu ��6�$        PK         ! &A�  �  F            ��) perl5/x86_64-linux-thread-multi/.meta/CPAN-Meta-YAML-0.018/MYMETA.jsonnu ��6�$        PK         ! �C!��  �  <            �* perl5/x86_64-linux-thread-multi/.meta/CPAN-2.28/install.jsonnu ��6�$        PK         ! �TB�F	  F	  ;            �* perl5/x86_64-linux-thread-multi/.meta/CPAN-2.28/MYMETA.jsonnu ��6�$        PK         ! �"@6    E            �* perl5/x86_64-linux-thread-multi/.meta/local-lib-2.000024/install.jsonnu ��6�$        PK         ! �
��    D            * perl5/x86_64-linux-thread-multi/.meta/local-lib-2.000024/MYMETA.jsonnu ��6�$        PK         ! ��ZW    >            �"* perl5/x86_64-linux-thread-multi/.meta/IO-Tty-1.20/install.jsonnu ��6�$        PK         ! �lMh  h  =            9$* perl5/x86_64-linux-thread-multi/.meta/IO-Tty-1.20/MYMETA.jsonnu ��6�$        PK         ! �,s  s  A            )* perl5/x86_64-linux-thread-multi/.meta/YAML-Syck-1.45/install.jsonnu ��6�$        PK         ! ���  �  @            �** perl5/x86_64-linux-thread-multi/.meta/YAML-Syck-1.45/MYMETA.jsonnu ��6�$        PK         ! ����|  |  A            H2* perl5/x86_64-linux-thread-multi/.meta/version-0.9932/install.jsonnu ��6�$        PK         ! "utD�  �  @            54* perl5/x86_64-linux-thread-multi/.meta/version-0.9932/MYMETA.jsonnu ��6�$        PK         ! &B�m  m  A            �:* perl5/x86_64-linux-thread-multi/.meta/YAML-Syck-1.36/install.jsonnu ��6�$        PK         ! VL     @            t<* perl5/x86_64-linux-thread-multi/.meta/YAML-Syck-1.36/MYMETA.jsonnu ��6�$        PK         ! 5J��`  `  I            �A* perl5/x86_64-linux-thread-multi/.meta/Template-Toolkit-3.010/install.jsonnu ��6�$        PK         ! �֗��  �  H            �R* perl5/x86_64-linux-thread-multi/.meta/Template-Toolkit-3.010/MYMETA.jsonnu ��6�$        PK         ! ��[�    A            �X* perl5/x86_64-linux-thread-multi/.meta/HTML-Tree-5.07/install.jsonnu ��6�$        PK         ! �)h]�B  �B  @            z[* perl5/x86_64-linux-thread-multi/.meta/HTML-Tree-5.07/MYMETA.jsonnu ��6�$        PK         ! ���/�   �   @            ��* perl5/x86_64-linux-thread-multi/.meta/Try-Tiny-0.31/install.jsonnu ��6�$        PK         ! Cx;;B�  B�  ?            �* perl5/x86_64-linux-thread-multi/.meta/Try-Tiny-0.31/MYMETA.jsonnu ��6�$        PK         ! �JjG�   �   D            �]+ perl5/x86_64-linux-thread-multi/.meta/FFI-CheckLib-0.27/install.jsonnu ��6�$        PK         ! ����	  �	  C            �^+ perl5/x86_64-linux-thread-multi/.meta/FFI-CheckLib-0.27/MYMETA.jsonnu ��6�$        PK         ! ����    E            i+ perl5/x86_64-linux-thread-multi/.meta/local-lib-2.000029/install.jsonnu ��6�$        PK         ! ��B    D            �j+ perl5/x86_64-linux-thread-multi/.meta/local-lib-2.000029/MYMETA.jsonnu ��6�$        PK         ! h���    >            r+ perl5/x86_64-linux-thread-multi/.meta/IO-Tty-1.14/install.jsonnu ��6�$        PK         ! ��+�  �  =            �s+ perl5/x86_64-linux-thread-multi/.meta/IO-Tty-1.14/MYMETA.jsonnu ��6�$        PK         ! �ͫ�   �   >            �w+ perl5/x86_64-linux-thread-multi/.meta/Net-IP-1.26/install.jsonnu ��6�$        PK         ! J8a  a  =            �x+ perl5/x86_64-linux-thread-multi/.meta/Net-IP-1.26/MYMETA.jsonnu ��6�$        PK         ! ���|  |  A            �|+ perl5/x86_64-linux-thread-multi/.meta/version-0.9928/install.jsonnu ��6�$        PK         ! ˏ��  �  @            �~+ perl5/x86_64-linux-thread-multi/.meta/version-0.9928/MYMETA.jsonnu ��6�$        PK         ! ���s  s  A            
�+ perl5/x86_64-linux-thread-multi/.meta/YAML-Syck-1.46/install.jsonnu ��6�$        PK         ! �p�  �  @            �+ perl5/x86_64-linux-thread-multi/.meta/YAML-Syck-1.46/MYMETA.jsonnu ��6�$        PK         ! ���b  b  J            D�+ perl5/x86_64-linux-thread-multi/.meta/ExtUtils-MakeMaker-7.50/install.jsonnu ��6�$        PK         ! ���    I             �+ perl5/x86_64-linux-thread-multi/.meta/ExtUtils-MakeMaker-7.50/MYMETA.jsonnu ��6�$        PK         ! Q��  �  C            ��+ perl5/x86_64-linux-thread-multi/.meta/IO-Stringy-2.113/install.jsonnu ��6�$        PK         ! %�,��L  �L  B            ��+ perl5/x86_64-linux-thread-multi/.meta/IO-Stringy-2.113/MYMETA.jsonnu ��6�$        PK         ! ����   �   E            ��+ perl5/x86_64-linux-thread-multi/.meta/XML-SAX-Expat-0.51/install.jsonnu ��6�$        PK         ! Z-�k  k  D            F�+ perl5/x86_64-linux-thread-multi/.meta/XML-SAX-Expat-0.51/MYMETA.jsonnu ��6�$        PK         ! �Z���  �  C            %�+ perl5/x86_64-linux-thread-multi/.meta/Alien-Build-2.83/install.jsonnu ��6�$        PK         ! )E�"  �"  B            a, perl5/x86_64-linux-thread-multi/.meta/Alien-Build-2.83/MYMETA.jsonnu ��6�$        PK         ! P&�k4  4  D            i8, perl5/x86_64-linux-thread-multi/.meta/HTTP-Message-6.26/install.jsonnu ��6�$        PK         ! >F�x  x  C            <, perl5/x86_64-linux-thread-multi/.meta/HTTP-Message-6.26/MYMETA.jsonnu ��6�$        PK         ! ���   �   B            ��, perl5/x86_64-linux-thread-multi/.meta/HTTP-Tiny-0.076/install.jsonnu ��6�$        PK         ! B}���  �  A            ̵, perl5/x86_64-linux-thread-multi/.meta/HTTP-Tiny-0.076/MYMETA.jsonnu ��6�$        PK         ! D�Ч�   �   E            5�, perl5/x86_64-linux-thread-multi/.meta/Alien-Libxml2-0.19/install.jsonnu ��6�$        PK         ! 	,H��  �  D            ��, perl5/x86_64-linux-thread-multi/.meta/Alien-Libxml2-0.19/MYMETA.jsonnu ��6�$        PK         ! Z�X��   �   E            ��, perl5/x86_64-linux-thread-multi/.meta/Alien-Libxml2-0.16/install.jsonnu ��6�$        PK         ! w=.  .  D            -�, perl5/x86_64-linux-thread-multi/.meta/Alien-Libxml2-0.16/MYMETA.jsonnu ��6�$        PK         ! ��^zs  s  A            ��, perl5/x86_64-linux-thread-multi/.meta/YAML-Syck-1.47/install.jsonnu ��6�$        PK         ! o����  �  @            ��, perl5/x86_64-linux-thread-multi/.meta/YAML-Syck-1.47/MYMETA.jsonnu ��6�$        PK         !  u��F  F  I            	- perl5/x86_64-linux-thread-multi/.meta/Template-Toolkit-3.106/install.jsonnu ��6�$        PK         ! ���    H            �- perl5/x86_64-linux-thread-multi/.meta/Template-Toolkit-3.106/MYMETA.jsonnu ��6�$        PK         ! ����   �   D            U- perl5/x86_64-linux-thread-multi/.meta/Capture-Tiny-0.48/install.jsonnu ��6�$        PK         ! ][�҆  �  C            �- perl5/x86_64-linux-thread-multi/.meta/Capture-Tiny-0.48/MYMETA.jsonnu ��6�$        PK         ! ��R�c
  c
  D            �*- perl5/x86_64-linux-thread-multi/.meta/XML-LibXML-2.0209/install.jsonnu ��6�$        PK         ! ΅J��	  �	  C            w5- perl5/x86_64-linux-thread-multi/.meta/XML-LibXML-2.0209/MYMETA.jsonnu ��6�$        PK         ! ���u!  !  O            �?- perl5/x86_64-linux-thread-multi/.meta/CPAN-Meta-Requirements-2.140/install.jsonnu ��6�$        PK         ! keTu    N            eA- perl5/x86_64-linux-thread-multi/.meta/CPAN-Meta-Requirements-2.140/MYMETA.jsonnu ��6�$        PK         ! ����  �  I            �X- perl5/x86_64-linux-thread-multi/.meta/Scalar-List-Utils-1.55/install.jsonnu ��6�$        PK         !  ����  �  H            �Z- perl5/x86_64-linux-thread-multi/.meta/Scalar-List-Utils-1.55/MYMETA.jsonnu ��6�$        PK         ! �����  �  H            ;a- perl5/x86_64-linux-thread-multi/.meta/ExtUtils-ParseXS-3.35/install.jsonnu ��6�$        PK         ! �K���  �  G            �e- perl5/x86_64-linux-thread-multi/.meta/ExtUtils-ParseXS-3.35/MYMETA.jsonnu ��6�$        PK         ! t���   �   B            l- perl5/x86_64-linux-thread-multi/.meta/File-Which-1.23/install.jsonnu ��6�$        PK         ! I�,\�  �  A            Fm- perl5/x86_64-linux-thread-multi/.meta/File-Which-1.23/MYMETA.jsonnu ��6�$        PK         ! y���   �   D            cu- perl5/x86_64-linux-thread-multi/.meta/common-sense-3.75/install.jsonnu ��6�$        PK         ! �0m�    C            �v- perl5/x86_64-linux-thread-multi/.meta/common-sense-3.75/MYMETA.jsonnu ��6�$        PK         ! �s�3�
  �
  D            "z- perl5/x86_64-linux-thread-multi/.meta/XML-LibXML-2.0210/install.jsonnu ��6�$        PK         ! �M�	  �	  C            C�- perl5/x86_64-linux-thread-multi/.meta/XML-LibXML-2.0210/MYMETA.jsonnu ��6�$        PK         ! �XHN    ;            ��- perl5/x86_64-linux-thread-multi/.meta/HDB-1.05/install.jsonnu ��6�$        PK         ! �y�n�  �  :            �- perl5/x86_64-linux-thread-multi/.meta/HDB-1.05/MYMETA.jsonnu ��6�$        PK         ! �*�e  e  D            �- perl5/x86_64-linux-thread-multi/.meta/File-chdir-0.1010/install.jsonnu ��6�$        PK         ! �Yb�    C            �- perl5/x86_64-linux-thread-multi/.meta/File-chdir-0.1010/MYMETA.jsonnu ��6�$        PK         ! ����   �   H            s�- perl5/x86_64-linux-thread-multi/.meta/Canary-Stability-2013/install.jsonnu ��6�$        PK         ! �L�G  G  G            Ҧ- perl5/x86_64-linux-thread-multi/.meta/Canary-Stability-2013/MYMETA.jsonnu ��6�$        PK         ! �*<[�   �   B            ��- perl5/x86_64-linux-thread-multi/.meta/XML-Simple-2.25/install.jsonnu ��6�$        PK         ! �;��K  K  A            Ϋ- perl5/x86_64-linux-thread-multi/.meta/XML-Simple-2.25/MYMETA.jsonnu ��6�$        PK         ! o^�'�  �  I            ��- perl5/x86_64-linux-thread-multi/.meta/Template-Toolkit-3.009/install.jsonnu ��6�$        PK         ! 1g�a�  �  H            ��- perl5/x86_64-linux-thread-multi/.meta/Template-Toolkit-3.009/MYMETA.jsonnu ��6�$        PK         ! �s0�  �  G            %�- perl5/x86_64-linux-thread-multi/.meta/Types-Serialiser-1.0/install.jsonnu ��6�$        PK         ! ��O$l  l  F            O�- perl5/x86_64-linux-thread-multi/.meta/Types-Serialiser-1.0/MYMETA.jsonnu ��6�$        PK         ! 鸞,�   �   ?            1�- perl5/x86_64-linux-thread-multi/.meta/JSON-XS-4.03/install.jsonnu ��6�$        PK         ! Poe�  �  >            S�- perl5/x86_64-linux-thread-multi/.meta/JSON-XS-4.03/MYMETA.jsonnu ��6�$        PK         ! wv�|�   �   C            w�- perl5/x86_64-linux-thread-multi/.meta/Test-Fatal-0.016/install.jsonnu ��6�$        PK         ! �>�o�J  �J  B            ��- perl5/x86_64-linux-thread-multi/.meta/Test-Fatal-0.016/MYMETA.jsonnu ��6�$        PK         ! <�"X  X  C            �. perl5/x86_64-linux-thread-multi/.meta/Getopt-Long-2.52/install.jsonnu ��6�$        PK         ! Zb�{�  �  B            �!. perl5/x86_64-linux-thread-multi/.meta/Getopt-Long-2.52/MYMETA.jsonnu ��6�$        PK         ! �}    E            �&. perl5/x86_64-linux-thread-multi/.meta/WWW-Mechanize-2.02/install.jsonnu ��6�$        PK         ! ��	  	  D            �(. perl5/x86_64-linux-thread-multi/.meta/WWW-Mechanize-2.02/MYMETA.jsonnu ��6�$        PK         ! P��Da
  a
  D            ]�. perl5/x86_64-linux-thread-multi/.meta/XML-LibXML-2.0213/install.jsonnu ��6�$        PK         ! �&
  &
  C            2�. perl5/x86_64-linux-thread-multi/.meta/XML-LibXML-2.0213/MYMETA.jsonnu ��6�$        PK         ! z�K�   �   @            ˽. perl5/x86_64-linux-thread-multi/.meta/Try-Tiny-0.30/install.jsonnu ��6�$        PK         ! X�\H��  ��  ?            ��. perl5/x86_64-linux-thread-multi/.meta/Try-Tiny-0.30/MYMETA.jsonnu ��6�$        PK         ! :+c
  c
  D            x/ perl5/x86_64-linux-thread-multi/.meta/XML-LibXML-2.0207/install.jsonnu ��6�$        PK         ! ]G#�	  �	  C            ؂/ perl5/x86_64-linux-thread-multi/.meta/XML-LibXML-2.0207/MYMETA.jsonnu ��6�$        PK         ! ��@I  I              &�/ perl5/Digest/HMAC.pmnu ��6�$        PK         ! ?�\H�  �              ��/ perl5/Digest/HMAC_SHA1.pmnu ��6�$        PK         ! ��[QZ  Z              ��/ perl5/Digest/HMAC_MD5.pmnu ��6�$        PK         ! ���ެT  �T              )�/ perl5/LWP.pmnu ��6�$        PK         ! ���ri  ri              �/ perl5/CPAN/Meta/YAML.pmnu ��6�$        PK         ! ��cm�  �              �`0 perl5/CPAN/Meta/Merge.pmnu ��6�$        PK         ! �somFU  FU              |0 perl5/CPAN/Meta/Requirements.pmnu ��6�$        PK         ! �E'�                ��0 perl5/CPAN/Meta/Feature.pmnu ��6�$        PK         ! B$s�  �              ��0 perl5/CPAN/Meta/Spec.pmnu ��6�$        PK         ! ��+n�  n�              Lo1 perl5/CPAN/Meta/Validator.pmnu ��6�$        PK         ! 4T�	�  �              �1 perl5/CPAN/Meta/History.pmnu ��6�$        PK         ! �A�Ɵ�  ��              	2 perl5/CPAN/Meta/Converter.pmnu ��6�$        PK         ! < $l:M  :M  %            
�2 perl5/CPAN/Meta/Requirements/Range.pmnu ��6�$        PK         ! ���h}.  }.              �3 perl5/CPAN/Meta/Prereqs.pmnu ��6�$        PK         ! �oO�q  �q              `F3 perl5/CPAN/Meta.pmnu ��6�$        PK         ! CP��>  �>              ��3 perl5/POD2/PT_BR/local/lib.podnu ��6�$        PK         ! ��(	�@  �@              o�3 perl5/POD2/DE/local/lib.podnu ��6�$        PK         ! �ڮ /"  /"              �84 perl5/Types/Serialiser.pmnu ��6�$        PK         ! �Wy��  �              ![4 perl5/Types/Serialiser/Error.pmnu ��6�$        PK         ! ���y  y              3]4 perl5/HTML/Parse.pmnu ��6�$        PK         ! �C�  �              �n4 perl5/HTML/Tree.pmnu ��6�$        PK         ! a@���'  �'              φ4 perl5/HTML/Element/traverse.pmnu ��6�$        PK         ! ���H�F �F             �4 perl5/HTML/TreeBuilder.pmnu ��6�$        PK         ! �֚+�z  �z               "�5 perl5/HTML/Tree/AboutObjects.podnu ��6�$        PK         ! ����d  �d              >q6 perl5/HTML/Tree/Scanning.podnu ��6�$        PK         ! MD����  ��              1�6 perl5/HTML/Tree/AboutTrees.podnu ��6�$        PK         ! v��  �              <�7 perl5/HTML/AsSubs.pmnu ��6�$        PK         ! �xl��* �*             �7 perl5/HTML/Element.pmnu ��6�$        PK         ! >:_�_�  _�              @�9 perl5/HTML/Form.pmnu ��6�$        PK         ! Ror�D� D�             �t: perl5/Path/Tiny.pmnu ��6�$        PK         ! ���9Z   Z   #            g3< perl5/auto/Data/Uniqid/autosplit.ixnu ��6�$        PK         ! �����	  �	              4< perl5/LWP/Authen/Digest.pmnu ��6�$        PK         ! �&u��  �              �=< perl5/LWP/Authen/Ntlm.pmnu ��6�$        PK         ! �ݵ�<
  <
              <S< perl5/LWP/Authen/Basic.pmnu ��6�$        PK         ! oFD��  �              �]< perl5/LWP/RobotUA.pmnu ��6�$        PK         ! ӗP7#  7#              �|< perl5/LWP/Protocol.pmnu ��6�$        PK         ! ��#"  #"              V�< perl5/LWP/ConnCache.pmnu ��6�$        PK         ! 5*3�  �              ��< perl5/LWP/Simple.pmnu ��6�$        PK         ! C\�;W  W              ��< perl5/LWP/Debug/TraceHTTP.pmnu ��6�$        PK         ! ݴ��C   C               ;�< perl5/LWP/DebugFile.pmnu ��6�$        PK         ! ^7�	k  k              ��< perl5/LWP/MemberMixin.pmnu ��6�$        PK         ! �s)b  b              w�< perl5/LWP/Debug.pmnu ��6�$        PK         ! n�[��  �              �< perl5/LWP/Protocol/data.pmnu ��6�$        PK         ! A��3b  b              6�< perl5/LWP/Protocol/nogo.pmnu ��6�$        PK         ! ���f6  6              ��< perl5/LWP/Protocol/mailto.pmnu ��6�$        PK         ! �eQ  Q              d= perl5/LWP/Protocol/cpan.pmnu ��6�$        PK         ! ���QJ  J              �= perl5/LWP/Protocol/loopback.pmnu ��6�$        PK         ! ���`  `              �= perl5/LWP/Protocol/gopher.pmnu ��6�$        PK         ! � �;  ;              C'= perl5/LWP/Protocol/http.pmnu ��6�$        PK         ! ��>�d  d              �b= perl5/LWP/Protocol/nntp.pmnu ��6�$        PK         ! �o8�J  �J              Bs= perl5/LWP/Protocol/ftp.pmnu ��6�$        PK         ! �z'$                O�= perl5/LWP/Protocol/file.pmnu ��6�$        PK         ! ��� �             ��= perl5/LWP/UserAgent.pmnu ��6�$        PK         ! h�y�  �              q�> perl5/newgetopt.plnu ��6�$        PK         ! z��y  �y              Q�> perl5/File/Slurp.pmnu ��6�$        PK         ! ����k  �k              �k? perl5/File/Copy/Recursive.pmnu ��6�$        PK         ! `�5\*  \*              ~�? perl5/File/chdir.pmnu ��6�$        PK         ! �95�.  �.              @ perl5/File/Which.pmnu ��6�$        PK         ! 6�0|	  |	              1@ perl5/WWW/Mechanize/Link.pmnu ��6�$        PK         ! � "��@  �@              �:@ perl5/WWW/Mechanize/FAQ.podnu ��6�$        PK         ! z��$  $              |@ perl5/WWW/Mechanize/Image.pmnu ��6�$        PK         ! �}q_
  
               ��@ perl5/WWW/Mechanize/Cookbook.podnu ��6�$        PK         ! �ܳ-@  @               �@ perl5/WWW/Mechanize/Examples.podnu ��6�$        PK         !  ��� ��             <�@ perl5/WWW/Mechanize.pmnu ��6�$        PK         ! �t��  �              y_B perl5/Alien/Util.pmnu ��6�$        PK         ! z�ħp  �p              ekB perl5/Alien/Base.pmnu ��6�$        PK         ! tJ J             O�B perl5/Alien/Build.pmnu ��6�$        PK         ! 5f�(�  �              ��C perl5/Alien/Base/FAQ.podnu ��6�$        PK         ! �r�  �              ��C perl5/Alien/Base/Authoring.podnu ��6�$        PK         ! )��l�4  �4              0�C perl5/Alien/Base/Wrapper.pmnu ��6�$        PK         ! Op-T(  (              P'D perl5/Alien/Base/PkgConfig.pmnu ��6�$        PK         ! #洊	  	              �:D perl5/Alien/Role.pmnu ��6�$        PK         ! >C�D  D              DD perl5/Alien/Build/Util.pmnu ��6�$        PK         ! 	ڱU9-  9-  %            �WD perl5/Alien/Build/Plugin/Test/Mock.pmnu ��6�$        PK         ! ��f �  �  &            /�D perl5/Alien/Build/Plugin/PkgConfig.podnu ��6�$        PK         ! D�YY�  �  !            N�D perl5/Alien/Build/Plugin/Core.podnu ��6�$        PK         ! �:��  �  1            !�D perl5/Alien/Build/Plugin/PkgConfig/CommandLine.pmnu ��6�$        PK         ! )��\�  �  0            \�D perl5/Alien/Build/Plugin/PkgConfig/LibPkgConf.pmnu ��6�$        PK         ! t�S  S  /            ��D perl5/Alien/Build/Plugin/PkgConfig/Negotiate.pmnu ��6�$        PK         ! n g  g  0            U�D perl5/Alien/Build/Plugin/PkgConfig/MakeStatic.pmnu ��6�$        PK         ! �նzc  c  (            �D perl5/Alien/Build/Plugin/PkgConfig/PP.pmnu ��6�$        PK         ! 6�O$  �$  .            �E perl5/Alien/Build/Plugin/Download/Negotiate.pmnu ��6�$        PK         ! �V}K  K  +            �:E perl5/Alien/Build/Plugin/Download/GitLab.pmnu ��6�$        PK         ! ���    4            nRE perl5/Alien/Build/Plugin/Decode/DirListingFtpcopy.pmnu ��6�$        PK         ! �w@�3  3  '            �_E perl5/Alien/Build/Plugin/Decode/HTML.pmnu ��6�$        PK         ! Mq�Fg  g  -            wlE perl5/Alien/Build/Plugin/Decode/DirListing.pmnu ��6�$        PK         ! ��tw      '            ;xE perl5/Alien/Build/Plugin/Decode/Mojo.pmnu ��6�$        PK         ! ��2R  R  %            ��E perl5/Alien/Build/Plugin/Download.podnu ��6�$        PK         ! Y��	  �	  "            Y�E perl5/Alien/Build/Plugin/Build.podnu ��6�$        PK         ! W�A0;	  ;	  "            _�E perl5/Alien/Build/Plugin/Probe.podnu ��6�$        PK         ! Ƌ7��  �  #            �E perl5/Alien/Build/Plugin/Prefer.podnu ��6�$        PK         ! �<b�  �  '            (�E perl5/Alien/Build/Plugin/Fetch/Local.pmnu ��6�$        PK         ! t���   �   -            2�E perl5/Alien/Build/Plugin/Fetch/CurlCommand.pmnu ��6�$        PK         ! .j?��  �  (            X�E perl5/Alien/Build/Plugin/Fetch/NetFTP.pmnu ��6�$        PK         ! 6���  �  *            ��E perl5/Alien/Build/Plugin/Fetch/HTTPTiny.pmnu ��6�$        PK         ! �q_��  �  &            �F perl5/Alien/Build/Plugin/Fetch/Wget.pmnu ��6�$        PK         ! ���	  	  %            #F perl5/Alien/Build/Plugin/Fetch/LWP.pmnu ��6�$        PK         ! �F��u  u  *            i4F perl5/Alien/Build/Plugin/Fetch/LocalDir.pmnu ��6�$        PK         ! j��Y5  Y5  /            8DF perl5/Alien/Build/Plugin/Extract/CommandLine.pmnu ��6�$        PK         ! �L�1    .            �yF perl5/Alien/Build/Plugin/Extract/ArchiveTar.pmnu ��6�$        PK         ! �u�P_  _  -            Z�F perl5/Alien/Build/Plugin/Extract/Negotiate.pmnu ��6�$        PK         ! �_Kw�  �  (            �F perl5/Alien/Build/Plugin/Extract/File.pmnu ��6�$        PK         ! NB,��  �  -            ��F perl5/Alien/Build/Plugin/Extract/Directory.pmnu ��6�$        PK         ! ��x  x  .            �F perl5/Alien/Build/Plugin/Extract/ArchiveZip.pmnu ��6�$        PK         ! �����  �  #            ��F perl5/Alien/Build/Plugin/Digest.podnu ��6�$        PK         ! �j���  �  %            ��F perl5/Alien/Build/Plugin/Core/Tail.pmnu ��6�$        PK         ! ���D�	  �	  '            ��F perl5/Alien/Build/Plugin/Core/Legacy.pmnu ��6�$        PK         ! 9�a�U  U  &            �F perl5/Alien/Build/Plugin/Core/Setup.pmnu ��6�$        PK         ! j�ᣢ  �  '            ��F perl5/Alien/Build/Plugin/Core/Gather.pmnu ��6�$        PK         ! KF���  �  )            �G perl5/Alien/Build/Plugin/Core/Override.pmnu ��6�$        PK         ! '�l�  �  $            �G perl5/Alien/Build/Plugin/Core/FFI.pmnu ��6�$        PK         ! du�0�  �  )            !#G perl5/Alien/Build/Plugin/Core/Download.pmnu ��6�$        PK         ! �Y��  �  -            89G perl5/Alien/Build/Plugin/Core/CleanInstall.pmnu ��6�$        PK         ! �7A��  �  .            GBG perl5/Alien/Build/Plugin/Prefer/GoodVersion.pmnu ��6�$        PK         ! ��g  g  /            uSG perl5/Alien/Build/Plugin/Prefer/SortVersions.pmnu ��6�$        PK         ! Ȳ�4�  �  -            ;bG perl5/Alien/Build/Plugin/Prefer/BadVersion.pmnu ��6�$        PK         ! ���
E  E  1            +sG perl5/Alien/Build/Plugin/Gather/IsolateDynamic.pmnu ��6�$        PK         ! �j�o	  	  &            рG perl5/Alien/Build/Plugin/Digest/SHA.pmnu ��6�$        PK         ! � (Q)  )  ,            -�G perl5/Alien/Build/Plugin/Digest/Negotiate.pmnu ��6�$        PK         ! RC`@t	  t	  (            ��G perl5/Alien/Build/Plugin/Digest/SHAPP.pmnu ��6�$        PK         ! � ���  �  !            ~�G perl5/Alien/Build/Plugin/Test.podnu ��6�$        PK         ! �&�mn  n  +            ~�G perl5/Alien/Build/Plugin/Build/SearchDep.pmnu ��6�$        PK         ! �U�O  O  &            G�G perl5/Alien/Build/Plugin/Build/Copy.pmnu ��6�$        PK         ! HLB4�  �  '            ��G perl5/Alien/Build/Plugin/Build/CMake.pmnu ��6�$        PK         ! UW٧%  �%  *             �G perl5/Alien/Build/Plugin/Build/Autoconf.pmnu ��6�$        PK         ! �#F�  �  &            !H perl5/Alien/Build/Plugin/Build/MSYS.pmnu ��6�$        PK         ! ����  �  &            JH perl5/Alien/Build/Plugin/Build/Make.pmnu ��6�$        PK         ! p����  �  #            ;-H perl5/Alien/Build/Plugin/Gather.podnu ��6�$        PK         ! W�O�	  	  $            W4H perl5/Alien/Build/Plugin/Extract.podnu ��6�$        PK         ! ��� �  �  -            �=H perl5/Alien/Build/Plugin/Probe/CommandLine.pmnu ��6�$        PK         ! �jF    *            
TH perl5/Alien/Build/Plugin/Probe/CBuilder.pmnu ��6�$        PK         ! vZ�    '            �nH perl5/Alien/Build/Plugin/Probe/Vcpkg.pmnu ��6�$        PK         ! 'S)�j
  j
  "            ܉H perl5/Alien/Build/Plugin/Fetch.podnu ��6�$        PK         ! ͆s��	  �	  #            ��H perl5/Alien/Build/Plugin/Decode.podnu ��6�$        PK         !  ��t�   �   (            �H perl5/Alien/Build/Interpolate/Default.pmnu ��6�$        PK         ! �6�*�;  �;              ��H perl5/Alien/Build/MM.pmnu ��6�$        PK         ! ā%�O  O              ��H perl5/Alien/Build/rc.pmnu ��6�$        PK         ! n����  �  "            KI perl5/Alien/Build/Version/Basic.pmnu ��6�$        PK         ! �h���  �              �I perl5/Alien/Build/Plugin.pmnu ��6�$        PK         ! �
�N�  �  $            �4I perl5/Alien/Build/CommandSequence.pmnu ��6�$        PK         ! �-�%t  t              �HI perl5/Alien/Build/Temp.pmnu ��6�$        PK         ! mM���R  �R               JTI perl5/Alien/Build/Manual/FAQ.podnu ��6�$        PK         ! �v��jb  jb  (            ��I perl5/Alien/Build/Manual/AlienAuthor.podnu ��6�$        PK         ! ����  �  &            H
J perl5/Alien/Build/Manual/AlienUser.podnu ��6�$        PK         ! ��N��#  �#  )            +%J perl5/Alien/Build/Manual/Contributing.podnu ��6�$        PK         ! �4���"  �"  %            iIJ perl5/Alien/Build/Manual/Security.podnu ��6�$        PK         ! 9��r�T  �T  )            �lJ perl5/Alien/Build/Manual/PluginAuthor.podnu ��6�$        PK         ! �p��W  W  "            ��J perl5/Alien/Build/Manual/Alien.podnu ��6�$        PK         ! �C�ċ	  �	              t�J perl5/Alien/Build/Manual.podnu ��6�$        PK         ! ���<
  <
  #            K�J perl5/Alien/Build/Log/Abbreviate.pmnu ��6�$        PK         ! ��T                 ��J perl5/Alien/Build/Log/Default.pmnu ��6�$        PK         ! 5K�n�  �               7�J perl5/Alien/Build/Interpolate.pmnu ��6�$        PK         ! f�7��  �              K perl5/Alien/Build/Log.pmnu ��6�$        PK         ! ��^�:  �:              �K perl5/IO/Scalar.pmnu ��6�$        PK         ! ���r�  �              �KK perl5/IO/AtomicFile.pmnu ��6�$        PK         ! �h�                aK perl5/IO/Stringy.pmnu ��6�$        PK         ! *�2U"  U"              ~hK perl5/IO/Wrap.pmnu ��6�$        PK         ! ��G�J  J              �K perl5/IO/Lines.pmnu ��6�$        PK         ! ��[|9  |9              ��K perl5/IO/WrapTie.pmnu ��6�$        PK         ! &��'�   �               ]�K perl5/IO/Tee.pmnu ��6�$        PK         ! ���  �              ��K perl5/IO/InnerFile.pmnu ��6�$        PK         ! l��]?@  ?@              _L perl5/IO/ScalarArray.pmnu ��6�$        PK         ! q�߁�  �              �RL perl5/HDB/MOD/oracle.pmnu ��6�$        PK         ! '����  �              �fL perl5/HDB/MOD/sqlite.pmnu ��6�$        PK         ! `���                  #vL perl5/HDB/MOD/mysql.pmnu ��6�$        PK         ! ���ʑ  ʑ              i�L perl5/HDB/CMDS.pmnu ��6�$        PK         ! @� fRl  Rl              tM perl5/HDB/Object.hploonu ��6�$        PK         ! )G2{�
  �
              �M perl5/HDB/MOD.pmnu ��6�$        PK         ! �퓠Z-  Z-              ��M perl5/HDB/Parser.pmnu ��6�$        PK         ! ����  �              ��M perl5/HDB/CORE.pmnu ��6�$        PK         ! ƚ��~  �~              b�M perl5/HDB/Object.pmnu ��6�$        PK         ! ��(�(  �(              aBN perl5/HDB/Encode.pmnu ��6�$        PK    ��  /kN   