#!/usr/bin/perl

# This chunk of stuff was generated by App::FatPacker. To find the original
# file's code, look for the end of this BEGIN block or the string 'FATPACK'
BEGIN {
my %fatpacked;

$fatpacked{"Carp.pm"} = <<'CARP';
  package Carp;
  
  { use 5.006; }
  use strict;
  use warnings;
  BEGIN {
      # Very old versions of warnings.pm load Carp.  This can go wrong due
      # to the circular dependency.  If warnings is invoked before Carp,
      # then warnings starts by loading Carp, then Carp (above) tries to
      # invoke warnings, and gets nothing because warnings is in the process
      # of loading and hasn't defined its import method yet.  If we were
      # only turning on warnings ("use warnings" above) this wouldn't be too
      # bad, because Carp would just gets the state of the -w switch and so
      # might not get some warnings that it wanted.  The real problem is
      # that we then want to turn off Unicode warnings, but "no warnings
      # 'utf8'" won't be effective if we're in this circular-dependency
      # situation.  So, if warnings.pm is an affected version, we turn
      # off all warnings ourselves by directly setting ${^WARNING_BITS}.
      # On unaffected versions, we turn off just Unicode warnings, via
      # the proper API.
      if(!defined($warnings::VERSION) || eval($warnings::VERSION) < 1.06) {
  	${^WARNING_BITS} = "";
      } else {
  	"warnings"->unimport("utf8");
      }
  }
  
  sub _fetch_sub { # fetch sub without autovivifying
      my($pack, $sub) = @_;
      $pack .= '::';
      # only works with top-level packages
      return unless exists($::{$pack});
      for ($::{$pack}) {
  	return unless ref \$_ eq 'GLOB' && *$_{HASH} && exists $$_{$sub};
  	for ($$_{$sub}) {
  	    return ref \$_ eq 'GLOB' ? *$_{CODE} : undef
  	}
      }
  }
  
  # UTF8_REGEXP_PROBLEM is a compile-time constant indicating whether Carp
  # must avoid applying a regular expression to an upgraded (is_utf8)
  # string.  There are multiple problems, on different Perl versions,
  # that require this to be avoided.  All versions prior to 5.13.8 will
  # load utf8_heavy.pl for the swash system, even if the regexp doesn't
  # use character classes.  Perl 5.6 and Perls [5.11.2, 5.13.11) exhibit
  # specific problems when Carp is being invoked in the aftermath of a
  # syntax error.
  BEGIN {
      if("$]" < 5.013011) {
  	*UTF8_REGEXP_PROBLEM = sub () { 1 };
      } else {
  	*UTF8_REGEXP_PROBLEM = sub () { 0 };
      }
  }
  
  # is_utf8() is essentially the utf8::is_utf8() function, which indicates
  # whether a string is represented in the upgraded form (using UTF-8
  # internally).  As utf8::is_utf8() is only available from Perl 5.8
  # onwards, extra effort is required here to make it work on Perl 5.6.
  BEGIN {
      if(defined(my $sub = _fetch_sub utf8 => 'is_utf8')) {
  	*is_utf8 = $sub;
      } else {
  	# black magic for perl 5.6
  	*is_utf8 = sub { unpack("C", "\xaa".$_[0]) != 170 };
      }
  }
  
  # The downgrade() function defined here is to be used for attempts to
  # downgrade where it is acceptable to fail.  It must be called with a
  # second argument that is a true value.
  BEGIN {
      if(defined(my $sub = _fetch_sub utf8 => 'downgrade')) {
  	*downgrade = \&{"utf8::downgrade"};
      } else {
  	*downgrade = sub {
  	    my $r = "";
  	    my $l = length($_[0]);
  	    for(my $i = 0; $i != $l; $i++) {
  		my $o = ord(substr($_[0], $i, 1));
  		return if $o > 255;
  		$r .= chr($o);
  	    }
  	    $_[0] = $r;
  	};
      }
  }
  
  our $VERSION = '1.32';
  
  our $MaxEvalLen = 0;
  our $Verbose    = 0;
  our $CarpLevel  = 0;
  our $MaxArgLen  = 64;    # How much of each argument to print. 0 = all.
  our $MaxArgNums = 8;     # How many arguments to print. 0 = all.
  our $RefArgFormatter = undef; # allow caller to format reference arguments
  
  require Exporter;
  our @ISA       = ('Exporter');
  our @EXPORT    = qw(confess croak carp);
  our @EXPORT_OK = qw(cluck verbose longmess shortmess);
  our @EXPORT_FAIL = qw(verbose);    # hook to enable verbose mode
  
  # The members of %Internal are packages that are internal to perl.
  # Carp will not report errors from within these packages if it
  # can.  The members of %CarpInternal are internal to Perl's warning
  # system.  Carp will not report errors from within these packages
  # either, and will not report calls *to* these packages for carp and
  # croak.  They replace $CarpLevel, which is deprecated.    The
  # $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval
  # text and function arguments should be formatted when printed.
  
  our %CarpInternal;
  our %Internal;
  
  # disable these by default, so they can live w/o require Carp
  $CarpInternal{Carp}++;
  $CarpInternal{warnings}++;
  $Internal{Exporter}++;
  $Internal{'Exporter::Heavy'}++;
  
  # if the caller specifies verbose usage ("perl -MCarp=verbose script.pl")
  # then the following method will be called by the Exporter which knows
  # to do this thanks to @EXPORT_FAIL, above.  $_[1] will contain the word
  # 'verbose'.
  
  sub export_fail { shift; $Verbose = shift if $_[0] eq 'verbose'; @_ }
  
  sub _cgc {
      no strict 'refs';
      return \&{"CORE::GLOBAL::caller"} if defined &{"CORE::GLOBAL::caller"};
      return;
  }
  
  sub longmess {
      local($!, $^E);
      # Icky backwards compatibility wrapper. :-(
      #
      # The story is that the original implementation hard-coded the
      # number of call levels to go back, so calls to longmess were off
      # by one.  Other code began calling longmess and expecting this
      # behaviour, so the replacement has to emulate that behaviour.
      my $cgc = _cgc();
      my $call_pack = $cgc ? $cgc->() : caller();
      if ( $Internal{$call_pack} or $CarpInternal{$call_pack} ) {
          return longmess_heavy(@_);
      }
      else {
          local $CarpLevel = $CarpLevel + 1;
          return longmess_heavy(@_);
      }
  }
  
  our @CARP_NOT;
  
  sub shortmess {
      local($!, $^E);
      my $cgc = _cgc();
  
      # Icky backwards compatibility wrapper. :-(
      local @CARP_NOT = $cgc ? $cgc->() : caller();
      shortmess_heavy(@_);
  }
  
  sub croak   { die shortmess @_ }
  sub confess { die longmess @_ }
  sub carp    { warn shortmess @_ }
  sub cluck   { warn longmess @_ }
  
  BEGIN {
      if("$]" >= 5.015002 || ("$]" >= 5.014002 && "$]" < 5.015) ||
  	    ("$]" >= 5.012005 && "$]" < 5.013)) {
  	*CALLER_OVERRIDE_CHECK_OK = sub () { 1 };
      } else {
  	*CALLER_OVERRIDE_CHECK_OK = sub () { 0 };
      }
  }
  
  sub caller_info {
      my $i = shift(@_) + 1;
      my %call_info;
      my $cgc = _cgc();
      {
  	# Some things override caller() but forget to implement the
  	# @DB::args part of it, which we need.  We check for this by
  	# pre-populating @DB::args with a sentinel which no-one else
  	# has the address of, so that we can detect whether @DB::args
  	# has been properly populated.  However, on earlier versions
  	# of perl this check tickles a bug in CORE::caller() which
  	# leaks memory.  So we only check on fixed perls.
          @DB::args = \$i if CALLER_OVERRIDE_CHECK_OK;
          package DB;
          @call_info{
              qw(pack file line sub has_args wantarray evaltext is_require) }
              = $cgc ? $cgc->($i) : caller($i);
      }
  
      unless ( defined $call_info{file} ) {
          return ();
      }
  
      my $sub_name = Carp::get_subname( \%call_info );
      if ( $call_info{has_args} ) {
          my @args;
          if (CALLER_OVERRIDE_CHECK_OK && @DB::args == 1
              && ref $DB::args[0] eq ref \$i
              && $DB::args[0] == \$i ) {
              @DB::args = ();    # Don't let anyone see the address of $i
              local $@;
              my $where = eval {
                  my $func    = $cgc or return '';
                  my $gv      =
                      (_fetch_sub B => 'svref_2object' or return '')
                          ->($func)->GV;
                  my $package = $gv->STASH->NAME;
                  my $subname = $gv->NAME;
                  return unless defined $package && defined $subname;
  
                  # returning CORE::GLOBAL::caller isn't useful for tracing the cause:
                  return if $package eq 'CORE::GLOBAL' && $subname eq 'caller';
                  " in &${package}::$subname";
              } || '';
              @args
                  = "** Incomplete caller override detected$where; \@DB::args were not set **";
          }
          else {
              @args = @DB::args;
              my $overflow;
              if ( $MaxArgNums and @args > $MaxArgNums )
              {    # More than we want to show?
                  $#args = $MaxArgNums;
                  $overflow = 1;
              }
  
              @args = map { Carp::format_arg($_) } @args;
  
              if ($overflow) {
                  push @args, '...';
              }
          }
  
          # Push the args onto the subroutine
          $sub_name .= '(' . join( ', ', @args ) . ')';
      }
      $call_info{sub_name} = $sub_name;
      return wantarray() ? %call_info : \%call_info;
  }
  
  # Transform an argument to a function into a string.
  our $in_recurse;
  sub format_arg {
      my $arg = shift;
  
      if ( ref($arg) ) {
           # legitimate, let's not leak it.
          if (!$in_recurse &&
  	    do {
                  local $@;
  	        local $in_recurse = 1;
  		local $SIG{__DIE__} = sub{};
                  eval {$arg->can('CARP_TRACE') }
              })
          {
              return $arg->CARP_TRACE();
          }
          elsif (!$in_recurse &&
  	       defined($RefArgFormatter) &&
  	       do {
                  local $@;
  	        local $in_recurse = 1;
  		local $SIG{__DIE__} = sub{};
                  eval {$arg = $RefArgFormatter->($arg); 1}
                  })
          {
              return $arg;
          }
          else
          {
  	    my $sub = _fetch_sub(overload => 'StrVal');
  	    return $sub ? &$sub($arg) : "$arg";
          }
      }
      return "undef" if !defined($arg);
      downgrade($arg, 1);
      return $arg if !(UTF8_REGEXP_PROBLEM && is_utf8($arg)) &&
  	    $arg =~ /\A-?[0-9]+(?:\.[0-9]*)?(?:[eE][-+]?[0-9]+)?\z/;
      my $suffix = "";
      if ( 2 < $MaxArgLen and $MaxArgLen < length($arg) ) {
          substr ( $arg, $MaxArgLen - 3 ) = "";
  	$suffix = "...";
      }
      if(UTF8_REGEXP_PROBLEM && is_utf8($arg)) {
  	for(my $i = length($arg); $i--; ) {
  	    my $c = substr($arg, $i, 1);
  	    my $x = substr($arg, 0, 0);   # work around bug on Perl 5.8.{1,2}
  	    if($c eq "\"" || $c eq "\\" || $c eq "\$" || $c eq "\@") {
  		substr $arg, $i, 0, "\\";
  		next;
  	    }
  	    my $o = ord($c);
  	    substr $arg, $i, 1, sprintf("\\x{%x}", $o)
  		if $o < 0x20 || $o > 0x7f;
  	}
      } else {
  	$arg =~ s/([\"\\\$\@])/\\$1/g;
  	$arg =~ s/([^ -~])/sprintf("\\x{%x}",ord($1))/eg;
      }
      downgrade($arg, 1);
      return "\"".$arg."\"".$suffix;
  }
  
  sub Regexp::CARP_TRACE {
      my $arg = "$_[0]";
      downgrade($arg, 1);
      if(UTF8_REGEXP_PROBLEM && is_utf8($arg)) {
  	for(my $i = length($arg); $i--; ) {
  	    my $o = ord(substr($arg, $i, 1));
  	    my $x = substr($arg, 0, 0);   # work around bug on Perl 5.8.{1,2}
  	    substr $arg, $i, 1, sprintf("\\x{%x}", $o)
  		if $o < 0x20 || $o > 0x7f;
  	}
      } else {
  	$arg =~ s/([^ -~])/sprintf("\\x{%x}",ord($1))/eg;
      }
      downgrade($arg, 1);
      my $suffix = "";
      if($arg =~ /\A\(\?\^?([a-z]*)(?:-[a-z]*)?:(.*)\)\z/s) {
  	($suffix, $arg) = ($1, $2);
      }
      if ( 2 < $MaxArgLen and $MaxArgLen < length($arg) ) {
          substr ( $arg, $MaxArgLen - 3 ) = "";
  	$suffix = "...".$suffix;
      }
      return "qr($arg)$suffix";
  }
  
  # Takes an inheritance cache and a package and returns
  # an anon hash of known inheritances and anon array of
  # inheritances which consequences have not been figured
  # for.
  sub get_status {
      my $cache = shift;
      my $pkg   = shift;
      $cache->{$pkg} ||= [ { $pkg => $pkg }, [ trusts_directly($pkg) ] ];
      return @{ $cache->{$pkg} };
  }
  
  # Takes the info from caller() and figures out the name of
  # the sub/require/eval
  sub get_subname {
      my $info = shift;
      if ( defined( $info->{evaltext} ) ) {
          my $eval = $info->{evaltext};
          if ( $info->{is_require} ) {
              return "require $eval";
          }
          else {
              $eval =~ s/([\\\'])/\\$1/g;
              return "eval '" . str_len_trim( $eval, $MaxEvalLen ) . "'";
          }
      }
  
      # this can happen on older perls when the sub (or the stash containing it)
      # has been deleted
      if ( !defined( $info->{sub} ) ) {
          return '__ANON__::__ANON__';
      }
  
      return ( $info->{sub} eq '(eval)' ) ? 'eval {...}' : $info->{sub};
  }
  
  # Figures out what call (from the point of view of the caller)
  # the long error backtrace should start at.
  sub long_error_loc {
      my $i;
      my $lvl = $CarpLevel;
      {
          ++$i;
          my $cgc = _cgc();
          my @caller = $cgc ? $cgc->($i) : caller($i);
          my $pkg = $caller[0];
          unless ( defined($pkg) ) {
  
              # This *shouldn't* happen.
              if (%Internal) {
                  local %Internal;
                  $i = long_error_loc();
                  last;
              }
              elsif (defined $caller[2]) {
                  # this can happen when the stash has been deleted
                  # in that case, just assume that it's a reasonable place to
                  # stop (the file and line data will still be intact in any
                  # case) - the only issue is that we can't detect if the
                  # deleted package was internal (so don't do that then)
                  # -doy
                  redo unless 0 > --$lvl;
                  last;
              }
              else {
                  return 2;
              }
          }
          redo if $CarpInternal{$pkg};
          redo unless 0 > --$lvl;
          redo if $Internal{$pkg};
      }
      return $i - 1;
  }
  
  sub longmess_heavy {
      return @_ if ref( $_[0] );    # don't break references as exceptions
      my $i = long_error_loc();
      return ret_backtrace( $i, @_ );
  }
  
  # Returns a full stack backtrace starting from where it is
  # told.
  sub ret_backtrace {
      my ( $i, @error ) = @_;
      my $mess;
      my $err = join '', @error;
      $i++;
  
      my $tid_msg = '';
      if ( defined &threads::tid ) {
          my $tid = threads->tid;
          $tid_msg = " thread $tid" if $tid;
      }
  
      my %i = caller_info($i);
      $mess = "$err at $i{file} line $i{line}$tid_msg";
      if( defined $. ) {
          local $@ = '';
          local $SIG{__DIE__};
          eval {
              CORE::die;
          };
          if($@ =~ /^Died at .*(, <.*?> line \d+).$/ ) {
              $mess .= $1;
          }
      }
      $mess .= "\.\n";
  
      while ( my %i = caller_info( ++$i ) ) {
          $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
      }
  
      return $mess;
  }
  
  sub ret_summary {
      my ( $i, @error ) = @_;
      my $err = join '', @error;
      $i++;
  
      my $tid_msg = '';
      if ( defined &threads::tid ) {
          my $tid = threads->tid;
          $tid_msg = " thread $tid" if $tid;
      }
  
      my %i = caller_info($i);
      return "$err at $i{file} line $i{line}$tid_msg\.\n";
  }
  
  sub short_error_loc {
      # You have to create your (hash)ref out here, rather than defaulting it
      # inside trusts *on a lexical*, as you want it to persist across calls.
      # (You can default it on $_[2], but that gets messy)
      my $cache = {};
      my $i     = 1;
      my $lvl   = $CarpLevel;
      {
          my $cgc = _cgc();
          my $called = $cgc ? $cgc->($i) : caller($i);
          $i++;
          my $caller = $cgc ? $cgc->($i) : caller($i);
  
          if (!defined($caller)) {
              my @caller = $cgc ? $cgc->($i) : caller($i);
              if (@caller) {
                  # if there's no package but there is other caller info, then
                  # the package has been deleted - treat this as a valid package
                  # in this case
                  redo if defined($called) && $CarpInternal{$called};
                  redo unless 0 > --$lvl;
                  last;
              }
              else {
                  return 0;
              }
          }
          redo if $Internal{$caller};
          redo if $CarpInternal{$caller};
          redo if $CarpInternal{$called};
          redo if trusts( $called, $caller, $cache );
          redo if trusts( $caller, $called, $cache );
          redo unless 0 > --$lvl;
      }
      return $i - 1;
  }
  
  sub shortmess_heavy {
      return longmess_heavy(@_) if $Verbose;
      return @_ if ref( $_[0] );    # don't break references as exceptions
      my $i = short_error_loc();
      if ($i) {
          ret_summary( $i, @_ );
      }
      else {
          longmess_heavy(@_);
      }
  }
  
  # If a string is too long, trims it with ...
  sub str_len_trim {
      my $str = shift;
      my $max = shift || 0;
      if ( 2 < $max and $max < length($str) ) {
          substr( $str, $max - 3 ) = '...';
      }
      return $str;
  }
  
  # Takes two packages and an optional cache.  Says whether the
  # first inherits from the second.
  #
  # Recursive versions of this have to work to avoid certain
  # possible endless loops, and when following long chains of
  # inheritance are less efficient.
  sub trusts {
      my $child  = shift;
      my $parent = shift;
      my $cache  = shift;
      my ( $known, $partial ) = get_status( $cache, $child );
  
      # Figure out consequences until we have an answer
      while ( @$partial and not exists $known->{$parent} ) {
          my $anc = shift @$partial;
          next if exists $known->{$anc};
          $known->{$anc}++;
          my ( $anc_knows, $anc_partial ) = get_status( $cache, $anc );
          my @found = keys %$anc_knows;
          @$known{@found} = ();
          push @$partial, @$anc_partial;
      }
      return exists $known->{$parent};
  }
  
  # Takes a package and gives a list of those trusted directly
  sub trusts_directly {
      my $class = shift;
      no strict 'refs';
      my $stash = \%{"$class\::"};
      for my $var (qw/ CARP_NOT ISA /) {
          # Don't try using the variable until we know it exists,
          # to avoid polluting the caller's namespace.
          if ( $stash->{$var} && *{$stash->{$var}}{ARRAY} && @{$stash->{$var}} ) {
             return @{$stash->{$var}}
          }
      }
      return;
  }
  
  if(!defined($warnings::VERSION) ||
  	do { no warnings "numeric"; $warnings::VERSION < 1.03 }) {
      # Very old versions of warnings.pm import from Carp.  This can go
      # wrong due to the circular dependency.  If Carp is invoked before
      # warnings, then Carp starts by loading warnings, then warnings
      # tries to import from Carp, and gets nothing because Carp is in
      # the process of loading and hasn't defined its import method yet.
      # So we work around that by manually exporting to warnings here.
      no strict "refs";
      *{"warnings::$_"} = \&$_ foreach @EXPORT;
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Carp - alternative warn and die for modules
  
  =head1 SYNOPSIS
  
      use Carp;
  
      # warn user (from perspective of caller)
      carp "string trimmed to 80 chars";
  
      # die of errors (from perspective of caller)
      croak "We're outta here!";
  
      # die of errors with stack backtrace
      confess "not implemented";
  
      # cluck, longmess and shortmess not exported by default
      use Carp qw(cluck longmess shortmess);
      cluck "This is how we got here!";
      $long_message   = longmess( "message from cluck() or confess()" );
      $short_message  = shortmess( "message from carp() or croak()" );
  
  =head1 DESCRIPTION
  
  The Carp routines are useful in your own modules because
  they act like C<die()> or C<warn()>, but with a message which is more
  likely to be useful to a user of your module.  In the case of
  C<cluck()> and C<confess()>, that context is a summary of every
  call in the call-stack; C<longmess()> returns the contents of the error
  message.
  
  For a shorter message you can use C<carp()> or C<croak()> which report the
  error as being from where your module was called.  C<shortmess()> returns the
  contents of this error message.  There is no guarantee that that is where the
  error was, but it is a good educated guess.
  
  C<Carp> takes care not to clobber the status variables C<$!> and C<$^E>
  in the course of assembling its error messages.  This means that a
  C<$SIG{__DIE__}> or C<$SIG{__WARN__}> handler can capture the error
  information held in those variables, if it is required to augment the
  error message, and if the code calling C<Carp> left useful values there.
  Of course, C<Carp> can't guarantee the latter.
  
  You can also alter the way the output and logic of C<Carp> works, by
  changing some global variables in the C<Carp> namespace. See the
  section on C<GLOBAL VARIABLES> below.
  
  Here is a more complete description of how C<carp> and C<croak> work.
  What they do is search the call-stack for a function call stack where
  they have not been told that there shouldn't be an error.  If every
  call is marked safe, they give up and give a full stack backtrace
  instead.  In other words they presume that the first likely looking
  potential suspect is guilty.  Their rules for telling whether
  a call shouldn't generate errors work as follows:
  
  =over 4
  
  =item 1.
  
  Any call from a package to itself is safe.
  
  =item 2.
  
  Packages claim that there won't be errors on calls to or from
  packages explicitly marked as safe by inclusion in C<@CARP_NOT>, or
  (if that array is empty) C<@ISA>.  The ability to override what
  @ISA says is new in 5.8.
  
  =item 3.
  
  The trust in item 2 is transitive.  If A trusts B, and B
  trusts C, then A trusts C.  So if you do not override C<@ISA>
  with C<@CARP_NOT>, then this trust relationship is identical to,
  "inherits from".
  
  =item 4.
  
  Any call from an internal Perl module is safe.  (Nothing keeps
  user modules from marking themselves as internal to Perl, but
  this practice is discouraged.)
  
  =item 5.
  
  Any call to Perl's warning system (eg Carp itself) is safe.
  (This rule is what keeps it from reporting the error at the
  point where you call C<carp> or C<croak>.)
  
  =item 6.
  
  C<$Carp::CarpLevel> can be set to skip a fixed number of additional
  call levels.  Using this is not recommended because it is very
  difficult to get it to behave correctly.
  
  =back
  
  =head2 Forcing a Stack Trace
  
  As a debugging aid, you can force Carp to treat a croak as a confess
  and a carp as a cluck across I<all> modules. In other words, force a
  detailed stack trace to be given.  This can be very helpful when trying
  to understand why, or from where, a warning or error is being generated.
  
  This feature is enabled by 'importing' the non-existent symbol
  'verbose'. You would typically enable it by saying
  
      perl -MCarp=verbose script.pl
  
  or by including the string C<-MCarp=verbose> in the PERL5OPT
  environment variable.
  
  Alternately, you can set the global variable C<$Carp::Verbose> to true.
  See the C<GLOBAL VARIABLES> section below.
  
  =head2 Stack Trace formatting
  
  At each stack level, the subroutine's name is displayed along with
  its parameters.  For simple scalars, this is sufficient.  For complex
  data types, such as objects and other references, this can simply
  display C<'HASH(0x1ab36d8)'>.
  
  Carp gives two ways to control this.
  
  =over 4
  
  =item 1.
  
  For objects, a method, C<CARP_TRACE>, will be called, if it exists.  If
  this method doesn't exist, or it recurses into C<Carp>, or it otherwise
  throws an exception, this is skipped, and Carp moves on to the next option,
  otherwise checking stops and the string returned is used.  It is recommended
  that the object's type is part of the string to make debugging easier.
  
  =item 2.
  
  For any type of reference, C<$Carp::RefArgFormatter> is checked (see below).
  This variable is expected to be a code reference, and the current parameter
  is passed in.  If this function doesn't exist (the variable is undef), or
  it recurses into C<Carp>, or it otherwise throws an exception, this is
  skipped, and Carp moves on to the next option, otherwise checking stops
  and the string returned is used.
  
  =item 3.
  
  Otherwise, if neither C<CARP_TRACE> nor C<$Carp::RefArgFormatter> is
  available, stringify the value ignoring any overloading.
  
  =back
  
  =head1 GLOBAL VARIABLES
  
  =head2 $Carp::MaxEvalLen
  
  This variable determines how many characters of a string-eval are to
  be shown in the output. Use a value of C<0> to show all text.
  
  Defaults to C<0>.
  
  =head2 $Carp::MaxArgLen
  
  This variable determines how many characters of each argument to a
  function to print. Use a value of C<0> to show the full length of the
  argument.
  
  Defaults to C<64>.
  
  =head2 $Carp::MaxArgNums
  
  This variable determines how many arguments to each function to show.
  Use a value of C<0> to show all arguments to a function call.
  
  Defaults to C<8>.
  
  =head2 $Carp::Verbose
  
  This variable makes C<carp()> and C<croak()> generate stack backtraces
  just like C<cluck()> and C<confess()>.  This is how C<use Carp 'verbose'>
  is implemented internally.
  
  Defaults to C<0>.
  
  =head2 $Carp::RefArgFormatter
  
  This variable sets a general argument formatter to display references.
  Plain scalars and objects that implement C<CARP_TRACE> will not go through
  this formatter.  Calling C<Carp> from within this function is not supported.
  
  local $Carp::RefArgFormatter = sub {
      require Data::Dumper;
      Data::Dumper::Dump($_[0]); # not necessarily safe
  };
  
  =head2 @CARP_NOT
  
  This variable, I<in your package>, says which packages are I<not> to be
  considered as the location of an error. The C<carp()> and C<cluck()>
  functions will skip over callers when reporting where an error occurred.
  
  NB: This variable must be in the package's symbol table, thus:
  
      # These work
      our @CARP_NOT; # file scope
      use vars qw(@CARP_NOT); # package scope
      @My::Package::CARP_NOT = ... ; # explicit package variable
  
      # These don't work
      sub xyz { ... @CARP_NOT = ... } # w/o declarations above
      my @CARP_NOT; # even at top-level
  
  Example of use:
  
      package My::Carping::Package;
      use Carp;
      our @CARP_NOT;
      sub bar     { .... or _error('Wrong input') }
      sub _error  {
          # temporary control of where'ness, __PACKAGE__ is implicit
          local @CARP_NOT = qw(My::Friendly::Caller);
          carp(@_)
      }
  
  This would make C<Carp> report the error as coming from a caller not
  in C<My::Carping::Package>, nor from C<My::Friendly::Caller>.
  
  Also read the L</DESCRIPTION> section above, about how C<Carp> decides
  where the error is reported from.
  
  Use C<@CARP_NOT>, instead of C<$Carp::CarpLevel>.
  
  Overrides C<Carp>'s use of C<@ISA>.
  
  =head2 %Carp::Internal
  
  This says what packages are internal to Perl.  C<Carp> will never
  report an error as being from a line in a package that is internal to
  Perl.  For example:
  
      $Carp::Internal{ (__PACKAGE__) }++;
      # time passes...
      sub foo { ... or confess("whatever") };
  
  would give a full stack backtrace starting from the first caller
  outside of __PACKAGE__.  (Unless that package was also internal to
  Perl.)
  
  =head2 %Carp::CarpInternal
  
  This says which packages are internal to Perl's warning system.  For
  generating a full stack backtrace this is the same as being internal
  to Perl, the stack backtrace will not start inside packages that are
  listed in C<%Carp::CarpInternal>.  But it is slightly different for
  the summary message generated by C<carp> or C<croak>.  There errors
  will not be reported on any lines that are calling packages in
  C<%Carp::CarpInternal>.
  
  For example C<Carp> itself is listed in C<%Carp::CarpInternal>.
  Therefore the full stack backtrace from C<confess> will not start
  inside of C<Carp>, and the short message from calling C<croak> is
  not placed on the line where C<croak> was called.
  
  =head2 $Carp::CarpLevel
  
  This variable determines how many additional call frames are to be
  skipped that would not otherwise be when reporting where an error
  occurred on a call to one of C<Carp>'s functions.  It is fairly easy
  to count these call frames on calls that generate a full stack
  backtrace.  However it is much harder to do this accounting for calls
  that generate a short message.  Usually people skip too many call
  frames.  If they are lucky they skip enough that C<Carp> goes all of
  the way through the call stack, realizes that something is wrong, and
  then generates a full stack backtrace.  If they are unlucky then the
  error is reported from somewhere misleading very high in the call
  stack.
  
  Therefore it is best to avoid C<$Carp::CarpLevel>.  Instead use
  C<@CARP_NOT>, C<%Carp::Internal> and C<%Carp::CarpInternal>.
  
  Defaults to C<0>.
  
  =head1 BUGS
  
  The Carp routines don't handle exception objects currently.
  If called with a first argument that is a reference, they simply
  call die() or warn(), as appropriate.
  
  Some of the Carp code assumes that Perl's basic character encoding is
  ASCII, and will go wrong on an EBCDIC platform.
  
  =head1 SEE ALSO
  
  L<Carp::Always>,
  L<Carp::Clan>
  
  =head1 AUTHOR
  
  The Carp module first appeared in Larry Wall's perl 5.000 distribution.
  Since then it has been modified by several of the perl 5 porters.
  Andrew Main (Zefram) <zefram@fysh.org> divested Carp into an independent
  distribution.
  
  =head1 COPYRIGHT
  
  Copyright (C) 1994-2013 Larry Wall
  
  Copyright (C) 2011, 2012, 2013 Andrew Main (Zefram) <zefram@fysh.org>
  
  =head1 LICENSE
  
  This module is free software; you can redistribute it and/or modify it
  under the same terms as Perl itself.
CARP

$fatpacked{"Carp/Heavy.pm"} = <<'CARP_HEAVY';
  package Carp::Heavy;
  
  use Carp ();
  
  our $VERSION = '1.32';
  
  my $cv = defined($Carp::VERSION) ? $Carp::VERSION : "undef";
  if($cv ne $VERSION) {
  	die "Version mismatch between Carp $cv ($INC{q(Carp.pm)}) and Carp::Heavy $VERSION ($INC{q(Carp/Heavy.pm)}).  Did you alter \@INC after Carp was loaded?\n";
  }
  
  1;
  
  # Most of the machinery of Carp used to be here.
  # It has been moved in Carp.pm now, but this placeholder remains for
  # the benefit of modules that like to preload Carp::Heavy directly.
  # This must load Carp, because some modules rely on the historical
  # behaviour of Carp::Heavy loading Carp.
CARP_HEAVY

$fatpacked{"File/Path.pm"} = <<'FILE_PATH';
  package File::Path;
  
  use 5.005_04;
  use strict;
  
  use Cwd 'getcwd';
  use File::Basename ();
  use File::Spec     ();
  
  BEGIN {
      if ($] < 5.006) {
          # can't say 'opendir my $dh, $dirname'
          # need to initialise $dh
          eval "use Symbol";
      }
  }
  
  use Exporter ();
  use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
  $VERSION   = '2.09';
  @ISA       = qw(Exporter);
  @EXPORT    = qw(mkpath rmtree);
  @EXPORT_OK = qw(make_path remove_tree);
  
  my $Is_VMS     = $^O eq 'VMS';
  my $Is_MacOS   = $^O eq 'MacOS';
  
  # These OSes complain if you want to remove a file that you have no
  # write permission to:
  my $Force_Writeable = grep {$^O eq $_} qw(amigaos dos epoc MSWin32 MacOS os2);
  
  # Unix-like systems need to stat each directory in order to detect
  # race condition. MS-Windows is immune to this particular attack.
  my $Need_Stat_Check = !($^O eq 'MSWin32');
  
  sub _carp {
      require Carp;
      goto &Carp::carp;
  }
  
  sub _croak {
      require Carp;
      goto &Carp::croak;
  }
  
  sub _error {
      my $arg     = shift;
      my $message = shift;
      my $object  = shift;
  
      if ($arg->{error}) {
          $object = '' unless defined $object;
          $message .= ": $!" if $!;
          push @{${$arg->{error}}}, {$object => $message};
      }
      else {
          _carp(defined($object) ? "$message for $object: $!" : "$message: $!");
      }
  }
  
  sub make_path {
      push @_, {} unless @_ and UNIVERSAL::isa($_[-1],'HASH');
      goto &mkpath;
  }
  
  sub mkpath {
      my $old_style = !(@_ and UNIVERSAL::isa($_[-1],'HASH'));
  
      my $arg;
      my $paths;
  
      if ($old_style) {
          my ($verbose, $mode);
          ($paths, $verbose, $mode) = @_;
          $paths = [$paths] unless UNIVERSAL::isa($paths,'ARRAY');
          $arg->{verbose} = $verbose;
          $arg->{mode}    = defined $mode ? $mode : 0777;
      }
      else {
          $arg = pop @_;
          $arg->{mode}      = delete $arg->{mask} if exists $arg->{mask};
          $arg->{mode}      = 0777 unless exists $arg->{mode};
          ${$arg->{error}}  = [] if exists $arg->{error};
          $arg->{owner}     = delete $arg->{user} if exists $arg->{user};
          $arg->{owner}     = delete $arg->{uid}  if exists $arg->{uid};
          if (exists $arg->{owner} and $arg->{owner} =~ /\D/) {
              my $uid = (getpwnam $arg->{owner})[2];
              if (defined $uid) {
                  $arg->{owner} = $uid;
              }
              else {
                  _error($arg, "unable to map $arg->{owner} to a uid, ownership not changed");
                  delete $arg->{owner};
              }
          }
          if (exists $arg->{group} and $arg->{group} =~ /\D/) {
              my $gid = (getgrnam $arg->{group})[2];
              if (defined $gid) {
                  $arg->{group} = $gid;
              }
              else {
                  _error($arg, "unable to map $arg->{group} to a gid, group ownership not changed");
                  delete $arg->{group};
              }
          }
          if (exists $arg->{owner} and not exists $arg->{group}) {
              $arg->{group} = -1; # chown will leave group unchanged
          }
          if (exists $arg->{group} and not exists $arg->{owner}) {
              $arg->{owner} = -1; # chown will leave owner unchanged
          }
          $paths = [@_];
      }
      return _mkpath($arg, $paths);
  }
  
  sub _mkpath {
      my $arg   = shift;
      my $paths = shift;
  
      my(@created,$path);
      foreach $path (@$paths) {
          next unless defined($path) and length($path);
          $path .= '/' if $^O eq 'os2' and $path =~ /^\w:\z/s; # feature of CRT 
          # Logic wants Unix paths, so go with the flow.
          if ($Is_VMS) {
              next if $path eq '/';
              $path = VMS::Filespec::unixify($path);
          }
          next if -d $path;
          my $parent = File::Basename::dirname($path);
          unless (-d $parent or $path eq $parent) {
              push(@created,_mkpath($arg, [$parent]));
          }
          print "mkdir $path\n" if $arg->{verbose};
          if (mkdir($path,$arg->{mode})) {
              push(@created, $path);
              if (exists $arg->{owner}) {
  				# NB: $arg->{group} guaranteed to be set during initialisation
                  if (!chown $arg->{owner}, $arg->{group}, $path) {
                      _error($arg, "Cannot change ownership of $path to $arg->{owner}:$arg->{group}");
                  }
              }
          }
          else {
              my $save_bang = $!;
              my ($e, $e1) = ($save_bang, $^E);
              $e .= "; $e1" if $e ne $e1;
              # allow for another process to have created it meanwhile
              if (!-d $path) {
                  $! = $save_bang;
                  if ($arg->{error}) {
                      push @{${$arg->{error}}}, {$path => $e};
                  }
                  else {
                      _croak("mkdir $path: $e");
                  }
              }
          }
      }
      return @created;
  }
  
  sub remove_tree {
      push @_, {} unless @_ and UNIVERSAL::isa($_[-1],'HASH');
      goto &rmtree;
  }
  
  sub _is_subdir {
      my($dir, $test) = @_;
  
      my($dv, $dd) = File::Spec->splitpath($dir, 1);
      my($tv, $td) = File::Spec->splitpath($test, 1);
  
      # not on same volume
      return 0 if $dv ne $tv;
  
      my @d = File::Spec->splitdir($dd);
      my @t = File::Spec->splitdir($td);
  
      # @t can't be a subdir if it's shorter than @d
      return 0 if @t < @d;
  
      return join('/', @d) eq join('/', splice @t, 0, +@d);
  }
  
  sub rmtree {
      my $old_style = !(@_ and UNIVERSAL::isa($_[-1],'HASH'));
  
      my $arg;
      my $paths;
  
      if ($old_style) {
          my ($verbose, $safe);
          ($paths, $verbose, $safe) = @_;
          $arg->{verbose} = $verbose;
          $arg->{safe}    = defined $safe    ? $safe    : 0;
  
          if (defined($paths) and length($paths)) {
              $paths = [$paths] unless UNIVERSAL::isa($paths,'ARRAY');
          }
          else {
              _carp ("No root path(s) specified\n");
              return 0;
          }
      }
      else {
          $arg = pop @_;
          ${$arg->{error}}  = [] if exists $arg->{error};
          ${$arg->{result}} = [] if exists $arg->{result};
          $paths = [@_];
      }
  
      $arg->{prefix} = '';
      $arg->{depth}  = 0;
  
      my @clean_path;
      $arg->{cwd} = getcwd() or do {
          _error($arg, "cannot fetch initial working directory");
          return 0;
      };
      for ($arg->{cwd}) { /\A(.*)\Z/; $_ = $1 } # untaint
  
      for my $p (@$paths) {
          # need to fixup case and map \ to / on Windows
          my $ortho_root = $^O eq 'MSWin32' ? _slash_lc($p)          : $p;
          my $ortho_cwd  = $^O eq 'MSWin32' ? _slash_lc($arg->{cwd}) : $arg->{cwd};
          my $ortho_root_length = length($ortho_root);
          $ortho_root_length-- if $^O eq 'VMS'; # don't compare '.' with ']'
          if ($ortho_root_length && _is_subdir($ortho_root, $ortho_cwd)) {
              local $! = 0;
              _error($arg, "cannot remove path when cwd is $arg->{cwd}", $p);
              next;
          }
  
          if ($Is_MacOS) {
              $p  = ":$p" unless $p =~ /:/;
              $p .= ":"   unless $p =~ /:\z/;
          }
          elsif ($^O eq 'MSWin32') {
              $p =~ s{[/\\]\z}{};
          }
          else {
              $p =~ s{/\z}{};
          }
          push @clean_path, $p;
      }
  
      @{$arg}{qw(device inode perm)} = (lstat $arg->{cwd})[0,1] or do {
          _error($arg, "cannot stat initial working directory", $arg->{cwd});
          return 0;
      };
  
      return _rmtree($arg, \@clean_path);
  }
  
  sub _rmtree {
      my $arg   = shift;
      my $paths = shift;
  
      my $count  = 0;
      my $curdir = File::Spec->curdir();
      my $updir  = File::Spec->updir();
  
      my (@files, $root);
      ROOT_DIR:
      foreach $root (@$paths) {
          # since we chdir into each directory, it may not be obvious
          # to figure out where we are if we generate a message about
          # a file name. We therefore construct a semi-canonical
          # filename, anchored from the directory being unlinked (as
          # opposed to being truly canonical, anchored from the root (/).
  
          my $canon = $arg->{prefix}
              ? File::Spec->catfile($arg->{prefix}, $root)
              : $root
          ;
  
          my ($ldev, $lino, $perm) = (lstat $root)[0,1,2] or next ROOT_DIR;
  
          if ( -d _ ) {
              $root = VMS::Filespec::vmspath(VMS::Filespec::pathify($root)) if $Is_VMS;
  
              if (!chdir($root)) {
                  # see if we can escalate privileges to get in
                  # (e.g. funny protection mask such as -w- instead of rwx)
                  $perm &= 07777;
                  my $nperm = $perm | 0700;
                  if (!($arg->{safe} or $nperm == $perm or chmod($nperm, $root))) {
                      _error($arg, "cannot make child directory read-write-exec", $canon);
                      next ROOT_DIR;
                  }
                  elsif (!chdir($root)) {
                      _error($arg, "cannot chdir to child", $canon);
                      next ROOT_DIR;
                  }
              }
  
              my ($cur_dev, $cur_inode, $perm) = (stat $curdir)[0,1,2] or do {
                  _error($arg, "cannot stat current working directory", $canon);
                  next ROOT_DIR;
              };
  
              if ($Need_Stat_Check) {
                  ($ldev eq $cur_dev and $lino eq $cur_inode)
                      or _croak("directory $canon changed before chdir, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting.");
              }
  
              $perm &= 07777; # don't forget setuid, setgid, sticky bits
              my $nperm = $perm | 0700;
  
              # notabene: 0700 is for making readable in the first place,
              # it's also intended to change it to writable in case we have
              # to recurse in which case we are better than rm -rf for 
              # subtrees with strange permissions
  
              if (!($arg->{safe} or $nperm == $perm or chmod($nperm, $curdir))) {
                  _error($arg, "cannot make directory read+writeable", $canon);
                  $nperm = $perm;
              }
  
              my $d;
              $d = gensym() if $] < 5.006;
              if (!opendir $d, $curdir) {
                  _error($arg, "cannot opendir", $canon);
                  @files = ();
              }
              else {
                  no strict 'refs';
                  if (!defined ${"\cTAINT"} or ${"\cTAINT"}) {
                      # Blindly untaint dir names if taint mode is
                      # active, or any perl < 5.006
                      @files = map { /\A(.*)\z/s; $1 } readdir $d;
                  }
                  else {
                      @files = readdir $d;
                  }
                  closedir $d;
              }
  
              if ($Is_VMS) {
                  # Deleting large numbers of files from VMS Files-11
                  # filesystems is faster if done in reverse ASCIIbetical order.
                  # include '.' to '.;' from blead patch #31775
                  @files = map {$_ eq '.' ? '.;' : $_} reverse @files;
              }
  
              @files = grep {$_ ne $updir and $_ ne $curdir} @files;
  
              if (@files) {
                  # remove the contained files before the directory itself
                  my $narg = {%$arg};
                  @{$narg}{qw(device inode cwd prefix depth)}
                      = ($cur_dev, $cur_inode, $updir, $canon, $arg->{depth}+1);
                  $count += _rmtree($narg, \@files);
              }
  
              # restore directory permissions of required now (in case the rmdir
              # below fails), while we are still in the directory and may do so
              # without a race via '.'
              if ($nperm != $perm and not chmod($perm, $curdir)) {
                  _error($arg, "cannot reset chmod", $canon);
              }
  
              # don't leave the client code in an unexpected directory
              chdir($arg->{cwd})
                  or _croak("cannot chdir to $arg->{cwd} from $canon: $!, aborting.");
  
              # ensure that a chdir upwards didn't take us somewhere other
              # than we expected (see CVE-2002-0435)
              ($cur_dev, $cur_inode) = (stat $curdir)[0,1]
                  or _croak("cannot stat prior working directory $arg->{cwd}: $!, aborting.");
  
              if ($Need_Stat_Check) {
                  ($arg->{device} eq $cur_dev and $arg->{inode} eq $cur_inode)
                      or _croak("previous directory $arg->{cwd} changed before entering $canon, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting.");
              }
  
              if ($arg->{depth} or !$arg->{keep_root}) {
                  if ($arg->{safe} &&
                      ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) {
                      print "skipped $root\n" if $arg->{verbose};
                      next ROOT_DIR;
                  }
                  if ($Force_Writeable and !chmod $perm | 0700, $root) {
                      _error($arg, "cannot make directory writeable", $canon);
                  }
                  print "rmdir $root\n" if $arg->{verbose};
                  if (rmdir $root) {
                      push @{${$arg->{result}}}, $root if $arg->{result};
                      ++$count;
                  }
                  else {
                      _error($arg, "cannot remove directory", $canon);
                      if ($Force_Writeable && !chmod($perm, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
                      ) {
                          _error($arg, sprintf("cannot restore permissions to 0%o",$perm), $canon);
                      }
                  }
              }
          }
          else {
              # not a directory
              $root = VMS::Filespec::vmsify("./$root")
                  if $Is_VMS
                     && !File::Spec->file_name_is_absolute($root)
                     && ($root !~ m/(?<!\^)[\]>]+/);  # not already in VMS syntax
  
              if ($arg->{safe} &&
                  ($Is_VMS ? !&VMS::Filespec::candelete($root)
                           : !(-l $root || -w $root)))
              {
                  print "skipped $root\n" if $arg->{verbose};
                  next ROOT_DIR;
              }
  
              my $nperm = $perm & 07777 | 0600;
              if ($Force_Writeable and $nperm != $perm and not chmod $nperm, $root) {
                  _error($arg, "cannot make file writeable", $canon);
              }
              print "unlink $canon\n" if $arg->{verbose};
              # delete all versions under VMS
              for (;;) {
                  if (unlink $root) {
                      push @{${$arg->{result}}}, $root if $arg->{result};
                  }
                  else {
                      _error($arg, "cannot unlink file", $canon);
                      $Force_Writeable and chmod($perm, $root) or
                          _error($arg, sprintf("cannot restore permissions to 0%o",$perm), $canon);
                      last;
                  }
                  ++$count;
                  last unless $Is_VMS && lstat $root;
              }
          }
      }
      return $count;
  }
  
  sub _slash_lc {
      # fix up slashes and case on MSWin32 so that we can determine that
      # c:\path\to\dir is underneath C:/Path/To
      my $path = shift;
      $path =~ tr{\\}{/};
      return lc($path);
  }
  
  1;
  __END__
  
  =head1 NAME
  
  File::Path - Create or remove directory trees
  
  =head1 VERSION
  
  This document describes version 2.09 of File::Path, released
  2013-01-17.
  
  =head1 SYNOPSIS
  
    use File::Path qw(make_path remove_tree);
  
    make_path('foo/bar/baz', '/zug/zwang');
    make_path('foo/bar/baz', '/zug/zwang', {
        verbose => 1,
        mode => 0711,
    });
  
    remove_tree('foo/bar/baz', '/zug/zwang');
    remove_tree('foo/bar/baz', '/zug/zwang', {
        verbose => 1,
        error  => \my $err_list,
    });
  
    # legacy (interface promoted before v2.00)
    mkpath('/foo/bar/baz');
    mkpath('/foo/bar/baz', 1, 0711);
    mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711);
    rmtree('foo/bar/baz', 1, 1);
    rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1);
  
    # legacy (interface promoted before v2.06)
    mkpath('foo/bar/baz', '/zug/zwang', { verbose => 1, mode => 0711 });
    rmtree('foo/bar/baz', '/zug/zwang', { verbose => 1, mode => 0711 });
  
  =head1 DESCRIPTION
  
  This module provide a convenient way to create directories of
  arbitrary depth and to delete an entire directory subtree from the
  filesystem.
  
  The following functions are provided:
  
  =over
  
  =item make_path( $dir1, $dir2, .... )
  
  =item make_path( $dir1, $dir2, ...., \%opts )
  
  The C<make_path> function creates the given directories if they don't
  exists before, much like the Unix command C<mkdir -p>.
  
  The function accepts a list of directories to be created. Its
  behaviour may be tuned by an optional hashref appearing as the last
  parameter on the call.
  
  The function returns the list of directories actually created during
  the call; in scalar context the number of directories created.
  
  The following keys are recognised in the option hash:
  
  =over
  
  =item mode => $num
  
  The numeric permissions mode to apply to each created directory
  (defaults to 0777), to be modified by the current C<umask>. If the
  directory already exists (and thus does not need to be created),
  the permissions will not be modified.
  
  C<mask> is recognised as an alias for this parameter.
  
  =item verbose => $bool
  
  If present, will cause C<make_path> to print the name of each directory
  as it is created. By default nothing is printed.
  
  =item error => \$err
  
  If present, it should be a reference to a scalar.
  This scalar will be made to reference an array, which will
  be used to store any errors that are encountered.  See the L</"ERROR
  HANDLING"> section for more information.
  
  If this parameter is not used, certain error conditions may raise
  a fatal error that will cause the program will halt, unless trapped
  in an C<eval> block.
  
  =item owner => $owner
  
  =item user => $owner
  
  =item uid => $owner
  
  If present, will cause any created directory to be owned by C<$owner>.
  If the value is numeric, it will be interpreted as a uid, otherwise
  as username is assumed. An error will be issued if the username cannot be
  mapped to a uid, or the uid does not exist, or the process lacks the
  privileges to change ownership.
  
  Ownwership of directories that already exist will not be changed.
  
  C<user> and C<uid> are aliases of C<owner>.
  
  =item group => $group
  
  If present, will cause any created directory to be owned by the group C<$group>.
  If the value is numeric, it will be interpreted as a gid, otherwise
  as group name is assumed. An error will be issued if the group name cannot be
  mapped to a gid, or the gid does not exist, or the process lacks the
  privileges to change group ownership.
  
  Group ownwership of directories that already exist will not be changed.
  
      make_path '/var/tmp/webcache', {owner=>'nobody', group=>'nogroup'};
  
  =back
  
  =item mkpath( $dir )
  
  =item mkpath( $dir, $verbose, $mode )
  
  =item mkpath( [$dir1, $dir2,...], $verbose, $mode )
  
  =item mkpath( $dir1, $dir2,..., \%opt )
  
  The mkpath() function provide the legacy interface of make_path() with
  a different interpretation of the arguments passed.  The behaviour and
  return value of the function is otherwise identical to make_path().
  
  =item remove_tree( $dir1, $dir2, .... )
  
  =item remove_tree( $dir1, $dir2, ...., \%opts )
  
  The C<remove_tree> function deletes the given directories and any
  files and subdirectories they might contain, much like the Unix
  command C<rm -r> or C<del /s> on Windows.
  
  The function accepts a list of directories to be
  removed. Its behaviour may be tuned by an optional hashref
  appearing as the last parameter on the call.
  
  The functions returns the number of files successfully deleted.
  
  The following keys are recognised in the option hash:
  
  =over
  
  =item verbose => $bool
  
  If present, will cause C<remove_tree> to print the name of each file as
  it is unlinked. By default nothing is printed.
  
  =item safe => $bool
  
  When set to a true value, will cause C<remove_tree> to skip the files
  for which the process lacks the required privileges needed to delete
  files, such as delete privileges on VMS. In other words, the code
  will make no attempt to alter file permissions. Thus, if the process
  is interrupted, no filesystem object will be left in a more
  permissive mode.
  
  =item keep_root => $bool
  
  When set to a true value, will cause all files and subdirectories
  to be removed, except the initially specified directories. This comes
  in handy when cleaning out an application's scratch directory.
  
    remove_tree( '/tmp', {keep_root => 1} );
  
  =item result => \$res
  
  If present, it should be a reference to a scalar.
  This scalar will be made to reference an array, which will
  be used to store all files and directories unlinked
  during the call. If nothing is unlinked, the array will be empty.
  
    remove_tree( '/tmp', {result => \my $list} );
    print "unlinked $_\n" for @$list;
  
  This is a useful alternative to the C<verbose> key.
  
  =item error => \$err
  
  If present, it should be a reference to a scalar.
  This scalar will be made to reference an array, which will
  be used to store any errors that are encountered.  See the L</"ERROR
  HANDLING"> section for more information.
  
  Removing things is a much more dangerous proposition than
  creating things. As such, there are certain conditions that
  C<remove_tree> may encounter that are so dangerous that the only
  sane action left is to kill the program.
  
  Use C<error> to trap all that is reasonable (problems with
  permissions and the like), and let it die if things get out
  of hand. This is the safest course of action.
  
  =back
  
  =item rmtree( $dir )
  
  =item rmtree( $dir, $verbose, $safe )
  
  =item rmtree( [$dir1, $dir2,...], $verbose, $safe )
  
  =item rmtree( $dir1, $dir2,..., \%opt )
  
  The rmtree() function provide the legacy interface of remove_tree()
  with a different interpretation of the arguments passed. The behaviour
  and return value of the function is otherwise identical to
  remove_tree().
  
  =back
  
  =head2 ERROR HANDLING
  
  =over 4
  
  =item B<NOTE:>
  
  The following error handling mechanism is considered
  experimental and is subject to change pending feedback from
  users.
  
  =back
  
  If C<make_path> or C<remove_tree> encounter an error, a diagnostic
  message will be printed to C<STDERR> via C<carp> (for non-fatal
  errors), or via C<croak> (for fatal errors).
  
  If this behaviour is not desirable, the C<error> attribute may be
  used to hold a reference to a variable, which will be used to store
  the diagnostics. The variable is made a reference to an array of hash
  references.  Each hash contain a single key/value pair where the key
  is the name of the file, and the value is the error message (including
  the contents of C<$!> when appropriate).  If a general error is
  encountered the diagnostic key will be empty.
  
  An example usage looks like:
  
    remove_tree( 'foo/bar', 'bar/rat', {error => \my $err} );
    if (@$err) {
        for my $diag (@$err) {
            my ($file, $message) = %$diag;
            if ($file eq '') {
                print "general error: $message\n";
            }
            else {
                print "problem unlinking $file: $message\n";
            }
        }
    }
    else {
        print "No error encountered\n";
    }
  
  Note that if no errors are encountered, C<$err> will reference an
  empty array.  This means that C<$err> will always end up TRUE; so you
  need to test C<@$err> to determine if errors occured.
  
  =head2 NOTES
  
  C<File::Path> blindly exports C<mkpath> and C<rmtree> into the
  current namespace. These days, this is considered bad style, but
  to change it now would break too much code. Nonetheless, you are
  invited to specify what it is you are expecting to use:
  
    use File::Path 'rmtree';
  
  The routines C<make_path> and C<remove_tree> are B<not> exported
  by default. You must specify which ones you want to use.
  
    use File::Path 'remove_tree';
  
  Note that a side-effect of the above is that C<mkpath> and C<rmtree>
  are no longer exported at all. This is due to the way the C<Exporter>
  module works. If you are migrating a codebase to use the new
  interface, you will have to list everything explicitly. But that's
  just good practice anyway.
  
    use File::Path qw(remove_tree rmtree);
  
  =head3 API CHANGES
  
  The API was changed in the 2.0 branch. For a time, C<mkpath> and
  C<rmtree> tried, unsuccessfully, to deal with the two different
  calling mechanisms. This approach was considered a failure.
  
  The new semantics are now only available with C<make_path> and
  C<remove_tree>. The old semantics are only available through
  C<mkpath> and C<rmtree>. Users are strongly encouraged to upgrade
  to at least 2.08 in order to avoid surprises.
  
  =head3 SECURITY CONSIDERATIONS
  
  There were race conditions 1.x implementations of File::Path's
  C<rmtree> function (although sometimes patched depending on the OS
  distribution or platform). The 2.0 version contains code to avoid the
  problem mentioned in CVE-2002-0435.
  
  See the following pages for more information:
  
    http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=286905
    http://www.nntp.perl.org/group/perl.perl5.porters/2005/01/msg97623.html
    http://www.debian.org/security/2005/dsa-696
  
  Additionally, unless the C<safe> parameter is set (or the
  third parameter in the traditional interface is TRUE), should a
  C<remove_tree> be interrupted, files that were originally in read-only
  mode may now have their permissions set to a read-write (or "delete
  OK") mode.
  
  =head1 DIAGNOSTICS
  
  FATAL errors will cause the program to halt (C<croak>), since the
  problem is so severe that it would be dangerous to continue. (This
  can always be trapped with C<eval>, but it's not a good idea. Under
  the circumstances, dying is the best thing to do).
  
  SEVERE errors may be trapped using the modern interface. If the
  they are not trapped, or the old interface is used, such an error
  will cause the program will halt.
  
  All other errors may be trapped using the modern interface, otherwise
  they will be C<carp>ed about. Program execution will not be halted.
  
  =over 4
  
  =item mkdir [path]: [errmsg] (SEVERE)
  
  C<make_path> was unable to create the path. Probably some sort of
  permissions error at the point of departure, or insufficient resources
  (such as free inodes on Unix).
  
  =item No root path(s) specified
  
  C<make_path> was not given any paths to create. This message is only
  emitted if the routine is called with the traditional interface.
  The modern interface will remain silent if given nothing to do.
  
  =item No such file or directory
  
  On Windows, if C<make_path> gives you this warning, it may mean that
  you have exceeded your filesystem's maximum path length.
  
  =item cannot fetch initial working directory: [errmsg]
  
  C<remove_tree> attempted to determine the initial directory by calling
  C<Cwd::getcwd>, but the call failed for some reason. No attempt
  will be made to delete anything.
  
  =item cannot stat initial working directory: [errmsg]
  
  C<remove_tree> attempted to stat the initial directory (after having
  successfully obtained its name via C<getcwd>), however, the call
  failed for some reason. No attempt will be made to delete anything.
  
  =item cannot chdir to [dir]: [errmsg]
  
  C<remove_tree> attempted to set the working directory in order to
  begin deleting the objects therein, but was unsuccessful. This is
  usually a permissions issue. The routine will continue to delete
  other things, but this directory will be left intact.
  
  =item directory [dir] changed before chdir, expected dev=[n] ino=[n], actual dev=[n] ino=[n], aborting. (FATAL)
  
  C<remove_tree> recorded the device and inode of a directory, and then
  moved into it. It then performed a C<stat> on the current directory
  and detected that the device and inode were no longer the same. As
  this is at the heart of the race condition problem, the program
  will die at this point.
  
  =item cannot make directory [dir] read+writeable: [errmsg]
  
  C<remove_tree> attempted to change the permissions on the current directory
  to ensure that subsequent unlinkings would not run into problems,
  but was unable to do so. The permissions remain as they were, and
  the program will carry on, doing the best it can.
  
  =item cannot read [dir]: [errmsg]
  
  C<remove_tree> tried to read the contents of the directory in order
  to acquire the names of the directory entries to be unlinked, but
  was unsuccessful. This is usually a permissions issue. The
  program will continue, but the files in this directory will remain
  after the call.
  
  =item cannot reset chmod [dir]: [errmsg]
  
  C<remove_tree>, after having deleted everything in a directory, attempted
  to restore its permissions to the original state but failed. The
  directory may wind up being left behind.
  
  =item cannot remove [dir] when cwd is [dir]
  
  The current working directory of the program is F</some/path/to/here>
  and you are attempting to remove an ancestor, such as F</some/path>.
  The directory tree is left untouched.
  
  The solution is to C<chdir> out of the child directory to a place
  outside the directory tree to be removed.
  
  =item cannot chdir to [parent-dir] from [child-dir]: [errmsg], aborting. (FATAL)
  
  C<remove_tree>, after having deleted everything and restored the permissions
  of a directory, was unable to chdir back to the parent. The program
  halts to avoid a race condition from occurring.
  
  =item cannot stat prior working directory [dir]: [errmsg], aborting. (FATAL)
  
  C<remove_tree> was unable to stat the parent directory after have returned
  from the child. Since there is no way of knowing if we returned to
  where we think we should be (by comparing device and inode) the only
  way out is to C<croak>.
  
  =item previous directory [parent-dir] changed before entering [child-dir], expected dev=[n] ino=[n], actual dev=[n] ino=[n], aborting. (FATAL)
  
  When C<remove_tree> returned from deleting files in a child directory, a
  check revealed that the parent directory it returned to wasn't the one
  it started out from. This is considered a sign of malicious activity.
  
  =item cannot make directory [dir] writeable: [errmsg]
  
  Just before removing a directory (after having successfully removed
  everything it contained), C<remove_tree> attempted to set the permissions
  on the directory to ensure it could be removed and failed. Program
  execution continues, but the directory may possibly not be deleted.
  
  =item cannot remove directory [dir]: [errmsg]
  
  C<remove_tree> attempted to remove a directory, but failed. This may because
  some objects that were unable to be removed remain in the directory, or
  a permissions issue. The directory will be left behind.
  
  =item cannot restore permissions of [dir] to [0nnn]: [errmsg]
  
  After having failed to remove a directory, C<remove_tree> was unable to
  restore its permissions from a permissive state back to a possibly
  more restrictive setting. (Permissions given in octal).
  
  =item cannot make file [file] writeable: [errmsg]
  
  C<remove_tree> attempted to force the permissions of a file to ensure it
  could be deleted, but failed to do so. It will, however, still attempt
  to unlink the file.
  
  =item cannot unlink file [file]: [errmsg]
  
  C<remove_tree> failed to remove a file. Probably a permissions issue.
  
  =item cannot restore permissions of [file] to [0nnn]: [errmsg]
  
  After having failed to remove a file, C<remove_tree> was also unable
  to restore the permissions on the file to a possibly less permissive
  setting. (Permissions given in octal).
  
  =item unable to map [owner] to a uid, ownership not changed");
  
  C<make_path> was instructed to give the ownership of created
  directories to the symbolic name [owner], but C<getpwnam> did
  not return the corresponding numeric uid. The directory will
  be created, but ownership will not be changed.
  
  =item unable to map [group] to a gid, group ownership not changed
  
  C<make_path> was instructed to give the group ownership of created
  directories to the symbolic name [group], but C<getgrnam> did
  not return the corresponding numeric gid. The directory will
  be created, but group ownership will not be changed.
  
  =back
  
  =head1 SEE ALSO
  
  =over 4
  
  =item *
  
  L<File::Remove>
  
  Allows files and directories to be moved to the Trashcan/Recycle
  Bin (where they may later be restored if necessary) if the operating
  system supports such functionality. This feature may one day be
  made available directly in C<File::Path>.
  
  =item *
  
  L<File::Find::Rule>
  
  When removing directory trees, if you want to examine each file to
  decide whether to delete it (and possibly leaving large swathes
  alone), F<File::Find::Rule> offers a convenient and flexible approach
  to examining directory trees.
  
  =back
  
  =head1 BUGS
  
  Please report all bugs on the RT queue:
  
  L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=File-Path>
  
  You can also send pull requests to the Github repository:
  
  L<https://github.com/dland/File-Path>
  
  =head1 ACKNOWLEDGEMENTS
  
  Paul Szabo identified the race condition originally, and Brendan
  O'Dea wrote an implementation for Debian that addressed the problem.
  That code was used as a basis for the current code. Their efforts
  are greatly appreciated.
  
  Gisle Aas made a number of improvements to the documentation for
  2.07 and his advice and assistance is also greatly appreciated.
  
  =head1 AUTHORS
  
  Tim Bunce and Charles Bailey. Currently maintained by David Landgren
  <F<david@landgren.net>>.
  
  =head1 COPYRIGHT
  
  This module is copyright (C) Charles Bailey, Tim Bunce and
  David Landgren 1995-2013. All rights reserved.
  
  =head1 LICENSE
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself.
  
  =cut
FILE_PATH

$fatpacked{"File/Temp.pm"} = <<'FILE_TEMP';
  package File::Temp;
  # ABSTRACT: return name and handle of a temporary file safely
  our $VERSION = '0.2304'; # VERSION
  
  
  # Toolchain targets v5.8.1, but we'll try to support back to v5.6 anyway.
  # It might be possible to make this v5.5, but many v5.6isms are creeping
  # into the code and tests.
  use 5.006;
  use strict;
  use Carp;
  use File::Spec 0.8;
  use Cwd ();
  use File::Path 2.06 qw/ rmtree /;
  use Fcntl 1.03;
  use IO::Seekable;               # For SEEK_*
  use Errno;
  use Scalar::Util 'refaddr';
  require VMS::Stdio if $^O eq 'VMS';
  
  # pre-emptively load Carp::Heavy. If we don't when we run out of file
  # handles and attempt to call croak() we get an error message telling
  # us that Carp::Heavy won't load rather than an error telling us we
  # have run out of file handles. We either preload croak() or we
  # switch the calls to croak from _gettemp() to use die.
  eval { require Carp::Heavy; };
  
  # Need the Symbol package if we are running older perl
  require Symbol if $] < 5.006;
  
  ### For the OO interface
  use parent 0.221 qw/ IO::Handle IO::Seekable /;
  use overload '""' => "STRINGIFY", '0+' => "NUMIFY",
    fallback => 1;
  
  # use 'our' on v5.6.0
  use vars qw(@EXPORT_OK %EXPORT_TAGS $DEBUG $KEEP_ALL);
  
  $DEBUG = 0;
  $KEEP_ALL = 0;
  
  # We are exporting functions
  
  use Exporter 5.57 'import';   # 5.57 lets us import 'import'
  
  # Export list - to allow fine tuning of export table
  
  @EXPORT_OK = qw{
                   tempfile
                   tempdir
                   tmpnam
                   tmpfile
                   mktemp
                   mkstemp
                   mkstemps
                   mkdtemp
                   unlink0
                   cleanup
                   SEEK_SET
                   SEEK_CUR
                   SEEK_END
               };
  
  # Groups of functions for export
  
  %EXPORT_TAGS = (
                  'POSIX' => [qw/ tmpnam tmpfile /],
                  'mktemp' => [qw/ mktemp mkstemp mkstemps mkdtemp/],
                  'seekable' => [qw/ SEEK_SET SEEK_CUR SEEK_END /],
                 );
  
  # add contents of these tags to @EXPORT
  Exporter::export_tags('POSIX','mktemp','seekable');
  
  # This is a list of characters that can be used in random filenames
  
  my @CHARS = (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
                   0 1 2 3 4 5 6 7 8 9 _
                 /);
  
  # Maximum number of tries to make a temp file before failing
  
  use constant MAX_TRIES => 1000;
  
  # Minimum number of X characters that should be in a template
  use constant MINX => 4;
  
  # Default template when no template supplied
  
  use constant TEMPXXX => 'X' x 10;
  
  # Constants for the security level
  
  use constant STANDARD => 0;
  use constant MEDIUM   => 1;
  use constant HIGH     => 2;
  
  # OPENFLAGS. If we defined the flag to use with Sysopen here this gives
  # us an optimisation when many temporary files are requested
  
  my $OPENFLAGS = O_CREAT | O_EXCL | O_RDWR;
  my $LOCKFLAG;
  
  unless ($^O eq 'MacOS') {
    for my $oflag (qw/ NOFOLLOW BINARY LARGEFILE NOINHERIT /) {
      my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
      no strict 'refs';
      $OPENFLAGS |= $bit if eval {
        # Make sure that redefined die handlers do not cause problems
        # e.g. CGI::Carp
        local $SIG{__DIE__} = sub {};
        local $SIG{__WARN__} = sub {};
        $bit = &$func();
        1;
      };
    }
    # Special case O_EXLOCK
    $LOCKFLAG = eval {
      local $SIG{__DIE__} = sub {};
      local $SIG{__WARN__} = sub {};
      &Fcntl::O_EXLOCK();
    };
  }
  
  # On some systems the O_TEMPORARY flag can be used to tell the OS
  # to automatically remove the file when it is closed. This is fine
  # in most cases but not if tempfile is called with UNLINK=>0 and
  # the filename is requested -- in the case where the filename is to
  # be passed to another routine. This happens on windows. We overcome
  # this by using a second open flags variable
  
  my $OPENTEMPFLAGS = $OPENFLAGS;
  unless ($^O eq 'MacOS') {
    for my $oflag (qw/ TEMPORARY /) {
      my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
      local($@);
      no strict 'refs';
      $OPENTEMPFLAGS |= $bit if eval {
        # Make sure that redefined die handlers do not cause problems
        # e.g. CGI::Carp
        local $SIG{__DIE__} = sub {};
        local $SIG{__WARN__} = sub {};
        $bit = &$func();
        1;
      };
    }
  }
  
  # Private hash tracking which files have been created by each process id via the OO interface
  my %FILES_CREATED_BY_OBJECT;
  
  # INTERNAL ROUTINES - not to be used outside of package
  
  # Generic routine for getting a temporary filename
  # modelled on OpenBSD _gettemp() in mktemp.c
  
  # The template must contain X's that are to be replaced
  # with the random values
  
  #  Arguments:
  
  #  TEMPLATE   - string containing the XXXXX's that is converted
  #           to a random filename and opened if required
  
  # Optionally, a hash can also be supplied containing specific options
  #   "open" => if true open the temp file, else just return the name
  #             default is 0
  #   "mkdir"=> if true, we are creating a temp directory rather than tempfile
  #             default is 0
  #   "suffixlen" => number of characters at end of PATH to be ignored.
  #                  default is 0.
  #   "unlink_on_close" => indicates that, if possible,  the OS should remove
  #                        the file as soon as it is closed. Usually indicates
  #                        use of the O_TEMPORARY flag to sysopen.
  #                        Usually irrelevant on unix
  #   "use_exlock" => Indicates that O_EXLOCK should be used. Default is true.
  
  # Optionally a reference to a scalar can be passed into the function
  # On error this will be used to store the reason for the error
  #   "ErrStr"  => \$errstr
  
  # "open" and "mkdir" can not both be true
  # "unlink_on_close" is not used when "mkdir" is true.
  
  # The default options are equivalent to mktemp().
  
  # Returns:
  #   filehandle - open file handle (if called with doopen=1, else undef)
  #   temp name  - name of the temp file or directory
  
  # For example:
  #   ($fh, $name) = _gettemp($template, "open" => 1);
  
  # for the current version, failures are associated with
  # stored in an error string and returned to give the reason whilst debugging
  # This routine is not called by any external function
  sub _gettemp {
  
    croak 'Usage: ($fh, $name) = _gettemp($template, OPTIONS);'
      unless scalar(@_) >= 1;
  
    # the internal error string - expect it to be overridden
    # Need this in case the caller decides not to supply us a value
    # need an anonymous scalar
    my $tempErrStr;
  
    # Default options
    my %options = (
                   "open" => 0,
                   "mkdir" => 0,
                   "suffixlen" => 0,
                   "unlink_on_close" => 0,
                   "use_exlock" => 1,
                   "ErrStr" => \$tempErrStr,
                  );
  
    # Read the template
    my $template = shift;
    if (ref($template)) {
      # Use a warning here since we have not yet merged ErrStr
      carp "File::Temp::_gettemp: template must not be a reference";
      return ();
    }
  
    # Check that the number of entries on stack are even
    if (scalar(@_) % 2 != 0) {
      # Use a warning here since we have not yet merged ErrStr
      carp "File::Temp::_gettemp: Must have even number of options";
      return ();
    }
  
    # Read the options and merge with defaults
    %options = (%options, @_)  if @_;
  
    # Make sure the error string is set to undef
    ${$options{ErrStr}} = undef;
  
    # Can not open the file and make a directory in a single call
    if ($options{"open"} && $options{"mkdir"}) {
      ${$options{ErrStr}} = "doopen and domkdir can not both be true\n";
      return ();
    }
  
    # Find the start of the end of the  Xs (position of last X)
    # Substr starts from 0
    my $start = length($template) - 1 - $options{"suffixlen"};
  
    # Check that we have at least MINX x X (e.g. 'XXXX") at the end of the string
    # (taking suffixlen into account). Any fewer is insecure.
  
    # Do it using substr - no reason to use a pattern match since
    # we know where we are looking and what we are looking for
  
    if (substr($template, $start - MINX + 1, MINX) ne 'X' x MINX) {
      ${$options{ErrStr}} = "The template must end with at least ".
        MINX . " 'X' characters\n";
      return ();
    }
  
    # Replace all the X at the end of the substring with a
    # random character or just all the XX at the end of a full string.
    # Do it as an if, since the suffix adjusts which section to replace
    # and suffixlen=0 returns nothing if used in the substr directly
    # and generate a full path from the template
  
    my $path = _replace_XX($template, $options{"suffixlen"});
  
  
    # Split the path into constituent parts - eventually we need to check
    # whether the directory exists
    # We need to know whether we are making a temp directory
    # or a tempfile
  
    my ($volume, $directories, $file);
    my $parent;                   # parent directory
    if ($options{"mkdir"}) {
      # There is no filename at the end
      ($volume, $directories, $file) = File::Spec->splitpath( $path, 1);
  
      # The parent is then $directories without the last directory
      # Split the directory and put it back together again
      my @dirs = File::Spec->splitdir($directories);
  
      # If @dirs only has one entry (i.e. the directory template) that means
      # we are in the current directory
      if ($#dirs == 0) {
        $parent = File::Spec->curdir;
      } else {
  
        if ($^O eq 'VMS') {     # need volume to avoid relative dir spec
          $parent = File::Spec->catdir($volume, @dirs[0..$#dirs-1]);
          $parent = 'sys$disk:[]' if $parent eq '';
        } else {
  
          # Put it back together without the last one
          $parent = File::Spec->catdir(@dirs[0..$#dirs-1]);
  
          # ...and attach the volume (no filename)
          $parent = File::Spec->catpath($volume, $parent, '');
        }
  
      }
  
    } else {
  
      # Get rid of the last filename (use File::Basename for this?)
      ($volume, $directories, $file) = File::Spec->splitpath( $path );
  
      # Join up without the file part
      $parent = File::Spec->catpath($volume,$directories,'');
  
      # If $parent is empty replace with curdir
      $parent = File::Spec->curdir
        unless $directories ne '';
  
    }
  
    # Check that the parent directories exist
    # Do this even for the case where we are simply returning a name
    # not a file -- no point returning a name that includes a directory
    # that does not exist or is not writable
  
    unless (-e $parent) {
      ${$options{ErrStr}} = "Parent directory ($parent) does not exist";
      return ();
    }
    unless (-d $parent) {
      ${$options{ErrStr}} = "Parent directory ($parent) is not a directory";
      return ();
    }
  
    # Check the stickiness of the directory and chown giveaway if required
    # If the directory is world writable the sticky bit
    # must be set
  
    if (File::Temp->safe_level == MEDIUM) {
      my $safeerr;
      unless (_is_safe($parent,\$safeerr)) {
        ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)";
        return ();
      }
    } elsif (File::Temp->safe_level == HIGH) {
      my $safeerr;
      unless (_is_verysafe($parent, \$safeerr)) {
        ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)";
        return ();
      }
    }
  
  
    # Now try MAX_TRIES time to open the file
    for (my $i = 0; $i < MAX_TRIES; $i++) {
  
      # Try to open the file if requested
      if ($options{"open"}) {
        my $fh;
  
        # If we are running before perl5.6.0 we can not auto-vivify
        if ($] < 5.006) {
          $fh = &Symbol::gensym;
        }
  
        # Try to make sure this will be marked close-on-exec
        # XXX: Win32 doesn't respect this, nor the proper fcntl,
        #      but may have O_NOINHERIT. This may or may not be in Fcntl.
        local $^F = 2;
  
        # Attempt to open the file
        my $open_success = undef;
        if ( $^O eq 'VMS' and $options{"unlink_on_close"} && !$KEEP_ALL) {
          # make it auto delete on close by setting FAB$V_DLT bit
          $fh = VMS::Stdio::vmssysopen($path, $OPENFLAGS, 0600, 'fop=dlt');
          $open_success = $fh;
        } else {
          my $flags = ( ($options{"unlink_on_close"} && !$KEEP_ALL) ?
                        $OPENTEMPFLAGS :
                        $OPENFLAGS );
          $flags |= $LOCKFLAG if (defined $LOCKFLAG && $options{use_exlock});
          $open_success = sysopen($fh, $path, $flags, 0600);
        }
        if ( $open_success ) {
  
          # in case of odd umask force rw
          chmod(0600, $path);
  
          # Opened successfully - return file handle and name
          return ($fh, $path);
  
        } else {
  
          # Error opening file - abort with error
          # if the reason was anything but EEXIST
          unless ($!{EEXIST}) {
            ${$options{ErrStr}} = "Could not create temp file $path: $!";
            return ();
          }
  
          # Loop round for another try
  
        }
      } elsif ($options{"mkdir"}) {
  
        # Open the temp directory
        if (mkdir( $path, 0700)) {
          # in case of odd umask
          chmod(0700, $path);
  
          return undef, $path;
        } else {
  
          # Abort with error if the reason for failure was anything
          # except EEXIST
          unless ($!{EEXIST}) {
            ${$options{ErrStr}} = "Could not create directory $path: $!";
            return ();
          }
  
          # Loop round for another try
  
        }
  
      } else {
  
        # Return true if the file can not be found
        # Directory has been checked previously
  
        return (undef, $path) unless -e $path;
  
        # Try again until MAX_TRIES
  
      }
  
      # Did not successfully open the tempfile/dir
      # so try again with a different set of random letters
      # No point in trying to increment unless we have only
      # 1 X say and the randomness could come up with the same
      # file MAX_TRIES in a row.
  
      # Store current attempt - in principal this implies that the
      # 3rd time around the open attempt that the first temp file
      # name could be generated again. Probably should store each
      # attempt and make sure that none are repeated
  
      my $original = $path;
      my $counter = 0;            # Stop infinite loop
      my $MAX_GUESS = 50;
  
      do {
  
        # Generate new name from original template
        $path = _replace_XX($template, $options{"suffixlen"});
  
        $counter++;
  
      } until ($path ne $original || $counter > $MAX_GUESS);
  
      # Check for out of control looping
      if ($counter > $MAX_GUESS) {
        ${$options{ErrStr}} = "Tried to get a new temp name different to the previous value $MAX_GUESS times.\nSomething wrong with template?? ($template)";
        return ();
      }
  
    }
  
    # If we get here, we have run out of tries
    ${ $options{ErrStr} } = "Have exceeded the maximum number of attempts ("
      . MAX_TRIES . ") to open temp file/dir";
  
    return ();
  
  }
  
  # Internal routine to replace the XXXX... with random characters
  # This has to be done by _gettemp() every time it fails to
  # open a temp file/dir
  
  # Arguments:  $template (the template with XXX),
  #             $ignore   (number of characters at end to ignore)
  
  # Returns:    modified template
  
  sub _replace_XX {
  
    croak 'Usage: _replace_XX($template, $ignore)'
      unless scalar(@_) == 2;
  
    my ($path, $ignore) = @_;
  
    # Do it as an if, since the suffix adjusts which section to replace
    # and suffixlen=0 returns nothing if used in the substr directly
    # Alternatively, could simply set $ignore to length($path)-1
    # Don't want to always use substr when not required though.
    my $end = ( $] >= 5.006 ? "\\z" : "\\Z" );
  
    if ($ignore) {
      substr($path, 0, - $ignore) =~ s/X(?=X*$end)/$CHARS[ int( rand( @CHARS ) ) ]/ge;
    } else {
      $path =~ s/X(?=X*$end)/$CHARS[ int( rand( @CHARS ) ) ]/ge;
    }
    return $path;
  }
  
  # Internal routine to force a temp file to be writable after
  # it is created so that we can unlink it. Windows seems to occasionally
  # force a file to be readonly when written to certain temp locations
  sub _force_writable {
    my $file = shift;
    chmod 0600, $file;
  }
  
  
  # internal routine to check to see if the directory is safe
  # First checks to see if the directory is not owned by the
  # current user or root. Then checks to see if anyone else
  # can write to the directory and if so, checks to see if
  # it has the sticky bit set
  
  # Will not work on systems that do not support sticky bit
  
  #Args:  directory path to check
  #       Optionally: reference to scalar to contain error message
  # Returns true if the path is safe and false otherwise.
  # Returns undef if can not even run stat() on the path
  
  # This routine based on version written by Tom Christiansen
  
  # Presumably, by the time we actually attempt to create the
  # file or directory in this directory, it may not be safe
  # anymore... Have to run _is_safe directly after the open.
  
  sub _is_safe {
  
    my $path = shift;
    my $err_ref = shift;
  
    # Stat path
    my @info = stat($path);
    unless (scalar(@info)) {
      $$err_ref = "stat(path) returned no values";
      return 0;
    }
    ;
    return 1 if $^O eq 'VMS';     # owner delete control at file level
  
    # Check to see whether owner is neither superuser (or a system uid) nor me
    # Use the effective uid from the $> variable
    # UID is in [4]
    if ($info[4] > File::Temp->top_system_uid() && $info[4] != $>) {
  
      Carp::cluck(sprintf "uid=$info[4] topuid=%s euid=$> path='$path'",
                  File::Temp->top_system_uid());
  
      $$err_ref = "Directory owned neither by root nor the current user"
        if ref($err_ref);
      return 0;
    }
  
    # check whether group or other can write file
    # use 066 to detect either reading or writing
    # use 022 to check writability
    # Do it with S_IWOTH and S_IWGRP for portability (maybe)
    # mode is in info[2]
    if (($info[2] & &Fcntl::S_IWGRP) ||  # Is group writable?
        ($info[2] & &Fcntl::S_IWOTH) ) { # Is world writable?
      # Must be a directory
      unless (-d $path) {
        $$err_ref = "Path ($path) is not a directory"
          if ref($err_ref);
        return 0;
      }
      # Must have sticky bit set
      unless (-k $path) {
        $$err_ref = "Sticky bit not set on $path when dir is group|world writable"
          if ref($err_ref);
        return 0;
      }
    }
  
    return 1;
  }
  
  # Internal routine to check whether a directory is safe
  # for temp files. Safer than _is_safe since it checks for
  # the possibility of chown giveaway and if that is a possibility
  # checks each directory in the path to see if it is safe (with _is_safe)
  
  # If _PC_CHOWN_RESTRICTED is not set, does the full test of each
  # directory anyway.
  
  # Takes optional second arg as scalar ref to error reason
  
  sub _is_verysafe {
  
    # Need POSIX - but only want to bother if really necessary due to overhead
    require POSIX;
  
    my $path = shift;
    print "_is_verysafe testing $path\n" if $DEBUG;
    return 1 if $^O eq 'VMS';     # owner delete control at file level
  
    my $err_ref = shift;
  
    # Should Get the value of _PC_CHOWN_RESTRICTED if it is defined
    # and If it is not there do the extensive test
    local($@);
    my $chown_restricted;
    $chown_restricted = &POSIX::_PC_CHOWN_RESTRICTED()
      if eval { &POSIX::_PC_CHOWN_RESTRICTED(); 1};
  
    # If chown_resticted is set to some value we should test it
    if (defined $chown_restricted) {
  
      # Return if the current directory is safe
      return _is_safe($path,$err_ref) if POSIX::sysconf( $chown_restricted );
  
    }
  
    # To reach this point either, the _PC_CHOWN_RESTRICTED symbol
    # was not available or the symbol was there but chown giveaway
    # is allowed. Either way, we now have to test the entire tree for
    # safety.
  
    # Convert path to an absolute directory if required
    unless (File::Spec->file_name_is_absolute($path)) {
      $path = File::Spec->rel2abs($path);
    }
  
    # Split directory into components - assume no file
    my ($volume, $directories, undef) = File::Spec->splitpath( $path, 1);
  
    # Slightly less efficient than having a function in File::Spec
    # to chop off the end of a directory or even a function that
    # can handle ../ in a directory tree
    # Sometimes splitdir() returns a blank at the end
    # so we will probably check the bottom directory twice in some cases
    my @dirs = File::Spec->splitdir($directories);
  
    # Concatenate one less directory each time around
    foreach my $pos (0.. $#dirs) {
      # Get a directory name
      my $dir = File::Spec->catpath($volume,
                                    File::Spec->catdir(@dirs[0.. $#dirs - $pos]),
                                    ''
                                   );
  
      print "TESTING DIR $dir\n" if $DEBUG;
  
      # Check the directory
      return 0 unless _is_safe($dir,$err_ref);
  
    }
  
    return 1;
  }
  
  
  
  # internal routine to determine whether unlink works on this
  # platform for files that are currently open.
  # Returns true if we can, false otherwise.
  
  # Currently WinNT, OS/2 and VMS can not unlink an opened file
  # On VMS this is because the O_EXCL flag is used to open the
  # temporary file. Currently I do not know enough about the issues
  # on VMS to decide whether O_EXCL is a requirement.
  
  sub _can_unlink_opened_file {
  
    if (grep { $^O eq $_ } qw/MSWin32 os2 VMS dos MacOS haiku/) {
      return 0;
    } else {
      return 1;
    }
  
  }
  
  # internal routine to decide which security levels are allowed
  # see safe_level() for more information on this
  
  # Controls whether the supplied security level is allowed
  
  #   $cando = _can_do_level( $level )
  
  sub _can_do_level {
  
    # Get security level
    my $level = shift;
  
    # Always have to be able to do STANDARD
    return 1 if $level == STANDARD;
  
    # Currently, the systems that can do HIGH or MEDIUM are identical
    if ( $^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'cygwin' || $^O eq 'dos' || $^O eq 'MacOS' || $^O eq 'mpeix') {
      return 0;
    } else {
      return 1;
    }
  
  }
  
  # This routine sets up a deferred unlinking of a specified
  # filename and filehandle. It is used in the following cases:
  #  - Called by unlink0 if an opened file can not be unlinked
  #  - Called by tempfile() if files are to be removed on shutdown
  #  - Called by tempdir() if directories are to be removed on shutdown
  
  # Arguments:
  #   _deferred_unlink( $fh, $fname, $isdir );
  #
  #   - filehandle (so that it can be explicitly closed if open
  #   - filename   (the thing we want to remove)
  #   - isdir      (flag to indicate that we are being given a directory)
  #                 [and hence no filehandle]
  
  # Status is not referred to since all the magic is done with an END block
  
  {
    # Will set up two lexical variables to contain all the files to be
    # removed. One array for files, another for directories They will
    # only exist in this block.
  
    #  This means we only have to set up a single END block to remove
    #  all files. 
  
    # in order to prevent child processes inadvertently deleting the parent
    # temp files we use a hash to store the temp files and directories
    # created by a particular process id.
  
    # %files_to_unlink contains values that are references to an array of
    # array references containing the filehandle and filename associated with
    # the temp file.
    my (%files_to_unlink, %dirs_to_unlink);
  
    # Set up an end block to use these arrays
    END {
      local($., $@, $!, $^E, $?);
      cleanup(at_exit => 1);
    }
  
    # Cleanup function. Always triggered on END (with at_exit => 1) but
    # can be invoked manually.
    sub cleanup {
      my %h = @_;
      my $at_exit = delete $h{at_exit};
      $at_exit = 0 if not defined $at_exit;
      { my @k = sort keys %h; die "unrecognized parameters: @k" if @k }
  
      if (!$KEEP_ALL) {
        # Files
        my @files = (exists $files_to_unlink{$$} ?
                     @{ $files_to_unlink{$$} } : () );
        foreach my $file (@files) {
          # close the filehandle without checking its state
          # in order to make real sure that this is closed
          # if its already closed then I don't care about the answer
          # probably a better way to do this
          close($file->[0]);      # file handle is [0]
  
          if (-f $file->[1]) {       # file name is [1]
            _force_writable( $file->[1] ); # for windows
            unlink $file->[1] or warn "Error removing ".$file->[1];
          }
        }
        # Dirs
        my @dirs = (exists $dirs_to_unlink{$$} ?
                    @{ $dirs_to_unlink{$$} } : () );
        my ($cwd, $cwd_to_remove);
        foreach my $dir (@dirs) {
          if (-d $dir) {
            # Some versions of rmtree will abort if you attempt to remove
            # the directory you are sitting in. For automatic cleanup
            # at program exit, we avoid this by chdir()ing out of the way
            # first. If not at program exit, it's best not to mess with the
            # current directory, so just let it fail with a warning.
            if ($at_exit) {
              $cwd = Cwd::abs_path(File::Spec->curdir) if not defined $cwd;
              my $abs = Cwd::abs_path($dir);
              if ($abs eq $cwd) {
                $cwd_to_remove = $dir;
                next;
              }
            }
            eval { rmtree($dir, $DEBUG, 0); };
            warn $@ if ($@ && $^W);
          }
        }
  
        if (defined $cwd_to_remove) {
          # We do need to clean up the current directory, and everything
          # else is done, so get out of there and remove it.
          chdir $cwd_to_remove or die "cannot chdir to $cwd_to_remove: $!";
          my $updir = File::Spec->updir;
          chdir $updir or die "cannot chdir to $updir: $!";
          eval { rmtree($cwd_to_remove, $DEBUG, 0); };
          warn $@ if ($@ && $^W);
        }
  
        # clear the arrays
        @{ $files_to_unlink{$$} } = ()
          if exists $files_to_unlink{$$};
        @{ $dirs_to_unlink{$$} } = ()
          if exists $dirs_to_unlink{$$};
      }
    }
  
  
    # This is the sub called to register a file for deferred unlinking
    # This could simply store the input parameters and defer everything
    # until the END block. For now we do a bit of checking at this
    # point in order to make sure that (1) we have a file/dir to delete
    # and (2) we have been called with the correct arguments.
    sub _deferred_unlink {
  
      croak 'Usage:  _deferred_unlink($fh, $fname, $isdir)'
        unless scalar(@_) == 3;
  
      my ($fh, $fname, $isdir) = @_;
  
      warn "Setting up deferred removal of $fname\n"
        if $DEBUG;
  
      # make sure we save the absolute path for later cleanup
      # OK to untaint because we only ever use this internally
      # as a file path, never interpolating into the shell
      $fname = Cwd::abs_path($fname);
      ($fname) = $fname =~ /^(.*)$/;
  
      # If we have a directory, check that it is a directory
      if ($isdir) {
  
        if (-d $fname) {
  
          # Directory exists so store it
          # first on VMS turn []foo into [.foo] for rmtree
          $fname = VMS::Filespec::vmspath($fname) if $^O eq 'VMS';
          $dirs_to_unlink{$$} = [] 
            unless exists $dirs_to_unlink{$$};
          push (@{ $dirs_to_unlink{$$} }, $fname);
  
        } else {
          carp "Request to remove directory $fname could not be completed since it does not exist!\n" if $^W;
        }
  
      } else {
  
        if (-f $fname) {
  
          # file exists so store handle and name for later removal
          $files_to_unlink{$$} = []
            unless exists $files_to_unlink{$$};
          push(@{ $files_to_unlink{$$} }, [$fh, $fname]);
  
        } else {
          carp "Request to remove file $fname could not be completed since it is not there!\n" if $^W;
        }
  
      }
  
    }
  
  
  }
  
  # normalize argument keys to upper case and do consistent handling
  # of leading template vs TEMPLATE
  sub _parse_args {
    my $leading_template = (scalar(@_) % 2 == 1 ? shift(@_) : '' );
    my %args = @_;
    %args = map { uc($_), $args{$_} } keys %args;
  
    # template (store it in an array so that it will
    # disappear from the arg list of tempfile)
    my @template = (
      exists $args{TEMPLATE}  ? $args{TEMPLATE} :
      $leading_template       ? $leading_template : ()
    );
    delete $args{TEMPLATE};
  
    return( \@template, \%args );
  }
  
  
  sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
  
    my ($maybe_template, $args) = _parse_args(@_);
  
    # see if they are unlinking (defaulting to yes)
    my $unlink = (exists $args->{UNLINK} ? $args->{UNLINK} : 1 );
    delete $args->{UNLINK};
  
    # Protect OPEN
    delete $args->{OPEN};
  
    # Open the file and retain file handle and file name
    my ($fh, $path) = tempfile( @$maybe_template, %$args );
  
    print "Tmp: $fh - $path\n" if $DEBUG;
  
    # Store the filename in the scalar slot
    ${*$fh} = $path;
  
    # Cache the filename by pid so that the destructor can decide whether to remove it
    $FILES_CREATED_BY_OBJECT{$$}{$path} = 1;
  
    # Store unlink information in hash slot (plus other constructor info)
    %{*$fh} = %$args;
  
    # create the object
    bless $fh, $class;
  
    # final method-based configuration
    $fh->unlink_on_destroy( $unlink );
  
    return $fh;
  }
  
  
  sub newdir {
    my $self = shift;
  
    my ($maybe_template, $args) = _parse_args(@_);
  
    # handle CLEANUP without passing CLEANUP to tempdir
    my $cleanup = (exists $args->{CLEANUP} ? $args->{CLEANUP} : 1 );
    delete $args->{CLEANUP};
  
    my $tempdir = tempdir( @$maybe_template, %$args);
  
    # get a safe absolute path for cleanup, just like
    # happens in _deferred_unlink
    my $real_dir = Cwd::abs_path( $tempdir );
    ($real_dir) = $real_dir =~ /^(.*)$/;
  
    return bless { DIRNAME => $tempdir,
                   REALNAME => $real_dir,
                   CLEANUP => $cleanup,
                   LAUNCHPID => $$,
                 }, "File::Temp::Dir";
  }
  
  
  sub filename {
    my $self = shift;
    return ${*$self};
  }
  
  sub STRINGIFY {
    my $self = shift;
    return $self->filename;
  }
  
  # For reference, can't use '0+'=>\&Scalar::Util::refaddr directly because
  # refaddr() demands one parameter only, whereas overload.pm calls with three
  # even for unary operations like '0+'.
  sub NUMIFY {
    return refaddr($_[0]);
  }
  
  
  sub unlink_on_destroy {
    my $self = shift;
    if (@_) {
      ${*$self}{UNLINK} = shift;
    }
    return ${*$self}{UNLINK};
  }
  
  
  sub DESTROY {
    local($., $@, $!, $^E, $?);
    my $self = shift;
  
    # Make sure we always remove the file from the global hash
    # on destruction. This prevents the hash from growing uncontrollably
    # and post-destruction there is no reason to know about the file.
    my $file = $self->filename;
    my $was_created_by_proc;
    if (exists $FILES_CREATED_BY_OBJECT{$$}{$file}) {
      $was_created_by_proc = 1;
      delete $FILES_CREATED_BY_OBJECT{$$}{$file};
    }
  
    if (${*$self}{UNLINK} && !$KEEP_ALL) {
      print "# --------->   Unlinking $self\n" if $DEBUG;
  
      # only delete if this process created it
      return unless $was_created_by_proc;
  
      # The unlink1 may fail if the file has been closed
      # by the caller. This leaves us with the decision
      # of whether to refuse to remove the file or simply
      # do an unlink without test. Seems to be silly
      # to do this when we are trying to be careful
      # about security
      _force_writable( $file ); # for windows
      unlink1( $self, $file )
        or unlink($file);
    }
  }
  
  
  sub tempfile {
    if ( @_ && $_[0] eq 'File::Temp' ) {
        croak "'tempfile' can't be called as a method";
    }
    # Can not check for argument count since we can have any
    # number of args
  
    # Default options
    my %options = (
                   "DIR"    => undef, # Directory prefix
                   "SUFFIX" => '',    # Template suffix
                   "UNLINK" => 0,     # Do not unlink file on exit
                   "OPEN"   => 1,     # Open file
                   "TMPDIR" => 0, # Place tempfile in tempdir if template specified
                   "EXLOCK" => 1, # Open file with O_EXLOCK
                  );
  
    # Check to see whether we have an odd or even number of arguments
    my ($maybe_template, $args) = _parse_args(@_);
    my $template = @$maybe_template ? $maybe_template->[0] : undef;
  
    # Read the options and merge with defaults
    %options = (%options, %$args);
  
    # First decision is whether or not to open the file
    if (! $options{"OPEN"}) {
  
      warn "tempfile(): temporary filename requested but not opened.\nPossibly unsafe, consider using tempfile() with OPEN set to true\n"
        if $^W;
  
    }
  
    if ($options{"DIR"} and $^O eq 'VMS') {
  
      # on VMS turn []foo into [.foo] for concatenation
      $options{"DIR"} = VMS::Filespec::vmspath($options{"DIR"});
    }
  
    # Construct the template
  
    # Have a choice of trying to work around the mkstemp/mktemp/tmpnam etc
    # functions or simply constructing a template and using _gettemp()
    # explicitly. Go for the latter
  
    # First generate a template if not defined and prefix the directory
    # If no template must prefix the temp directory
    if (defined $template) {
      # End up with current directory if neither DIR not TMPDIR are set
      if ($options{"DIR"}) {
  
        $template = File::Spec->catfile($options{"DIR"}, $template);
  
      } elsif ($options{TMPDIR}) {
  
        $template = File::Spec->catfile(File::Spec->tmpdir, $template );
  
      }
  
    } else {
  
      if ($options{"DIR"}) {
  
        $template = File::Spec->catfile($options{"DIR"}, TEMPXXX);
  
      } else {
  
        $template = File::Spec->catfile(File::Spec->tmpdir, TEMPXXX);
  
      }
  
    }
  
    # Now add a suffix
    $template .= $options{"SUFFIX"};
  
    # Determine whether we should tell _gettemp to unlink the file
    # On unix this is irrelevant and can be worked out after the file is
    # opened (simply by unlinking the open filehandle). On Windows or VMS
    # we have to indicate temporary-ness when we open the file. In general
    # we only want a true temporary file if we are returning just the
    # filehandle - if the user wants the filename they probably do not
    # want the file to disappear as soon as they close it (which may be
    # important if they want a child process to use the file)
    # For this reason, tie unlink_on_close to the return context regardless
    # of OS.
    my $unlink_on_close = ( wantarray ? 0 : 1);
  
    # Create the file
    my ($fh, $path, $errstr);
    croak "Error in tempfile() using template $template: $errstr"
      unless (($fh, $path) = _gettemp($template,
                                      "open" => $options{'OPEN'},
                                      "mkdir"=> 0 ,
                                      "unlink_on_close" => $unlink_on_close,
                                      "suffixlen" => length($options{'SUFFIX'}),
                                      "ErrStr" => \$errstr,
                                      "use_exlock" => $options{EXLOCK},
                                     ) );
  
    # Set up an exit handler that can do whatever is right for the
    # system. This removes files at exit when requested explicitly or when
    # system is asked to unlink_on_close but is unable to do so because
    # of OS limitations.
    # The latter should be achieved by using a tied filehandle.
    # Do not check return status since this is all done with END blocks.
    _deferred_unlink($fh, $path, 0) if $options{"UNLINK"};
  
    # Return
    if (wantarray()) {
  
      if ($options{'OPEN'}) {
        return ($fh, $path);
      } else {
        return (undef, $path);
      }
  
    } else {
  
      # Unlink the file. It is up to unlink0 to decide what to do with
      # this (whether to unlink now or to defer until later)
      unlink0($fh, $path) or croak "Error unlinking file $path using unlink0";
  
      # Return just the filehandle.
      return $fh;
    }
  
  
  }
  
  
  # '
  
  sub tempdir  {
    if ( @_ && $_[0] eq 'File::Temp' ) {
        croak "'tempdir' can't be called as a method";
    }
  
    # Can not check for argument count since we can have any
    # number of args
  
    # Default options
    my %options = (
                   "CLEANUP"    => 0, # Remove directory on exit
                   "DIR"        => '', # Root directory
                   "TMPDIR"     => 0,  # Use tempdir with template
                  );
  
    # Check to see whether we have an odd or even number of arguments
    my ($maybe_template, $args) = _parse_args(@_);
    my $template = @$maybe_template ? $maybe_template->[0] : undef;
  
    # Read the options and merge with defaults
    %options = (%options, %$args);
  
    # Modify or generate the template
  
    # Deal with the DIR and TMPDIR options
    if (defined $template) {
  
      # Need to strip directory path if using DIR or TMPDIR
      if ($options{'TMPDIR'} || $options{'DIR'}) {
  
        # Strip parent directory from the filename
        #
        # There is no filename at the end
        $template = VMS::Filespec::vmspath($template) if $^O eq 'VMS';
        my ($volume, $directories, undef) = File::Spec->splitpath( $template, 1);
  
        # Last directory is then our template
        $template = (File::Spec->splitdir($directories))[-1];
  
        # Prepend the supplied directory or temp dir
        if ($options{"DIR"}) {
  
          $template = File::Spec->catdir($options{"DIR"}, $template);
  
        } elsif ($options{TMPDIR}) {
  
          # Prepend tmpdir
          $template = File::Spec->catdir(File::Spec->tmpdir, $template);
  
        }
  
      }
  
    } else {
  
      if ($options{"DIR"}) {
  
        $template = File::Spec->catdir($options{"DIR"}, TEMPXXX);
  
      } else {
  
        $template = File::Spec->catdir(File::Spec->tmpdir, TEMPXXX);
  
      }
  
    }
  
    # Create the directory
    my $tempdir;
    my $suffixlen = 0;
    if ($^O eq 'VMS') {           # dir names can end in delimiters
      $template =~ m/([\.\]:>]+)$/;
      $suffixlen = length($1);
    }
    if ( ($^O eq 'MacOS') && (substr($template, -1) eq ':') ) {
      # dir name has a trailing ':'
      ++$suffixlen;
    }
  
    my $errstr;
    croak "Error in tempdir() using $template: $errstr"
      unless ((undef, $tempdir) = _gettemp($template,
                                           "open" => 0,
                                           "mkdir"=> 1 ,
                                           "suffixlen" => $suffixlen,
                                           "ErrStr" => \$errstr,
                                          ) );
  
    # Install exit handler; must be dynamic to get lexical
    if ( $options{'CLEANUP'} && -d $tempdir) {
      _deferred_unlink(undef, $tempdir, 1);
    }
  
    # Return the dir name
    return $tempdir;
  
  }
  
  
  
  
  sub mkstemp {
  
    croak "Usage: mkstemp(template)"
      if scalar(@_) != 1;
  
    my $template = shift;
  
    my ($fh, $path, $errstr);
    croak "Error in mkstemp using $template: $errstr"
      unless (($fh, $path) = _gettemp($template,
                                      "open" => 1,
                                      "mkdir"=> 0 ,
                                      "suffixlen" => 0,
                                      "ErrStr" => \$errstr,
                                     ) );
  
    if (wantarray()) {
      return ($fh, $path);
    } else {
      return $fh;
    }
  
  }
  
  
  
  sub mkstemps {
  
    croak "Usage: mkstemps(template, suffix)"
      if scalar(@_) != 2;
  
  
    my $template = shift;
    my $suffix   = shift;
  
    $template .= $suffix;
  
    my ($fh, $path, $errstr);
    croak "Error in mkstemps using $template: $errstr"
      unless (($fh, $path) = _gettemp($template,
                                      "open" => 1,
                                      "mkdir"=> 0 ,
                                      "suffixlen" => length($suffix),
                                      "ErrStr" => \$errstr,
                                     ) );
  
    if (wantarray()) {
      return ($fh, $path);
    } else {
      return $fh;
    }
  
  }
  
  
  #' # for emacs
  
  sub mkdtemp {
  
    croak "Usage: mkdtemp(template)"
      if scalar(@_) != 1;
  
    my $template = shift;
    my $suffixlen = 0;
    if ($^O eq 'VMS') {           # dir names can end in delimiters
      $template =~ m/([\.\]:>]+)$/;
      $suffixlen = length($1);
    }
    if ( ($^O eq 'MacOS') && (substr($template, -1) eq ':') ) {
      # dir name has a trailing ':'
      ++$suffixlen;
    }
    my ($junk, $tmpdir, $errstr);
    croak "Error creating temp directory from template $template\: $errstr"
      unless (($junk, $tmpdir) = _gettemp($template,
                                          "open" => 0,
                                          "mkdir"=> 1 ,
                                          "suffixlen" => $suffixlen,
                                          "ErrStr" => \$errstr,
                                         ) );
  
    return $tmpdir;
  
  }
  
  
  sub mktemp {
  
    croak "Usage: mktemp(template)"
      if scalar(@_) != 1;
  
    my $template = shift;
  
    my ($tmpname, $junk, $errstr);
    croak "Error getting name to temp file from template $template: $errstr"
      unless (($junk, $tmpname) = _gettemp($template,
                                           "open" => 0,
                                           "mkdir"=> 0 ,
                                           "suffixlen" => 0,
                                           "ErrStr" => \$errstr,
                                          ) );
  
    return $tmpname;
  }
  
  
  sub tmpnam {
  
    # Retrieve the temporary directory name
    my $tmpdir = File::Spec->tmpdir;
  
    croak "Error temporary directory is not writable"
      if $tmpdir eq '';
  
    # Use a ten character template and append to tmpdir
    my $template = File::Spec->catfile($tmpdir, TEMPXXX);
  
    if (wantarray() ) {
      return mkstemp($template);
    } else {
      return mktemp($template);
    }
  
  }
  
  
  sub tmpfile {
  
    # Simply call tmpnam() in a list context
    my ($fh, $file) = tmpnam();
  
    # Make sure file is removed when filehandle is closed
    # This will fail on NFS
    unlink0($fh, $file)
      or return undef;
  
    return $fh;
  
  }
  
  
  sub tempnam {
  
    croak 'Usage tempnam($dir, $prefix)' unless scalar(@_) == 2;
  
    my ($dir, $prefix) = @_;
  
    # Add a string to the prefix
    $prefix .= 'XXXXXXXX';
  
    # Concatenate the directory to the file
    my $template = File::Spec->catfile($dir, $prefix);
  
    return mktemp($template);
  
  }
  
  
  sub unlink0 {
  
    croak 'Usage: unlink0(filehandle, filename)'
      unless scalar(@_) == 2;
  
    # Read args
    my ($fh, $path) = @_;
  
    cmpstat($fh, $path) or return 0;
  
    # attempt remove the file (does not work on some platforms)
    if (_can_unlink_opened_file()) {
  
      # return early (Without unlink) if we have been instructed to retain files.
      return 1 if $KEEP_ALL;
  
      # XXX: do *not* call this on a directory; possible race
      #      resulting in recursive removal
      croak "unlink0: $path has become a directory!" if -d $path;
      unlink($path) or return 0;
  
      # Stat the filehandle
      my @fh = stat $fh;
  
      print "Link count = $fh[3] \n" if $DEBUG;
  
      # Make sure that the link count is zero
      # - Cygwin provides deferred unlinking, however,
      #   on Win9x the link count remains 1
      # On NFS the link count may still be 1 but we can't know that
      # we are on NFS.  Since we can't be sure, we'll defer it
  
      return 1 if $fh[3] == 0 || $^O eq 'cygwin';
    }
    # fall-through if we can't unlink now
    _deferred_unlink($fh, $path, 0);
    return 1;
  }
  
  
  sub cmpstat {
  
    croak 'Usage: cmpstat(filehandle, filename)'
      unless scalar(@_) == 2;
  
    # Read args
    my ($fh, $path) = @_;
  
    warn "Comparing stat\n"
      if $DEBUG;
  
    # Stat the filehandle - which may be closed if someone has manually
    # closed the file. Can not turn off warnings without using $^W
    # unless we upgrade to 5.006 minimum requirement
    my @fh;
    {
      local ($^W) = 0;
      @fh = stat $fh;
    }
    return unless @fh;
  
    if ($fh[3] > 1 && $^W) {
      carp "unlink0: fstat found too many links; SB=@fh" if $^W;
    }
  
    # Stat the path
    my @path = stat $path;
  
    unless (@path) {
      carp "unlink0: $path is gone already" if $^W;
      return;
    }
  
    # this is no longer a file, but may be a directory, or worse
    unless (-f $path) {
      confess "panic: $path is no longer a file: SB=@fh";
    }
  
    # Do comparison of each member of the array
    # On WinNT dev and rdev seem to be different
    # depending on whether it is a file or a handle.
    # Cannot simply compare all members of the stat return
    # Select the ones we can use
    my @okstat = (0..$#fh);       # Use all by default
    if ($^O eq 'MSWin32') {
      @okstat = (1,2,3,4,5,7,8,9,10);
    } elsif ($^O eq 'os2') {
      @okstat = (0, 2..$#fh);
    } elsif ($^O eq 'VMS') {      # device and file ID are sufficient
      @okstat = (0, 1);
    } elsif ($^O eq 'dos') {
      @okstat = (0,2..7,11..$#fh);
    } elsif ($^O eq 'mpeix') {
      @okstat = (0..4,8..10);
    }
  
    # Now compare each entry explicitly by number
    for (@okstat) {
      print "Comparing: $_ : $fh[$_] and $path[$_]\n" if $DEBUG;
      # Use eq rather than == since rdev, blksize, and blocks (6, 11,
      # and 12) will be '' on platforms that do not support them.  This
      # is fine since we are only comparing integers.
      unless ($fh[$_] eq $path[$_]) {
        warn "Did not match $_ element of stat\n" if $DEBUG;
        return 0;
      }
    }
  
    return 1;
  }
  
  
  sub unlink1 {
    croak 'Usage: unlink1(filehandle, filename)'
      unless scalar(@_) == 2;
  
    # Read args
    my ($fh, $path) = @_;
  
    cmpstat($fh, $path) or return 0;
  
    # Close the file
    close( $fh ) or return 0;
  
    # Make sure the file is writable (for windows)
    _force_writable( $path );
  
    # return early (without unlink) if we have been instructed to retain files.
    return 1 if $KEEP_ALL;
  
    # remove the file
    return unlink($path);
  }
  
  
  {
    # protect from using the variable itself
    my $LEVEL = STANDARD;
    sub safe_level {
      my $self = shift;
      if (@_) {
        my $level = shift;
        if (($level != STANDARD) && ($level != MEDIUM) && ($level != HIGH)) {
          carp "safe_level: Specified level ($level) not STANDARD, MEDIUM or HIGH - ignoring\n" if $^W;
        } else {
          # Don't allow this on perl 5.005 or earlier
          if ($] < 5.006 && $level != STANDARD) {
            # Cant do MEDIUM or HIGH checks
            croak "Currently requires perl 5.006 or newer to do the safe checks";
          }
          # Check that we are allowed to change level
          # Silently ignore if we can not.
          $LEVEL = $level if _can_do_level($level);
        }
      }
      return $LEVEL;
    }
  }
  
  
  {
    my $TopSystemUID = 10;
    $TopSystemUID = 197108 if $^O eq 'interix'; # "Administrator"
    sub top_system_uid {
      my $self = shift;
      if (@_) {
        my $newuid = shift;
        croak "top_system_uid: UIDs should be numeric"
          unless $newuid =~ /^\d+$/s;
        $TopSystemUID = $newuid;
      }
      return $TopSystemUID;
    }
  }
  
  
  package File::Temp::Dir;
  
  use File::Path qw/ rmtree /;
  use strict;
  use overload '""' => "STRINGIFY",
    '0+' => \&File::Temp::NUMIFY,
    fallback => 1;
  
  # private class specifically to support tempdir objects
  # created by File::Temp->newdir
  
  # ostensibly the same method interface as File::Temp but without
  # inheriting all the IO::Seekable methods and other cruft
  
  # Read-only - returns the name of the temp directory
  
  sub dirname {
    my $self = shift;
    return $self->{DIRNAME};
  }
  
  sub STRINGIFY {
    my $self = shift;
    return $self->dirname;
  }
  
  sub unlink_on_destroy {
    my $self = shift;
    if (@_) {
      $self->{CLEANUP} = shift;
    }
    return $self->{CLEANUP};
  }
  
  sub DESTROY {
    my $self = shift;
    local($., $@, $!, $^E, $?);
    if ($self->unlink_on_destroy && 
        $$ == $self->{LAUNCHPID} && !$File::Temp::KEEP_ALL) {
      if (-d $self->{REALNAME}) {
        # Some versions of rmtree will abort if you attempt to remove
        # the directory you are sitting in. We protect that and turn it
        # into a warning. We do this because this occurs during object
        # destruction and so can not be caught by the user.
        eval { rmtree($self->{REALNAME}, $File::Temp::DEBUG, 0); };
        warn $@ if ($@ && $^W);
      }
    }
  }
  
  1;
  
  __END__
  
  =pod
  
  =encoding utf-8
  
  =head1 NAME
  
  File::Temp - return name and handle of a temporary file safely
  
  =head1 VERSION
  
  version 0.2304
  
  =head1 SYNOPSIS
  
    use File::Temp qw/ tempfile tempdir /;
  
    $fh = tempfile();
    ($fh, $filename) = tempfile();
  
    ($fh, $filename) = tempfile( $template, DIR => $dir);
    ($fh, $filename) = tempfile( $template, SUFFIX => '.dat');
    ($fh, $filename) = tempfile( $template, TMPDIR => 1 );
  
    binmode( $fh, ":utf8" );
  
    $dir = tempdir( CLEANUP => 1 );
    ($fh, $filename) = tempfile( DIR => $dir );
  
  Object interface:
  
    require File::Temp;
    use File::Temp ();
    use File::Temp qw/ :seekable /;
  
    $fh = File::Temp->new();
    $fname = $fh->filename;
  
    $fh = File::Temp->new(TEMPLATE => $template);
    $fname = $fh->filename;
  
    $tmp = File::Temp->new( UNLINK => 0, SUFFIX => '.dat' );
    print $tmp "Some data\n";
    print "Filename is $tmp\n";
    $tmp->seek( 0, SEEK_END );
  
  The following interfaces are provided for compatibility with
  existing APIs. They should not be used in new code.
  
  MkTemp family:
  
    use File::Temp qw/ :mktemp  /;
  
    ($fh, $file) = mkstemp( "tmpfileXXXXX" );
    ($fh, $file) = mkstemps( "tmpfileXXXXXX", $suffix);
  
    $tmpdir = mkdtemp( $template );
  
    $unopened_file = mktemp( $template );
  
  POSIX functions:
  
    use File::Temp qw/ :POSIX /;
  
    $file = tmpnam();
    $fh = tmpfile();
  
    ($fh, $file) = tmpnam();
  
  Compatibility functions:
  
    $unopened_file = File::Temp::tempnam( $dir, $pfx );
  
  =head1 DESCRIPTION
  
  C<File::Temp> can be used to create and open temporary files in a safe
  way.  There is both a function interface and an object-oriented
  interface.  The File::Temp constructor or the tempfile() function can
  be used to return the name and the open filehandle of a temporary
  file.  The tempdir() function can be used to create a temporary
  directory.
  
  The security aspect of temporary file creation is emphasized such that
  a filehandle and filename are returned together.  This helps guarantee
  that a race condition can not occur where the temporary file is
  created by another process between checking for the existence of the
  file and its opening.  Additional security levels are provided to
  check, for example, that the sticky bit is set on world writable
  directories.  See L<"safe_level"> for more information.
  
  For compatibility with popular C library functions, Perl implementations of
  the mkstemp() family of functions are provided. These are, mkstemp(),
  mkstemps(), mkdtemp() and mktemp().
  
  Additionally, implementations of the standard L<POSIX|POSIX>
  tmpnam() and tmpfile() functions are provided if required.
  
  Implementations of mktemp(), tmpnam(), and tempnam() are provided,
  but should be used with caution since they return only a filename
  that was valid when function was called, so cannot guarantee
  that the file will not exist by the time the caller opens the filename.
  
  Filehandles returned by these functions support the seekable methods.
  
  =begin __INTERNALS
  
  =head1 PORTABILITY
  
  This section is at the top in order to provide easier access to
  porters.  It is not expected to be rendered by a standard pod
  formatting tool. Please skip straight to the SYNOPSIS section if you
  are not trying to port this module to a new platform.
  
  This module is designed to be portable across operating systems and it
  currently supports Unix, VMS, DOS, OS/2, Windows and Mac OS
  (Classic). When porting to a new OS there are generally three main
  issues that have to be solved:
  =over 4
  
  =item *
  
  Can the OS unlink an open file? If it can not then the
  C<_can_unlink_opened_file> method should be modified.
  
  =item *
  
  Are the return values from C<stat> reliable? By default all the
  return values from C<stat> are compared when unlinking a temporary
  file using the filename and the handle. Operating systems other than
  unix do not always have valid entries in all fields. If utility function
  C<File::Temp::unlink0> fails then the C<stat> comparison should be
  modified accordingly.
  
  =item *
  
  Security. Systems that can not support a test for the sticky bit
  on a directory can not use the MEDIUM and HIGH security tests.
  The C<_can_do_level> method should be modified accordingly.
  
  =back
  
  =end __INTERNALS
  
  =head1 OBJECT-ORIENTED INTERFACE
  
  This is the primary interface for interacting with
  C<File::Temp>. Using the OO interface a temporary file can be created
  when the object is constructed and the file can be removed when the
  object is no longer required.
  
  Note that there is no method to obtain the filehandle from the
  C<File::Temp> object. The object itself acts as a filehandle.  The object
  isa C<IO::Handle> and isa C<IO::Seekable> so all those methods are
  available.
  
  Also, the object is configured such that it stringifies to the name of the
  temporary file and so can be compared to a filename directly.  It numifies
  to the C<refaddr> the same as other handles and so can be compared to other
  handles with C<==>.
  
      $fh eq $filename       # as a string
      $fh != \*STDOUT        # as a number
  
  =over 4
  
  =item B<new>
  
  Create a temporary file object.
  
    my $tmp = File::Temp->new();
  
  by default the object is constructed as if C<tempfile>
  was called without options, but with the additional behaviour
  that the temporary file is removed by the object destructor
  if UNLINK is set to true (the default).
  
  Supported arguments are the same as for C<tempfile>: UNLINK
  (defaulting to true), DIR, EXLOCK and SUFFIX. Additionally, the filename
  template is specified using the TEMPLATE option. The OPEN option
  is not supported (the file is always opened).
  
   $tmp = File::Temp->new( TEMPLATE => 'tempXXXXX',
                          DIR => 'mydir',
                          SUFFIX => '.dat');
  
  Arguments are case insensitive.
  
  Can call croak() if an error occurs.
  
  =item B<newdir>
  
  Create a temporary directory using an object oriented interface.
  
    $dir = File::Temp->newdir();
  
  By default the directory is deleted when the object goes out of scope.
  
  Supports the same options as the C<tempdir> function. Note that directories
  created with this method default to CLEANUP => 1.
  
    $dir = File::Temp->newdir( $template, %options );
  
  A template may be specified either with a leading template or
  with a TEMPLATE argument.
  
  =item B<filename>
  
  Return the name of the temporary file associated with this object
  (if the object was created using the "new" constructor).
  
    $filename = $tmp->filename;
  
  This method is called automatically when the object is used as
  a string.
  
  =item B<dirname>
  
  Return the name of the temporary directory associated with this
  object (if the object was created using the "newdir" constructor).
  
    $dirname = $tmpdir->dirname;
  
  This method is called automatically when the object is used in string context.
  
  =item B<unlink_on_destroy>
  
  Control whether the file is unlinked when the object goes out of scope.
  The file is removed if this value is true and $KEEP_ALL is not.
  
   $fh->unlink_on_destroy( 1 );
  
  Default is for the file to be removed.
  
  =item B<DESTROY>
  
  When the object goes out of scope, the destructor is called. This
  destructor will attempt to unlink the file (using L<unlink1|"unlink1">)
  if the constructor was called with UNLINK set to 1 (the default state
  if UNLINK is not specified).
  
  No error is given if the unlink fails.
  
  If the object has been passed to a child process during a fork, the
  file will be deleted when the object goes out of scope in the parent.
  
  For a temporary directory object the directory will be removed unless
  the CLEANUP argument was used in the constructor (and set to false) or
  C<unlink_on_destroy> was modified after creation.  Note that if a temp
  directory is your current directory, it cannot be removed - a warning
  will be given in this case.  C<chdir()> out of the directory before
  letting the object go out of scope.
  
  If the global variable $KEEP_ALL is true, the file or directory
  will not be removed.
  
  =back
  
  =head1 FUNCTIONS
  
  This section describes the recommended interface for generating
  temporary files and directories.
  
  =over 4
  
  =item B<tempfile>
  
  This is the basic function to generate temporary files.
  The behaviour of the file can be changed using various options:
  
    $fh = tempfile();
    ($fh, $filename) = tempfile();
  
  Create a temporary file in  the directory specified for temporary
  files, as specified by the tmpdir() function in L<File::Spec>.
  
    ($fh, $filename) = tempfile($template);
  
  Create a temporary file in the current directory using the supplied
  template.  Trailing `X' characters are replaced with random letters to
  generate the filename.  At least four `X' characters must be present
  at the end of the template.
  
    ($fh, $filename) = tempfile($template, SUFFIX => $suffix)
  
  Same as previously, except that a suffix is added to the template
  after the `X' translation.  Useful for ensuring that a temporary
  filename has a particular extension when needed by other applications.
  But see the WARNING at the end.
  
    ($fh, $filename) = tempfile($template, DIR => $dir);
  
  Translates the template as before except that a directory name
  is specified.
  
    ($fh, $filename) = tempfile($template, TMPDIR => 1);
  
  Equivalent to specifying a DIR of "File::Spec->tmpdir", writing the file
  into the same temporary directory as would be used if no template was
  specified at all.
  
    ($fh, $filename) = tempfile($template, UNLINK => 1);
  
  Return the filename and filehandle as before except that the file is
  automatically removed when the program exits (dependent on
  $KEEP_ALL). Default is for the file to be removed if a file handle is
  requested and to be kept if the filename is requested. In a scalar
  context (where no filename is returned) the file is always deleted
  either (depending on the operating system) on exit or when it is
  closed (unless $KEEP_ALL is true when the temp file is created).
  
  Use the object-oriented interface if fine-grained control of when
  a file is removed is required.
  
  If the template is not specified, a template is always
  automatically generated. This temporary file is placed in tmpdir()
  (L<File::Spec>) unless a directory is specified explicitly with the
  DIR option.
  
    $fh = tempfile( DIR => $dir );
  
  If called in scalar context, only the filehandle is returned and the
  file will automatically be deleted when closed on operating systems
  that support this (see the description of tmpfile() elsewhere in this
  document).  This is the preferred mode of operation, as if you only
  have a filehandle, you can never create a race condition by fumbling
  with the filename. On systems that can not unlink an open file or can
  not mark a file as temporary when it is opened (for example, Windows
  NT uses the C<O_TEMPORARY> flag) the file is marked for deletion when
  the program ends (equivalent to setting UNLINK to 1). The C<UNLINK>
  flag is ignored if present.
  
    (undef, $filename) = tempfile($template, OPEN => 0);
  
  This will return the filename based on the template but
  will not open this file.  Cannot be used in conjunction with
  UNLINK set to true. Default is to always open the file
  to protect from possible race conditions. A warning is issued
  if warnings are turned on. Consider using the tmpnam()
  and mktemp() functions described elsewhere in this document
  if opening the file is not required.
  
  If the operating system supports it (for example BSD derived systems), the 
  filehandle will be opened with O_EXLOCK (open with exclusive file lock). 
  This can sometimes cause problems if the intention is to pass the filename 
  to another system that expects to take an exclusive lock itself (such as 
  DBD::SQLite) whilst ensuring that the tempfile is not reused. In this 
  situation the "EXLOCK" option can be passed to tempfile. By default EXLOCK 
  will be true (this retains compatibility with earlier releases).
  
    ($fh, $filename) = tempfile($template, EXLOCK => 0);
  
  Options can be combined as required.
  
  Will croak() if there is an error.
  
  =item B<tempdir>
  
  This is the recommended interface for creation of temporary
  directories.  By default the directory will not be removed on exit
  (that is, it won't be temporary; this behaviour can not be changed
  because of issues with backwards compatibility). To enable removal
  either use the CLEANUP option which will trigger removal on program
  exit, or consider using the "newdir" method in the object interface which
  will allow the directory to be cleaned up when the object goes out of
  scope.
  
  The behaviour of the function depends on the arguments:
  
    $tempdir = tempdir();
  
  Create a directory in tmpdir() (see L<File::Spec|File::Spec>).
  
    $tempdir = tempdir( $template );
  
  Create a directory from the supplied template. This template is
  similar to that described for tempfile(). `X' characters at the end
  of the template are replaced with random letters to construct the
  directory name. At least four `X' characters must be in the template.
  
    $tempdir = tempdir ( DIR => $dir );
  
  Specifies the directory to use for the temporary directory.
  The temporary directory name is derived from an internal template.
  
    $tempdir = tempdir ( $template, DIR => $dir );
  
  Prepend the supplied directory name to the template. The template
  should not include parent directory specifications itself. Any parent
  directory specifications are removed from the template before
  prepending the supplied directory.
  
    $tempdir = tempdir ( $template, TMPDIR => 1 );
  
  Using the supplied template, create the temporary directory in
  a standard location for temporary files. Equivalent to doing
  
    $tempdir = tempdir ( $template, DIR => File::Spec->tmpdir);
  
  but shorter. Parent directory specifications are stripped from the
  template itself. The C<TMPDIR> option is ignored if C<DIR> is set
  explicitly.  Additionally, C<TMPDIR> is implied if neither a template
  nor a directory are supplied.
  
    $tempdir = tempdir( $template, CLEANUP => 1);
  
  Create a temporary directory using the supplied template, but
  attempt to remove it (and all files inside it) when the program
  exits. Note that an attempt will be made to remove all files from
  the directory even if they were not created by this module (otherwise
  why ask to clean it up?). The directory removal is made with
  the rmtree() function from the L<File::Path|File::Path> module.
  Of course, if the template is not specified, the temporary directory
  will be created in tmpdir() and will also be removed at program exit.
  
  Will croak() if there is an error.
  
  =back
  
  =head1 MKTEMP FUNCTIONS
  
  The following functions are Perl implementations of the
  mktemp() family of temp file generation system calls.
  
  =over 4
  
  =item B<mkstemp>
  
  Given a template, returns a filehandle to the temporary file and the name
  of the file.
  
    ($fh, $name) = mkstemp( $template );
  
  In scalar context, just the filehandle is returned.
  
  The template may be any filename with some number of X's appended
  to it, for example F</tmp/temp.XXXX>. The trailing X's are replaced
  with unique alphanumeric combinations.
  
  Will croak() if there is an error.
  
  =item B<mkstemps>
  
  Similar to mkstemp(), except that an extra argument can be supplied
  with a suffix to be appended to the template.
  
    ($fh, $name) = mkstemps( $template, $suffix );
  
  For example a template of C<testXXXXXX> and suffix of C<.dat>
  would generate a file similar to F<testhGji_w.dat>.
  
  Returns just the filehandle alone when called in scalar context.
  
  Will croak() if there is an error.
  
  =item B<mkdtemp>
  
  Create a directory from a template. The template must end in
  X's that are replaced by the routine.
  
    $tmpdir_name = mkdtemp($template);
  
  Returns the name of the temporary directory created.
  
  Directory must be removed by the caller.
  
  Will croak() if there is an error.
  
  =item B<mktemp>
  
  Returns a valid temporary filename but does not guarantee
  that the file will not be opened by someone else.
  
    $unopened_file = mktemp($template);
  
  Template is the same as that required by mkstemp().
  
  Will croak() if there is an error.
  
  =back
  
  =head1 POSIX FUNCTIONS
  
  This section describes the re-implementation of the tmpnam()
  and tmpfile() functions described in L<POSIX>
  using the mkstemp() from this module.
  
  Unlike the L<POSIX|POSIX> implementations, the directory used
  for the temporary file is not specified in a system include
  file (C<P_tmpdir>) but simply depends on the choice of tmpdir()
  returned by L<File::Spec|File::Spec>. On some implementations this
  location can be set using the C<TMPDIR> environment variable, which
  may not be secure.
  If this is a problem, simply use mkstemp() and specify a template.
  
  =over 4
  
  =item B<tmpnam>
  
  When called in scalar context, returns the full name (including path)
  of a temporary file (uses mktemp()). The only check is that the file does
  not already exist, but there is no guarantee that that condition will
  continue to apply.
  
    $file = tmpnam();
  
  When called in list context, a filehandle to the open file and
  a filename are returned. This is achieved by calling mkstemp()
  after constructing a suitable template.
  
    ($fh, $file) = tmpnam();
  
  If possible, this form should be used to prevent possible
  race conditions.
  
  See L<File::Spec/tmpdir> for information on the choice of temporary
  directory for a particular operating system.
  
  Will croak() if there is an error.
  
  =item B<tmpfile>
  
  Returns the filehandle of a temporary file.
  
    $fh = tmpfile();
  
  The file is removed when the filehandle is closed or when the program
  exits. No access to the filename is provided.
  
  If the temporary file can not be created undef is returned.
  Currently this command will probably not work when the temporary
  directory is on an NFS file system.
  
  Will croak() if there is an error.
  
  =back
  
  =head1 ADDITIONAL FUNCTIONS
  
  These functions are provided for backwards compatibility
  with common tempfile generation C library functions.
  
  They are not exported and must be addressed using the full package
  name.
  
  =over 4
  
  =item B<tempnam>
  
  Return the name of a temporary file in the specified directory
  using a prefix. The file is guaranteed not to exist at the time
  the function was called, but such guarantees are good for one
  clock tick only.  Always use the proper form of C<sysopen>
  with C<O_CREAT | O_EXCL> if you must open such a filename.
  
    $filename = File::Temp::tempnam( $dir, $prefix );
  
  Equivalent to running mktemp() with $dir/$prefixXXXXXXXX
  (using unix file convention as an example)
  
  Because this function uses mktemp(), it can suffer from race conditions.
  
  Will croak() if there is an error.
  
  =back
  
  =head1 UTILITY FUNCTIONS
  
  Useful functions for dealing with the filehandle and filename.
  
  =over 4
  
  =item B<unlink0>
  
  Given an open filehandle and the associated filename, make a safe
  unlink. This is achieved by first checking that the filename and
  filehandle initially point to the same file and that the number of
  links to the file is 1 (all fields returned by stat() are compared).
  Then the filename is unlinked and the filehandle checked once again to
  verify that the number of links on that file is now 0.  This is the
  closest you can come to making sure that the filename unlinked was the
  same as the file whose descriptor you hold.
  
    unlink0($fh, $path)
       or die "Error unlinking file $path safely";
  
  Returns false on error but croaks() if there is a security
  anomaly. The filehandle is not closed since on some occasions this is
  not required.
  
  On some platforms, for example Windows NT, it is not possible to
  unlink an open file (the file must be closed first). On those
  platforms, the actual unlinking is deferred until the program ends and
  good status is returned. A check is still performed to make sure that
  the filehandle and filename are pointing to the same thing (but not at
  the time the end block is executed since the deferred removal may not
  have access to the filehandle).
  
  Additionally, on Windows NT not all the fields returned by stat() can
  be compared. For example, the C<dev> and C<rdev> fields seem to be
  different.  Also, it seems that the size of the file returned by stat()
  does not always agree, with C<stat(FH)> being more accurate than
  C<stat(filename)>, presumably because of caching issues even when
  using autoflush (this is usually overcome by waiting a while after
  writing to the tempfile before attempting to C<unlink0> it).
  
  Finally, on NFS file systems the link count of the file handle does
  not always go to zero immediately after unlinking. Currently, this
  command is expected to fail on NFS disks.
  
  This function is disabled if the global variable $KEEP_ALL is true
  and an unlink on open file is supported. If the unlink is to be deferred
  to the END block, the file is still registered for removal.
  
  This function should not be called if you are using the object oriented
  interface since the it will interfere with the object destructor deleting
  the file.
  
  =item B<cmpstat>
  
  Compare C<stat> of filehandle with C<stat> of provided filename.  This
  can be used to check that the filename and filehandle initially point
  to the same file and that the number of links to the file is 1 (all
  fields returned by stat() are compared).
  
    cmpstat($fh, $path)
       or die "Error comparing handle with file";
  
  Returns false if the stat information differs or if the link count is
  greater than 1. Calls croak if there is a security anomaly.
  
  On certain platforms, for example Windows, not all the fields returned by stat()
  can be compared. For example, the C<dev> and C<rdev> fields seem to be
  different in Windows.  Also, it seems that the size of the file
  returned by stat() does not always agree, with C<stat(FH)> being more
  accurate than C<stat(filename)>, presumably because of caching issues
  even when using autoflush (this is usually overcome by waiting a while
  after writing to the tempfile before attempting to C<unlink0> it).
  
  Not exported by default.
  
  =item B<unlink1>
  
  Similar to C<unlink0> except after file comparison using cmpstat, the
  filehandle is closed prior to attempting to unlink the file. This
  allows the file to be removed without using an END block, but does
  mean that the post-unlink comparison of the filehandle state provided
  by C<unlink0> is not available.
  
    unlink1($fh, $path)
       or die "Error closing and unlinking file";
  
  Usually called from the object destructor when using the OO interface.
  
  Not exported by default.
  
  This function is disabled if the global variable $KEEP_ALL is true.
  
  Can call croak() if there is a security anomaly during the stat()
  comparison.
  
  =item B<cleanup>
  
  Calling this function will cause any temp files or temp directories
  that are registered for removal to be removed. This happens automatically
  when the process exits but can be triggered manually if the caller is sure
  that none of the temp files are required. This method can be registered as
  an Apache callback.
  
  Note that if a temp directory is your current directory, it cannot be
  removed.  C<chdir()> out of the directory first before calling
  C<cleanup()>. (For the cleanup at program exit when the CLEANUP flag
  is set, this happens automatically.)
  
  On OSes where temp files are automatically removed when the temp file
  is closed, calling this function will have no effect other than to remove
  temporary directories (which may include temporary files).
  
    File::Temp::cleanup();
  
  Not exported by default.
  
  =back
  
  =head1 PACKAGE VARIABLES
  
  These functions control the global state of the package.
  
  =over 4
  
  =item B<safe_level>
  
  Controls the lengths to which the module will go to check the safety of the
  temporary file or directory before proceeding.
  Options are:
  
  =over 8
  
  =item STANDARD
  
  Do the basic security measures to ensure the directory exists and is
  writable, that temporary files are opened only if they do not already
  exist, and that possible race conditions are avoided.  Finally the
  L<unlink0|"unlink0"> function is used to remove files safely.
  
  =item MEDIUM
  
  In addition to the STANDARD security, the output directory is checked
  to make sure that it is owned either by root or the user running the
  program. If the directory is writable by group or by other, it is then
  checked to make sure that the sticky bit is set.
  
  Will not work on platforms that do not support the C<-k> test
  for sticky bit.
  
  =item HIGH
  
  In addition to the MEDIUM security checks, also check for the
  possibility of ``chown() giveaway'' using the L<POSIX|POSIX>
  sysconf() function. If this is a possibility, each directory in the
  path is checked in turn for safeness, recursively walking back to the
  root directory.
  
  For platforms that do not support the L<POSIX|POSIX>
  C<_PC_CHOWN_RESTRICTED> symbol (for example, Windows NT) it is
  assumed that ``chown() giveaway'' is possible and the recursive test
  is performed.
  
  =back
  
  The level can be changed as follows:
  
    File::Temp->safe_level( File::Temp::HIGH );
  
  The level constants are not exported by the module.
  
  Currently, you must be running at least perl v5.6.0 in order to
  run with MEDIUM or HIGH security. This is simply because the
  safety tests use functions from L<Fcntl|Fcntl> that are not
  available in older versions of perl. The problem is that the version
  number for Fcntl is the same in perl 5.6.0 and in 5.005_03 even though
  they are different versions.
  
  On systems that do not support the HIGH or MEDIUM safety levels
  (for example Win NT or OS/2) any attempt to change the level will
  be ignored. The decision to ignore rather than raise an exception
  allows portable programs to be written with high security in mind
  for the systems that can support this without those programs failing
  on systems where the extra tests are irrelevant.
  
  If you really need to see whether the change has been accepted
  simply examine the return value of C<safe_level>.
  
    $newlevel = File::Temp->safe_level( File::Temp::HIGH );
    die "Could not change to high security"
        if $newlevel != File::Temp::HIGH;
  
  =item TopSystemUID
  
  This is the highest UID on the current system that refers to a root
  UID. This is used to make sure that the temporary directory is
  owned by a system UID (C<root>, C<bin>, C<sys> etc) rather than
  simply by root.
  
  This is required since on many unix systems C</tmp> is not owned
  by root.
  
  Default is to assume that any UID less than or equal to 10 is a root
  UID.
  
    File::Temp->top_system_uid(10);
    my $topid = File::Temp->top_system_uid;
  
  This value can be adjusted to reduce security checking if required.
  The value is only relevant when C<safe_level> is set to MEDIUM or higher.
  
  =item B<$KEEP_ALL>
  
  Controls whether temporary files and directories should be retained
  regardless of any instructions in the program to remove them
  automatically.  This is useful for debugging but should not be used in
  production code.
  
    $File::Temp::KEEP_ALL = 1;
  
  Default is for files to be removed as requested by the caller.
  
  In some cases, files will only be retained if this variable is true
  when the file is created. This means that you can not create a temporary
  file, set this variable and expect the temp file to still be around
  when the program exits.
  
  =item B<$DEBUG>
  
  Controls whether debugging messages should be enabled.
  
    $File::Temp::DEBUG = 1;
  
  Default is for debugging mode to be disabled.
  
  =back
  
  =head1 WARNING
  
  For maximum security, endeavour always to avoid ever looking at,
  touching, or even imputing the existence of the filename.  You do not
  know that that filename is connected to the same file as the handle
  you have, and attempts to check this can only trigger more race
  conditions.  It's far more secure to use the filehandle alone and
  dispense with the filename altogether.
  
  If you need to pass the handle to something that expects a filename
  then on a unix system you can use C<"/dev/fd/" . fileno($fh)> for
  arbitrary programs. Perl code that uses the 2-argument version of
  C<< open >> can be passed C<< "+<=&" . fileno($fh) >>. Otherwise you
  will need to pass the filename. You will have to clear the
  close-on-exec bit on that file descriptor before passing it to another
  process.
  
      use Fcntl qw/F_SETFD F_GETFD/;
      fcntl($tmpfh, F_SETFD, 0)
          or die "Can't clear close-on-exec flag on temp fh: $!\n";
  
  =head2 Temporary files and NFS
  
  Some problems are associated with using temporary files that reside
  on NFS file systems and it is recommended that a local filesystem
  is used whenever possible. Some of the security tests will most probably
  fail when the temp file is not local. Additionally, be aware that
  the performance of I/O operations over NFS will not be as good as for
  a local disk.
  
  =head2 Forking
  
  In some cases files created by File::Temp are removed from within an
  END block. Since END blocks are triggered when a child process exits
  (unless C<POSIX::_exit()> is used by the child) File::Temp takes care
  to only remove those temp files created by a particular process ID. This
  means that a child will not attempt to remove temp files created by the
  parent process.
  
  If you are forking many processes in parallel that are all creating
  temporary files, you may need to reset the random number seed using
  srand(EXPR) in each child else all the children will attempt to walk
  through the same set of random file names and may well cause
  themselves to give up if they exceed the number of retry attempts.
  
  =head2 Directory removal
  
  Note that if you have chdir'ed into the temporary directory and it is
  subsequently cleaned up (either in the END block or as part of object
  destruction), then you will get a warning from File::Path::rmtree().
  
  =head2 Taint mode
  
  If you need to run code under taint mode, updating to the latest
  L<File::Spec> is highly recommended.
  
  =head2 BINMODE
  
  The file returned by File::Temp will have been opened in binary mode
  if such a mode is available. If that is not correct, use the C<binmode()>
  function to change the mode of the filehandle.
  
  Note that you can modify the encoding of a file opened by File::Temp
  also by using C<binmode()>.
  
  =head1 HISTORY
  
  Originally began life in May 1999 as an XS interface to the system
  mkstemp() function. In March 2000, the OpenBSD mkstemp() code was
  translated to Perl for total control of the code's
  security checking, to ensure the presence of the function regardless of
  operating system and to help with portability. The module was shipped
  as a standard part of perl from v5.6.1.
  
  Thanks to Tom Christiansen for suggesting that this module
  should be written and providing ideas for code improvements and
  security enhancements.
  
  =head1 SEE ALSO
  
  L<POSIX/tmpnam>, L<POSIX/tmpfile>, L<File::Spec>, L<File::Path>
  
  See L<IO::File> and L<File::MkTemp>, L<Apache::TempFile> for
  different implementations of temporary file handling.
  
  See L<File::Tempdir> for an alternative object-oriented wrapper for
  the C<tempdir> function.
  
  =for Pod::Coverage STRINGIFY NUMIFY top_system_uid
  
  # vim: ts=2 sts=2 sw=2 et:
  
  =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=File-Temp>.
  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/File-Temp>
  
    git clone https://github.com/Perl-Toolchain-Gang/File-Temp.git
  
  =head1 AUTHOR
  
  Tim Jenness <tjenness@cpan.org>
  
  =head1 CONTRIBUTORS
  
  =over 4
  
  =item *
  
  Ben Tilly <btilly@gmail.com>
  
  =item *
  
  David Golden <dagolden@cpan.org>
  
  =item *
  
  David Steinbrunner <dsteinbrunner@pobox.com>
  
  =item *
  
  Ed Avis <eda@linux01.wcl.local>
  
  =item *
  
  James E. Keenan <jkeen@verizon.net>
  
  =item *
  
  Karen Etheridge <ether@cpan.org>
  
  =item *
  
  Kevin Ryde <user42@zip.com.au>
  
  =item *
  
  Olivier Mengue <dolmen@cpan.org>
  
  =item *
  
  Peter John Acklam <pjacklam@online.no>
  
  =item *
  
  Peter Rabbitson <ribasushi@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2013 by Tim Jenness and the UK Particle Physics and Astronomy Research Council.
  
  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
FILE_TEMP

$fatpacked{"File/Which.pm"} = <<'FILE_WHICH';
  package File::Which;
  
  use 5.004;
  use strict;
  use Exporter   ();
  use File::Spec ();
  
  use vars qw{$VERSION @ISA @EXPORT @EXPORT_OK};
  BEGIN {
  	$VERSION   = '1.09';
  	@ISA       = 'Exporter';
  	@EXPORT    = 'which';
  	@EXPORT_OK = 'where';
  }
  
  use constant IS_VMS => ($^O eq 'VMS');
  use constant IS_MAC => ($^O eq 'MacOS');
  use constant IS_DOS => ($^O eq 'MSWin32' or $^O eq 'dos' or $^O eq 'os2');
  
  # 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_DOS ) {
  	# 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};
  }
  
  sub which {
  	my ($exec) = @_;
  
  	return undef unless $exec;
  
  	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;
  			}
  		}
  	}
  
  	my @path = File::Spec->path;
  	if ( IS_DOS or IS_VMS or IS_MAC ) {
  		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_DOS
  						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
  
  =head1 NAME
  
  File::Which - Portable implementation of the `which' utility
  
  =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
  
  C<File::Which> was created to be able to get the paths to executable programs
  on systems under which the `which' program wasn't implemented in the shell.
  
  C<File::Which> searches the directories of the user's C<PATH> (as returned by
  C<File::Spec-E<gt>path()>), looking for executable files having the name
  specified as a parameter to C<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.)
  
  =head1 Steps Used on Win32, DOS, OS2 and VMS
  
  =head2 Windows NT
  
  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.
  
  =head2 Windows 9x and other ancient Win/DOS/OS2
  
  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.
  
  =head2 VMS
  
  Same case as Windows 9x: uses C<.exe> and C<.com> (in that order).
  
  =head1 Functions
  
  =head2 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($short_exe_name)
  
  Not exported by default.
  
  Same as C<which($short_exe_name)> in array context. Same as the
  C<`where'> utility, will return an array containing all the path names
  matching C<$short_exe_name>.
  
  =head1 BUGS AND CAVEATS
  
  Not tested on VMS or MacOS, 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.
  
  File::Spec adds the current directory to the front of PATH if on
  Win32, VMS or MacOS. I have no knowledge of those so don't know if the
  current directory is searced first or not. Could someone please tell
  me?
  
  =head1 SUPPORT
  
  Bugs should be reported via the CPAN bug tracker at
  
  L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=File-Which>
  
  For other issues, contact the maintainer.
  
  =head1 AUTHOR
  
  Adam Kennedy E<lt>adamk@cpan.orgE<gt>
  
  Per Einar Ellefsen E<lt>pereinar@cpan.orgE<gt>
  
  Originated in F<modperl-2.0/lib/Apache/Build.pm>. Changed for use in DocSet
  (for the mod_perl site) and Win32-awareness by me, with slight modifications
  by Stas Bekman, then extracted to create C<File::Which>.
  
  Version 0.04 had some significant platform-related changes, taken from
  the Perl Power Tools C<`which'> implementation by Abigail with
  enhancements from Peter Prymmer. See
  L<http://www.perl.com/language/ppt/src/which/index.html> for more
  information.
  
  =head1 COPYRIGHT
  
  Copyright 2002 Per Einar Ellefsen.
  
  Some parts copyright 2009 Adam Kennedy.
  
  This program is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself.
  
  =head1 SEE ALSO
  
  L<File::Spec>, L<which(1)>, Perl Power Tools:
  L<http://www.perl.com/language/ppt/index.html>.
  
  =cut
FILE_WHICH

$fatpacked{"Getopt/Long.pm"} = <<'GETOPT_LONG';
  #! 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 Oct  1 08:25:52 2013
  # Update Count    : 1651
  # Status          : Released
  
  ################ Module Preamble ################
  
  package Getopt::Long;
  
  use 5.004;
  
  use strict;
  
  use vars qw($VERSION);
  $VERSION        =  2.42;
  # For testing versions only.
  use vars qw($VERSION_STRING);
  $VERSION_STRING = "2.42";
  
  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);
  
  # 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
  }
  
  # 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 => "[-+]?[0-9_]+(\.[0-9_]+)?([eE][-+]?[0-9_]+)?";
  
  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 ",
  	   "called from package \"$pkg\".",
  	   "\n  ",
  	   "argv: (@$argv)",
  	   "\n  ",
  	   "autoabbrev=$autoabbrev,".
  	   "bundling=$bundling,",
  	   "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";
  	}
  
      }
  
      # 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.
  		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,
  				    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 ) {
  	#  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]* )
  		     # Alias names, or "?"
  		     (?: \| (?: \? | \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 && $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;
  	}
  	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;
  	    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;
  	}
  	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 && defined $optarg && $optarg eq '' ) {
  	return (1, $opt, $ctl, $type eq 's' ? '' : 0) ;#unless $mand;
  	$optarg = 0 unless $type eq 's';
      }
  
      # 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 ) {
  	    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
  	# We require at least one digit before a point or 'e',
  	# and at least one digit following the point and 'e'.
  	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
  	# We require at least one digit before a point or 'e',
  	# and at least one digit following the point and 'e'.
  	# [-]NN[.NN][eNN]
  	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,
  	$autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
  	$gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
  	$longprefix ];
  
      if ( ref($options[0]) eq 'ARRAY' ) {
  	( $error, $debug, $major_version, $minor_version,
  	  $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
  	  $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
  	  $longprefix ) = @{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;
  	    }
  	}
  	elsif ( $try eq 'gnu_compat' ) {
  	    $gnu_compat = $action;
  	}
  	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;
  	}
  	elsif ( $try eq 'bundling_override' ) {
  	    $bundling = $action ? 2 : 0;
  	}
  	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];
      shift->SUPER::VERSION(@_);
  }
  
  package Getopt::Long::CallBack;
  
  sub new {
      my ($pkg, %atts) = @_;
      bless { %atts }, $pkg;
  }
  
  sub name {
      my $self = shift;
      ''.$self->{name};
  }
  
  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 scalar reference as the
  destination:
  
      GetOptions ("library=s@" => \$libfiles);
  
  Used with the example above, C<@libfiles> (or 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<-->.
  
  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.
  
  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 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.
  
  =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
  
  would set all three.
  
  Getopt::Long supports two levels of bundling. To enable bundling, a
  call to Getopt::Long::Configure is required.
  
  The first level of bundling can be enabled with:
  
      Getopt::Long::Configure ("bundling");
  
  Configured this way, single-character options can be bundled but long
  options 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
  
  would set C<a>, C<v> and C<x>, but
  
      --vax
  
  would set C<vax>.
  
  The second level of bundling lifts this restriction. It can be enabled
  with:
  
      Getopt::Long::Configure ("bundling_override");
  
  Now, C<-vax> would set the option C<vax>.
  
  When any level of bundling is enabled, option values may be inserted
  in the bundle. For example:
  
      -h24w80
  
  is equivalent to
  
      -h 24 -w 80
  
  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. Well, actually
  it is an object that stringifies to 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>, or disabled, 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.
  
  =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
  fully 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
  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)
  
  Options that are unknown, ambiguous or supplied with an invalid option
  value are passed through in C<@ARGV> instead of being flagged as
  errors. 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.
  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
  as aliases with Getopt::Long of at least version 2.39.
  
  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,2013 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
  
GETOPT_LONG

$fatpacked{"Pod/Usage.pm"} = <<'POD_USAGE';
  #############################################################################
  # Pod/Usage.pm -- print usage messages for the running script.
  #
  # Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved.
  # This file is part of "PodParser". PodParser is free software;
  # you can redistribute it and/or modify it under the same terms
  # as Perl itself.
  #############################################################################
  
  package Pod::Usage;
  use strict;
  
  use vars qw($VERSION @ISA @EXPORT);
  $VERSION = '1.63';  ## Current version of this package
  require  5.006;    ## requires this Perl version or later
  
  #use diagnostics;
  use Carp;
  use Config;
  use Exporter;
  use File::Spec;
  
  @EXPORT = qw(&pod2usage);
  BEGIN {
      $Pod::Usage::Formatter ||= 'Pod::Text';
      eval "require $Pod::Usage::Formatter";
      die $@ if $@;
      @ISA = ( $Pod::Usage::Formatter );
  }
  
  our $MAX_HEADING_LEVEL = 3;
  
  ##---------------------------------------------------------------------------
  
  ##---------------------------------
  ## Function definitions begin here
  ##---------------------------------
  
  sub pod2usage {
      local($_) = shift;
      my %opts;
      ## Collect arguments
      if (@_ > 0) {
          ## Too many arguments - assume that this is a hash and
          ## the user forgot to pass a reference to it.
          %opts = ($_, @_);
      }
      elsif (!defined $_) {
        $_ = '';
      }
      elsif (ref $_) {
          ## User passed a ref to a hash
          %opts = %{$_}  if (ref($_) eq 'HASH');
      }
      elsif (/^[-+]?\d+$/) {
          ## User passed in the exit value to use
          $opts{'-exitval'} =  $_;
      }
      else {
          ## User passed in a message to print before issuing usage.
          $_  and  $opts{'-message'} = $_;
      }
  
      ## Need this for backward compatibility since we formerly used
      ## options that were all uppercase words rather than ones that
      ## looked like Unix command-line options.
      ## to be uppercase keywords)
      %opts = map {
          my ($key, $val) = ($_, $opts{$_});
          $key =~ s/^(?=\w)/-/;
          $key =~ /^-msg/i   and  $key = '-message';
          $key =~ /^-exit/i  and  $key = '-exitval';
          lc($key) => $val;
      } (keys %opts);
  
      ## Now determine default -exitval and -verbose values to use
      if ((! defined $opts{'-exitval'}) && (! defined $opts{'-verbose'})) {
          $opts{'-exitval'} = 2;
          $opts{'-verbose'} = 0;
      }
      elsif (! defined $opts{'-exitval'}) {
          $opts{'-exitval'} = ($opts{'-verbose'} > 0) ? 1 : 2;
      }
      elsif (! defined $opts{'-verbose'}) {
          $opts{'-verbose'} = (lc($opts{'-exitval'}) eq 'noexit' ||
                               $opts{'-exitval'} < 2);
      }
  
      ## Default the output file
      $opts{'-output'} = (lc($opts{'-exitval'}) eq 'noexit' ||
                          $opts{'-exitval'} < 2) ? \*STDOUT : \*STDERR
              unless (defined $opts{'-output'});
      ## Default the input file
      $opts{'-input'} = $0  unless (defined $opts{'-input'});
  
      ## Look up input file in path if it doesn't exist.
      unless ((ref $opts{'-input'}) || (-e $opts{'-input'})) {
          my $basename = $opts{'-input'};
          my $pathsep = ($^O =~ /^(?:dos|os2|MSWin32)$/i) ? ';'
                              : (($^O eq 'MacOS' || $^O eq 'VMS') ? ',' :  ':');
          my $pathspec = $opts{'-pathlist'} || $ENV{PATH} || $ENV{PERL5LIB};
  
          my @paths = (ref $pathspec) ? @$pathspec : split($pathsep, $pathspec);
          for my $dirname (@paths) {
              $_ = File::Spec->catfile($dirname, $basename)  if length;
              last if (-e $_) && ($opts{'-input'} = $_);
          }
      }
  
      ## Now create a pod reader and constrain it to the desired sections.
      my $parser = new Pod::Usage(USAGE_OPTIONS => \%opts);
      if ($opts{'-verbose'} == 0) {
          $parser->select('(?:SYNOPSIS|USAGE)\s*');
      }
      elsif ($opts{'-verbose'} == 1) {
          my $opt_re = '(?i)' .
                       '(?:OPTIONS|ARGUMENTS)' .
                       '(?:\s*(?:AND|\/)\s*(?:OPTIONS|ARGUMENTS))?';
          $parser->select( '(?:SYNOPSIS|USAGE)\s*', $opt_re, "DESCRIPTION/$opt_re" );
      }
      elsif ($opts{'-verbose'} >= 2 && $opts{'-verbose'} != 99) {
          $parser->select('.*');
      }
      elsif ($opts{'-verbose'} == 99) {
          my $sections = $opts{'-sections'};
          $parser->select( (ref $sections) ? @$sections : $sections );
          $opts{'-verbose'} = 1;
      }
  
      ## Check for perldoc
      my $progpath = File::Spec->catfile($Config{scriptdirexp} 
  	|| $Config{scriptdir}, 'perldoc');
  
      my $version = sprintf("%vd",$^V);
      if ($Config{versiononly} and $Config{startperl} =~ /\Q$version\E$/ ) {
        $progpath .= $version;
      }
      $opts{'-noperldoc'} = 1 unless -e $progpath;
  
      ## Now translate the pod document and then exit with the desired status
      if (      !$opts{'-noperldoc'}
           and  $opts{'-verbose'} >= 2
           and  !ref($opts{'-input'})
           and  $opts{'-output'} == \*STDOUT )
      {
         ## spit out the entire PODs. Might as well invoke perldoc
         print { $opts{'-output'} } ($opts{'-message'}, "\n") if($opts{'-message'});
         if(defined $opts{-input} && $opts{-input} =~ /^\s*(\S.*?)\s*$/) {
           # the perldocs back to 5.005 should all have -F
  	 # without -F there are warnings in -T scripts
           system($progpath, '-F', $1);
           if($?) {
             # RT16091: fall back to more if perldoc failed
             system(($Config{pager} || $ENV{PAGER} || '/bin/more'), $1);
           }
         } else {
           croak "Unspecified input file or insecure argument.\n";
         }
      }
      else {
         $parser->parse_from_file($opts{'-input'}, $opts{'-output'});
      }
  
      exit($opts{'-exitval'})  unless (lc($opts{'-exitval'}) eq 'noexit');
  }
  
  ##---------------------------------------------------------------------------
  
  ##-------------------------------
  ## Method definitions begin here
  ##-------------------------------
  
  sub new {
      my $this = shift;
      my $class = ref($this) || $this;
      my %params = @_;
      my $self = {%params};
      bless $self, $class;
      if ($self->can('initialize')) {
          $self->initialize();
      } else {
          # pass through options to Pod::Text
          my %opts;
         	for (qw(alt code indent loose margin quotes sentence stderr utf8 width)) {
              my $val = $params{USAGE_OPTIONS}{"-$_"};
              $opts{$_} = $val if defined $val;
          }
          $self = $self->SUPER::new(%opts);
          %$self = (%$self, %params);
      }
      return $self;
  }
  
  # This subroutine was copied in whole-cloth from Pod::Select 1.60 in order to
  # allow the ejection of Pod::Select from the core without breaking Pod::Usage.
  # -- rjbs, 2013-03-18
  sub _compile_section_spec {
      my ($section_spec) = @_;
      my (@regexs, $negated);
  
      ## Compile the spec into a list of regexs
      local $_ = $section_spec;
      s{\\\\}{\001}g;  ## handle escaped backward slashes
      s{\\/}{\002}g;   ## handle escaped forward slashes
  
      ## Parse the regexs for the heading titles
      @regexs = split(/\//, $_, $MAX_HEADING_LEVEL);
  
      ## Set default regex for ommitted levels
      for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) {
          $regexs[$i]  = '.*'  unless ((defined $regexs[$i])
                                       && (length $regexs[$i]));
      }
      ## Modify the regexs as needed and validate their syntax
      my $bad_regexs = 0;
      for (@regexs) {
          $_ .= '.+'  if ($_ eq '!');
          s{\001}{\\\\}g;       ## restore escaped backward slashes
          s{\002}{\\/}g;        ## restore escaped forward slashes
          $negated = s/^\!//;   ## check for negation
          eval "m{$_}";         ## check regex syntax
          if ($@) {
              ++$bad_regexs;
              carp qq{Bad regular expression /$_/ in "$section_spec": $@\n};
          }
          else {
              ## Add the forward and rear anchors (and put the negator back)
              $_ = '^' . $_  unless (/^\^/);
              $_ = $_ . '$'  unless (/\$$/);
              $_ = '!' . $_  if ($negated);
          }
      }
      return  (! $bad_regexs) ? [ @regexs ] : undef;
  }
  
  sub select {
      my ($self, @sections) = @_;
      if ($ISA[0]->can('select')) {
          $self->SUPER::select(@sections);
      } else {
          # we're using Pod::Simple - need to mimic the behavior of Pod::Select
          my $add = ($sections[0] eq '+') ? shift(@sections) : '';
          ## Reset the set of sections to use
          unless (@sections) {
            delete $self->{USAGE_SELECT} unless ($add);
            return;
          }
          $self->{USAGE_SELECT} = []
            unless ($add && $self->{USAGE_SELECT});
          my $sref = $self->{USAGE_SELECT};
          ## Compile each spec
          for my $spec (@sections) {
            my $cs = _compile_section_spec($spec);
            if ( defined $cs ) {
              ## Store them in our sections array
              push(@$sref, $cs);
            } else {
              carp qq{Ignoring section spec "$spec"!\n};
            }
          }
      }
  }
  
  # Override Pod::Text->seq_i to return just "arg", not "*arg*".
  sub seq_i { return $_[1] }
  
  # This overrides the Pod::Text method to do something very akin to what
  # Pod::Select did as well as the work done below by preprocess_paragraph.
  # Note that the below is very, very specific to Pod::Text.
  sub _handle_element_end {
      my ($self, $element) = @_;
      if ($element eq 'head1') {
          $self->{USAGE_HEADINGS} = [ $$self{PENDING}[-1][1] ];
          if ($self->{USAGE_OPTIONS}->{-verbose} < 2) {
              $$self{PENDING}[-1][1] =~ s/^\s*SYNOPSIS\s*$/USAGE/;
          }
      } elsif ($element =~ /^head(\d+)$/ && $1) { # avoid 0
          my $idx = $1 - 1;
          $self->{USAGE_HEADINGS} = [] unless($self->{USAGE_HEADINGS});
          $self->{USAGE_HEADINGS}->[$idx] = $$self{PENDING}[-1][1];
      }
      if ($element =~ /^head\d+$/) {
          $$self{USAGE_SKIPPING} = 1;
          if (!$$self{USAGE_SELECT} || !@{ $$self{USAGE_SELECT} }) {
              $$self{USAGE_SKIPPING} = 0;
          } else {
              my @headings = @{$$self{USAGE_HEADINGS}};
              for my $section_spec ( @{$$self{USAGE_SELECT}} ) {
                  my $match = 1;
                  for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) {
                      $headings[$i] = '' unless defined $headings[$i];
                      my $regex   = $section_spec->[$i];
                      my $negated = ($regex =~ s/^\!//);
                      $match  &= ($negated ? ($headings[$i] !~ /${regex}/)
                                           : ($headings[$i] =~ /${regex}/));
                      last unless ($match);
                  } # end heading levels
                  if ($match) {
                    $$self{USAGE_SKIPPING} = 0;
                    last;
                  }
              } # end sections
          }
  
          # Try to do some lowercasing instead of all-caps in headings, and use
          # a colon to end all headings.
          if($self->{USAGE_OPTIONS}->{-verbose} < 2) {
              local $_ = $$self{PENDING}[-1][1];
              s{([A-Z])([A-Z]+)}{((length($2) > 2) ? $1 : lc($1)) . lc($2)}ge;
              s/\s*$/:/  unless (/:\s*$/);
              $_ .= "\n";
              $$self{PENDING}[-1][1] = $_;
          }
      }
      if ($$self{USAGE_SKIPPING} && $element !~ m/^over-/) {
          pop @{ $$self{PENDING} };
      } else {
          $self->SUPER::_handle_element_end($element);
      }
  }
  
  # required for Pod::Simple API
  sub start_document {
      my $self = shift;
      $self->SUPER::start_document();
      my $msg = $self->{USAGE_OPTIONS}->{-message}  or  return 1;
      my $out_fh = $self->output_fh();
      print $out_fh "$msg\n";
  }
  
  # required for old Pod::Parser API
  sub begin_pod {
      my $self = shift;
      $self->SUPER::begin_pod();  ## Have to call superclass
      my $msg = $self->{USAGE_OPTIONS}->{-message}  or  return 1;
      my $out_fh = $self->output_handle();
      print $out_fh "$msg\n";
  }
  
  sub preprocess_paragraph {
      my $self = shift;
      local $_ = shift;
      my $line = shift;
      ## See if this is a heading and we aren't printing the entire manpage.
      if (($self->{USAGE_OPTIONS}->{-verbose} < 2) && /^=head/) {
          ## Change the title of the SYNOPSIS section to USAGE
          s/^=head1\s+SYNOPSIS\s*$/=head1 USAGE/;
          ## Try to do some lowercasing instead of all-caps in headings
          s{([A-Z])([A-Z]+)}{((length($2) > 2) ? $1 : lc($1)) . lc($2)}ge;
          ## Use a colon to end all headings
          s/\s*$/:/  unless (/:\s*$/);
          $_ .= "\n";
      }
      return  $self->SUPER::preprocess_paragraph($_);
  }
  
  1; # keep require happy
  
  __END__
  
  =head1 NAME
  
  Pod::Usage, pod2usage() - print a usage message from embedded pod documentation
  
  =head1 SYNOPSIS
  
    use Pod::Usage
  
    my $message_text  = "This text precedes the usage message.";
    my $exit_status   = 2;          ## The exit status to use
    my $verbose_level = 0;          ## The verbose level to use
    my $filehandle    = \*STDERR;   ## The filehandle to write to
  
    pod2usage($message_text);
  
    pod2usage($exit_status);
  
    pod2usage( { -message => $message_text ,
                 -exitval => $exit_status  ,  
                 -verbose => $verbose_level,  
                 -output  => $filehandle } );
  
    pod2usage(   -msg     => $message_text ,
                 -exitval => $exit_status  ,  
                 -verbose => $verbose_level,  
                 -output  => $filehandle   );
  
    pod2usage(   -verbose => 2,
                 -noperldoc => 1  )
  
  =head1 ARGUMENTS
  
  B<pod2usage> should be given either a single argument, or a list of
  arguments corresponding to an associative array (a "hash"). When a single
  argument is given, it should correspond to exactly one of the following:
  
  =over 4
  
  =item *
  
  A string containing the text of a message to print I<before> printing
  the usage 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<-verbose>
  
  The desired level of "verboseness" to use when printing the usage
  message. If the corresponding value is 0, then only the "SYNOPSIS"
  section of the pod documentation is printed. If the corresponding value
  is 1, then the "SYNOPSIS" section, along with any section entitled
  "OPTIONS", "ARGUMENTS", or "OPTIONS AND ARGUMENTS" is printed.  If the
  corresponding value is 2 or more then the entire manpage is printed.
  
  The special verbosity level 99 requires to also specify the -sections
  parameter; then these sections are extracted and printed.
  
  =item C<-sections>
  
  A string representing a selection list for sections to be printed
  when -verbose is set to 99, e.g. C<"NAME|SYNOPSIS|DESCRIPTION|VERSION">.
  
  Alternatively, an array reference of section specifications can be used:
  
    pod2usage(-verbose => 99, 
              -sections => [ qw(fred fred/subsection) ] );
  
  =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>).
  
  =item C<-input>
  
  A reference to a filehandle, or the pathname of a file from which the
  invoking script's pod documentation should be read.  It defaults to the
  file indicated by C<$0> (C<$PROGRAM_NAME> for users of F<English.pm>).
  
  If you are calling B<pod2usage()> from a module and want to display
  that module's POD, you can use this:
  
    use Pod::Find qw(pod_where);
    pod2usage( -input => pod_where({-inc => 1}, __PACKAGE__) );
  
  =item C<-pathlist>
  
  A list of directory paths. If the input file does not exist, then it
  will be searched for in the given directory list (in the order the
  directories appear in the list). It defaults to the list of directories
  implied by C<$ENV{PATH}>. The list may be specified either by a reference
  to an array, or by a string of directory paths which use the same path
  separator as C<$ENV{PATH}> on your system (e.g., C<:> for Unix, C<;> for
  MSWin32 and DOS).
  
  =item C<-noperldoc>
  
  By default, Pod::Usage will call L<perldoc> when -verbose >= 2 is
  specified. This does not work well e.g. if the script was packed
  with L<PAR>. The -noperldoc option suppresses the external call to
  L<perldoc> and uses the simple text formatter (L<Pod::Text>) to 
  output the POD.
  
  =back
  
  =head2 Formatting base class
  
  The default text formatter is L<Pod::Text>.  The base class for Pod::Usage can
  be defined by pre-setting C<$Pod::Usage::Formatter> I<before>
  loading Pod::Usage, e.g.:
  
      BEGIN { $Pod::Usage::Formatter = 'Pod::Text::Termcap'; }
      use Pod::Usage qw(pod2usage);
  
  =head2 Pass-through options
  
  The following options are passed through to the underlying text formatter.
  See the manual pages of these modules for more information.
  
    alt code indent loose margin quotes sentence stderr utf8 width
  
  =head1 DESCRIPTION
  
  B<pod2usage> will print a usage message for the invoking script (using
  its embedded pod documentation) and then exit the script with the
  desired exit status. The usage message printed may have any one of three
  levels of "verboseness": If the verbose level is 0, then only a synopsis
  is printed. If the verbose level is 1, then the synopsis is printed
  along with a description (if present) of the command line options and
  arguments. If the verbose level is 2, then the entire manual page is
  printed.
  
  Unless they are explicitly specified, the default values for the exit
  status, verbose level, and output stream to use are determined as
  follows:
  
  =over 4
  
  =item *
  
  If neither the exit status nor the verbose level is specified, then the
  default is to use an exit status of 2 with a verbose level of 0.
  
  =item *
  
  If an exit status I<is> specified but the verbose level is I<not>, then the
  verbose level will default to 1 if the exit status is less than 2 and
  will default to 0 otherwise.
  
  =item *
  
  If an exit status is I<not> specified but verbose level I<is> given, then
  the exit status will default to 2 if the verbose level is 0 and will
  default to 1 otherwise.
  
  =item *
  
  If the exit status used is less than 2, then output is printed on
  C<STDOUT>.  Otherwise output is printed on C<STDERR>.
  
  =back
  
  Although the above may seem a bit confusing at first, it generally does
  "the right thing" in most situations.  This determination of the default
  values to use is based upon the following typical Unix conventions:
  
  =over 4
  
  =item *
  
  An exit status of 0 implies "success". For example, B<diff(1)> exits
  with a status of 0 if the two files have the same contents.
  
  =item *
  
  An exit status of 1 implies possibly abnormal, but non-defective, program
  termination.  For example, B<grep(1)> exits with a status of 1 if
  it did I<not> find a matching line for the given regular expression.
  
  =item *
  
  An exit status of 2 or more implies a fatal error. For example, B<ls(1)>
  exits with a status of 2 if you specify an illegal (unknown) option on
  the command line.
  
  =item *
  
  Usage messages issued as a result of bad command-line syntax should go
  to C<STDERR>.  However, usage messages issued due to an explicit request
  to print usage (like specifying B<-help> on the command line) should go
  to C<STDOUT>, just in case the user wants to pipe the output to a pager
  (such as B<more(1)>).
  
  =item *
  
  If program usage has been explicitly requested by the user, it is often
  desirable to exit with a status of 1 (as opposed to 0) after issuing
  the user-requested usage message.  It is also desirable to give a
  more verbose description of program usage in this case.
  
  =back
  
  B<pod2usage> doesn't force the above conventions upon you, but it will
  use them by default if you don't expressly tell it to do otherwise.  The
  ability of B<pod2usage()> to accept a single number or a string makes it
  convenient to use as an innocent looking error message handling function:
  
      use Pod::Usage;
      use Getopt::Long;
  
      ## Parse options
      GetOptions("help", "man", "flag1")  ||  pod2usage(2);
      pod2usage(1)  if ($opt_help);
      pod2usage(-verbose => 2)  if ($opt_man);
  
      ## Check for too many filenames
      pod2usage("$0: Too many files given.\n")  if (@ARGV > 1);
  
  Some user's however may feel that the above "economy of expression" is
  not particularly readable nor consistent and may instead choose to do
  something more like the following:
  
      use Pod::Usage;
      use Getopt::Long;
  
      ## Parse options
      GetOptions("help", "man", "flag1")  ||  pod2usage(-verbose => 0);
      pod2usage(-verbose => 1)  if ($opt_help);
      pod2usage(-verbose => 2)  if ($opt_man);
  
      ## Check for too many filenames
      pod2usage(-verbose => 2, -message => "$0: Too many files given.\n")
          if (@ARGV > 1);
  
  As with all things in Perl, I<there's more than one way to do it>, and
  B<pod2usage()> adheres to this philosophy.  If you are interested in
  seeing a number of different ways to invoke B<pod2usage> (although by no
  means exhaustive), please refer to L<"EXAMPLES">.
  
  =head1 EXAMPLES
  
  Each of the following invocations of C<pod2usage()> will print just the
  "SYNOPSIS" section to C<STDERR> and will exit with a status of 2:
  
      pod2usage();
  
      pod2usage(2);
  
      pod2usage(-verbose => 0);
  
      pod2usage(-exitval => 2);
  
      pod2usage({-exitval => 2, -output => \*STDERR});
  
      pod2usage({-verbose => 0, -output  => \*STDERR});
  
      pod2usage(-exitval => 2, -verbose => 0);
  
      pod2usage(-exitval => 2, -verbose => 0, -output => \*STDERR);
  
  Each of the following invocations of C<pod2usage()> will print a message
  of "Syntax error." (followed by a newline) to C<STDERR>, immediately
  followed by just the "SYNOPSIS" section (also printed to C<STDERR>) and
  will exit with a status of 2:
  
      pod2usage("Syntax error.");
  
      pod2usage(-message => "Syntax error.", -verbose => 0);
  
      pod2usage(-msg  => "Syntax error.", -exitval => 2);
  
      pod2usage({-msg => "Syntax error.", -exitval => 2, -output => \*STDERR});
  
      pod2usage({-msg => "Syntax error.", -verbose => 0, -output => \*STDERR});
  
      pod2usage(-msg  => "Syntax error.", -exitval => 2, -verbose => 0);
  
      pod2usage(-message => "Syntax error.",
                -exitval => 2,
                -verbose => 0,
                -output  => \*STDERR);
  
  Each of the following invocations of C<pod2usage()> will print the
  "SYNOPSIS" section and any "OPTIONS" and/or "ARGUMENTS" sections to
  C<STDOUT> and will exit with a status of 1:
  
      pod2usage(1);
  
      pod2usage(-verbose => 1);
  
      pod2usage(-exitval => 1);
  
      pod2usage({-exitval => 1, -output => \*STDOUT});
  
      pod2usage({-verbose => 1, -output => \*STDOUT});
  
      pod2usage(-exitval => 1, -verbose => 1);
  
      pod2usage(-exitval => 1, -verbose => 1, -output => \*STDOUT});
  
  Each of the following invocations of C<pod2usage()> will print the
  entire manual page to C<STDOUT> and will exit with a status of 1:
  
      pod2usage(-verbose  => 2);
  
      pod2usage({-verbose => 2, -output => \*STDOUT});
  
      pod2usage(-exitval  => 1, -verbose => 2);
  
      pod2usage({-exitval => 1, -verbose => 2, -output => \*STDOUT});
  
  =head2 Recommended Use
  
  Most scripts should print some type of usage message to C<STDERR> when a
  command line syntax error is detected. They should also provide an
  option (usually C<-H> or C<-help>) to print a (possibly more verbose)
  usage message to C<STDOUT>. Some scripts may even wish to go so far as to
  provide a means of printing their complete documentation to C<STDOUT>
  (perhaps by allowing a C<-man> option). The following complete example
  uses B<Pod::Usage> in combination with B<Getopt::Long> to do all of these
  things:
  
      use Getopt::Long;
      use Pod::Usage;
  
      my $man = 0;
      my $help = 0;
      ## Parse options and print usage if there is a syntax error,
      ## or if usage was explicitly requested.
      GetOptions('help|?' => \$help, man => \$man) or pod2usage(2);
      pod2usage(1) if $help;
      pod2usage(-verbose => 2) if $man;
  
      ## If no arguments were given, then allow STDIN to be used only
      ## if it's not connected to a terminal (otherwise print usage)
      pod2usage("$0: No files given.")  if ((@ARGV == 0) && (-t STDIN));
      __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
  
  =head1 CAVEATS
  
  By default, B<pod2usage()> will use C<$0> as the path to the pod input
  file.  Unfortunately, not all systems on which Perl runs will set C<$0>
  properly (although if C<$0> isn't found, B<pod2usage()> will search
  C<$ENV{PATH}> or else the list specified by the C<-pathlist> option).
  If this is the case for your system, you may need to explicitly specify
  the path to the pod docs for the invoking script using something
  similar to the following:
  
      pod2usage(-exitval => 2, -input => "/path/to/your/pod/docs");
  
  In the pathological case that a script is called via a relative path
  I<and> the script itself changes the current working directory
  (see L<perlfunc/chdir>) I<before> calling pod2usage, Pod::Usage will
  fail even on robust platforms. Don't do that. Or use L<FindBin> to locate
  the script:
  
      use FindBin;
      pod2usage(-input => $FindBin::Bin . "/" . $FindBin::Script);
  
  =head1 AUTHOR
  
  Please report bugs using L<http://rt.cpan.org>.
  
  Marek Rouchal E<lt>marekr@cpan.orgE<gt>
  
  Brad Appleton E<lt>bradapp@enteract.comE<gt>
  
  Based on code for B<Pod::Text::pod2text()> written by
  Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
  
  =head1 ACKNOWLEDGMENTS
  
  rjbs for refactoring Pod::Usage to not use Pod::Parser any more.
  
  Steven McDougall E<lt>swmcd@world.std.comE<gt> for his help and patience
  with re-writing this manpage.
  
  =head1 SEE ALSO
  
  B<Pod::Usage> is now a standalone distribution, depending on
  L<Pod::Text> which in turn depends on L<Pod::Simple>.
  
  L<Pod::Perldoc>, L<Getopt::Long>, L<Pod::Find>, L<FindBin>,
  L<Pod::Text>, L<Pod::Text::Termcap>, L<Pod::Simple>
  
  =cut
  
POD_USAGE

$fatpacked{"Text/CSV.pm"} = <<'TEXT_CSV';
  package Text::CSV;
  
  
  use strict;
  use Carp ();
  use vars qw( $VERSION $DEBUG );
  
  BEGIN {
      $VERSION = '1.32';
      $DEBUG   = 0;
  }
  
  # if use CSV_XS, requires version
  my $Module_XS  = 'Text::CSV_XS';
  my $Module_PP  = 'Text::CSV_PP';
  my $XS_Version = '0.99';
  
  my $Is_Dynamic = 0;
  
  # used in _load_xs and _load_pp
  my $Install_Dont_Die = 1; # When _load_xs fails to load XS, don't die.
  my $Install_Only     = 2; # Don't call _set_methods()
  
  
  my @PublicMethods = qw/
      version types quote_char escape_char sep_char eol always_quote binary allow_whitespace
      keep_meta_info allow_loose_quotes allow_loose_escapes verbatim meta_info is_quoted is_binary eof
      getline print parse combine fields string error_diag error_input status blank_is_undef empty_is_undef
      getline_hr column_names bind_columns auto_diag quote_space quote_null getline_all getline_hr_all
      is_missing quote_binary record_number print_hr
      PV IV NV
  /;
  #
  my @UndocumentedXSMethods = qw/Combine Parse SetDiag/;
  
  my @UndocumentedPPMethods = qw//; # Currently empty
  
  
  # Check the environment variable to decide worker module. 
  
  unless ($Text::CSV::Worker) {
      $Text::CSV::DEBUG and  Carp::carp("Check used worker module...");
  
      if ( exists $ENV{PERL_TEXT_CSV} ) {
          if ($ENV{PERL_TEXT_CSV} eq '0' or $ENV{PERL_TEXT_CSV} eq 'Text::CSV_PP') {
              _load_pp();
          }
          elsif ($ENV{PERL_TEXT_CSV} eq '1' or $ENV{PERL_TEXT_CSV} =~ /Text::CSV_XS\s*,\s*Text::CSV_PP/) {
              _load_xs($Install_Dont_Die) or _load_pp();
          }
          elsif ($ENV{PERL_TEXT_CSV} eq '2' or $ENV{PERL_TEXT_CSV} eq 'Text::CSV_XS') {
              _load_xs();
          }
          else {
              Carp::croak "The value of environmental variable 'PERL_TEXT_CSV' is invalid.";
          }
      }
      else {
          _load_xs($Install_Dont_Die) or _load_pp();
      }
  
  }
  
  
  
  sub import {
      my ($class, $option) = @_;
  }
  
  
  
  sub new { # normal mode
      my $proto = shift;
      my $class = ref($proto) || $proto;
  
      unless ( $proto ) { # for Text::CSV_XS/PP::new(0);
          return eval qq| $Text::CSV::Worker\::new( \$proto ) |;
      }
  
      #if (ref $_[0] and $_[0]->{module}) {
      #    Carp::croak("Can't set 'module' in non dynamic mode.");
      #}
  
      if ( my $obj = $Text::CSV::Worker->new(@_) ) {
          $obj->{_MODULE} = $Text::CSV::Worker;
          bless $obj, $class;
          return $obj;
      }
      else {
          return;
      }
  
  
  }
  
  
  sub require_xs_version { $XS_Version; }
  
  
  sub module {
      my $proto = shift;
      return   !ref($proto)            ? $Text::CSV::Worker
             :  ref($proto->{_MODULE}) ? ref($proto->{_MODULE}) : $proto->{_MODULE};
  }
  
  *backend = *module;
  
  
  sub is_xs {
      return $_[0]->module eq $Module_XS;
  }
  
  
  sub is_pp {
      return $_[0]->module eq $Module_PP;
  }
  
  
  sub is_dynamic { $Is_Dynamic; }
  
  
  sub AUTOLOAD {
      my $self = $_[0];
      my $attr = $Text::CSV::AUTOLOAD;
      $attr =~ s/.*:://;
  
      return if $attr =~ /^[A-Z]+$/;
      Carp::croak( "Can't locate method $attr" ) unless $attr =~ /^_/;
  
      my $pkg = $Text::CSV::Worker;
  
      my $method = "$pkg\::$attr";
  
      $Text::CSV::DEBUG and Carp::carp("'$attr' is private method, so try to autoload...");
  
      local $^W;
      no strict qw(refs);
  
      *{"Text::CSV::$attr"} = *{"$pkg\::$attr"};
  
      goto &$attr;
  }
  
  
  
  sub _load_xs {
      my $opt = shift;
  
      $Text::CSV::DEBUG and Carp::carp "Load $Module_XS.";
  
      eval qq| use $Module_XS $XS_Version |;
  
      if ($@) {
          if (defined $opt and $opt & $Install_Dont_Die) {
              $Text::CSV::DEBUG and Carp::carp "Can't load $Module_XS...($@)";
              return 0;
          }
          Carp::croak $@;
      }
  
      push @Text::CSV::ISA, 'Text::CSV_XS';
  
      unless (defined $opt and $opt & $Install_Only) {
          _set_methods( $Text::CSV::Worker = $Module_XS );
      }
  
      return 1;
  };
  
  
  sub _load_pp {
      my $opt = shift;
  
      $Text::CSV::DEBUG and Carp::carp "Load $Module_PP.";
  
      eval qq| require $Module_PP |;
      if ($@) {
          Carp::croak $@;
      }
  
      push @Text::CSV::ISA, 'Text::CSV_PP';
  
      unless (defined $opt and $opt & $Install_Only) {
          _set_methods( $Text::CSV::Worker = $Module_PP );
      }
  };
  
  
  
  
  sub _set_methods {
      my $class = shift;
  
      #return;
  
      local $^W;
      no strict qw(refs);
  
      for my $method (@PublicMethods) {
          *{"Text::CSV::$method"} = \&{"$class\::$method"};
      }
  
      if ($Text::CSV::Worker eq $Module_XS) {
          for my $method (@UndocumentedXSMethods) {
              *{"Text::CSV::$method"} = \&{"$Module_XS\::$method"};
          }
      }
  
      if ($Text::CSV::Worker eq $Module_PP) {
          for my $method (@UndocumentedPPMethods) {
              *{"Text::CSV::$method"} = \&{"$Module_PP\::$method"};
          }
      }
  
  }
  
  
  
  1;
  __END__
  
  =pod
  
  =head1 NAME
  
  Text::CSV - comma-separated values manipulator (using XS or PurePerl)
  
  
  =head1 SYNOPSIS
  
   use Text::CSV;
  
   my @rows;
   my $csv = Text::CSV->new ( { binary => 1 } )  # should set binary attribute.
                   or die "Cannot use CSV: ".Text::CSV->error_diag ();
   
   open my $fh, "<:encoding(utf8)", "test.csv" or die "test.csv: $!";
   while ( my $row = $csv->getline( $fh ) ) {
       $row->[2] =~ m/pattern/ or next; # 3rd field should match
       push @rows, $row;
   }
   $csv->eof or $csv->error_diag();
   close $fh;
  
   $csv->eol ("\r\n");
   
   open $fh, ">:encoding(utf8)", "new.csv" or die "new.csv: $!";
   $csv->print ($fh, $_) for @rows;
   close $fh or die "new.csv: $!";
   
   #
   # parse and combine style
   #
   
   $status = $csv->combine(@columns);    # combine columns into a string
   $line   = $csv->string();             # get the combined string
   
   $status  = $csv->parse($line);        # parse a CSV string into fields
   @columns = $csv->fields();            # get the parsed fields
   
   $status       = $csv->status ();      # get the most recent status
   $bad_argument = $csv->error_input (); # get the most recent bad argument
   $diag         = $csv->error_diag ();  # if an error occured, explains WHY
   
   $status = $csv->print ($io, $colref); # Write an array of fields
                                         # immediately to a file $io
   $colref = $csv->getline ($io);        # Read a line from file $io,
                                         # parse it and return an array
                                         # ref of fields
   $csv->column_names (@names);          # Set column names for getline_hr ()
   $ref = $csv->getline_hr ($io);        # getline (), but returns a hashref
   $eof = $csv->eof ();                  # Indicate if last parse or
                                         # getline () hit End Of File
   
   $csv->types(\@t_array);               # Set column types
  
  =head1 DESCRIPTION
  
  Text::CSV provides facilities for the composition and decomposition of
  comma-separated values using L<Text::CSV_XS> or its pure Perl version.
  
  An instance of the Text::CSV class can combine fields into a CSV string
  and parse a CSV string into fields.
  
  The module accepts either strings or files as input and can utilize any
  user-specified characters as delimiters, separators, and escapes so it is
  perhaps better called ASV (anything separated values) rather than just CSV.
  
  =head1 VERSION
  
      1.32
  
  This module is compatible with Text::CSV_XS B<0.99> and later.
  (except for diag_verbose and allow_unquoted_escape)
  
  =head2 Embedded newlines
  
  B<Important Note>: The default behavior is to only accept ASCII characters.
  This means that fields can not contain newlines. If your data contains
  newlines embedded in fields, or characters above 0x7e (tilde), or binary data,
  you *must* set C<< binary => 1 >> in the call to C<new ()>.  To cover the widest
  range of parsing options, you will always want to set binary.
  
  But you still have the problem that you have to pass a correct line to the
  C<parse ()> method, which is more complicated from the usual point of
  usage:
  
   my $csv = Text::CSV->new ({ binary => 1, eol => $/ });
   while (<>) {		#  WRONG!
       $csv->parse ($_);
       my @fields = $csv->fields ();
  
  will break, as the while might read broken lines, as that does not care
  about the quoting. If you need to support embedded newlines, the way to go
  is either
  
   my $csv = Text::CSV->new ({ binary => 1, eol => $/ });
   while (my $row = $csv->getline (*ARGV)) {
       my @fields = @$row;
  
  or, more safely in perl 5.6 and up
  
   my $csv = Text::CSV->new ({ binary => 1, eol => $/ });
   open my $io, "<", $file or die "$file: $!";
   while (my $row = $csv->getline ($io)) {
       my @fields = @$row;
  
  =head2 Unicode (UTF8)
  
  On parsing (both for C<getline ()> and C<parse ()>), if the source is
  marked being UTF8, then all fields that are marked binary will also be
  be marked UTF8.
  
  For complete control over encoding, please use L<Text::CSV::Encoded>:
  
      use Text::CSV::Encoded;
      my $csv = Text::CSV::Encoded->new ({
          encoding_in  => "iso-8859-1", # the encoding comes into   Perl
          encoding_out => "cp1252",     # the encoding comes out of Perl
      });
  
      $csv = Text::CSV::Encoded->new ({ encoding  => "utf8" });
      # combine () and print () accept *literally* utf8 encoded data
      # parse () and getline () return *literally* utf8 encoded data
  
      $csv = Text::CSV::Encoded->new ({ encoding  => undef }); # default
      # combine () and print () accept UTF8 marked data
      # parse () and getline () return UTF8 marked data
  
  On combining (C<print ()> and C<combine ()>), if any of the combining
  fields was marked UTF8, the resulting string will be marked UTF8.
  
  Note however if the backend module is Text::CSV_XS,
  that all fields C<before> the first field that was marked UTF8
  and contained 8-bit characters that were not upgraded to UTF8, these
  will be bytes in the resulting string too, causing errors. If you pass
  data of different encoding, or you don't know if there is different
  encoding, force it to be upgraded before you pass them on:
  
      # backend = Text::CSV_XS
      $csv->print ($fh, [ map { utf8::upgrade (my $x = $_); $x } @data ]);
  
  =head1 SPECIFICATION
  
  See to L<Text::CSV_XS/SPECIFICATION>.
  
  =head1 FUNCTIONS
  
  These methods are common between XS and puer Perl version.
  Most of the document was shamelessly copied and replaced from Text::CSV_XS.
  
  =head2 version ()
  
  (Class method) Returns the current backend module version.
  If you want the module version, you can use the C<VERSION> method,
  
   print Text::CSV->VERSION;      # This module version
   print Text::CSV->version;      # The version of the worker module
                                  # same as Text::CSV->backend->version
  
  =head2 new (\%attr)
  
  (Class method) Returns a new instance of Text::CSV_XS. The objects
  attributes are described by the (optional) hash ref C<\%attr>.
  Currently the following attributes are available:
  
  =over 4
  
  =item eol
  
  An end-of-line string to add to rows. C<undef> is replaced with an
  empty string. The default is C<$\>. Common values for C<eol> are
  C<"\012"> (Line Feed) or C<"\015\012"> (Carriage Return, Line Feed).
  Cannot be longer than 7 (ASCII) characters.
  
  If both C<$/> and C<eol> equal C<"\015">, parsing lines that end on
  only a Carriage Return without Line Feed, will be C<parse>d correct.
  Line endings, whether in C<$/> or C<eol>, other than C<undef>,
  C<"\n">, C<"\r\n">, or C<"\r"> are not (yet) supported for parsing.
  
  =item sep_char
  
  The char used for separating fields, by default a comma. (C<,>).
  Limited to a single-byte character, usually in the range from 0x20
  (space) to 0x7e (tilde).
  
  The separation character can not be equal to the quote character.
  The separation character can not be equal to the escape character.
  
  See also L<Text::CSV_XS/CAVEATS>
  
  =item allow_whitespace
  
  When this option is set to true, whitespace (TAB's and SPACE's)
  surrounding the separation character is removed when parsing. If
  either TAB or SPACE is one of the three major characters C<sep_char>,
  C<quote_char>, or C<escape_char> it will not be considered whitespace.
  
  So lines like:
  
    1 , "foo" , bar , 3 , zapp
  
  are now correctly parsed, even though it violates the CSV specs.
  
  Note that B<all> whitespace is stripped from start and end of each
  field. That would make it more a I<feature> than a way to be able
  to parse bad CSV lines, as
  
   1,   2.0,  3,   ape  , monkey
  
  will now be parsed as
  
   ("1", "2.0", "3", "ape", "monkey")
  
  even if the original line was perfectly sane CSV.
  
  =item blank_is_undef
  
  Under normal circumstances, CSV data makes no distinction between
  quoted- and unquoted empty fields. They both end up in an empty
  string field once read, so
  
   1,"",," ",2
  
  is read as
  
   ("1", "", "", " ", "2")
  
  When I<writing> CSV files with C<always_quote> set, the unquoted empty
  field is the result of an undefined value. To make it possible to also
  make this distinction when reading CSV data, the C<blank_is_undef> option
  will cause unquoted empty fields to be set to undef, causing the above to
  be parsed as
  
   ("1", "", undef, " ", "2")
  
  =item empty_is_undef
  
  Going one step further than C<blank_is_undef>, this attribute converts
  all empty fields to undef, so
  
   1,"",," ",2
  
  is read as
  
   (1, undef, undef, " ", 2)
  
  Note that this only effects fields that are I<really> empty, not fields
  that are empty after stripping allowed whitespace. YMMV.
  
  =item quote_char
  
  The char used for quoting fields containing blanks, by default the
  double quote character (C<">). A value of undef suppresses
  quote chars. (For simple cases only).
  Limited to a single-byte character, usually in the range from 0x20
  (space) to 0x7e (tilde).
  
  The quote character can not be equal to the separation character.
  
  =item allow_loose_quotes
  
  By default, parsing fields that have C<quote_char> characters inside
  an unquoted field, like
  
   1,foo "bar" baz,42
  
  would result in a parse error. Though it is still bad practice to
  allow this format, we cannot help there are some vendors that make
  their applications spit out lines styled like this.
  
  In case there is B<really> bad CSV data, like
  
   1,"foo "bar" baz",42
  
  or
  
   1,""foo bar baz"",42
  
  there is a way to get that parsed, and leave the quotes inside the quoted
  field as-is. This can be achieved by setting C<allow_loose_quotes> B<AND>
  making sure that the C<escape_char> is I<not> equal to C<quote_char>.
  
  =item escape_char
  
  The character used for escaping certain characters inside quoted fields.
  Limited to a single-byte character, usually in the range from 0x20
  (space) to 0x7e (tilde).
  
  The C<escape_char> defaults to being the literal double-quote mark (C<">)
  in other words, the same as the default C<quote_char>. This means that
  doubling the quote mark in a field escapes it:
  
    "foo","bar","Escape ""quote mark"" with two ""quote marks""","baz"
  
  If you change the default quote_char without changing the default
  escape_char, the escape_char will still be the quote mark.  If instead
  you want to escape the quote_char by doubling it, you will need to change
  the escape_char to be the same as what you changed the quote_char to.
  
  The escape character can not be equal to the separation character.
  
  =item allow_loose_escapes
  
  By default, parsing fields that have C<escape_char> characters that
  escape characters that do not need to be escaped, like:
  
   my $csv = Text::CSV->new ({ escape_char => "\\" });
   $csv->parse (qq{1,"my bar\'s",baz,42});
  
  would result in a parse error. Though it is still bad practice to
  allow this format, this option enables you to treat all escape character
  sequences equal.
  
  =item binary
  
  If this attribute is TRUE, you may use binary characters in quoted fields,
  including line feeds, carriage returns and NULL bytes. (The latter must
  be escaped as C<"0>.) By default this feature is off.
  
  If a string is marked UTF8, binary will be turned on automatically when
  binary characters other than CR or NL are encountered. Note that a simple
  string like C<"\x{00a0}"> might still be binary, but not marked UTF8, so
  setting C<{ binary =E<gt> 1 }> is still a wise option.
  
  =item types
  
  A set of column types; this attribute is immediately passed to the
  I<types> method below. You must not set this attribute otherwise,
  except for using the I<types> method. For details see the description
  of the I<types> method below.
  
  =item always_quote
  
  By default the generated fields are quoted only, if they need to, for
  example, if they contain the separator. If you set this attribute to
  a TRUE value, then all defined fields will be quoted. This is typically
  easier to handle in external applications.
  
  =item quote_space
  
  By default, a space in a field would trigger quotation. As no rule
  exists this to be forced in CSV, nor any for the opposite, the default
  is true for safety. You can exclude the space from this trigger by
  setting this option to 0.
  
  =item quote_null
  
  By default, a NULL byte in a field would be escaped. This attribute
  enables you to treat the NULL byte as a simple binary character in
  binary mode (the C<{ binary =E<gt> 1 }> is set). The default is true.
  You can prevent NULL escapes by setting this attribute to 0.
  
  =item quote_binary
  
  By default,  all "unsafe" bytes inside a string cause the combined field to
  be quoted. By setting this attribute to 0, you can disable that trigger for
  bytes >= 0x7f.
  
  =item keep_meta_info
  
  By default, the parsing of input lines is as simple and fast as
  possible. However, some parsing information - like quotation of
  the original field - is lost in that process. Set this flag to
  true to be able to retrieve that information after parsing with
  the methods C<meta_info ()>, C<is_quoted ()>, and C<is_binary ()>
  described below.  Default is false.
  
  =item verbatim
  
  This is a quite controversial attribute to set, but it makes hard
  things possible.
  
  The basic thought behind this is to tell the parser that the normally
  special characters newline (NL) and Carriage Return (CR) will not be
  special when this flag is set, and be dealt with as being ordinary
  binary characters. This will ease working with data with embedded
  newlines.
  
  When C<verbatim> is used with C<getline ()>, C<getline ()>
  auto-chomp's every line.
  
  Imagine a file format like
  
    M^^Hans^Janssen^Klas 2\n2A^Ja^11-06-2007#\r\n
  
  where, the line ending is a very specific "#\r\n", and the sep_char
  is a ^ (caret). None of the fields is quoted, but embedded binary
  data is likely to be present. With the specific line ending, that
  shouldn not be too hard to detect.
  
  By default, Text::CSV' parse function however is instructed to only
  know about "\n" and "\r" to be legal line endings, and so has to deal
  with the embedded newline as a real end-of-line, so it can scan the next
  line if binary is true, and the newline is inside a quoted field.
  With this attribute however, we can tell parse () to parse the line
  as if \n is just nothing more than a binary character.
  
  For parse () this means that the parser has no idea about line ending
  anymore, and getline () chomps line endings on reading.
  
  =item auto_diag
  
  Set to true will cause C<error_diag ()> to be automatically be called
  in void context upon errors.
  
  If set to a value greater than 1, it will die on errors instead of
  warn.
  
  To check future plans and a difference in XS version,
  please see to L<Text::CSV_XS/auto_diag>.
  
  =back
  
  To sum it up,
  
   $csv = Text::CSV->new ();
  
  is equivalent to
  
   $csv = Text::CSV->new ({
       quote_char          => '"',
       escape_char         => '"',
       sep_char            => ',',
       eol                 => $\,
       always_quote        => 0,
       quote_space         => 1,
       quote_null          => 1,
       binary              => 0,
       keep_meta_info      => 0,
       allow_loose_quotes  => 0,
       allow_loose_escapes => 0,
       allow_whitespace    => 0,
       blank_is_undef      => 0,
       empty_is_undef      => 0,
       verbatim            => 0,
       auto_diag           => 0,
       });
  
  For all of the above mentioned flags, there is an accessor method
  available where you can inquire for the current value, or change
  the value
  
   my $quote = $csv->quote_char;
   $csv->binary (1);
  
  It is unwise to change these settings halfway through writing CSV
  data to a stream. If however, you want to create a new stream using
  the available CSV object, there is no harm in changing them.
  
  If the C<new ()> constructor call fails, it returns C<undef>, and makes
  the fail reason available through the C<error_diag ()> method.
  
   $csv = Text::CSV->new ({ ecs_char => 1 }) or
       die "" . Text::CSV->error_diag ();
  
  C<error_diag ()> will return a string like
  
   "INI - Unknown attribute 'ecs_char'"
  
  =head2 print
  
   $status = $csv->print ($io, $colref);
  
  Similar to C<combine () + string () + print>, but more efficient. It
  expects an array ref as input (not an array!) and the resulting string is
  not really created (XS version), but immediately written to the I<$io> object, typically
  an IO handle or any other object that offers a I<print> method. Note, this
  implies that the following is wrong in perl 5.005_xx and older:
  
   open FILE, ">", "whatever";
   $status = $csv->print (\*FILE, $colref);
  
  as in perl 5.005 and older, the glob C<\*FILE> is not an object, thus it
  does not have a print method. The solution is to use an IO::File object or
  to hide the glob behind an IO::Wrap object. See L<IO::File> and L<IO::Wrap>
  for details.
  
  For performance reasons the print method doesn't create a result string.
  (If its backend is PP version, result strings are created internally.)
  In particular the I<$csv-E<gt>string ()>, I<$csv-E<gt>status ()>,
  I<$csv->fields ()> and I<$csv-E<gt>error_input ()> methods are meaningless
  after executing this method.
  
  =head2 combine
  
   $status = $csv->combine (@columns);
  
  This object function constructs a CSV string from the arguments, returning
  success or failure.  Failure can result from lack of arguments or an argument
  containing an invalid character.  Upon success, C<string ()> can be called to
  retrieve the resultant CSV string.  Upon failure, the value returned by
  C<string ()> is undefined and C<error_input ()> can be called to retrieve an
  invalid argument.
  
  =head2 string
  
   $line = $csv->string ();
  
  This object function returns the input to C<parse ()> or the resultant CSV
  string of C<combine ()>, whichever was called more recently.
  
  =head2 getline
  
   $colref = $csv->getline ($io);
  
  This is the counterpart to print, like parse is the counterpart to
  combine: It reads a row from the IO object $io using $io->getline ()
  and parses this row into an array ref. This array ref is returned
  by the function or undef for failure.
  
  When fields are bound with C<bind_columns ()>, the return value is a
  reference to an empty list.
  
  The I<$csv-E<gt>string ()>, I<$csv-E<gt>fields ()> and I<$csv-E<gt>status ()>
  methods are meaningless, again.
  
  =head2 getline_all
  
   $arrayref = $csv->getline_all ($io);
   $arrayref = $csv->getline_all ($io, $offset);
   $arrayref = $csv->getline_all ($io, $offset, $length);
  
  This will return a reference to a list of C<getline ($io)> results.
  In this call, C<keep_meta_info> is disabled. If C<$offset> is negative,
  as with C<splice ()>, only the last C<abs ($offset)> records of C<$io>
  are taken into consideration.
  
  Given a CSV file with 10 lines:
  
   lines call
   ----- ---------------------------------------------------------
   0..9  $csv->getline_all ($io)         # all
   0..9  $csv->getline_all ($io,  0)     # all
   8..9  $csv->getline_all ($io,  8)     # start at 8
   -     $csv->getline_all ($io,  0,  0) # start at 0 first 0 rows
   0..4  $csv->getline_all ($io,  0,  5) # start at 0 first 5 rows
   4..5  $csv->getline_all ($io,  4,  2) # start at 4 first 2 rows
   8..9  $csv->getline_all ($io, -2)     # last 2 rows
   6..7  $csv->getline_all ($io, -4,  2) # first 2 of last  4 rows
  
  =head2 parse
  
   $status = $csv->parse ($line);
  
  This object function decomposes a CSV string into fields, returning
  success or failure.  Failure can result from a lack of argument or the
  given CSV string is improperly formatted.  Upon success, C<fields ()> can
  be called to retrieve the decomposed fields .  Upon failure, the value
  returned by C<fields ()> is undefined and C<error_input ()> can be called
  to retrieve the invalid argument.
  
  You may use the I<types ()> method for setting column types. See the
  description below.
  
  =head2 getline_hr
  
  The C<getline_hr ()> and C<column_names ()> methods work together to allow
  you to have rows returned as hashrefs. You must call C<column_names ()>
  first to declare your column names.
  
   $csv->column_names (qw( code name price description ));
   $hr = $csv->getline_hr ($io);
   print "Price for $hr->{name} is $hr->{price} EUR\n";
  
  C<getline_hr ()> will croak if called before C<column_names ()>.
  
  =head2 getline_hr_all
  
   $arrayref = $csv->getline_hr_all ($io);
   $arrayref = $csv->getline_hr_all ($io, $offset);
   $arrayref = $csv->getline_hr_all ($io, $offset, $length);
  
  This will return a reference to a list of C<getline_hr ($io)> results.
  In this call, C<keep_meta_info> is disabled.
  
  =head2 column_names
  
  Set the keys that will be used in the C<getline_hr ()> calls. If no keys
  (column names) are passed, it'll return the current setting.
  
  C<column_names ()> accepts a list of scalars (the column names) or a
  single array_ref, so you can pass C<getline ()>
  
    $csv->column_names ($csv->getline ($io));
  
  C<column_names ()> does B<no> checking on duplicates at all, which might
  lead to unwanted results. Undefined entries will be replaced with the
  string C<"\cAUNDEF\cA">, so
  
    $csv->column_names (undef, "", "name", "name");
    $hr = $csv->getline_hr ($io);
  
  Will set C<$hr->{"\cAUNDEF\cA"}> to the 1st field, C<$hr->{""}> to the
  2nd field, and C<$hr->{name}> to the 4th field, discarding the 3rd field.
  
  C<column_names ()> croaks on invalid arguments.
  
  =head2 bind_columns
  
  Takes a list of references to scalars to store the fields fetched
  C<getline ()> in. When you don't pass enough references to store the
  fetched fields in, C<getline ()> will fail. If you pass more than there are
  fields to return, the remaining references are left untouched.
  
    $csv->bind_columns (\$code, \$name, \$price, \$description);
    while ($csv->getline ($io)) {
        print "The price of a $name is \x{20ac} $price\n";
        }
  
  =head2 eof
  
   $eof = $csv->eof ();
  
  If C<parse ()> or C<getline ()> was used with an IO stream, this
  method will return true (1) if the last call hit end of file, otherwise
  it will return false (''). This is useful to see the difference between
  a failure and end of file.
  
  =head2 types
  
   $csv->types (\@tref);
  
  This method is used to force that columns are of a given type. For
  example, if you have an integer column, two double columns and a
  string column, then you might do a
  
   $csv->types ([Text::CSV::IV (),
                 Text::CSV::NV (),
                 Text::CSV::NV (),
                 Text::CSV::PV ()]);
  
  Column types are used only for decoding columns, in other words
  by the I<parse ()> and I<getline ()> methods.
  
  You can unset column types by doing a
  
   $csv->types (undef);
  
  or fetch the current type settings with
  
   $types = $csv->types ();
  
  =over 4
  
  =item IV
  
  Set field type to integer.
  
  =item NV
  
  Set field type to numeric/float.
  
  =item PV
  
  Set field type to string.
  
  =back
  
  =head2 fields
  
   @columns = $csv->fields ();
  
  This object function returns the input to C<combine ()> or the resultant
  decomposed fields of C successful <parse ()>, whichever was called more
  recently.
  
  Note that the return value is undefined after using C<getline ()>, which
  does not fill the data structures returned by C<parse ()>.
  
  =head2 meta_info
  
   @flags = $csv->meta_info ();
  
  This object function returns the flags of the input to C<combine ()> or
  the flags of the resultant decomposed fields of C<parse ()>, whichever
  was called more recently.
  
  For each field, a meta_info field will hold flags that tell something about
  the field returned by the C<fields ()> method or passed to the C<combine ()>
  method. The flags are bit-wise-or'd like:
  
  =over 4
  
  =item 0x0001
  
  The field was quoted.
  
  =item 0x0002
  
  The field was binary.
  
  =back
  
  See the C<is_*** ()> methods below.
  
  =head2 is_quoted
  
    my $quoted = $csv->is_quoted ($column_idx);
  
  Where C<$column_idx> is the (zero-based) index of the column in the
  last result of C<parse ()>.
  
  This returns a true value if the data in the indicated column was
  enclosed in C<quote_char> quotes. This might be important for data
  where C<,20070108,> is to be treated as a numeric value, and where
  C<,"20070108",> is explicitly marked as character string data.
  
  =head2 is_binary
  
    my $binary = $csv->is_binary ($column_idx);
  
  Where C<$column_idx> is the (zero-based) index of the column in the
  last result of C<parse ()>.
  
  This returns a true value if the data in the indicated column
  contained any byte in the range [\x00-\x08,\x10-\x1F,\x7F-\xFF]
  
  =head2 is_missing
  
    my $missing = $csv->is_missing ($column_idx);
  
  Where C<$column_idx> is the (zero-based) index of the column in the last
  result of L</getline_hr>.
  
   while (my $hr = $csv->getline_hr ($fh)) {
       $csv->is_missing (0) and next; # This was an empty line
   }
  
  When using L</getline_hr> for parsing, it is impossible to tell if the
  fields are C<undef> because they where not filled in the CSV stream or
  because they were not read at all, as B<all> the fields defined by
  L</column_names> are set in the hash-ref. If you still need to know if all
  fields in each row are provided, you should enable C<keep_meta_info> so you
  can check the flags.
  
  =head2 status
  
   $status = $csv->status ();
  
  This object function returns success (or failure) of C<combine ()> or
  C<parse ()>, whichever was called more recently.
  
  =head2 error_input
  
   $bad_argument = $csv->error_input ();
  
  This object function returns the erroneous argument (if it exists) of
  C<combine ()> or C<parse ()>, whichever was called more recently.
  
  =head2 error_diag
  
   Text::CSV->error_diag ();
   $csv->error_diag ();
   $error_code   = 0  + $csv->error_diag ();
   $error_str    = "" . $csv->error_diag ();
   ($cde, $str, $pos) = $csv->error_diag ();
  
  If (and only if) an error occured, this function returns the diagnostics
  of that error.
  
  If called in void context, it will print the internal error code and the
  associated error message to STDERR.
  
  If called in list context, it will return the error code and the error
  message in that order. If the last error was from parsing, the third
  value returned is the best guess at the location within the line that was
  being parsed. It's value is 1-based.
  
  Note: C<$pos> returned by the backend Text::CSV_PP does not show
  the error point in many cases (see to the below line).
  It is for conscience's sake in using Text::CSV_PP.
  
  If called in scalar context, it will return the diagnostics in a single
  scalar, a-la $!. It will contain the error code in numeric context, and
  the diagnostics message in string context.
  
  Depending on the used worker module, returned diagnostics is diffferent.
  
  Text::CSV_XS parses csv strings by dividing one character while Text::CSV_PP
  by using the regular expressions. That difference makes the different cause
  of the failure.
  
  When called as a class method or a direct function call, the error diag
  is that of the last C<new ()> call.
  
  =head2 record_number
  
    $recno = $csv->record_number ();
  
  Returns the records parsed by this csv instance. This value should be more
  accurate than C<$.> when embedded newlines come in play. Records written by
  this instance are not counted.
  
  =head2 SetDiag
  
   $csv->SetDiag (0);
  
  Use to reset the diagnostics if you are dealing with errors.
  
  =head2 Some methods are Text::CSV only.
  
  =over
  
  =item backend
  
  Returns the backend module name called by Text::CSV.
  C<module> is an alias.
  
  
  =item is_xs
  
  Returns true value if Text::CSV or the object uses XS module as worker.
  
  =item is_pp
  
  Returns true value if Text::CSV or the object uses pure-Perl module as worker.
  
  
  =back
  
  
  =head1 DIAGNOSTICS
  
  If an error occured, $csv->error_diag () can be used to get more information
  on the cause of the failure. Note that for speed reasons, the internal value
  is never cleared on success, so using the value returned by error_diag () in
  normal cases - when no error occured - may cause unexpected results.
  
  This function changes depending on the used module (XS or PurePerl).
  
  See to L<Text::CSV_XS/DIAGNOSTICS> and L<Text::CSV_PP/DIAGNOSTICS>.
  
  
  
  =head2 HISTORY AND WORKER MODULES
  
  This module, L<Text::CSV> was firstly written by Alan Citterman which could deal with
  B<only ascii characters>. Then, Jochen Wiedmann wrote L<Text::CSV_XS> which has
  the B<binary mode>. This XS version is maintained by H.Merijn Brand and L<Text::CSV_PP>
  written by Makamaka was pure-Perl version of Text::CSV_XS.
  
  Now, Text::CSV was rewritten by Makamaka and become a wrapper to Text::CSV_XS or Text::CSV_PP.
  Text::CSV_PP will be bundled in this distribution.
  
  When you use Text::CSV, it calls a backend worker module - L<Text::CSV_XS> or L<Text::CSV_PP>.
  By default, Text::CSV tries to use Text::CSV_XS which must be complied and installed properly.
  If this call is fail, Text::CSV uses L<Text::CSV_PP>.
  
  The required Text::CSV_XS version is I<0.41> in Text::CSV version 1.03.
  
  If you set an enviornment variable C<PERL_TEXT_CSV>, The calling action will be changed.
  
  =over
  
  =item PERL_TEXT_CSV = 0
  
  =item PERL_TEXT_CSV = 'Text::CSV_PP'
  
  Always use Text::CSV_PP
  
  =item PERL_TEXT_CSV = 1
  
  =item PERL_TEXT_CSV = 'Text::CSV_XS,Text::CSV_PP'
  
  (The default) Use compiled Text::CSV_XS if it is properly compiled & installed,
  otherwise use Text::CSV_PP
  
  =item PERL_TEXT_CSV = 2
  
  =item PERL_TEXT_CSV = 'Text::CSV_XS'
  
  Always use compiled Text::CSV_XS, die if it isn't properly compiled & installed.
  
  =back
  
  These ideas come from L<DBI::PurePerl> mechanism.
  
  example:
  
    BEGIN { $ENV{PERL_TEXT_CSV} = 0 }
    use Text::CSV; # always uses Text::CSV_PP
  
  
  In future, it may be able to specify another module.
  
  =head1 TODO
  
  =over
  
  =item Wrapper mechanism
  
  Currently the wrapper mechanism is to change symbolic table for speed.
  
   for my $method (@PublicMethods) {
       *{"Text::CSV::$method"} = \&{"$class\::$method"};
   }
  
  But how about it - calling worker module object?
  
   sub parse {
       my $self = shift;
       $self->{_WORKER_OBJECT}->parse(@_); # XS or PP CSV object
   }
  
  
  =back
  
  See to L<Text::CSV_XS/TODO> and L<Text::CSV_PP/TODO>.
  
  
  =head1 SEE ALSO
  
  L<Text::CSV_PP>, L<Text::CSV_XS> and L<Text::CSV::Encoded>.
  
  
  =head1 AUTHORS and MAINTAINERS
  
  Alan Citterman F<E<lt>alan[at]mfgrtl.comE<gt>> wrote the original Perl
  module. Please don't send mail concerning Text::CSV to Alan, as
  he's not a present maintainer.
  
  Jochen Wiedmann F<E<lt>joe[at]ispsoft.deE<gt>> rewrote the encoding and
  decoding in C by implementing a simple finite-state machine and added
  the variable quote, escape and separator characters, the binary mode
  and the print and getline methods. See ChangeLog releases 0.10 through
  0.23.
  
  H.Merijn Brand F<E<lt>h.m.brand[at]xs4all.nlE<gt>> cleaned up the code,
  added the field flags methods, wrote the major part of the test suite,
  completed the documentation, fixed some RT bugs. See ChangeLog releases
  0.25 and on.
  
  Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt> wrote Text::CSV_PP
  which is the pure-Perl version of Text::CSV_XS.
  
  New Text::CSV (since 0.99) is maintained by Makamaka.
  
  
  =head1 COPYRIGHT AND LICENSE
  
  Text::CSV
  
  Copyright (C) 1997 Alan Citterman. All rights reserved.
  Copyright (C) 2007-2009 Makamaka Hannyaharamitu.
  
  
  Text::CSV_PP:
  
  Copyright (C) 2005-2013 Makamaka Hannyaharamitu.
  
  
  Text:CSV_XS:
  
  Copyright (C) 2007-2013 H.Merijn Brand for PROCURA B.V.
  Copyright (C) 1998-2001 Jochen Wiedmann. All rights reserved.
  Portions Copyright (C) 1997 Alan Citterman. All rights reserved.
  
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself. 
  
  =cut
TEXT_CSV

$fatpacked{"Text/CSV_PP.pm"} = <<'TEXT_CSV_PP';
  package Text::CSV_PP;
  
  ################################################################################
  #
  # Text::CSV_PP - Text::CSV_XS compatible pure-Perl module
  #
  ################################################################################
  require 5.005;
  
  use strict;
  use vars qw($VERSION);
  use Carp ();
  
  $VERSION = '1.31';
  
  sub PV  { 0 }
  sub IV  { 1 }
  sub NV  { 2 }
  
  sub IS_QUOTED () { 0x0001; }
  sub IS_BINARY () { 0x0002; }
  sub IS_MISSING () { 0x0010; }
  
  
  my $ERRORS = {
          # PP and XS
          1000 => "INI - constructor failed",
          1001 => "sep_char is equal to quote_char or escape_char",
          1002 => "INI - allow_whitespace with escape_char or quote_char SP or TAB",
          1003 => "INI - \r or \n in main attr not allowed",
  
          2010 => "ECR - QUO char inside quotes followed by CR not part of EOL",
          2011 => "ECR - Characters after end of quoted field",
  
          2021 => "EIQ - NL char inside quotes, binary off",
          2022 => "EIQ - CR char inside quotes, binary off",
          2025 => "EIQ - Loose unescaped escape",
          2026 => "EIQ - Binary character inside quoted field, binary off",
          2027 => "EIQ - Quoted field not terminated",
  
          2030 => "EIF - NL char inside unquoted verbatim, binary off",
          2031 => "EIF - CR char is first char of field, not part of EOL",
          2032 => "EIF - CR char inside unquoted, not part of EOL",
          2034 => "EIF - Loose unescaped quote",
          2037 => "EIF - Binary character in unquoted field, binary off",
  
          2110 => "ECB - Binary character in Combine, binary off",
  
          2200 => "EIO - print to IO failed. See errno",
  
          # PP Only Error
          4002 => "EIQ - Unescaped ESC in quoted field",
          4003 => "EIF - ESC CR",
          4004 => "EUF - ",
  
          # Hash-Ref errors
          3001 => "EHR - Unsupported syntax for column_names ()",
          3002 => "EHR - getline_hr () called before column_names ()",
          3003 => "EHR - bind_columns () and column_names () fields count mismatch",
          3004 => "EHR - bind_columns () only accepts refs to scalars",
          3006 => "EHR - bind_columns () did not pass enough refs for parsed fields",
          3007 => "EHR - bind_columns needs refs to writable scalars",
          3008 => "EHR - unexpected error in bound fields",
          3009 => "EHR - print_hr () called before column_names ()",
          3010 => "EHR - print_hr () called with invalid arguments",
  
          0    => "",
  };
  
  
  my $last_new_error = '';
  my $last_new_err_num;
  
  my %def_attr = (
      quote_char          => '"',
      escape_char         => '"',
      sep_char            => ',',
      eol                 => defined $\ ? $\ : '',
      always_quote        => 0,
      binary              => 0,
      keep_meta_info      => 0,
      allow_loose_quotes  => 0,
      allow_loose_escapes => 0,
      allow_unquoted_escape => 0,
      allow_whitespace    => 0,
      chomp_verbatim      => 0,
      types               => undef,
      verbatim            => 0,
      blank_is_undef      => 0,
      empty_is_undef      => 0,
      auto_diag           => 0,
      quote_space         => 1,
      quote_null          => 1,
      quote_binary        => 1,
      diag_verbose        => 0,
  
      _EOF                => 0,
      _RECNO              => 0,
      _STATUS             => undef,
      _FIELDS             => undef,
      _FFLAGS             => undef,
      _STRING             => undef,
      _ERROR_INPUT        => undef,
      _ERROR_DIAG         => undef,
  
      _COLUMN_NAMES       => undef,
      _BOUND_COLUMNS      => undef,
  );
  
  
  BEGIN {
      if ( $] < 5.006 ) {
          $INC{'bytes.pm'} = 1 unless $INC{'bytes.pm'}; # dummy
          no strict 'refs';
          *{"utf8::is_utf8"} = sub { 0; };
          *{"utf8::decode"}  = sub { };
      }
      elsif ( $] < 5.008 ) {
          no strict 'refs';
          *{"utf8::is_utf8"} = sub { 0; };
          *{"utf8::decode"}  = sub { };
      }
      elsif ( !defined &utf8::is_utf8 ) {
         require Encode;
         *utf8::is_utf8 = *Encode::is_utf8;
      }
  
      eval q| require Scalar::Util |;
      if ( $@ ) {
          eval q| require B |;
          if ( $@ ) {
              Carp::croak $@;
          }
          else {
              *Scalar::Util::readonly = sub (\$) {
                  my $b = B::svref_2object( $_[0] );
                  $b->FLAGS & 0x00800000; # SVf_READONLY?
              }
          }
      }
  }
  
  ################################################################################
  # version
  ################################################################################
  sub version {
      return $VERSION;
  }
  ################################################################################
  # new
  ################################################################################
  
  sub _check_sanity {
      my ( $self ) = @_;
  
      for ( qw( sep_char quote_char escape_char ) ) {
          ( exists $self->{$_} && defined $self->{$_} && $self->{$_} =~ m/[\r\n]/ ) and return 1003;
      }
  
      if ( $self->{allow_whitespace} and
             ( defined $self->{quote_char}  && $self->{quote_char}  =~ m/^[ \t]$/ ) 
             ||
             ( defined $self->{escape_char} && $self->{escape_char} =~ m/^[ \t]$/ )
      ) {
         #$last_new_error = "INI - allow_whitespace with escape_char or quote_char SP or TAB";
         #$last_new_err_num = 1002;
         return 1002;
      }
  
      return 0;
  }
  
  
  sub new {
      my $proto = shift;
      my $attr  = @_ > 0 ? shift : {};
  
      $last_new_error   = 'usage: my $csv = Text::CSV_PP->new ([{ option => value, ... }]);';
      $last_new_err_num = 1000;
  
      return unless ( defined $attr and ref($attr) eq 'HASH' );
  
      my $class = ref($proto) || $proto or return;
      my $self  = { %def_attr };
  
      for my $prop (keys %$attr) { # if invalid attr, return undef
          unless ($prop =~ /^[a-z]/ && exists $def_attr{$prop}) {
              $last_new_error = "INI - Unknown attribute '$prop'";
              error_diag() if $attr->{ auto_diag };
              return;
          }
          $self->{$prop} = $attr->{$prop};
      }
  
      my $ec = _check_sanity( $self );
  
      if ( $ec ) {
          $last_new_error   = $ERRORS->{ $ec };
          $last_new_err_num = $ec;
          return;
          #$class->SetDiag ($ec);
      }
  
      $last_new_error = '';
  
      defined $\ and $self->{eol} = $\;
  
      bless $self, $class;
  
      $self->types( $self->{types} ) if( exists( $self->{types} ) );
  
      return $self;
  }
  ################################################################################
  # status
  ################################################################################
  sub status {
      $_[0]->{_STATUS};
  }
  ################################################################################
  # error_input
  ################################################################################
  sub error_input {
      $_[0]->{_ERROR_INPUT};
  }
  ################################################################################
  # error_diag
  ################################################################################
  sub error_diag {
      my $self = shift;
      my @diag = (0, $last_new_error, 0);
  
      unless ($self and ref $self) {	# Class method or direct call
          $last_new_error and $diag[0] = defined $last_new_err_num ? $last_new_err_num : 1000;
      }
      elsif ( $self->isa (__PACKAGE__) and defined $self->{_ERROR_DIAG} ) {
          @diag = ( 0 + $self->{_ERROR_DIAG}, $ERRORS->{ $self->{_ERROR_DIAG} } );
          exists $self->{_ERROR_POS} and $diag[2] = 1 + $self->{_ERROR_POS};
      }
  
      my $context = wantarray;
  
      my $diagobj = bless \@diag, 'Text::CSV::ErrorDiag';
  
      unless (defined $context) { # Void context
          if ( $diag[0] ) {
              my $msg = "# CSV_PP ERROR: " . $diag[0] . " - $diag[1]\n";
              ref $self ? ( $self->{auto_diag} > 1 ? die $msg : warn $msg )
                        : warn $msg;
          }
          return;
      }
  
      return $context ? @diag : $diagobj;
  }
  
  sub record_number {
      return shift->{_RECNO};
  } 
  
  ################################################################################
  # string
  ################################################################################
  *string = \&_string;
  sub _string {
      defined $_[0]->{_STRING} ? ${ $_[0]->{_STRING} } : undef;
  }
  ################################################################################
  # fields
  ################################################################################
  *fields = \&_fields;
  sub _fields {
      ref($_[0]->{_FIELDS}) ?  @{$_[0]->{_FIELDS}} : undef;
  }
  ################################################################################
  # combine
  ################################################################################
  *combine = \&_combine;
  sub _combine {
      my ($self, @part) = @_;
  
      # at least one argument was given for "combining"...
      return $self->{_STATUS} = 0 unless(@part);
  
      $self->{_FIELDS}      = \@part;
      $self->{_ERROR_INPUT} = undef;
      $self->{_STRING}      = '';
      $self->{_STATUS}      = 0;
  
      my ($always_quote, $binary, $quot, $sep, $esc, $empty_is_undef, $quote_space, $quote_null, $quote_binary )
              = @{$self}{qw/always_quote binary quote_char sep_char escape_char empty_is_undef quote_space quote_null quote_binary/};
  
      if(!defined $quot){ $quot = ''; }
  
      return $self->_set_error_diag(1001) if ($sep eq $esc or $sep eq $quot);
  
      my $re_esc = $self->{_re_comb_escape}->{$quot}->{$esc} ||= qr/(\Q$quot\E|\Q$esc\E)/;
      my $re_sp  = $self->{_re_comb_sp}->{$sep}->{$quote_space} ||= ( $quote_space ? qr/[\s\Q$sep\E]/ : qr/[\Q$sep\E]/ );
  
      my $must_be_quoted;
      for my $column (@part) {
  
          unless (defined $column) {
              $column = '';
              next;
          }
          elsif ( !$binary ) {
              $binary = 1 if utf8::is_utf8 $column;
          }
  
          if (!$binary and $column =~ /[^\x09\x20-\x7E]/) {
              # an argument contained an invalid character...
              $self->{_ERROR_INPUT} = $column;
              $self->_set_error_diag(2110);
              return $self->{_STATUS};
          }
  
          $must_be_quoted = 0;
  
          if($quot ne '' and $column =~ s/$re_esc/$esc$1/g){
              $must_be_quoted++;
          }
          if($column =~ /$re_sp/){
              $must_be_quoted++;
          }
  
          if( $binary and $quote_null ){
              use bytes;
              $must_be_quoted++ if ( $column =~ s/\0/${esc}0/g || ($quote_binary && $column =~ /[\x00-\x1f\x7f-\xa0]/) );
          }
  
          if($always_quote or $must_be_quoted){
              $column = $quot . $column . $quot;
          }
  
      }
  
      $self->{_STRING} = \do { join($sep, @part) . ( defined $self->{eol} ? $self->{eol} : '' ) };
      $self->{_STATUS} = 1;
  
      return $self->{_STATUS};
  }
  ################################################################################
  # parse
  ################################################################################
  my %allow_eol = ("\r" => 1, "\r\n" => 1, "\n" => 1, "" => 1);
  
  *parse = \&_parse;
  
  sub _parse {
      my ($self, $line) = @_;
  
      @{$self}{qw/_STRING _FIELDS _STATUS _ERROR_INPUT/} = ( \do{ defined $line ? "$line" : undef }, undef, 0, $line );
  
      return 0 if(!defined $line);
  
      my ($binary, $quot, $sep, $esc, $types, $keep_meta_info, $allow_whitespace, $eol, $blank_is_undef, $empty_is_undef, $unquot_esc)
           = @{$self}{
              qw/binary quote_char sep_char escape_char types keep_meta_info allow_whitespace eol blank_is_undef empty_is_undef allow_unquoted_escape/
             };
  
      $sep  = ',' unless (defined $sep);
      $esc  = "\0" unless (defined $esc);
      $quot = "\0" unless (defined $quot);
  
      my $quot_is_null = $quot eq "\0"; # in this case, any fields are not interpreted as quoted data.
  
      return $self->_set_error_diag(1001) if (($sep eq $esc or $sep eq $quot) and $sep ne "\0");
  
      my $meta_flag      = $keep_meta_info ? [] : undef;
      my $re_split       = $self->{_re_split}->{$quot}->{$esc}->{$sep} ||= _make_regexp_split_column($esc, $quot, $sep);
      my $re_quoted       = $self->{_re_quoted}->{$quot}               ||= qr/^\Q$quot\E(.*)\Q$quot\E$/s;
      my $re_in_quot_esp1 = $self->{_re_in_quot_esp1}->{$esc}          ||= qr/\Q$esc\E(.)/;
      my $re_in_quot_esp2 = $self->{_re_in_quot_esp2}->{$quot}->{$esc} ||= qr/[\Q$quot$esc$sep\E0]/;
      my $re_quot_char    = $self->{_re_quot_char}->{$quot}            ||= qr/\Q$quot\E/;
      my $re_esc          = $self->{_re_esc}->{$quot}->{$esc}          ||= qr/\Q$esc\E(\Q$quot\E|\Q$esc\E|\Q$sep\E|0)/;
      my $re_invalid_quot = $self->{_re_invalid_quot}->{$quot}->{$esc} ||= qr/^$re_quot_char|[^\Q$re_esc\E]$re_quot_char/;
  
      if ($allow_whitespace) {
          $re_split = $self->{_re_split_allow_sp}->{$quot}->{$esc}->{$sep}
                       ||= _make_regexp_split_column_allow_sp($esc, $quot, $sep);
      }
      if ($unquot_esc) {
          $re_split = $self->{_re_split_allow_unqout_esc}->{$quot}->{$esc}->{$sep}
                       ||= _make_regexp_split_column_allow_unqout_esc($esc, $quot, $sep);
      }
  
      my $palatable = 1;
      my @part      = ();
  
      my $i = 0;
      my $flag;
  
      if (defined $eol and $eol eq "\r") {
          $line =~ s/[\r ]*\r[ ]*$//;
      }
  
      if ($self->{verbatim}) {
          $line .= $sep;
      }
      else {
          if (defined $eol and !$allow_eol{$eol}) {
              $line .= $sep;
          }
          else {
              $line =~ s/(?:\x0D\x0A|\x0A)?$|(?:\x0D\x0A|\x0A)[ ]*$/$sep/;
          }
      }
  
      my $pos = 0;
  
      my $utf8 = 1 if utf8::is_utf8( $line ); # if UTF8 marked, flag on.
  
      for my $col ( $line =~ /$re_split/g ) {
  
          if ($keep_meta_info) {
              $flag = 0x0000;
              $flag |= IS_BINARY if ($col =~ /[^\x09\x20-\x7E]/);
          }
  
          $pos += length $col;
  
          if ( ( !$binary and !$utf8 ) and $col =~ /[^\x09\x20-\x7E]/) { # Binary character, binary off
              if ( not $quot_is_null and $col =~ $re_quoted ) {
                  $self->_set_error_diag(
                        $col =~ /\n([^\n]*)/ ? (2021, $pos - 1 - length $1)
                      : $col =~ /\r([^\r]*)/ ? (2022, $pos - 1 - length $1)
                      : (2026, $pos -2) # Binary character inside quoted field, binary off
                  );
              }
              else {
                  $self->_set_error_diag(
                        $col =~ /\Q$quot\E(.*)\Q$quot\E\r$/   ? (2010, $pos - 2)
                      : $col =~ /\n/                          ? (2030, $pos - length $col)
                      : $col =~ /^\r/                         ? (2031, $pos - length $col)
                      : $col =~ /\r([^\r]*)/                  ? (2032, $pos - 1 - length $1)
                      : (2037, $pos - length $col) # Binary character in unquoted field, binary off
                  );
              }
              $palatable = 0;
              last;
          }
  
          if ( ($utf8 and !$binary) and  $col =~ /\n|\0/ ) { # \n still needs binary (Text::CSV_XS 0.51 compat)
              $self->_set_error_diag(2021, $pos);
              $palatable = 0;
              last;
          }
  
          if ( not $quot_is_null and $col =~ $re_quoted ) {
              $flag |= IS_QUOTED if ($keep_meta_info);
              $col = $1;
  
              my $flag_in_quot_esp;
              while ( $col =~ /$re_in_quot_esp1/g ) {
                  my $str = $1;
                  $flag_in_quot_esp = 1;
  
                  if ($str !~ $re_in_quot_esp2) {
  
                      unless ($self->{allow_loose_escapes}) {
                          $self->_set_error_diag( 2025, $pos - 2 ); # Needless ESC in quoted field
                          $palatable = 0;
                          last;
                      }
  
                      unless ($self->{allow_loose_quotes}) {
                          $col =~ s/\Q$esc\E(.)/$1/g;
                      }
                  }
  
              }
  
              last unless ( $palatable );
  
              unless ( $flag_in_quot_esp ) {
                  if ($col =~ /(?<!\Q$esc\E)\Q$esc\E/) {
                      $self->_set_error_diag( 4002, $pos - 1 ); # No escaped ESC in quoted field
                      $palatable = 0;
                      last;
                  }
              }
  
              $col =~ s{$re_esc}{$1 eq '0' ? "\0" : $1}eg;
  
              if ( $empty_is_undef and length($col) == 0 ) {
                  $col = undef;
              }
  
              if ($types and $types->[$i]) { # IV or NV
                  _check_type(\$col, $types->[$i]);
              }
  
          }
  
          # quoted but invalid
  
          elsif ( not $quot_is_null and $col =~ $re_invalid_quot ) {
  
              unless ($self->{allow_loose_quotes} and $col =~ /$re_quot_char/) {
                  $self->_set_error_diag(
                        $col =~ /^\Q$quot\E(.*)\Q$quot\E.$/s  ? (2011, $pos - 2)
                      : $col =~ /^$re_quot_char/              ? (2027, $pos - 1)
                      : (2034, $pos - length $col) # Loose unescaped quote
                  );
                  $palatable = 0;
                  last;
              }
  
          }
  
          elsif ($types and $types->[$i]) { # IV or NV
              _check_type(\$col, $types->[$i]);
          }
  
          # unquoted
  
          else {
  
              if (!$self->{verbatim} and $col =~ /\r\n|\n/) {
                  $col =~ s/(?:\r\n|\n).*$//sm;
              }
  
              if ($col =~ /\Q$esc\E\r$/) { # for t/15_flags : test 165 'ESC CR' at line 203
                  $self->_set_error_diag( 4003, $pos );
                  $palatable = 0;
                  last;
              }
  
              if ($col =~ /.\Q$esc\E$/) { # for t/65_allow : test 53-54 parse('foo\') at line 62, 65
                  $self->_set_error_diag( 4004, $pos );
                  $palatable = 0;
                  last;
              }
  
              if ( $col eq '' and $blank_is_undef ) {
                  $col = undef;
              }
  
              if ( $empty_is_undef and length($col) == 0 ) {
                  $col = undef;
              }
  
              if ( $unquot_esc ) {
                  $col =~ s/\Q$esc\E(.)/$1/g;
              }
  
          }
  
          utf8::encode($col) if $utf8;
          if ( defined $col && _is_valid_utf8($col) ) {
              utf8::decode($col);
          }
  
          push @part,$col;
          push @{$meta_flag}, $flag if ($keep_meta_info);
          $self->{ _RECNO }++;
  
          $i++;
      }
  
      if ($palatable and ! @part) {
          $palatable = 0;
      }
  
      if ($palatable) {
          $self->{_ERROR_INPUT} = undef;
          $self->{_FIELDS}      = \@part;
      }
  
      $self->{_FFLAGS} = $keep_meta_info ? $meta_flag : [];
  
      return $self->{_STATUS} = $palatable;
  }
  
  
  sub _make_regexp_split_column {
      my ($esc, $quot, $sep) = @_;
  
      if ( $quot eq '' ) {
          return qr/([^\Q$sep\E]*)\Q$sep\E/s;
      }
  
     return qr/(
          \Q$quot\E
              [^\Q$quot$esc\E]*(?:\Q$esc\E[\Q$quot$esc\E0][^\Q$quot$esc\E]*)*
          \Q$quot\E
          | # or
          \Q$quot\E
              (?:\Q$esc\E[\Q$quot$esc$sep\E0]|[^\Q$quot$esc$sep\E])*
          \Q$quot\E
          | # or
          [^\Q$sep\E]*
         )
         \Q$sep\E
      /xs;
  }
  
  
  sub _make_regexp_split_column_allow_unqout_esc {
      my ($esc, $quot, $sep) = @_;
  
     return qr/(
          \Q$quot\E
              [^\Q$quot$esc\E]*(?:\Q$esc\E[\Q$quot$esc\E0][^\Q$quot$esc\E]*)*
          \Q$quot\E
          | # or
          \Q$quot\E
              (?:\Q$esc\E[\Q$quot$esc$sep\E0]|[^\Q$quot$esc$sep\E])*
          \Q$quot\E
          | # or
              (?:\Q$esc\E[\Q$quot$esc$sep\E0]|[^\Q$quot$esc$sep\E])*
          | # or
          [^\Q$sep\E]*
         )
         \Q$sep\E
      /xs;
  }
  
  
  sub _make_regexp_split_column_allow_sp {
      my ($esc, $quot, $sep) = @_;
  
      # if separator is space or tab, don't count that separator
      # as whitespace  --- patched by Mike O'Sullivan
      my $ws = $sep eq ' '  ? '[\x09]'
             : $sep eq "\t" ? '[\x20]'
             : '[\x20\x09]'
             ;
  
      if ( $quot eq '' ) {
          return qr/$ws*([^\Q$sep\E]?)$ws*\Q$sep\E$ws*/s;
      }
  
      qr/$ws*
         (
          \Q$quot\E
              [^\Q$quot$esc\E]*(?:\Q$esc\E[\Q$quot$esc$sep\E0][^\Q$quot$esc\E]*)*
          \Q$quot\E
          | # or
          [^\Q$sep\E]*?
         )
         $ws*\Q$sep\E$ws*
      /xs;
  }
  ################################################################################
  # print
  ################################################################################
  sub print {
      my ($self, $io, $cols) = @_;
  
      require IO::Handle;
  
      if(ref($cols) ne 'ARRAY'){
          Carp::croak("Expected fields to be an array ref");
      }
  
      $self->_combine(@$cols) or return '';
  
      local $\ = '';
  
      $io->print( $self->_string ) or $self->_set_error_diag(2200);
  }
  
  sub print_hr {
      my ($self, $io, $hr) = @_;
      $self->{_COLUMN_NAMES} or $self->_set_error_diag(3009);
      ref $hr eq "HASH"      or $self->_set_error_diag(3010);
      $self->print ($io, [ map { $hr->{$_} } $self->column_names ]);
  }
  ################################################################################
  # getline
  ################################################################################
  sub getline {
      my ($self, $io) = @_;
  
      require IO::Handle;
  
      $self->{_EOF} = eof($io) ? 1 : '';
  
      my $quot = $self->{quote_char};
      my $sep  = $self->{sep_char};
      my $re   =  defined $quot ? qr/(?:\Q$quot\E)/ : undef;
  
      my $eol  = $self->{eol};
  
      local $/ = $eol if ( defined $eol and $eol ne '' );
  
      my $line = $io->getline();
  
      # AUTO DETECTION EOL CR
      if ( defined $line and defined $eol and $eol eq '' and $line =~ /[^\r]\r[^\r\n]/ and eof ) {
          $self->{_AUTO_DETECT_CR} = 1;
          $self->{eol} = "\r";
          seek( $io, 0, 0 ); # restart
          return $self->getline( $io );
      }
  
      if ( $re and defined $line ) {
          LOOP: {
              my $is_continued   = scalar(my @list = $line =~ /$re/g) % 2; # if line is valid, quot is even
  
              if ( $self->{allow_loose_quotes } ) {
                  $is_continued = 0;
              }
              elsif ( $line =~ /${re}0/ ) { # null suspicion case
                  $is_continued = $line =~ qr/
                      ^
                      (
                          (?:
                              $re             # $quote
                              (?:
                                    $re$re    #    escaped $quote
                                  | ${re}0    # or escaped zero
                                  | [^$quot]  # or exceptions of $quote
                              )*
                              $re             # $quote
                              [^0$quot]       # non zero or $quote
                          )
                          |                   
                          (?:[^$quot]*)       # exceptions of $quote
                      )+
                      $
                  /x ? 0 : 1;
              }
  
              if ( $is_continued and !eof($io) ) {
                  $line .= $io->getline();
                  goto LOOP;
              }
          }
      }
  
      $line =~ s/\Q$eol\E$// if ( defined $line and defined $eol and $eol ne '' );
  
      $self->_parse($line);
  
      return $self->_return_getline_result();
  }
  
  
  sub _return_getline_result {
  
      if ( eof ) {
          $_[0]->{_AUTO_DETECT_CR} = 0;
      }
  
      return unless $_[0]->{_STATUS};
  
      return [ $_[0]->_fields() ] unless $_[0]->{_BOUND_COLUMNS};
  
      my @vals  = $_[0]->_fields();
      my ( $max, $count ) = ( scalar @vals, 0 );
  
      if ( @{ $_[0]->{_BOUND_COLUMNS} } < $max ) {
              $_[0]->_set_error_diag(3006);
              return;
      }
  
      for ( my $i = 0; $i < $max; $i++ ) {
          my $bind = $_[0]->{_BOUND_COLUMNS}->[ $i ];
          if ( Scalar::Util::readonly( $$bind ) ) {
              $_[0]->_set_error_diag(3008);
              return;
          }
          $$bind = $vals[ $i ];
      }
  
      return [];
  }
  ################################################################################
  # getline_all
  ################################################################################
  sub getline_all {
      my ( $self, $io, $offset, $len ) = @_;
      my @list;
      my $tail;
      my $n = 0;
  
      $offset ||= 0;
  
      if ( $offset < 0 ) {
          $tail = -$offset;
          $offset = 0;
      }
  
      while ( my $row = $self->getline($io) ) {
          next if $offset && $offset-- > 0;               # skip
          last if defined $len && !$tail && $n >= $len;   # exceedes limit size
          push @list, $row;
          ++$n;
          if ( $tail && $n > $tail ) {
              shift @list;
          }
      }
  
      if ( $tail && defined $len && $n > $len ) {
          @list = splice( @list, 0, $len);
      }
  
      return \@list;
  }
  ################################################################################
  # getline_hr
  ################################################################################
  sub getline_hr {
      my ( $self, $io) = @_;
      my %hr;
  
      unless ( $self->{_COLUMN_NAMES} ) {
          $self->SetDiag( 3002 );
      }
  
      my $fr = $self->getline( $io ) or return undef;
  
      if ( ref $self->{_FFLAGS} ) {
          $self->{_FFLAGS}[$_] = IS_MISSING for ($#{$fr} + 1) .. $#{$self->{_COLUMN_NAMES}};
      }
  
      @hr{ @{ $self->{_COLUMN_NAMES} } } = @$fr;
  
      \%hr;
  }
  ################################################################################
  # getline_hr_all
  ################################################################################
  sub getline_hr_all {
      my ( $self, $io, @args ) = @_;
      my %hr;
  
      unless ( $self->{_COLUMN_NAMES} ) {
          $self->SetDiag( 3002 );
      }
  
      my @cn = @{$self->{_COLUMN_NAMES}};
  
      return [ map { my %h; @h{ @cn } = @$_; \%h } @{ $self->getline_all( $io, @args ) } ];
  }
  ################################################################################
  # column_names
  ################################################################################
  sub column_names {
      my ( $self, @columns ) = @_;
  
      @columns or return defined $self->{_COLUMN_NAMES} ? @{$self->{_COLUMN_NAMES}} : undef;
      @columns == 1 && ! defined $columns[0] and return $self->{_COLUMN_NAMES} = undef;
  
      if ( @columns == 1 && ref $columns[0] eq "ARRAY" ) {
          @columns = @{ $columns[0] };
      }
      elsif ( join "", map { defined $_ ? ref $_ : "" } @columns ) {
          $self->SetDiag( 3001 );
      }
  
      if ( $self->{_BOUND_COLUMNS} && @columns != @{$self->{_BOUND_COLUMNS}} ) {
          $self->SetDiag( 3003 );
      }
  
      $self->{_COLUMN_NAMES} = [ map { defined $_ ? $_ : "\cAUNDEF\cA" } @columns ];
      @{ $self->{_COLUMN_NAMES} };
  }
  ################################################################################
  # bind_columns
  ################################################################################
  sub bind_columns {
      my ( $self, @refs ) = @_;
  
      @refs or return defined $self->{_BOUND_COLUMNS} ? @{$self->{_BOUND_COLUMNS}} : undef;
      @refs == 1 && ! defined $refs[0] and return $self->{_BOUND_COLUMNS} = undef;
  
      if ( $self->{_COLUMN_NAMES} && @refs != @{$self->{_COLUMN_NAMES}} ) {
          $self->SetDiag( 3003 );
      }
  
      if ( grep { ref $_ ne "SCALAR" } @refs ) { # why don't use grep?
          $self->SetDiag( 3004 );
      }
  
      $self->{_is_bound} = scalar @refs; #pack("C", scalar @refs);
      $self->{_BOUND_COLUMNS} = [ @refs ];
      @refs;
  }
  ################################################################################
  # eof
  ################################################################################
  sub eof {
      $_[0]->{_EOF};
  }
  ################################################################################
  # type
  ################################################################################
  sub types {
      my $self = shift;
  
      if (@_) {
          if (my $types = shift) {
              $self->{'_types'} = join("", map{ chr($_) } @$types);
              $self->{'types'} = $types;
          }
          else {
              delete $self->{'types'};
              delete $self->{'_types'};
              undef;
          }
      }
      else {
          $self->{'types'};
      }
  }
  ################################################################################
  sub meta_info {
      $_[0]->{_FFLAGS} ? @{ $_[0]->{_FFLAGS} } : undef;
  }
  
  sub is_quoted {
      return unless (defined $_[0]->{_FFLAGS});
      return if( $_[1] =~ /\D/ or $_[1] < 0 or  $_[1] > $#{ $_[0]->{_FFLAGS} } );
  
      $_[0]->{_FFLAGS}->[$_[1]] & IS_QUOTED ? 1 : 0;
  }
  
  sub is_binary {
      return unless (defined $_[0]->{_FFLAGS});
      return if( $_[1] =~ /\D/ or $_[1] < 0 or  $_[1] > $#{ $_[0]->{_FFLAGS} } );
      $_[0]->{_FFLAGS}->[$_[1]] & IS_BINARY ? 1 : 0;
  }
  
  sub is_missing {
      my ($self, $idx, $val) = @_;
      ref $self->{_FFLAGS} &&
              $idx >= 0 && $idx < @{$self->{_FFLAGS}} or return;
      $self->{_FFLAGS}[$idx] & IS_MISSING ? 1 : 0;
  }
  ################################################################################
  # _check_type
  #  take an arg as scalar referrence.
  #  if not numeric, make the value 0. otherwise INTEGERized.
  ################################################################################
  sub _check_type {
      my ($col_ref, $type) = @_;
      unless ($$col_ref =~ /^[+-]?(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/) {
          Carp::carp sprintf("Argument \"%s\" isn't numeric in subroutine entry",$$col_ref);
          $$col_ref = 0;
      }
      elsif ($type == NV) {
          $$col_ref = sprintf("%G",$$col_ref);
      }
      else {
          $$col_ref = sprintf("%d",$$col_ref);
      }
  }
  ################################################################################
  # _set_error_diag
  ################################################################################
  sub _set_error_diag {
      my ( $self, $error, $pos ) = @_;
  
      $self->{_ERROR_DIAG} = $error;
  
      if (defined $pos) {
          $_[0]->{_ERROR_POS} = $pos;
      }
  
      $self->error_diag() if ( $error and $self->{auto_diag} );
  
      return;
  }
  ################################################################################
  
  BEGIN {
      for my $method ( qw/always_quote binary keep_meta_info allow_loose_quotes allow_loose_escapes
                              verbatim blank_is_undef empty_is_undef quote_space quote_null
                              quote_binary allow_unquoted_escape/ ) {
          eval qq|
              sub $method {
                  \$_[0]->{$method} = defined \$_[1] ? \$_[1] : 0 if (\@_ > 1);
                  \$_[0]->{$method};
              }
          |;
      }
  }
  
  
  
  sub sep_char {
      my $self = shift;
      if ( @_ ) {
          $self->{sep_char} = $_[0];
          my $ec = _check_sanity( $self );
          $ec and Carp::croak( $self->SetDiag( $ec ) );
      }
      $self->{sep_char};
  }
  
  
  sub quote_char {
      my $self = shift;
      if ( @_ ) {
          $self->{quote_char} = $_[0];
          my $ec = _check_sanity( $self );
          $ec and Carp::croak( $self->SetDiag( $ec ) );
      }
      $self->{quote_char};
  }
  
  
  sub escape_char {
      my $self = shift;
      if ( @_ ) {
          $self->{escape_char} = $_[0];
          my $ec = _check_sanity( $self );
          $ec and Carp::croak( $self->SetDiag( $ec ) );
      }
      $self->{escape_char};
  }
  
  
  sub allow_whitespace {
      my $self = shift;
      if ( @_ ) {
          my $aw = shift;
          $aw and
              (defined $self->{quote_char}  && $self->{quote_char}  =~ m/^[ \t]$/) ||
              (defined $self->{escape_char} && $self->{escape_char} =~ m/^[ \t]$/)
                  and Carp::croak ($self->SetDiag (1002));
          $self->{allow_whitespace} = $aw;
      }
      $self->{allow_whitespace};
  }
  
  
  sub eol {
      $_[0]->{eol} = defined $_[1] ? $_[1] : '' if ( @_ > 1 );
      $_[0]->{eol};
  }
  
  
  sub SetDiag {
      if ( defined $_[1] and $_[1] == 0 ) {
          $_[0]->{_ERROR_DIAG} = undef;
          $last_new_error = '';
          return;
      }
  
      $_[0]->_set_error_diag( $_[1] );
      Carp::croak( $_[0]->error_diag . '' );
  }
  
  sub auto_diag {
      my $self = shift;
      if (@_) {
          my $v = shift;
          !defined $v || $v eq "" and $v = 0;
          $v =~ m/^[0-9]/ or $v = $v ? 1 : 0; # default for true/false
          $self->{auto_diag} = $v;
      }
      $self->{auto_diag};
  }
  
  sub diag_verbose {
      my $self = shift;
      if (@_) {
          my $v = shift;
          !defined $v || $v eq "" and $v = 0;
          $v =~ m/^[0-9]/ or $v = $v ? 1 : 0; # default for true/false
          $self->{diag_verbose} = $v;
      }
      $self->{diag_verbose};
  }
  
  sub _is_valid_utf8 {
      return ( $_[0] =~ /^(?:
           [\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 )  ? 1 : 0;
  }
  ################################################################################
  package Text::CSV::ErrorDiag;
  
  use strict;
  use overload (
      '""' => \&stringify,
      '+'  => \&numeric,
      '-'  => \&numeric,
      '*'  => \&numeric,
      '/'  => \&numeric,
  );
  
  
  sub numeric {
      my ($left, $right) = @_;
      return ref $left ? $left->[0] : $right->[0];
  }
  
  
  sub stringify {
      $_[0]->[1];
  }
  ################################################################################
  1;
  __END__
  
  =head1 NAME
  
  Text::CSV_PP - Text::CSV_XS compatible pure-Perl module
  
  
  =head1 SYNOPSIS
  
   use Text::CSV_PP;
   
   $csv = Text::CSV_PP->new();     # create a new object
   # If you want to handle non-ascii char.
   $csv = Text::CSV_PP->new({binary => 1});
   
   $status = $csv->combine(@columns);    # combine columns into a string
   $line   = $csv->string();             # get the combined string
   
   $status  = $csv->parse($line);        # parse a CSV string into fields
   @columns = $csv->fields();            # get the parsed fields
   
   $status       = $csv->status ();      # get the most recent status
   $bad_argument = $csv->error_input (); # get the most recent bad argument
   $diag         = $csv->error_diag ();  # if an error occured, explains WHY
   
   $status = $csv->print ($io, $colref); # Write an array of fields
                                         # immediately to a file $io
   $colref = $csv->getline ($io);        # Read a line from file $io,
                                         # parse it and return an array
                                         # ref of fields
   $csv->column_names (@names);          # Set column names for getline_hr ()
   $ref = $csv->getline_hr ($io);        # getline (), but returns a hashref
   $eof = $csv->eof ();                  # Indicate if last parse or
                                         # getline () hit End Of File
   
   $csv->types(\@t_array);               # Set column types
  
  
  =head1 DESCRIPTION
  
  Text::CSV_PP has almost same functions of L<Text::CSV_XS> which 
  provides facilities for the composition and decomposition of
  comma-separated values. As its name suggests, L<Text::CSV_XS>
  is a XS module and Text::CSV_PP is a Puer Perl one.
  
  =head1 VERSION
  
      1.31
  
  This module is compatible with Text::CSV_XS B<0.99>.
  (except for diag_verbose and allow_unquoted_escape)
  
  =head2 Unicode (UTF8)
  
  On parsing (both for C<getline ()> and C<parse ()>), if the source is
  marked being UTF8, then parsing that source will mark all fields that
  are marked binary will also be marked UTF8.
  
  On combining (C<print ()> and C<combine ()>), if any of the combining
  fields was marked UTF8, the resulting string will be marked UTF8.
  
  =head1 FUNCTIONS
  
  These methods are almost same as Text::CSV_XS.
  Most of the documentation was shamelessly copied and replaced from Text::CSV_XS.
  
  See to L<Text::CSV_XS>.
  
  =head2 version ()
  
  (Class method) Returns the current backend module version.
  If you want the module version, you can use the C<VERSION> method,
  
   print Text::CSV->VERSION;      # This module version
   print Text::CSV->version;      # The version of the worker module
                                  # same as Text::CSV->backend->version
  
  =head2 new (\%attr)
  
  (Class method) Returns a new instance of Text::CSV_XS. The objects
  attributes are described by the (optional) hash ref C<\%attr>.
  Currently the following attributes are available:
  
  =over 4
  
  =item eol
  
  An end-of-line string to add to rows. C<undef> is replaced with an
  empty string. The default is C<$\>. Common values for C<eol> are
  C<"\012"> (Line Feed) or C<"\015\012"> (Carriage Return, Line Feed).
  Cannot be longer than 7 (ASCII) characters.
  
  If both C<$/> and C<eol> equal C<"\015">, parsing lines that end on
  only a Carriage Return without Line Feed, will be C<parse>d correct.
  Line endings, whether in C<$/> or C<eol>, other than C<undef>,
  C<"\n">, C<"\r\n">, or C<"\r"> are not (yet) supported for parsing.
  
  =item sep_char
  
  The char used for separating fields, by default a comma. (C<,>).
  Limited to a single-byte character, usually in the range from 0x20
  (space) to 0x7e (tilde).
  
  The separation character can not be equal to the quote character.
  The separation character can not be equal to the escape character.
  
  See also L<Text::CSV_XS/CAVEATS>
  
  =item allow_whitespace
  
  When this option is set to true, whitespace (TAB's and SPACE's)
  surrounding the separation character is removed when parsing. If
  either TAB or SPACE is one of the three major characters C<sep_char>,
  C<quote_char>, or C<escape_char> it will not be considered whitespace.
  
  So lines like:
  
    1 , "foo" , bar , 3 , zapp
  
  are now correctly parsed, even though it violates the CSV specs.
  
  Note that B<all> whitespace is stripped from start and end of each
  field. That would make it more a I<feature> than a way to be able
  to parse bad CSV lines, as
  
   1,   2.0,  3,   ape  , monkey
  
  will now be parsed as
  
   ("1", "2.0", "3", "ape", "monkey")
  
  even if the original line was perfectly sane CSV.
  
  =item blank_is_undef
  
  Under normal circumstances, CSV data makes no distinction between
  quoted- and unquoted empty fields. They both end up in an empty
  string field once read, so
  
   1,"",," ",2
  
  is read as
  
   ("1", "", "", " ", "2")
  
  When I<writing> CSV files with C<always_quote> set, the unquoted empty
  field is the result of an undefined value. To make it possible to also
  make this distinction when reading CSV data, the C<blank_is_undef> option
  will cause unquoted empty fields to be set to undef, causing the above to
  be parsed as
  
   ("1", "", undef, " ", "2")
  
  =item empty_is_undef
  
  Going one step further than C<blank_is_undef>, this attribute converts
  all empty fields to undef, so
  
   1,"",," ",2
  
  is read as
  
   (1, undef, undef, " ", 2)
  
  Note that this only effects fields that are I<realy> empty, not fields
  that are empty after stripping allowed whitespace. YMMV.
  
  =item quote_char
  
  The char used for quoting fields containing blanks, by default the
  double quote character (C<">). A value of undef suppresses
  quote chars. (For simple cases only).
  Limited to a single-byte character, usually in the range from 0x20
  (space) to 0x7e (tilde).
  
  The quote character can not be equal to the separation character.
  
  =item allow_loose_quotes
  
  By default, parsing fields that have C<quote_char> characters inside
  an unquoted field, like
  
   1,foo "bar" baz,42
  
  would result in a parse error. Though it is still bad practice to
  allow this format, we cannot help there are some vendors that make
  their applications spit out lines styled like this.
  
  In case there is B<really> bad CSV data, like
  
   1,"foo "bar" baz",42
  
  or
  
   1,""foo bar baz"",42
  
  there is a way to get that parsed, and leave the quotes inside the quoted
  field as-is. This can be achieved by setting C<allow_loose_quotes> B<AND>
  making sure that the C<escape_char> is I<not> equal to C<quote_char>.
  
  =item escape_char
  
  The character used for escaping certain characters inside quoted fields.
  Limited to a single-byte character, usually in the range from 0x20
  (space) to 0x7e (tilde).
  
  The C<escape_char> defaults to being the literal double-quote mark (C<">)
  in other words, the same as the default C<quote_char>. This means that
  doubling the quote mark in a field escapes it:
  
    "foo","bar","Escape ""quote mark"" with two ""quote marks""","baz"
  
  If you change the default quote_char without changing the default
  escape_char, the escape_char will still be the quote mark.  If instead
  you want to escape the quote_char by doubling it, you will need to change
  the escape_char to be the same as what you changed the quote_char to.
  
  The escape character can not be equal to the separation character.
  
  =item allow_loose_escapes
  
  By default, parsing fields that have C<escape_char> characters that
  escape characters that do not need to be escaped, like:
  
   my $csv = Text::CSV->new ({ escape_char => "\\" });
   $csv->parse (qq{1,"my bar\'s",baz,42});
  
  would result in a parse error. Though it is still bad practice to
  allow this format, this option enables you to treat all escape character
  sequences equal.
  
  =item binary
  
  If this attribute is TRUE, you may use binary characters in quoted fields,
  including line feeds, carriage returns and NULL bytes. (The latter must
  be escaped as C<"0>.) By default this feature is off.
  
  If a string is marked UTF8, binary will be turned on automatically when
  binary characters other than CR or NL are encountered. Note that a simple
  string like C<"\x{00a0}"> might still be binary, but not marked UTF8, so
  setting C<{ binary =E<gt> 1 }> is still a wise option.
  
  =item types
  
  A set of column types; this attribute is immediately passed to the
  I<types> method below. You must not set this attribute otherwise,
  except for using the I<types> method. For details see the description
  of the I<types> method below.
  
  =item always_quote
  
  By default the generated fields are quoted only, if they need to, for
  example, if they contain the separator. If you set this attribute to
  a TRUE value, then all defined fields will be quoted. This is typically
  easier to handle in external applications.
  
  =item quote_space
  
  By default, a space in a field would trigger quotation. As no rule
  exists this to be forced in CSV, nor any for the opposite, the default
  is true for safety. You can exclude the space from this trigger by
  setting this option to 0.
  
  =item quote_null
  
  By default, a NULL byte in a field would be escaped. This attribute
  enables you to treat the NULL byte as a simple binary character in
  binary mode (the C<{ binary =E<gt> 1 }> is set). The default is true.
  You can prevent NULL escapes by setting this attribute to 0.
  
  =item keep_meta_info
  
  By default, the parsing of input lines is as simple and fast as
  possible. However, some parsing information - like quotation of
  the original field - is lost in that process. Set this flag to
  true to be able to retrieve that information after parsing with
  the methods C<meta_info ()>, C<is_quoted ()>, and C<is_binary ()>
  described below.  Default is false.
  
  =item verbatim
  
  This is a quite controversial attribute to set, but it makes hard
  things possible.
  
  The basic thought behind this is to tell the parser that the normally
  special characters newline (NL) and Carriage Return (CR) will not be
  special when this flag is set, and be dealt with as being ordinary
  binary characters. This will ease working with data with embedded
  newlines.
  
  When C<verbatim> is used with C<getline ()>, C<getline ()>
  auto-chomp's every line.
  
  Imagine a file format like
  
    M^^Hans^Janssen^Klas 2\n2A^Ja^11-06-2007#\r\n
  
  where, the line ending is a very specific "#\r\n", and the sep_char
  is a ^ (caret). None of the fields is quoted, but embedded binary
  data is likely to be present. With the specific line ending, that
  shouldn't be too hard to detect.
  
  By default, Text::CSV' parse function however is instructed to only
  know about "\n" and "\r" to be legal line endings, and so has to deal
  with the embedded newline as a real end-of-line, so it can scan the next
  line if binary is true, and the newline is inside a quoted field.
  With this attribute however, we can tell parse () to parse the line
  as if \n is just nothing more than a binary character.
  
  For parse () this means that the parser has no idea about line ending
  anymore, and getline () chomps line endings on reading.
  
  =item auto_diag
  
  Set to true will cause C<error_diag ()> to be automatically be called
  in void context upon errors.
  
  If set to a value greater than 1, it will die on errors instead of
  warn.
  
  To check future plans and a difference in XS version,
  please see to L<Text::CSV_XS/auto_diag>.
  
  =back
  
  To sum it up,
  
   $csv = Text::CSV_PP->new ();
  
  is equivalent to
  
   $csv = Text::CSV_PP->new ({
       quote_char          => '"',
       escape_char         => '"',
       sep_char            => ',',
       eol                 => $\,
       always_quote        => 0,
       quote_space         => 1,
       quote_null          => 1,
       binary              => 0,
       keep_meta_info      => 0,
       allow_loose_quotes  => 0,
       allow_loose_escapes => 0,
       allow_whitespace    => 0,
       blank_is_undef      => 0,
       empty_is_undef      => 0,
       verbatim            => 0,
       auto_diag           => 0,
       });
  
  
  For all of the above mentioned flags, there is an accessor method
  available where you can inquire for the current value, or change
  the value
  
   my $quote = $csv->quote_char;
   $csv->binary (1);
  
  It is unwise to change these settings halfway through writing CSV
  data to a stream. If however, you want to create a new stream using
  the available CSV object, there is no harm in changing them.
  
  If the C<new ()> constructor call fails, it returns C<undef>, and makes
  the fail reason available through the C<error_diag ()> method.
  
   $csv = Text::CSV->new ({ ecs_char => 1 }) or
       die "" . Text::CSV->error_diag ();
  
  C<error_diag ()> will return a string like
  
   "INI - Unknown attribute 'ecs_char'"
  
  =head2 print
  
   $status = $csv->print ($io, $colref);
  
  Similar to C<combine () + string () + print>, but more efficient. It
  expects an array ref as input (not an array!) and the resulting string is
  not really created (XS version), but immediately written to the I<$io> object, typically
  an IO handle or any other object that offers a I<print> method. Note, this
  implies that the following is wrong in perl 5.005_xx and older:
  
   open FILE, ">", "whatever";
   $status = $csv->print (\*FILE, $colref);
  
  as in perl 5.005 and older, the glob C<\*FILE> is not an object, thus it
  doesn't have a print method. The solution is to use an IO::File object or
  to hide the glob behind an IO::Wrap object. See L<IO::File> and L<IO::Wrap>
  for details.
  
  For performance reasons the print method doesn't create a result string.
  (If its backend is PP version, result strings are created internally.)
  In particular the I<$csv-E<gt>string ()>, I<$csv-E<gt>status ()>,
  I<$csv->fields ()> and I<$csv-E<gt>error_input ()> methods are meaningless
  after executing this method.
  
  =head2 combine
  
   $status = $csv->combine (@columns);
  
  This object function constructs a CSV string from the arguments, returning
  success or failure.  Failure can result from lack of arguments or an argument
  containing an invalid character.  Upon success, C<string ()> can be called to
  retrieve the resultant CSV string.  Upon failure, the value returned by
  C<string ()> is undefined and C<error_input ()> can be called to retrieve an
  invalid argument.
  
  =head2 string
  
   $line = $csv->string ();
  
  This object function returns the input to C<parse ()> or the resultant CSV
  string of C<combine ()>, whichever was called more recently.
  
  =head2 getline
  
   $colref = $csv->getline ($io);
  
  This is the counterpart to print, like parse is the counterpart to
  combine: It reads a row from the IO object $io using $io->getline ()
  and parses this row into an array ref. This array ref is returned
  by the function or undef for failure.
  
  When fields are bound with C<bind_columns ()>, the return value is a
  reference to an empty list.
  
  The I<$csv-E<gt>string ()>, I<$csv-E<gt>fields ()> and I<$csv-E<gt>status ()>
  methods are meaningless, again.
  
  =head2 getline_all
  
   $arrayref = $csv->getline_all ($io);
   $arrayref = $csv->getline_all ($io, $offset);
   $arrayref = $csv->getline_all ($io, $offset, $length);
  
  This will return a reference to a list of C<getline ($io)> results.
  In this call, C<keep_meta_info> is disabled. If C<$offset> is negative,
  as with C<splice ()>, only the last C<abs ($offset)> records of C<$io>
  are taken into consideration.
  
  Given a CSV file with 10 lines:
  
   lines call
   ----- ---------------------------------------------------------
   0..9  $csv->getline_all ($io)         # all
   0..9  $csv->getline_all ($io,  0)     # all
   8..9  $csv->getline_all ($io,  8)     # start at 8
   -     $csv->getline_all ($io,  0,  0) # start at 0 first 0 rows
   0..4  $csv->getline_all ($io,  0,  5) # start at 0 first 5 rows
   4..5  $csv->getline_all ($io,  4,  2) # start at 4 first 2 rows
   8..9  $csv->getline_all ($io, -2)     # last 2 rows
   6..7  $csv->getline_all ($io, -4,  2) # first 2 of last  4 rows
  
  =head2 parse
  
   $status = $csv->parse ($line);
  
  This object function decomposes a CSV string into fields, returning
  success or failure.  Failure can result from a lack of argument or the
  given CSV string is improperly formatted.  Upon success, C<fields ()> can
  be called to retrieve the decomposed fields .  Upon failure, the value
  returned by C<fields ()> is undefined and C<error_input ()> can be called
  to retrieve the invalid argument.
  
  You may use the I<types ()> method for setting column types. See the
  description below.
  
  =head2 getline_hr
  
  The C<getline_hr ()> and C<column_names ()> methods work together to allow
  you to have rows returned as hashrefs. You must call C<column_names ()>
  first to declare your column names.
  
   $csv->column_names (qw( code name price description ));
   $hr = $csv->getline_hr ($io);
   print "Price for $hr->{name} is $hr->{price} EUR\n";
  
  C<getline_hr ()> will croak if called before C<column_names ()>.
  
  =head2 getline_hr_all
  
   $arrayref = $csv->getline_hr_all ($io);
  
  This will return a reference to a list of C<getline_hr ($io)> results.
  In this call, C<keep_meta_info> is disabled.
  
  =head2 column_names
  
  Set the keys that will be used in the C<getline_hr ()> calls. If no keys
  (column names) are passed, it'll return the current setting.
  
  C<column_names ()> accepts a list of scalars (the column names) or a
  single array_ref, so you can pass C<getline ()>
  
    $csv->column_names ($csv->getline ($io));
  
  C<column_names ()> does B<no> checking on duplicates at all, which might
  lead to unwanted results. Undefined entries will be replaced with the
  string C<"\cAUNDEF\cA">, so
  
    $csv->column_names (undef, "", "name", "name");
    $hr = $csv->getline_hr ($io);
  
  Will set C<$hr->{"\cAUNDEF\cA"}> to the 1st field, C<$hr->{""}> to the
  2nd field, and C<$hr->{name}> to the 4th field, discarding the 3rd field.
  
  C<column_names ()> croaks on invalid arguments.
  
  =head2 bind_columns
  
  Takes a list of references to scalars to store the fields fetched
  C<getline ()> in. When you don't pass enough references to store the
  fetched fields in, C<getline ()> will fail. If you pass more than there are
  fields to return, the remaining references are left untouched.
  
    $csv->bind_columns (\$code, \$name, \$price, \$description);
    while ($csv->getline ($io)) {
        print "The price of a $name is \x{20ac} $price\n";
        }
  
  =head2 eof
  
   $eof = $csv->eof ();
  
  If C<parse ()> or C<getline ()> was used with an IO stream, this
  method will return true (1) if the last call hit end of file, otherwise
  it will return false (''). This is useful to see the difference between
  a failure and end of file.
  
  =head2 types
  
   $csv->types (\@tref);
  
  This method is used to force that columns are of a given type. For
  example, if you have an integer column, two double columns and a
  string column, then you might do a
  
   $csv->types ([Text::CSV_PP::IV (),
                 Text::CSV_PP::NV (),
                 Text::CSV_PP::NV (),
                 Text::CSV_PP::PV ()]);
  
  Column types are used only for decoding columns, in other words
  by the I<parse ()> and I<getline ()> methods.
  
  You can unset column types by doing a
  
   $csv->types (undef);
  
  or fetch the current type settings with
  
   $types = $csv->types ();
  
  =over 4
  
  =item IV
  
  Set field type to integer.
  
  =item NV
  
  Set field type to numeric/float.
  
  =item PV
  
  Set field type to string.
  
  =back
  
  =head2 fields
  
   @columns = $csv->fields ();
  
  This object function returns the input to C<combine ()> or the resultant
  decomposed fields of C successful <parse ()>, whichever was called more
  recently.
  
  Note that the return value is undefined after using C<getline ()>, which
  does not fill the data structures returned by C<parse ()>.
  
  =head2 meta_info
  
   @flags = $csv->meta_info ();
  
  This object function returns the flags of the input to C<combine ()> or
  the flags of the resultant decomposed fields of C<parse ()>, whichever
  was called more recently.
  
  For each field, a meta_info field will hold flags that tell something about
  the field returned by the C<fields ()> method or passed to the C<combine ()>
  method. The flags are bitwise-or'd like:
  
  =over 4
  
  =item 0x0001
  
  The field was quoted.
  
  =item 0x0002
  
  The field was binary.
  
  =back
  
  See the C<is_*** ()> methods below.
  
  =head2 is_quoted
  
    my $quoted = $csv->is_quoted ($column_idx);
  
  Where C<$column_idx> is the (zero-based) index of the column in the
  last result of C<parse ()>.
  
  This returns a true value if the data in the indicated column was
  enclosed in C<quote_char> quotes. This might be important for data
  where C<,20070108,> is to be treated as a numeric value, and where
  C<,"20070108",> is explicitly marked as character string data.
  
  =head2 is_binary
  
    my $binary = $csv->is_binary ($column_idx);
  
  Where C<$column_idx> is the (zero-based) index of the column in the
  last result of C<parse ()>.
  
  This returns a true value if the data in the indicated column
  contained any byte in the range [\x00-\x08,\x10-\x1F,\x7F-\xFF]
  
  =head2 status
  
   $status = $csv->status ();
  
  This object function returns success (or failure) of C<combine ()> or
  C<parse ()>, whichever was called more recently.
  
  =head2 error_input
  
   $bad_argument = $csv->error_input ();
  
  This object function returns the erroneous argument (if it exists) of
  C<combine ()> or C<parse ()>, whichever was called more recently.
  
  =head2 error_diag
  
   Text::CSV_PP->error_diag ();
   $csv->error_diag ();
   $error_code   = 0  + $csv->error_diag ();
   $error_str    = "" . $csv->error_diag ();
   ($cde, $str, $pos) = $csv->error_diag ();
  
  If (and only if) an error occured, this function returns the diagnostics
  of that error.
  
  If called in void context, it will print the internal error code and the
  associated error message to STDERR.
  
  If called in list context, it will return the error code and the error
  message in that order. If the last error was from parsing, the third
  value returned is the best guess at the location within the line that was
  being parsed. It's value is 1-based.
  
  Note: C<$pos> does not show the error point in many cases.
  It is for conscience's sake.
  
  If called in scalar context, it will return the diagnostics in a single
  scalar, a-la $!. It will contain the error code in numeric context, and
  the diagnostics message in string context.
  
  To achieve this behavior with CSV_PP, the returned diagnostics is blessed object.
  
  =head2 SetDiag
  
   $csv->SetDiag (0);
  
  Use to reset the diagnostics if you are dealing with errors.
  
  =head1 DIAGNOSTICS
  
  If an error occured, $csv->error_diag () can be used to get more information
  on the cause of the failure. Note that for speed reasons, the internal value
  is never cleared on success, so using the value returned by error_diag () in
  normal cases - when no error occured - may cause unexpected results.
  
  Note: CSV_PP's diagnostics is different from CSV_XS's:
  
  Text::CSV_XS parses csv strings by dividing one character
  while Text::CSV_PP by using the regular expressions.
  That difference makes the different cause of the failure.
  
  Currently these errors are available:
  
  =over 2
  
  =item 1001 "sep_char is equal to quote_char or escape_char"
  
  The separation character cannot be equal to either the quotation character
  or the escape character, as that will invalidate all parsing rules.
  
  =item 1002 "INI - allow_whitespace with escape_char or quote_char SP or TAB"
  
  Using C<allow_whitespace> when either C<escape_char> or C<quote_char> is
  equal to SPACE or TAB is too ambiguous to allow.
  
  =item 1003 "INI - \r or \n in main attr not allowed"
  
  Using default C<eol> characters in either C<sep_char>, C<quote_char>, or
  C<escape_char> is not allowed.
  
  =item 2010 "ECR - QUO char inside quotes followed by CR not part of EOL"
  
  =item 2011 "ECR - Characters after end of quoted field"
  
  =item 2021 "EIQ - NL char inside quotes, binary off"
  
  =item 2022 "EIQ - CR char inside quotes, binary off"
  
  =item 2025 "EIQ - Loose unescaped escape"
  
  =item 2026 "EIQ - Binary character inside quoted field, binary off"
  
  =item 2027 "EIQ - Quoted field not terminated"
  
  =item 2030 "EIF - NL char inside unquoted verbatim, binary off"
  
  =item 2031 "EIF - CR char is first char of field, not part of EOL",
  
  =item 2032 "EIF - CR char inside unquoted, not part of EOL",
  
  =item 2034 "EIF - Loose unescaped quote",
  
  =item 2037 "EIF - Binary character in unquoted field, binary off",
  
  =item 2110 "ECB - Binary character in Combine, binary off"
  
  =item 2200 "EIO - print to IO failed. See errno"
  
  =item 4002 "EIQ - Unescaped ESC in quoted field"
  
  =item 4003 "EIF - ESC CR"
  
  =item 4004 "EUF - "
  
  =item 3001 "EHR - Unsupported syntax for column_names ()"
  
  =item 3002 "EHR - getline_hr () called before column_names ()"
  
  =item 3003 "EHR - bind_columns () and column_names () fields count mismatch"
  
  =item 3004 "EHR - bind_columns () only accepts refs to scalars"
  
  =item 3006 "EHR - bind_columns () did not pass enough refs for parsed fields"
  
  =item 3007 "EHR - bind_columns needs refs to writable scalars"
  
  =item 3008 "EHR - unexpected error in bound fields"
  
  =back
  
  =head1 AUTHOR
  
  Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
  
  Text::CSV_XS was written by E<lt>joe[at]ispsoft.deE<gt>
  and maintained by E<lt>h.m.brand[at]xs4all.nlE<gt>.
  
  Text::CSV was written by E<lt>alan[at]mfgrtl.comE<gt>.
  
  
  =head1 COPYRIGHT AND LICENSE
  
  Copyright 2005-2013 by Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself. 
  
  =head1 SEE ALSO
  
  L<Text::CSV_XS>, L<Text::CSV>
  
  I got many regexp bases from L<http://www.din.or.jp/~ohzaki/perl.htm>
  
  =cut
TEXT_CSV_PP

$fatpacked{"x86_64-linux-gnu-thread-multi/Cwd.pm"} = <<'X86_64-LINUX-GNU-THREAD-MULTI_CWD';
  package Cwd;
  
  =head1 NAME
  
  Cwd - get pathname of current working directory
  
  =head1 SYNOPSIS
  
      use Cwd;
      my $dir = getcwd;
  
      use Cwd 'abs_path';
      my $abs_path = abs_path($file);
  
  =head1 DESCRIPTION
  
  This module provides functions for determining the pathname of the
  current working directory.  It is recommended that getcwd (or another
  *cwd() function) be used in I<all> code to ensure portability.
  
  By default, it exports the functions cwd(), getcwd(), fastcwd(), and
  fastgetcwd() (and, on Win32, getdcwd()) into the caller's namespace.  
  
  
  =head2 getcwd and friends
  
  Each of these functions are called without arguments and return the
  absolute path of the current working directory.
  
  =over 4
  
  =item getcwd
  
      my $cwd = getcwd();
  
  Returns the current working directory.
  
  Exposes the POSIX function getcwd(3) or re-implements it if it's not
  available.
  
  =item cwd
  
      my $cwd = cwd();
  
  The cwd() is the most natural form for the current architecture.  For
  most systems it is identical to `pwd` (but without the trailing line
  terminator).
  
  =item fastcwd
  
      my $cwd = fastcwd();
  
  A more dangerous version of getcwd(), but potentially faster.
  
  It might conceivably chdir() you out of a directory that it can't
  chdir() you back into.  If fastcwd encounters a problem it will return
  undef but will probably leave you in a different directory.  For a
  measure of extra security, if everything appears to have worked, the
  fastcwd() function will check that it leaves you in the same directory
  that it started in.  If it has changed it will C<die> with the message
  "Unstable directory path, current directory changed
  unexpectedly".  That should never happen.
  
  =item fastgetcwd
  
    my $cwd = fastgetcwd();
  
  The fastgetcwd() function is provided as a synonym for cwd().
  
  =item getdcwd
  
      my $cwd = getdcwd();
      my $cwd = getdcwd('C:');
  
  The getdcwd() function is also provided on Win32 to get the current working
  directory on the specified drive, since Windows maintains a separate current
  working directory for each drive.  If no drive is specified then the current
  drive is assumed.
  
  This function simply calls the Microsoft C library _getdcwd() function.
  
  =back
  
  
  =head2 abs_path and friends
  
  These functions are exported only on request.  They each take a single
  argument and return the absolute pathname for it.  If no argument is
  given they'll use the current working directory.
  
  =over 4
  
  =item abs_path
  
    my $abs_path = abs_path($file);
  
  Uses the same algorithm as getcwd().  Symbolic links and relative-path
  components ("." and "..") are resolved to return the canonical
  pathname, just like realpath(3).
  
  =item realpath
  
    my $abs_path = realpath($file);
  
  A synonym for abs_path().
  
  =item fast_abs_path
  
    my $abs_path = fast_abs_path($file);
  
  A more dangerous, but potentially faster version of abs_path.
  
  =back
  
  =head2 $ENV{PWD}
  
  If you ask to override your chdir() built-in function, 
  
    use Cwd qw(chdir);
  
  then your PWD environment variable will be kept up to date.  Note that
  it will only be kept up to date if all packages which use chdir import
  it from Cwd.
  
  
  =head1 NOTES
  
  =over 4
  
  =item *
  
  Since the path separators are different on some operating systems ('/'
  on Unix, ':' on MacPerl, etc...) we recommend you use the File::Spec
  modules wherever portability is a concern.
  
  =item *
  
  Actually, on Mac OS, the C<getcwd()>, C<fastgetcwd()> and C<fastcwd()>
  functions are all aliases for the C<cwd()> function, which, on Mac OS,
  calls `pwd`.  Likewise, the C<abs_path()> function is an alias for
  C<fast_abs_path()>.
  
  =back
  
  =head1 AUTHOR
  
  Originally by the perl5-porters.
  
  Maintained by Ken Williams <KWILLIAMS@cpan.org>
  
  =head1 COPYRIGHT
  
  Copyright (c) 2004 by the Perl 5 Porters.  All rights reserved.
  
  This program is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself.
  
  Portions of the C code in this library are copyright (c) 1994 by the
  Regents of the University of California.  All rights reserved.  The
  license on this code is compatible with the licensing of the rest of
  the distribution - please see the source code in F<Cwd.xs> for the
  details.
  
  =head1 SEE ALSO
  
  L<File::chdir>
  
  =cut
  
  use strict;
  use Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
  
  $VERSION = '3.40';
  my $xs_version = $VERSION;
  $VERSION =~ tr/_//;
  
  @ISA = qw/ Exporter /;
  @EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
  push @EXPORT, qw(getdcwd) if $^O eq 'MSWin32';
  @EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath);
  
  # sys_cwd may keep the builtin command
  
  # All the functionality of this module may provided by builtins,
  # there is no sense to process the rest of the file.
  # The best choice may be to have this in BEGIN, but how to return from BEGIN?
  
  if ($^O eq 'os2') {
      local $^W = 0;
  
      *cwd                = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
      *getcwd             = \&cwd;
      *fastgetcwd         = \&cwd;
      *fastcwd            = \&cwd;
  
      *fast_abs_path      = \&sys_abspath if defined &sys_abspath;
      *abs_path           = \&fast_abs_path;
      *realpath           = \&fast_abs_path;
      *fast_realpath      = \&fast_abs_path;
  
      return 1;
  }
  
  # Need to look up the feature settings on VMS.  The preferred way is to use the
  # VMS::Feature module, but that may not be available to dual life modules.
  
  my $use_vms_feature;
  BEGIN {
      if ($^O eq 'VMS') {
          if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
              $use_vms_feature = 1;
          }
      }
  }
  
  # Need to look up the UNIX report mode.  This may become a dynamic mode
  # in the future.
  sub _vms_unix_rpt {
      my $unix_rpt;
      if ($use_vms_feature) {
          $unix_rpt = VMS::Feature::current("filename_unix_report");
      } else {
          my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
          $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; 
      }
      return $unix_rpt;
  }
  
  # Need to look up the EFS character set mode.  This may become a dynamic
  # mode in the future.
  sub _vms_efs {
      my $efs;
      if ($use_vms_feature) {
          $efs = VMS::Feature::current("efs_charset");
      } else {
          my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
          $efs = $env_efs =~ /^[ET1]/i; 
      }
      return $efs;
  }
  
  
  # If loading the XS stuff doesn't work, we can fall back to pure perl
  eval {
    if ( $] >= 5.006 ) {
      require XSLoader;
      XSLoader::load( __PACKAGE__, $xs_version);
    } else {
      require DynaLoader;
      push @ISA, 'DynaLoader';
      __PACKAGE__->bootstrap( $xs_version );
    }
  };
  
  # Big nasty table of function aliases
  my %METHOD_MAP =
    (
     VMS =>
     {
      cwd			=> '_vms_cwd',
      getcwd		=> '_vms_cwd',
      fastcwd		=> '_vms_cwd',
      fastgetcwd		=> '_vms_cwd',
      abs_path		=> '_vms_abs_path',
      fast_abs_path	=> '_vms_abs_path',
     },
  
     MSWin32 =>
     {
      # We assume that &_NT_cwd is defined as an XSUB or in the core.
      cwd			=> '_NT_cwd',
      getcwd		=> '_NT_cwd',
      fastcwd		=> '_NT_cwd',
      fastgetcwd		=> '_NT_cwd',
      abs_path		=> 'fast_abs_path',
      realpath		=> 'fast_abs_path',
     },
  
     dos => 
     {
      cwd			=> '_dos_cwd',
      getcwd		=> '_dos_cwd',
      fastgetcwd		=> '_dos_cwd',
      fastcwd		=> '_dos_cwd',
      abs_path		=> 'fast_abs_path',
     },
  
     # QNX4.  QNX6 has a $os of 'nto'.
     qnx =>
     {
      cwd			=> '_qnx_cwd',
      getcwd		=> '_qnx_cwd',
      fastgetcwd		=> '_qnx_cwd',
      fastcwd		=> '_qnx_cwd',
      abs_path		=> '_qnx_abs_path',
      fast_abs_path	=> '_qnx_abs_path',
     },
  
     cygwin =>
     {
      getcwd		=> 'cwd',
      fastgetcwd		=> 'cwd',
      fastcwd		=> 'cwd',
      abs_path		=> 'fast_abs_path',
      realpath		=> 'fast_abs_path',
     },
  
     epoc =>
     {
      cwd			=> '_epoc_cwd',
      getcwd	        => '_epoc_cwd',
      fastgetcwd		=> '_epoc_cwd',
      fastcwd		=> '_epoc_cwd',
      abs_path		=> 'fast_abs_path',
     },
  
     MacOS =>
     {
      getcwd		=> 'cwd',
      fastgetcwd		=> 'cwd',
      fastcwd		=> 'cwd',
      abs_path		=> 'fast_abs_path',
     },
    );
  
  $METHOD_MAP{NT} = $METHOD_MAP{MSWin32};
  
  
  # Find the pwd command in the expected locations.  We assume these
  # are safe.  This prevents _backtick_pwd() consulting $ENV{PATH}
  # so everything works under taint mode.
  my $pwd_cmd;
  foreach my $try ('/bin/pwd',
  		 '/usr/bin/pwd',
  		 '/QOpenSys/bin/pwd', # OS/400 PASE.
  		) {
  
      if( -x $try ) {
          $pwd_cmd = $try;
          last;
      }
  }
  my $found_pwd_cmd = defined($pwd_cmd);
  unless ($pwd_cmd) {
      # Isn't this wrong?  _backtick_pwd() will fail if somenone has
      # pwd in their path but it is not /bin/pwd or /usr/bin/pwd?
      # See [perl #16774]. --jhi
      $pwd_cmd = 'pwd';
  }
  
  # Lazy-load Carp
  sub _carp  { require Carp; Carp::carp(@_)  }
  sub _croak { require Carp; Carp::croak(@_) }
  
  # The 'natural and safe form' for UNIX (pwd may be setuid root)
  sub _backtick_pwd {
      # Localize %ENV entries in a way that won't create new hash keys
      my @localize = grep exists $ENV{$_}, qw(PATH IFS CDPATH ENV BASH_ENV);
      local @ENV{@localize};
      
      my $cwd = `$pwd_cmd`;
      # Belt-and-suspenders in case someone said "undef $/".
      local $/ = "\n";
      # `pwd` may fail e.g. if the disk is full
      chomp($cwd) if defined $cwd;
      $cwd;
  }
  
  # Since some ports may predefine cwd internally (e.g., NT)
  # we take care not to override an existing definition for cwd().
  
  unless ($METHOD_MAP{$^O}{cwd} or defined &cwd) {
      # The pwd command is not available in some chroot(2)'ed environments
      my $sep = $Config::Config{path_sep} || ':';
      my $os = $^O;  # Protect $^O from tainting
  
  
      # Try again to find a pwd, this time searching the whole PATH.
      if (defined $ENV{PATH} and $os ne 'MSWin32') {  # no pwd on Windows
  	my @candidates = split($sep, $ENV{PATH});
  	while (!$found_pwd_cmd and @candidates) {
  	    my $candidate = shift @candidates;
  	    $found_pwd_cmd = 1 if -x "$candidate/pwd";
  	}
      }
  
      # MacOS has some special magic to make `pwd` work.
      if( $os eq 'MacOS' || $found_pwd_cmd )
      {
  	*cwd = \&_backtick_pwd;
      }
      else {
  	*cwd = \&getcwd;
      }
  }
  
  if ($^O eq 'cygwin') {
    # We need to make sure cwd() is called with no args, because it's
    # got an arg-less prototype and will die if args are present.
    local $^W = 0;
    my $orig_cwd = \&cwd;
    *cwd = sub { &$orig_cwd() }
  }
  
  
  # set a reasonable (and very safe) default for fastgetcwd, in case it
  # isn't redefined later (20001212 rspier)
  *fastgetcwd = \&cwd;
  
  # A non-XS version of getcwd() - also used to bootstrap the perl build
  # process, when miniperl is running and no XS loading happens.
  sub _perl_getcwd
  {
      abs_path('.');
  }
  
  # By John Bazik
  #
  # Usage: $cwd = &fastcwd;
  #
  # This is a faster version of getcwd.  It's also more dangerous because
  # you might chdir out of a directory that you can't chdir back into.
      
  sub fastcwd_ {
      my($odev, $oino, $cdev, $cino, $tdev, $tino);
      my(@path, $path);
      local(*DIR);
  
      my($orig_cdev, $orig_cino) = stat('.');
      ($cdev, $cino) = ($orig_cdev, $orig_cino);
      for (;;) {
  	my $direntry;
  	($odev, $oino) = ($cdev, $cino);
  	CORE::chdir('..') || return undef;
  	($cdev, $cino) = stat('.');
  	last if $odev == $cdev && $oino == $cino;
  	opendir(DIR, '.') || return undef;
  	for (;;) {
  	    $direntry = readdir(DIR);
  	    last unless defined $direntry;
  	    next if $direntry eq '.';
  	    next if $direntry eq '..';
  
  	    ($tdev, $tino) = lstat($direntry);
  	    last unless $tdev != $odev || $tino != $oino;
  	}
  	closedir(DIR);
  	return undef unless defined $direntry; # should never happen
  	unshift(@path, $direntry);
      }
      $path = '/' . join('/', @path);
      if ($^O eq 'apollo') { $path = "/".$path; }
      # At this point $path may be tainted (if tainting) and chdir would fail.
      # Untaint it then check that we landed where we started.
      $path =~ /^(.*)\z/s		# untaint
  	&& CORE::chdir($1) or return undef;
      ($cdev, $cino) = stat('.');
      die "Unstable directory path, current directory changed unexpectedly"
  	if $cdev != $orig_cdev || $cino != $orig_cino;
      $path;
  }
  if (not defined &fastcwd) { *fastcwd = \&fastcwd_ }
  
  
  # Keeps track of current working directory in PWD environment var
  # Usage:
  #	use Cwd 'chdir';
  #	chdir $newdir;
  
  my $chdir_init = 0;
  
  sub chdir_init {
      if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') {
  	my($dd,$di) = stat('.');
  	my($pd,$pi) = stat($ENV{'PWD'});
  	if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
  	    $ENV{'PWD'} = cwd();
  	}
      }
      else {
  	my $wd = cwd();
  	$wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32';
  	$ENV{'PWD'} = $wd;
      }
      # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
      if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) {
  	my($pd,$pi) = stat($2);
  	my($dd,$di) = stat($1);
  	if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
  	    $ENV{'PWD'}="$2$3";
  	}
      }
      $chdir_init = 1;
  }
  
  sub chdir {
      my $newdir = @_ ? shift : '';	# allow for no arg (chdir to HOME dir)
      $newdir =~ s|///*|/|g unless $^O eq 'MSWin32';
      chdir_init() unless $chdir_init;
      my $newpwd;
      if ($^O eq 'MSWin32') {
  	# get the full path name *before* the chdir()
  	$newpwd = Win32::GetFullPathName($newdir);
      }
  
      return 0 unless CORE::chdir $newdir;
  
      if ($^O eq 'VMS') {
  	return $ENV{'PWD'} = $ENV{'DEFAULT'}
      }
      elsif ($^O eq 'MacOS') {
  	return $ENV{'PWD'} = cwd();
      }
      elsif ($^O eq 'MSWin32') {
  	$ENV{'PWD'} = $newpwd;
  	return 1;
      }
  
      if (ref $newdir eq 'GLOB') { # in case a file/dir handle is passed in
  	$ENV{'PWD'} = cwd();
      } elsif ($newdir =~ m#^/#s) {
  	$ENV{'PWD'} = $newdir;
      } else {
  	my @curdir = split(m#/#,$ENV{'PWD'});
  	@curdir = ('') unless @curdir;
  	my $component;
  	foreach $component (split(m#/#, $newdir)) {
  	    next if $component eq '.';
  	    pop(@curdir),next if $component eq '..';
  	    push(@curdir,$component);
  	}
  	$ENV{'PWD'} = join('/',@curdir) || '/';
      }
      1;
  }
  
  
  sub _perl_abs_path
  {
      my $start = @_ ? shift : '.';
      my($dotdots, $cwd, @pst, @cst, $dir, @tst);
  
      unless (@cst = stat( $start ))
      {
  	_carp("stat($start): $!");
  	return '';
      }
  
      unless (-d _) {
          # Make sure we can be invoked on plain files, not just directories.
          # NOTE that this routine assumes that '/' is the only directory separator.
  	
          my ($dir, $file) = $start =~ m{^(.*)/(.+)$}
  	    or return cwd() . '/' . $start;
  	
  	# Can't use "-l _" here, because the previous stat was a stat(), not an lstat().
  	if (-l $start) {
  	    my $link_target = readlink($start);
  	    die "Can't resolve link $start: $!" unless defined $link_target;
  	    
  	    require File::Spec;
              $link_target = $dir . '/' . $link_target
                  unless File::Spec->file_name_is_absolute($link_target);
  	    
  	    return abs_path($link_target);
  	}
  	
  	return $dir ? abs_path($dir) . "/$file" : "/$file";
      }
  
      $cwd = '';
      $dotdots = $start;
      do
      {
  	$dotdots .= '/..';
  	@pst = @cst;
  	local *PARENT;
  	unless (opendir(PARENT, $dotdots))
  	{
  	    # probably a permissions issue.  Try the native command.
  	    require File::Spec;
  	    return File::Spec->rel2abs( $start, _backtick_pwd() );
  	}
  	unless (@cst = stat($dotdots))
  	{
  	    _carp("stat($dotdots): $!");
  	    closedir(PARENT);
  	    return '';
  	}
  	if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
  	{
  	    $dir = undef;
  	}
  	else
  	{
  	    do
  	    {
  		unless (defined ($dir = readdir(PARENT)))
  	        {
  		    _carp("readdir($dotdots): $!");
  		    closedir(PARENT);
  		    return '';
  		}
  		$tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
  	    }
  	    while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
  		   $tst[1] != $pst[1]);
  	}
  	$cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
  	closedir(PARENT);
      } while (defined $dir);
      chop($cwd) unless $cwd eq '/'; # drop the trailing /
      $cwd;
  }
  
  
  my $Curdir;
  sub fast_abs_path {
      local $ENV{PWD} = $ENV{PWD} || ''; # Guard against clobberage
      my $cwd = getcwd();
      require File::Spec;
      my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir);
  
      # Detaint else we'll explode in taint mode.  This is safe because
      # we're not doing anything dangerous with it.
      ($path) = $path =~ /(.*)/s;
      ($cwd)  = $cwd  =~ /(.*)/s;
  
      unless (-e $path) {
   	_croak("$path: No such file or directory");
      }
  
      unless (-d _) {
          # Make sure we can be invoked on plain files, not just directories.
  	
  	my ($vol, $dir, $file) = File::Spec->splitpath($path);
  	return File::Spec->catfile($cwd, $path) unless length $dir;
  
  	if (-l $path) {
  	    my $link_target = readlink($path);
  	    die "Can't resolve link $path: $!" unless defined $link_target;
  	    
  	    $link_target = File::Spec->catpath($vol, $dir, $link_target)
                  unless File::Spec->file_name_is_absolute($link_target);
  	    
  	    return fast_abs_path($link_target);
  	}
  	
  	return $dir eq File::Spec->rootdir
  	  ? File::Spec->catpath($vol, $dir, $file)
  	  : fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file;
      }
  
      if (!CORE::chdir($path)) {
   	_croak("Cannot chdir to $path: $!");
      }
      my $realpath = getcwd();
      if (! ((-d $cwd) && (CORE::chdir($cwd)))) {
   	_croak("Cannot chdir back to $cwd: $!");
      }
      $realpath;
  }
  
  # added function alias to follow principle of least surprise
  # based on previous aliasing.  --tchrist 27-Jan-00
  *fast_realpath = \&fast_abs_path;
  
  
  # --- PORTING SECTION ---
  
  # VMS: $ENV{'DEFAULT'} points to default directory at all times
  # 06-Mar-1996  Charles Bailey  bailey@newman.upenn.edu
  # Note: Use of Cwd::chdir() causes the logical name PWD to be defined
  #   in the process logical name table as the default device and directory
  #   seen by Perl. This may not be the same as the default device
  #   and directory seen by DCL after Perl exits, since the effects
  #   the CRTL chdir() function persist only until Perl exits.
  
  sub _vms_cwd {
      return $ENV{'DEFAULT'};
  }
  
  sub _vms_abs_path {
      return $ENV{'DEFAULT'} unless @_;
      my $path = shift;
  
      my $efs = _vms_efs;
      my $unix_rpt = _vms_unix_rpt;
  
      if (defined &VMS::Filespec::vmsrealpath) {
          my $path_unix = 0;
          my $path_vms = 0;
  
          $path_unix = 1 if ($path =~ m#(?<=\^)/#);
          $path_unix = 1 if ($path =~ /^\.\.?$/);
          $path_vms = 1 if ($path =~ m#[\[<\]]#);
          $path_vms = 1 if ($path =~ /^--?$/);
  
          my $unix_mode = $path_unix;
          if ($efs) {
              # In case of a tie, the Unix report mode decides.
              if ($path_vms == $path_unix) {
                  $unix_mode = $unix_rpt;
              } else {
                  $unix_mode = 0 if $path_vms;
              }
          }
  
          if ($unix_mode) {
              # Unix format
              return VMS::Filespec::unixrealpath($path);
          }
  
  	# VMS format
  
  	my $new_path = VMS::Filespec::vmsrealpath($path);
  
  	# Perl expects directories to be in directory format
  	$new_path = VMS::Filespec::pathify($new_path) if -d $path;
  	return $new_path;
      }
  
      # Fallback to older algorithm if correct ones are not
      # available.
  
      if (-l $path) {
          my $link_target = readlink($path);
          die "Can't resolve link $path: $!" unless defined $link_target;
  
          return _vms_abs_path($link_target);
      }
  
      # may need to turn foo.dir into [.foo]
      my $pathified = VMS::Filespec::pathify($path);
      $path = $pathified if defined $pathified;
  	
      return VMS::Filespec::rmsexpand($path);
  }
  
  sub _os2_cwd {
      $ENV{'PWD'} = `cmd /c cd`;
      chomp $ENV{'PWD'};
      $ENV{'PWD'} =~ s:\\:/:g ;
      return $ENV{'PWD'};
  }
  
  sub _win32_cwd_simple {
      $ENV{'PWD'} = `cd`;
      chomp $ENV{'PWD'};
      $ENV{'PWD'} =~ s:\\:/:g ;
      return $ENV{'PWD'};
  }
  
  sub _win32_cwd {
      # Need to avoid taking any sort of reference to the typeglob or the code in
      # the optree, so that this tests the runtime state of things, as the
      # ExtUtils::MakeMaker tests for "miniperl" need to be able to fake things at
      # runtime by deleting the subroutine. *foo{THING} syntax on a symbol table
      # lookup avoids needing a string eval, which has been reported to cause
      # problems (for reasons that we haven't been able to get to the bottom of -
      # rt.cpan.org #56225)
      if (*{$DynaLoader::{boot_DynaLoader}}{CODE}) {
  	$ENV{'PWD'} = Win32::GetCwd();
      }
      else { # miniperl
  	chomp($ENV{'PWD'} = `cd`);
      }
      $ENV{'PWD'} =~ s:\\:/:g ;
      return $ENV{'PWD'};
  }
  
  *_NT_cwd = defined &Win32::GetCwd ? \&_win32_cwd : \&_win32_cwd_simple;
  
  sub _dos_cwd {
      if (!defined &Dos::GetCwd) {
          $ENV{'PWD'} = `command /c cd`;
          chomp $ENV{'PWD'};
          $ENV{'PWD'} =~ s:\\:/:g ;
      } else {
          $ENV{'PWD'} = Dos::GetCwd();
      }
      return $ENV{'PWD'};
  }
  
  sub _qnx_cwd {
  	local $ENV{PATH} = '';
  	local $ENV{CDPATH} = '';
  	local $ENV{ENV} = '';
      $ENV{'PWD'} = `/usr/bin/fullpath -t`;
      chomp $ENV{'PWD'};
      return $ENV{'PWD'};
  }
  
  sub _qnx_abs_path {
  	local $ENV{PATH} = '';
  	local $ENV{CDPATH} = '';
  	local $ENV{ENV} = '';
      my $path = @_ ? shift : '.';
      local *REALPATH;
  
      defined( open(REALPATH, '-|') || exec '/usr/bin/fullpath', '-t', $path ) or
        die "Can't open /usr/bin/fullpath: $!";
      my $realpath = <REALPATH>;
      close REALPATH;
      chomp $realpath;
      return $realpath;
  }
  
  sub _epoc_cwd {
      $ENV{'PWD'} = EPOC::getcwd();
      return $ENV{'PWD'};
  }
  
  
  # Now that all the base-level functions are set up, alias the
  # user-level functions to the right places
  
  if (exists $METHOD_MAP{$^O}) {
    my $map = $METHOD_MAP{$^O};
    foreach my $name (keys %$map) {
      local $^W = 0;  # assignments trigger 'subroutine redefined' warning
      no strict 'refs';
      *{$name} = \&{$map->{$name}};
    }
  }
  
  # In case the XS version doesn't load.
  *abs_path = \&_perl_abs_path unless defined &abs_path;
  *getcwd = \&_perl_getcwd unless defined &getcwd;
  
  # added function alias for those of us more
  # used to the libc function.  --tchrist 27-Jan-00
  *realpath = \&abs_path;
  
  1;
X86_64-LINUX-GNU-THREAD-MULTI_CWD

$fatpacked{"x86_64-linux-gnu-thread-multi/File/Spec.pm"} = <<'X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC';
  package File::Spec;
  
  use strict;
  use vars qw(@ISA $VERSION);
  
  $VERSION = '3.40';
  $VERSION =~ tr/_//;
  
  my %module = (MacOS   => 'Mac',
  	      MSWin32 => 'Win32',
  	      os2     => 'OS2',
  	      VMS     => 'VMS',
  	      epoc    => 'Epoc',
  	      NetWare => 'Win32', # Yes, File::Spec::Win32 works on NetWare.
  	      symbian => 'Win32', # Yes, File::Spec::Win32 works on symbian.
  	      dos     => 'OS2',   # Yes, File::Spec::OS2 works on DJGPP.
  	      cygwin  => 'Cygwin');
  
  
  my $module = $module{$^O} || 'Unix';
  
  require "File/Spec/$module.pm";
  @ISA = ("File::Spec::$module");
  
  1;
  
  __END__
  
  =head1 NAME
  
  File::Spec - portably perform operations on file names
  
  =head1 SYNOPSIS
  
  	use File::Spec;
  
  	$x=File::Spec->catfile('a', 'b', 'c');
  
  which returns 'a/b/c' under Unix. Or:
  
  	use File::Spec::Functions;
  
  	$x = catfile('a', 'b', 'c');
  
  =head1 DESCRIPTION
  
  This module is designed to support operations commonly performed on file
  specifications (usually called "file names", but not to be confused with the
  contents of a file, or Perl's file handles), such as concatenating several
  directory and file names into a single path, or determining whether a path
  is rooted. It is based on code directly taken from MakeMaker 5.17, code
  written by Andreas KE<ouml>nig, Andy Dougherty, Charles Bailey, Ilya
  Zakharevich, Paul Schinder, and others.
  
  Since these functions are different for most operating systems, each set of
  OS specific routines is available in a separate module, including:
  
  	File::Spec::Unix
  	File::Spec::Mac
  	File::Spec::OS2
  	File::Spec::Win32
  	File::Spec::VMS
  
  The module appropriate for the current OS is automatically loaded by
  File::Spec. Since some modules (like VMS) make use of facilities available
  only under that OS, it may not be possible to load all modules under all
  operating systems.
  
  Since File::Spec is object oriented, subroutines should not be called directly,
  as in:
  
  	File::Spec::catfile('a','b');
  
  but rather as class methods:
  
  	File::Spec->catfile('a','b');
  
  For simple uses, L<File::Spec::Functions> provides convenient functional
  forms of these methods.
  
  =head1 METHODS
  
  =over 2
  
  =item canonpath
  X<canonpath>
  
  No physical check on the filesystem, but a logical cleanup of a
  path.
  
      $cpath = File::Spec->canonpath( $path ) ;
  
  Note that this does *not* collapse F<x/../y> sections into F<y>.  This
  is by design.  If F</foo> on your system is a symlink to F</bar/baz>,
  then F</foo/../quux> is actually F</bar/quux>, not F</quux> as a naive
  F<../>-removal would give you.  If you want to do this kind of
  processing, you probably want C<Cwd>'s C<realpath()> function to
  actually traverse the filesystem cleaning up paths like this.
  
  =item catdir
  X<catdir>
  
  Concatenate two or more directory names to form a complete path ending
  with a directory. But remove the trailing slash from the resulting
  string, because it doesn't look good, isn't necessary and confuses
  OS/2. Of course, if this is the root directory, don't cut off the
  trailing slash :-)
  
      $path = File::Spec->catdir( @directories );
  
  =item catfile
  X<catfile>
  
  Concatenate one or more directory names and a filename to form a
  complete path ending with a filename
  
      $path = File::Spec->catfile( @directories, $filename );
  
  =item curdir
  X<curdir>
  
  Returns a string representation of the current directory.
  
      $curdir = File::Spec->curdir();
  
  =item devnull
  X<devnull>
  
  Returns a string representation of the null device.
  
      $devnull = File::Spec->devnull();
  
  =item rootdir
  X<rootdir>
  
  Returns a string representation of the root directory.
  
      $rootdir = File::Spec->rootdir();
  
  =item tmpdir
  X<tmpdir>
  
  Returns a string representation of the first writable directory from a
  list of possible temporary directories.  Returns the current directory
  if no writable temporary directories are found.  The list of directories
  checked depends on the platform; e.g. File::Spec::Unix checks C<$ENV{TMPDIR}>
  (unless taint is on) and F</tmp>.
  
      $tmpdir = File::Spec->tmpdir();
  
  =item updir
  X<updir>
  
  Returns a string representation of the parent directory.
  
      $updir = File::Spec->updir();
  
  =item no_upwards
  
  Given a list of file names, strip out those that refer to a parent
  directory. (Does not strip symlinks, only '.', '..', and equivalents.)
  
      @paths = File::Spec->no_upwards( @paths );
  
  =item case_tolerant
  
  Returns a true or false value indicating, respectively, that alphabetic
  case is not or is significant when comparing file specifications.
  Cygwin and Win32 accept an optional drive argument.
  
      $is_case_tolerant = File::Spec->case_tolerant();
  
  =item file_name_is_absolute
  
  Takes as its argument a path, and returns true if it is an absolute path.
  
      $is_absolute = File::Spec->file_name_is_absolute( $path );
  
  This does not consult the local filesystem on Unix, Win32, OS/2, or
  Mac OS (Classic).  It does consult the working environment for VMS
  (see L<File::Spec::VMS/file_name_is_absolute>).
  
  =item path
  X<path>
  
  Takes no argument.  Returns the environment variable C<PATH> (or the local
  platform's equivalent) as a list.
  
      @PATH = File::Spec->path();
  
  =item join
  X<join, path>
  
  join is the same as catfile.
  
  =item splitpath
  X<splitpath> X<split, path>
  
  Splits a path in to volume, directory, and filename portions. On systems
  with no concept of volume, returns '' for volume. 
  
      ($volume,$directories,$file) =
                         File::Spec->splitpath( $path );
      ($volume,$directories,$file) =
                         File::Spec->splitpath( $path, $no_file );
  
  For systems with no syntax differentiating filenames from directories, 
  assumes that the last file is a path unless C<$no_file> is true or a
  trailing separator or F</.> or F</..> is present. On Unix, this means that C<$no_file>
  true makes this return ( '', $path, '' ).
  
  The directory portion may or may not be returned with a trailing '/'.
  
  The results can be passed to L</catpath()> to get back a path equivalent to
  (usually identical to) the original path.
  
  =item splitdir
  X<splitdir> X<split, dir>
  
  The opposite of L</catdir>.
  
      @dirs = File::Spec->splitdir( $directories );
  
  C<$directories> must be only the directory portion of the path on systems 
  that have the concept of a volume or that have path syntax that differentiates
  files from directories.
  
  Unlike just splitting the directories on the separator, empty
  directory names (C<''>) can be returned, because these are significant
  on some OSes.
  
  =item catpath()
  
  Takes volume, directory and file portions and returns an entire path. Under
  Unix, C<$volume> is ignored, and directory and file are concatenated.  A '/' is
  inserted if need be.  On other OSes, C<$volume> is significant.
  
      $full_path = File::Spec->catpath( $volume, $directory, $file );
  
  =item abs2rel
  X<abs2rel> X<absolute, path> X<relative, path>
  
  Takes a destination path and an optional base path returns a relative path
  from the base path to the destination path:
  
      $rel_path = File::Spec->abs2rel( $path ) ;
      $rel_path = File::Spec->abs2rel( $path, $base ) ;
  
  If C<$base> is not present or '', then L<Cwd::cwd()|Cwd> is used. If C<$base> is
  relative, then it is converted to absolute form using
  L</rel2abs()>. This means that it is taken to be relative to
  L<Cwd::cwd()|Cwd>.
  
  On systems with the concept of volume, if C<$path> and C<$base> appear to be
  on two different volumes, we will not attempt to resolve the two
  paths, and we will instead simply return C<$path>.  Note that previous
  versions of this module ignored the volume of C<$base>, which resulted in
  garbage results part of the time.
  
  On systems that have a grammar that indicates filenames, this ignores the 
  C<$base> filename as well. Otherwise all path components are assumed to be
  directories.
  
  If C<$path> is relative, it is converted to absolute form using L</rel2abs()>.
  This means that it is taken to be relative to L<Cwd::cwd()|Cwd>.
  
  No checks against the filesystem are made.  On VMS, there is
  interaction with the working environment, as logicals and
  macros are expanded.
  
  Based on code written by Shigio Yamaguchi.
  
  =item rel2abs()
  X<rel2abs> X<absolute, path> X<relative, path>
  
  Converts a relative path to an absolute path. 
  
      $abs_path = File::Spec->rel2abs( $path ) ;
      $abs_path = File::Spec->rel2abs( $path, $base ) ;
  
  If C<$base> is not present or '', then L<Cwd::cwd()|Cwd> is used. If C<$base> is relative,
  then it is converted to absolute form using L</rel2abs()>. This means that it
  is taken to be relative to L<Cwd::cwd()|Cwd>.
  
  On systems with the concept of volume, if C<$path> and C<$base> appear to be
  on two different volumes, we will not attempt to resolve the two
  paths, and we will instead simply return C<$path>.  Note that previous
  versions of this module ignored the volume of C<$base>, which resulted in
  garbage results part of the time.
  
  On systems that have a grammar that indicates filenames, this ignores the 
  C<$base> filename as well. Otherwise all path components are assumed to be
  directories.
  
  If C<$path> is absolute, it is cleaned up and returned using L</canonpath>.
  
  No checks against the filesystem are made.  On VMS, there is
  interaction with the working environment, as logicals and
  macros are expanded.
  
  Based on code written by Shigio Yamaguchi.
  
  =back
  
  For further information, please see L<File::Spec::Unix>,
  L<File::Spec::Mac>, L<File::Spec::OS2>, L<File::Spec::Win32>, or
  L<File::Spec::VMS>.
  
  =head1 SEE ALSO
  
  L<File::Spec::Unix>, L<File::Spec::Mac>, L<File::Spec::OS2>,
  L<File::Spec::Win32>, L<File::Spec::VMS>, L<File::Spec::Functions>,
  L<ExtUtils::MakeMaker>
  
  =head1 AUTHOR
  
  Currently maintained by Ken Williams C<< <KWILLIAMS@cpan.org> >>.
  
  The vast majority of the code was written by
  Kenneth Albanowski C<< <kjahds@kjahds.com> >>,
  Andy Dougherty C<< <doughera@lafayette.edu> >>,
  Andreas KE<ouml>nig C<< <A.Koenig@franz.ww.TU-Berlin.DE> >>,
  Tim Bunce C<< <Tim.Bunce@ig.co.uk> >>.
  VMS support by Charles Bailey C<< <bailey@newman.upenn.edu> >>.
  OS/2 support by Ilya Zakharevich C<< <ilya@math.ohio-state.edu> >>.
  Mac support by Paul Schinder C<< <schinder@pobox.com> >>, and
  Thomas Wegner C<< <wegner_thomas@yahoo.com> >>.
  abs2rel() and rel2abs() written by Shigio Yamaguchi C<< <shigio@tamacom.com> >>,
  modified by Barrie Slaymaker C<< <barries@slaysys.com> >>.
  splitpath(), splitdir(), catpath() and catdir() by Barrie Slaymaker.
  
  =head1 COPYRIGHT
  
  Copyright (c) 2004-2013 by the Perl 5 Porters.  All rights reserved.
  
  This program is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself.
  
  =cut
X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC

$fatpacked{"x86_64-linux-gnu-thread-multi/File/Spec/Cygwin.pm"} = <<'X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC_CYGWIN';
  package File::Spec::Cygwin;
  
  use strict;
  use vars qw(@ISA $VERSION);
  require File::Spec::Unix;
  
  $VERSION = '3.40';
  $VERSION =~ tr/_//;
  
  @ISA = qw(File::Spec::Unix);
  
  =head1 NAME
  
  File::Spec::Cygwin - methods for Cygwin file specs
  
  =head1 SYNOPSIS
  
   require File::Spec::Cygwin; # Done internally by File::Spec if needed
  
  =head1 DESCRIPTION
  
  See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
  implementation of these methods, not the semantics.
  
  This module is still in beta.  Cygwin-knowledgeable folks are invited
  to offer patches and suggestions.
  
  =cut
  
  =pod
  
  =over 4
  
  =item canonpath
  
  Any C<\> (backslashes) are converted to C</> (forward slashes),
  and then File::Spec::Unix canonpath() is called on the result.
  
  =cut
  
  sub canonpath {
      my($self,$path) = @_;
      return unless defined $path;
  
      $path =~ s|\\|/|g;
  
      # Handle network path names beginning with double slash
      my $node = '';
      if ( $path =~ s@^(//[^/]+)(?:/|\z)@/@s ) {
          $node = $1;
      }
      return $node . $self->SUPER::canonpath($path);
  }
  
  sub catdir {
      my $self = shift;
      return unless @_;
  
      # Don't create something that looks like a //network/path
      if ($_[0] and ($_[0] eq '/' or $_[0] eq '\\')) {
          shift;
          return $self->SUPER::catdir('', @_);
      }
  
      $self->SUPER::catdir(@_);
  }
  
  =pod
  
  =item file_name_is_absolute
  
  True is returned if the file name begins with C<drive_letter:>,
  and if not, File::Spec::Unix file_name_is_absolute() is called.
  
  =cut
  
  
  sub file_name_is_absolute {
      my ($self,$file) = @_;
      return 1 if $file =~ m{^([a-z]:)?[\\/]}is; # C:/test
      return $self->SUPER::file_name_is_absolute($file);
  }
  
  =item tmpdir (override)
  
  Returns a string representation of the first existing directory
  from the following list:
  
      $ENV{TMPDIR}
      /tmp
      $ENV{'TMP'}
      $ENV{'TEMP'}
      C:/temp
  
  Since Perl 5.8.0, if running under taint mode, and if the environment
  variables are tainted, they are not used.
  
  =cut
  
  my $tmpdir;
  sub tmpdir {
      return $tmpdir if defined $tmpdir;
      $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp", $ENV{'TMP'}, $ENV{'TEMP'}, 'C:/temp' );
  }
  
  =item case_tolerant
  
  Override Unix. Cygwin case-tolerance depends on managed mount settings and
  as with MsWin32 on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE,
  indicating the case significance when comparing file specifications.
  Default: 1
  
  =cut
  
  sub case_tolerant {
    return 1 unless $^O eq 'cygwin'
      and defined &Cygwin::mount_flags;
  
    my $drive = shift;
    if (! $drive) {
        my @flags = split(/,/, Cygwin::mount_flags('/cygwin'));
        my $prefix = pop(@flags);
        if (! $prefix || $prefix eq 'cygdrive') {
            $drive = '/cygdrive/c';
        } elsif ($prefix eq '/') {
            $drive = '/c';
        } else {
            $drive = "$prefix/c";
        }
    }
    my $mntopts = Cygwin::mount_flags($drive);
    if ($mntopts and ($mntopts =~ /,managed/)) {
      return 0;
    }
    eval { require Win32API::File; } or return 1;
    my $osFsType = "\0"x256;
    my $osVolName = "\0"x256;
    my $ouFsFlags = 0;
    Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 );
    if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; }
    else { return 1; }
  }
  
  =back
  
  =head1 COPYRIGHT
  
  Copyright (c) 2004,2007 by the Perl 5 Porters.  All rights reserved.
  
  This program is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself.
  
  =cut
  
  1;
X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC_CYGWIN

$fatpacked{"x86_64-linux-gnu-thread-multi/File/Spec/Epoc.pm"} = <<'X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC_EPOC';
  package File::Spec::Epoc;
  
  use strict;
  use vars qw($VERSION @ISA);
  
  $VERSION = '3.40';
  $VERSION =~ tr/_//;
  
  require File::Spec::Unix;
  @ISA = qw(File::Spec::Unix);
  
  =head1 NAME
  
  File::Spec::Epoc - methods for Epoc file specs
  
  =head1 SYNOPSIS
  
   require File::Spec::Epoc; # Done internally by File::Spec if needed
  
  =head1 DESCRIPTION
  
  See File::Spec::Unix for a documentation of the methods provided
  there. This package overrides the implementation of these methods, not
  the semantics.
  
  This package is still work in progress ;-)
  
  =cut
  
  sub case_tolerant {
      return 1;
  }
  
  =pod
  
  =over 4
  
  =item canonpath()
  
  No physical check on the filesystem, but a logical cleanup of a
  path. On UNIX eliminated successive slashes and successive "/.".
  
  =back
  
  =cut
  
  sub canonpath {
      my ($self,$path) = @_;
      return unless defined $path;
  
      $path =~ s|/+|/|g;                             # xx////xx  -> xx/xx
      $path =~ s|(/\.)+/|/|g;                        # xx/././xx -> xx/xx
      $path =~ s|^(\./)+||s unless $path eq "./";    # ./xx      -> xx
      $path =~ s|^/(\.\./)+|/|s;                     # /../../xx -> xx
      $path =~  s|/\Z(?!\n)|| unless $path eq "/";          # xx/       -> xx
      return $path;
  }
  
  =pod
  
  =head1 AUTHOR
  
  o.flebbe@gmx.de
  
  =head1 COPYRIGHT
  
  Copyright (c) 2004 by the Perl 5 Porters.  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
  
  See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
  implementation of these methods, not the semantics.
  
  =cut
  
  1;
X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC_EPOC

$fatpacked{"x86_64-linux-gnu-thread-multi/File/Spec/Functions.pm"} = <<'X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC_FUNCTIONS';
  package File::Spec::Functions;
  
  use File::Spec;
  use strict;
  
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  
  $VERSION = '3.40';
  $VERSION =~ tr/_//;
  
  require Exporter;
  
  @ISA = qw(Exporter);
  
  @EXPORT = qw(
  	canonpath
  	catdir
  	catfile
  	curdir
  	rootdir
  	updir
  	no_upwards
  	file_name_is_absolute
  	path
  );
  
  @EXPORT_OK = qw(
  	devnull
  	tmpdir
  	splitpath
  	splitdir
  	catpath
  	abs2rel
  	rel2abs
  	case_tolerant
  );
  
  %EXPORT_TAGS = ( ALL => [ @EXPORT_OK, @EXPORT ] );
  
  foreach my $meth (@EXPORT, @EXPORT_OK) {
      my $sub = File::Spec->can($meth);
      no strict 'refs';
      *{$meth} = sub {&$sub('File::Spec', @_)};
  }
  
  
  1;
  __END__
  
  =head1 NAME
  
  File::Spec::Functions - portably perform operations on file names
  
  =head1 SYNOPSIS
  
  	use File::Spec::Functions;
  	$x = catfile('a','b');
  
  =head1 DESCRIPTION
  
  This module exports convenience functions for all of the class methods
  provided by File::Spec.
  
  For a reference of available functions, please consult L<File::Spec::Unix>,
  which contains the entire set, and which is inherited by the modules for
  other platforms. For further information, please see L<File::Spec::Mac>,
  L<File::Spec::OS2>, L<File::Spec::Win32>, or L<File::Spec::VMS>.
  
  =head2 Exports
  
  The following functions are exported by default.
  
  	canonpath
  	catdir
  	catfile
  	curdir
  	rootdir
  	updir
  	no_upwards
  	file_name_is_absolute
  	path
  
  
  The following functions are exported only by request.
  
  	devnull
  	tmpdir
  	splitpath
  	splitdir
  	catpath
  	abs2rel
  	rel2abs
  	case_tolerant
  
  All the functions may be imported using the C<:ALL> tag.
  
  =head1 COPYRIGHT
  
  Copyright (c) 2004 by the Perl 5 Porters.  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
  
  File::Spec, File::Spec::Unix, File::Spec::Mac, File::Spec::OS2,
  File::Spec::Win32, File::Spec::VMS, ExtUtils::MakeMaker
  
  =cut
  
X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC_FUNCTIONS

$fatpacked{"x86_64-linux-gnu-thread-multi/File/Spec/Mac.pm"} = <<'X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC_MAC';
  package File::Spec::Mac;
  
  use strict;
  use vars qw(@ISA $VERSION);
  require File::Spec::Unix;
  
  $VERSION = '3.40';
  $VERSION =~ tr/_//;
  
  @ISA = qw(File::Spec::Unix);
  
  my $macfiles;
  if ($^O eq 'MacOS') {
  	$macfiles = eval { require Mac::Files };
  }
  
  sub case_tolerant { 1 }
  
  
  =head1 NAME
  
  File::Spec::Mac - File::Spec for Mac OS (Classic)
  
  =head1 SYNOPSIS
  
   require File::Spec::Mac; # Done internally by File::Spec if needed
  
  =head1 DESCRIPTION
  
  Methods for manipulating file specifications.
  
  =head1 METHODS
  
  =over 2
  
  =item canonpath
  
  On Mac OS, there's nothing to be done. Returns what it's given.
  
  =cut
  
  sub canonpath {
      my ($self,$path) = @_;
      return $path;
  }
  
  =item catdir()
  
  Concatenate two or more directory names to form a path separated by colons
  (":") ending with a directory. Resulting paths are B<relative> by default,
  but can be forced to be absolute (but avoid this, see below). Automatically
  puts a trailing ":" on the end of the complete path, because that's what's
  done in MacPerl's environment and helps to distinguish a file path from a
  directory path.
  
  B<IMPORTANT NOTE:> Beginning with version 1.3 of this module, the resulting
  path is relative by default and I<not> absolute. This decision was made due
  to portability reasons. Since C<File::Spec-E<gt>catdir()> returns relative paths
  on all other operating systems, it will now also follow this convention on Mac
  OS. Note that this may break some existing scripts.
  
  The intended purpose of this routine is to concatenate I<directory names>.
  But because of the nature of Macintosh paths, some additional possibilities
  are allowed to make using this routine give reasonable results for some
  common situations. In other words, you are also allowed to concatenate
  I<paths> instead of directory names (strictly speaking, a string like ":a"
  is a path, but not a name, since it contains a punctuation character ":").
  
  So, beside calls like
  
      catdir("a") = ":a:"
      catdir("a","b") = ":a:b:"
      catdir() = ""                    (special case)
  
  calls like the following
  
      catdir(":a:") = ":a:"
      catdir(":a","b") = ":a:b:"
      catdir(":a:","b") = ":a:b:"
      catdir(":a:",":b:") = ":a:b:"
      catdir(":") = ":"
  
  are allowed.
  
  Here are the rules that are used in C<catdir()>; note that we try to be as
  compatible as possible to Unix:
  
  =over 2
  
  =item 1.
  
  The resulting path is relative by default, i.e. the resulting path will have a
  leading colon.
  
  =item 2.
  
  A trailing colon is added automatically to the resulting path, to denote a
  directory.
  
  =item 3.
  
  Generally, each argument has one leading ":" and one trailing ":"
  removed (if any). They are then joined together by a ":". Special
  treatment applies for arguments denoting updir paths like "::lib:",
  see (4), or arguments consisting solely of colons ("colon paths"),
  see (5).
  
  =item 4.
  
  When an updir path like ":::lib::" is passed as argument, the number
  of directories to climb up is handled correctly, not removing leading
  or trailing colons when necessary. E.g.
  
      catdir(":::a","::b","c")    = ":::a::b:c:"
      catdir(":::a::","::b","c")  = ":::a:::b:c:"
  
  =item 5.
  
  Adding a colon ":" or empty string "" to a path at I<any> position
  doesn't alter the path, i.e. these arguments are ignored. (When a ""
  is passed as the first argument, it has a special meaning, see
  (6)). This way, a colon ":" is handled like a "." (curdir) on Unix,
  while an empty string "" is generally ignored (see
  C<Unix-E<gt>canonpath()> ). Likewise, a "::" is handled like a ".."
  (updir), and a ":::" is handled like a "../.." etc.  E.g.
  
      catdir("a",":",":","b")   = ":a:b:"
      catdir("a",":","::",":b") = ":a::b:"
  
  =item 6.
  
  If the first argument is an empty string "" or is a volume name, i.e. matches
  the pattern /^[^:]+:/, the resulting path is B<absolute>.
  
  =item 7.
  
  Passing an empty string "" as the first argument to C<catdir()> is
  like passingC<File::Spec-E<gt>rootdir()> as the first argument, i.e.
  
      catdir("","a","b")          is the same as
  
      catdir(rootdir(),"a","b").
  
  This is true on Unix, where C<catdir("","a","b")> yields "/a/b" and
  C<rootdir()> is "/". Note that C<rootdir()> on Mac OS is the startup
  volume, which is the closest in concept to Unix' "/". This should help
  to run existing scripts originally written for Unix.
  
  =item 8.
  
  For absolute paths, some cleanup is done, to ensure that the volume
  name isn't immediately followed by updirs. This is invalid, because
  this would go beyond "root". Generally, these cases are handled like
  their Unix counterparts:
  
   Unix:
      Unix->catdir("","")                 =  "/"
      Unix->catdir("",".")                =  "/"
      Unix->catdir("","..")               =  "/"        # can't go
                                                        # beyond root
      Unix->catdir("",".","..","..","a")  =  "/a"
   Mac:
      Mac->catdir("","")                  =  rootdir()  # (e.g. "HD:")
      Mac->catdir("",":")                 =  rootdir()
      Mac->catdir("","::")                =  rootdir()  # can't go
                                                        # beyond root
      Mac->catdir("",":","::","::","a")   =  rootdir() . "a:"
                                                      # (e.g. "HD:a:")
  
  However, this approach is limited to the first arguments following
  "root" (again, see C<Unix-E<gt>canonpath()> ). If there are more
  arguments that move up the directory tree, an invalid path going
  beyond root can be created.
  
  =back
  
  As you've seen, you can force C<catdir()> to create an absolute path
  by passing either an empty string or a path that begins with a volume
  name as the first argument. However, you are strongly encouraged not
  to do so, since this is done only for backward compatibility. Newer
  versions of File::Spec come with a method called C<catpath()> (see
  below), that is designed to offer a portable solution for the creation
  of absolute paths.  It takes volume, directory and file portions and
  returns an entire path. While C<catdir()> is still suitable for the
  concatenation of I<directory names>, you are encouraged to use
  C<catpath()> to concatenate I<volume names> and I<directory
  paths>. E.g.
  
      $dir      = File::Spec->catdir("tmp","sources");
      $abs_path = File::Spec->catpath("MacintoshHD:", $dir,"");
  
  yields
  
      "MacintoshHD:tmp:sources:" .
  
  =cut
  
  sub catdir {
  	my $self = shift;
  	return '' unless @_;
  	my @args = @_;
  	my $first_arg;
  	my $relative;
  
  	# take care of the first argument
  
  	if ($args[0] eq '')  { # absolute path, rootdir
  		shift @args;
  		$relative = 0;
  		$first_arg = $self->rootdir;
  
  	} elsif ($args[0] =~ /^[^:]+:/) { # absolute path, volume name
  		$relative = 0;
  		$first_arg = shift @args;
  		# add a trailing ':' if need be (may be it's a path like HD:dir)
  		$first_arg = "$first_arg:" unless ($first_arg =~ /:\Z(?!\n)/);
  
  	} else { # relative path
  		$relative = 1;
  		if ( $args[0] =~ /^::+\Z(?!\n)/ ) {
  			# updir colon path ('::', ':::' etc.), don't shift
  			$first_arg = ':';
  		} elsif ($args[0] eq ':') {
  			$first_arg = shift @args;
  		} else {
  			# add a trailing ':' if need be
  			$first_arg = shift @args;
  			$first_arg = "$first_arg:" unless ($first_arg =~ /:\Z(?!\n)/);
  		}
  	}
  
  	# For all other arguments,
  	# (a) ignore arguments that equal ':' or '',
  	# (b) handle updir paths specially:
  	#     '::' 			-> concatenate '::'
  	#     '::' . '::' 	-> concatenate ':::' etc.
  	# (c) add a trailing ':' if need be
  
  	my $result = $first_arg;
  	while (@args) {
  		my $arg = shift @args;
  		unless (($arg eq '') || ($arg eq ':')) {
  			if ($arg =~ /^::+\Z(?!\n)/ ) { # updir colon path like ':::'
  				my $updir_count = length($arg) - 1;
  				while ((@args) && ($args[0] =~ /^::+\Z(?!\n)/) ) { # while updir colon path
  					$arg = shift @args;
  					$updir_count += (length($arg) - 1);
  				}
  				$arg = (':' x $updir_count);
  			} else {
  				$arg =~ s/^://s; # remove a leading ':' if any
  				$arg = "$arg:" unless ($arg =~ /:\Z(?!\n)/); # ensure trailing ':'
  			}
  			$result .= $arg;
  		}#unless
  	}
  
  	if ( ($relative) && ($result !~ /^:/) ) {
  		# add a leading colon if need be
  		$result = ":$result";
  	}
  
  	unless ($relative) {
  		# remove updirs immediately following the volume name
  		$result =~ s/([^:]+:)(:*)(.*)\Z(?!\n)/$1$3/;
  	}
  
  	return $result;
  }
  
  =item catfile
  
  Concatenate one or more directory names and a filename to form a
  complete path ending with a filename. Resulting paths are B<relative>
  by default, but can be forced to be absolute (but avoid this).
  
  B<IMPORTANT NOTE:> Beginning with version 1.3 of this module, the
  resulting path is relative by default and I<not> absolute. This
  decision was made due to portability reasons. Since
  C<File::Spec-E<gt>catfile()> returns relative paths on all other
  operating systems, it will now also follow this convention on Mac OS.
  Note that this may break some existing scripts.
  
  The last argument is always considered to be the file portion. Since
  C<catfile()> uses C<catdir()> (see above) for the concatenation of the
  directory portions (if any), the following with regard to relative and
  absolute paths is true:
  
      catfile("")     = ""
      catfile("file") = "file"
  
  but
  
      catfile("","")        = rootdir()         # (e.g. "HD:")
      catfile("","file")    = rootdir() . file  # (e.g. "HD:file")
      catfile("HD:","file") = "HD:file"
  
  This means that C<catdir()> is called only when there are two or more
  arguments, as one might expect.
  
  Note that the leading ":" is removed from the filename, so that
  
      catfile("a","b","file")  = ":a:b:file"    and
  
      catfile("a","b",":file") = ":a:b:file"
  
  give the same answer.
  
  To concatenate I<volume names>, I<directory paths> and I<filenames>,
  you are encouraged to use C<catpath()> (see below).
  
  =cut
  
  sub catfile {
      my $self = shift;
      return '' unless @_;
      my $file = pop @_;
      return $file unless @_;
      my $dir = $self->catdir(@_);
      $file =~ s/^://s;
      return $dir.$file;
  }
  
  =item curdir
  
  Returns a string representing the current directory. On Mac OS, this is ":".
  
  =cut
  
  sub curdir {
      return ":";
  }
  
  =item devnull
  
  Returns a string representing the null device. On Mac OS, this is "Dev:Null".
  
  =cut
  
  sub devnull {
      return "Dev:Null";
  }
  
  =item rootdir
  
  Returns a string representing the root directory.  Under MacPerl,
  returns the name of the startup volume, since that's the closest in
  concept, although other volumes aren't rooted there. The name has a
  trailing ":", because that's the correct specification for a volume
  name on Mac OS.
  
  If Mac::Files could not be loaded, the empty string is returned.
  
  =cut
  
  sub rootdir {
  #
  #  There's no real root directory on Mac OS. The name of the startup
  #  volume is returned, since that's the closest in concept.
  #
      return '' unless $macfiles;
      my $system = Mac::Files::FindFolder(&Mac::Files::kOnSystemDisk,
  	&Mac::Files::kSystemFolderType);
      $system =~ s/:.*\Z(?!\n)/:/s;
      return $system;
  }
  
  =item tmpdir
  
  Returns the contents of $ENV{TMPDIR}, if that directory exits or the
  current working directory otherwise. Under MacPerl, $ENV{TMPDIR} will
  contain a path like "MacintoshHD:Temporary Items:", which is a hidden
  directory on your startup volume.
  
  =cut
  
  my $tmpdir;
  sub tmpdir {
      return $tmpdir if defined $tmpdir;
      $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR} );
  }
  
  =item updir
  
  Returns a string representing the parent directory. On Mac OS, this is "::".
  
  =cut
  
  sub updir {
      return "::";
  }
  
  =item file_name_is_absolute
  
  Takes as argument a path and returns true, if it is an absolute path.
  If the path has a leading ":", it's a relative path. Otherwise, it's an
  absolute path, unless the path doesn't contain any colons, i.e. it's a name
  like "a". In this particular case, the path is considered to be relative
  (i.e. it is considered to be a filename). Use ":" in the appropriate place
  in the path if you want to distinguish unambiguously. As a special case,
  the filename '' is always considered to be absolute. Note that with version
  1.2 of File::Spec::Mac, this does no longer consult the local filesystem.
  
  E.g.
  
      File::Spec->file_name_is_absolute("a");         # false (relative)
      File::Spec->file_name_is_absolute(":a:b:");     # false (relative)
      File::Spec->file_name_is_absolute("MacintoshHD:");
                                                      # true (absolute)
      File::Spec->file_name_is_absolute("");          # true (absolute)
  
  
  =cut
  
  sub file_name_is_absolute {
      my ($self,$file) = @_;
      if ($file =~ /:/) {
  	return (! ($file =~ m/^:/s) );
      } elsif ( $file eq '' ) {
          return 1 ;
      } else {
  	return 0; # i.e. a file like "a"
      }
  }
  
  =item path
  
  Returns the null list for the MacPerl application, since the concept is
  usually meaningless under Mac OS. But if you're using the MacPerl tool under
  MPW, it gives back $ENV{Commands} suitably split, as is done in
  :lib:ExtUtils:MM_Mac.pm.
  
  =cut
  
  sub path {
  #
  #  The concept is meaningless under the MacPerl application.
  #  Under MPW, it has a meaning.
  #
      return unless exists $ENV{Commands};
      return split(/,/, $ENV{Commands});
  }
  
  =item splitpath
  
      ($volume,$directories,$file) = File::Spec->splitpath( $path );
      ($volume,$directories,$file) = File::Spec->splitpath( $path,
                                                            $no_file );
  
  Splits a path into volume, directory, and filename portions.
  
  On Mac OS, assumes that the last part of the path is a filename unless
  $no_file is true or a trailing separator ":" is present.
  
  The volume portion is always returned with a trailing ":". The directory portion
  is always returned with a leading (to denote a relative path) and a trailing ":"
  (to denote a directory). The file portion is always returned I<without> a leading ":".
  Empty portions are returned as empty string ''.
  
  The results can be passed to C<catpath()> to get back a path equivalent to
  (usually identical to) the original path.
  
  
  =cut
  
  sub splitpath {
      my ($self,$path, $nofile) = @_;
      my ($volume,$directory,$file);
  
      if ( $nofile ) {
          ( $volume, $directory ) = $path =~ m|^((?:[^:]+:)?)(.*)|s;
      }
      else {
          $path =~
              m|^( (?: [^:]+: )? )
                 ( (?: .*: )? )
                 ( .* )
               |xs;
          $volume    = $1;
          $directory = $2;
          $file      = $3;
      }
  
      $volume = '' unless defined($volume);
  	$directory = ":$directory" if ( $volume && $directory ); # take care of "HD::dir"
      if ($directory) {
          # Make sure non-empty directories begin and end in ':'
          $directory .= ':' unless (substr($directory,-1) eq ':');
          $directory = ":$directory" unless (substr($directory,0,1) eq ':');
      } else {
  	$directory = '';
      }
      $file = '' unless defined($file);
  
      return ($volume,$directory,$file);
  }
  
  
  =item splitdir
  
  The opposite of C<catdir()>.
  
      @dirs = File::Spec->splitdir( $directories );
  
  $directories should be only the directory portion of the path on systems
  that have the concept of a volume or that have path syntax that differentiates
  files from directories. Consider using C<splitpath()> otherwise.
  
  Unlike just splitting the directories on the separator, empty directory names
  (C<"">) can be returned. Since C<catdir()> on Mac OS always appends a trailing
  colon to distinguish a directory path from a file path, a single trailing colon
  will be ignored, i.e. there's no empty directory name after it.
  
  Hence, on Mac OS, both
  
      File::Spec->splitdir( ":a:b::c:" );    and
      File::Spec->splitdir( ":a:b::c" );
  
  yield:
  
      ( "a", "b", "::", "c")
  
  while
  
      File::Spec->splitdir( ":a:b::c::" );
  
  yields:
  
      ( "a", "b", "::", "c", "::")
  
  
  =cut
  
  sub splitdir {
  	my ($self, $path) = @_;
  	my @result = ();
  	my ($head, $sep, $tail, $volume, $directories);
  
  	return @result if ( (!defined($path)) || ($path eq '') );
  	return (':') if ($path eq ':');
  
  	( $volume, $sep, $directories ) = $path =~ m|^((?:[^:]+:)?)(:*)(.*)|s;
  
  	# deprecated, but handle it correctly
  	if ($volume) {
  		push (@result, $volume);
  		$sep .= ':';
  	}
  
  	while ($sep || $directories) {
  		if (length($sep) > 1) {
  			my $updir_count = length($sep) - 1;
  			for (my $i=0; $i<$updir_count; $i++) {
  				# push '::' updir_count times;
  				# simulate Unix '..' updirs
  				push (@result, '::');
  			}
  		}
  		$sep = '';
  		if ($directories) {
  			( $head, $sep, $tail ) = $directories =~ m|^((?:[^:]+)?)(:*)(.*)|s;
  			push (@result, $head);
  			$directories = $tail;
  		}
  	}
  	return @result;
  }
  
  
  =item catpath
  
      $path = File::Spec->catpath($volume,$directory,$file);
  
  Takes volume, directory and file portions and returns an entire path. On Mac OS,
  $volume, $directory and $file are concatenated.  A ':' is inserted if need be. You
  may pass an empty string for each portion. If all portions are empty, the empty
  string is returned. If $volume is empty, the result will be a relative path,
  beginning with a ':'. If $volume and $directory are empty, a leading ":" (if any)
  is removed form $file and the remainder is returned. If $file is empty, the
  resulting path will have a trailing ':'.
  
  
  =cut
  
  sub catpath {
      my ($self,$volume,$directory,$file) = @_;
  
      if ( (! $volume) && (! $directory) ) {
  	$file =~ s/^:// if $file;
  	return $file ;
      }
  
      # We look for a volume in $volume, then in $directory, but not both
  
      my ($dir_volume, $dir_dirs) = $self->splitpath($directory, 1);
  
      $volume = $dir_volume unless length $volume;
      my $path = $volume; # may be ''
      $path .= ':' unless (substr($path, -1) eq ':'); # ensure trailing ':'
  
      if ($directory) {
  	$directory = $dir_dirs if $volume;
  	$directory =~ s/^://; # remove leading ':' if any
  	$path .= $directory;
  	$path .= ':' unless (substr($path, -1) eq ':'); # ensure trailing ':'
      }
  
      if ($file) {
  	$file =~ s/^://; # remove leading ':' if any
  	$path .= $file;
      }
  
      return $path;
  }
  
  =item abs2rel
  
  Takes a destination path and an optional base path and returns a relative path
  from the base path to the destination path:
  
      $rel_path = File::Spec->abs2rel( $path ) ;
      $rel_path = File::Spec->abs2rel( $path, $base ) ;
  
  Note that both paths are assumed to have a notation that distinguishes a
  directory path (with trailing ':') from a file path (without trailing ':').
  
  If $base is not present or '', then the current working directory is used.
  If $base is relative, then it is converted to absolute form using C<rel2abs()>.
  This means that it is taken to be relative to the current working directory.
  
  If $path and $base appear to be on two different volumes, we will not
  attempt to resolve the two paths, and we will instead simply return
  $path.  Note that previous versions of this module ignored the volume
  of $base, which resulted in garbage results part of the time.
  
  If $base doesn't have a trailing colon, the last element of $base is
  assumed to be a filename.  This filename is ignored.  Otherwise all path
  components are assumed to be directories.
  
  If $path is relative, it is converted to absolute form using C<rel2abs()>.
  This means that it is taken to be relative to the current working directory.
  
  Based on code written by Shigio Yamaguchi.
  
  
  =cut
  
  # maybe this should be done in canonpath() ?
  sub _resolve_updirs {
  	my $path = shift @_;
  	my $proceed;
  
  	# resolve any updirs, e.g. "HD:tmp::file" -> "HD:file"
  	do {
  		$proceed = ($path =~ s/^(.*):[^:]+::(.*?)\z/$1:$2/);
  	} while ($proceed);
  
  	return $path;
  }
  
  
  sub abs2rel {
      my($self,$path,$base) = @_;
  
      # Clean up $path
      if ( ! $self->file_name_is_absolute( $path ) ) {
          $path = $self->rel2abs( $path ) ;
      }
  
      # Figure out the effective $base and clean it up.
      if ( !defined( $base ) || $base eq '' ) {
  	$base = $self->_cwd();
      }
      elsif ( ! $self->file_name_is_absolute( $base ) ) {
          $base = $self->rel2abs( $base ) ;
  	$base = _resolve_updirs( $base ); # resolve updirs in $base
      }
      else {
  	$base = _resolve_updirs( $base );
      }
  
      # Split up paths - ignore $base's file
      my ( $path_vol, $path_dirs, $path_file ) =  $self->splitpath( $path );
      my ( $base_vol, $base_dirs )             =  $self->splitpath( $base );
  
      return $path unless lc( $path_vol ) eq lc( $base_vol );
  
      # Now, remove all leading components that are the same
      my @pathchunks = $self->splitdir( $path_dirs );
      my @basechunks = $self->splitdir( $base_dirs );
  	
      while ( @pathchunks &&
  	    @basechunks &&
  	    lc( $pathchunks[0] ) eq lc( $basechunks[0] ) ) {
          shift @pathchunks ;
          shift @basechunks ;
      }
  
      # @pathchunks now has the directories to descend in to.
      # ensure relative path, even if @pathchunks is empty
      $path_dirs = $self->catdir( ':', @pathchunks );
  
      # @basechunks now contains the number of directories to climb out of.
      $base_dirs = (':' x @basechunks) . ':' ;
  
      return $self->catpath( '', $self->catdir( $base_dirs, $path_dirs ), $path_file ) ;
  }
  
  =item rel2abs
  
  Converts a relative path to an absolute path:
  
      $abs_path = File::Spec->rel2abs( $path ) ;
      $abs_path = File::Spec->rel2abs( $path, $base ) ;
  
  Note that both paths are assumed to have a notation that distinguishes a
  directory path (with trailing ':') from a file path (without trailing ':').
  
  If $base is not present or '', then $base is set to the current working
  directory. If $base is relative, then it is converted to absolute form
  using C<rel2abs()>. This means that it is taken to be relative to the
  current working directory.
  
  If $base doesn't have a trailing colon, the last element of $base is
  assumed to be a filename.  This filename is ignored.  Otherwise all path
  components are assumed to be directories.
  
  If $path is already absolute, it is returned and $base is ignored.
  
  Based on code written by Shigio Yamaguchi.
  
  =cut
  
  sub rel2abs {
      my ($self,$path,$base) = @_;
  
      if ( ! $self->file_name_is_absolute($path) ) {
          # Figure out the effective $base and clean it up.
          if ( !defined( $base ) || $base eq '' ) {
  	    $base = $self->_cwd();
          }
          elsif ( ! $self->file_name_is_absolute($base) ) {
              $base = $self->rel2abs($base) ;
          }
  
  	# Split up paths
  
  	# ignore $path's volume
          my ( $path_dirs, $path_file ) = ($self->splitpath($path))[1,2] ;
  
          # ignore $base's file part
  	my ( $base_vol, $base_dirs ) = $self->splitpath($base) ;
  
  	# Glom them together
  	$path_dirs = ':' if ($path_dirs eq '');
  	$base_dirs =~ s/:$//; # remove trailing ':', if any
  	$base_dirs = $base_dirs . $path_dirs;
  
          $path = $self->catpath( $base_vol, $base_dirs, $path_file );
      }
      return $path;
  }
  
  
  =back
  
  =head1 AUTHORS
  
  See the authors list in I<File::Spec>. Mac OS support by Paul Schinder
  <schinder@pobox.com> and Thomas Wegner <wegner_thomas@yahoo.com>.
  
  =head1 COPYRIGHT
  
  Copyright (c) 2004 by the Perl 5 Porters.  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
  
  See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
  implementation of these methods, not the semantics.
  
  =cut
  
  1;
X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC_MAC

$fatpacked{"x86_64-linux-gnu-thread-multi/File/Spec/OS2.pm"} = <<'X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC_OS2';
  package File::Spec::OS2;
  
  use strict;
  use vars qw(@ISA $VERSION);
  require File::Spec::Unix;
  
  $VERSION = '3.40';
  $VERSION =~ tr/_//;
  
  @ISA = qw(File::Spec::Unix);
  
  sub devnull {
      return "/dev/nul";
  }
  
  sub case_tolerant {
      return 1;
  }
  
  sub file_name_is_absolute {
      my ($self,$file) = @_;
      return scalar($file =~ m{^([a-z]:)?[\\/]}is);
  }
  
  sub path {
      my $path = $ENV{PATH};
      $path =~ s:\\:/:g;
      my @path = split(';',$path);
      foreach (@path) { $_ = '.' if $_ eq '' }
      return @path;
  }
  
  sub _cwd {
      # In OS/2 the "require Cwd" is unnecessary bloat.
      return Cwd::sys_cwd();
  }
  
  my $tmpdir;
  sub tmpdir {
      return $tmpdir if defined $tmpdir;
      my @d = @ENV{qw(TMPDIR TEMP TMP)};	# function call could autovivivy
      $tmpdir = $_[0]->_tmpdir( @d, '/tmp', '/'  );
  }
  
  sub catdir {
      my $self = shift;
      my @args = @_;
      foreach (@args) {
  	tr[\\][/];
          # append a backslash to each argument unless it has one there
          $_ .= "/" unless m{/$};
      }
      return $self->canonpath(join('', @args));
  }
  
  sub canonpath {
      my ($self,$path) = @_;
      return unless defined $path;
  
      $path =~ s/^([a-z]:)/\l$1/s;
      $path =~ s|\\|/|g;
      $path =~ s|([^/])/+|$1/|g;                  # xx////xx  -> xx/xx
      $path =~ s|(/\.)+/|/|g;                     # xx/././xx -> xx/xx
      $path =~ s|^(\./)+(?=[^/])||s;		# ./xx      -> xx
      $path =~ s|/\Z(?!\n)||
               unless $path =~ m#^([a-z]:)?/\Z(?!\n)#si;# xx/       -> xx
      $path =~ s{^/\.\.$}{/};                     # /..    -> /
      1 while $path =~ s{^/\.\.}{};               # /../xx -> /xx
      return $path;
  }
  
  
  sub splitpath {
      my ($self,$path, $nofile) = @_;
      my ($volume,$directory,$file) = ('','','');
      if ( $nofile ) {
          $path =~ 
              m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? ) 
                   (.*)
               }xs;
          $volume    = $1;
          $directory = $2;
      }
      else {
          $path =~ 
              m{^ ( (?: [a-zA-Z]: |
                        (?:\\\\|//)[^\\/]+[\\/][^\\/]+
                    )?
                  )
                  ( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? )
                  (.*)
               }xs;
          $volume    = $1;
          $directory = $2;
          $file      = $3;
      }
  
      return ($volume,$directory,$file);
  }
  
  
  sub splitdir {
      my ($self,$directories) = @_ ;
      split m|[\\/]|, $directories, -1;
  }
  
  
  sub catpath {
      my ($self,$volume,$directory,$file) = @_;
  
      # If it's UNC, make sure the glue separator is there, reusing
      # whatever separator is first in the $volume
      $volume .= $1
          if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s &&
               $directory =~ m@^[^\\/]@s
             ) ;
  
      $volume .= $directory ;
  
      # If the volume is not just A:, make sure the glue separator is 
      # there, reusing whatever separator is first in the $volume if possible.
      if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
           $volume =~ m@[^\\/]\Z(?!\n)@      &&
           $file   =~ m@[^\\/]@
         ) {
          $volume =~ m@([\\/])@ ;
          my $sep = $1 ? $1 : '/' ;
          $volume .= $sep ;
      }
  
      $volume .= $file ;
  
      return $volume ;
  }
  
  
  sub abs2rel {
      my($self,$path,$base) = @_;
  
      # Clean up $path
      if ( ! $self->file_name_is_absolute( $path ) ) {
          $path = $self->rel2abs( $path ) ;
      } else {
          $path = $self->canonpath( $path ) ;
      }
  
      # Figure out the effective $base and clean it up.
      if ( !defined( $base ) || $base eq '' ) {
  	$base = $self->_cwd();
      } elsif ( ! $self->file_name_is_absolute( $base ) ) {
          $base = $self->rel2abs( $base ) ;
      } else {
          $base = $self->canonpath( $base ) ;
      }
  
      # Split up paths
      my ( $path_volume, $path_directories, $path_file ) = $self->splitpath( $path, 1 ) ;
      my ( $base_volume, $base_directories ) = $self->splitpath( $base, 1 ) ;
      return $path unless $path_volume eq $base_volume;
  
      # Now, remove all leading components that are the same
      my @pathchunks = $self->splitdir( $path_directories );
      my @basechunks = $self->splitdir( $base_directories );
  
      while ( @pathchunks && 
              @basechunks && 
              lc( $pathchunks[0] ) eq lc( $basechunks[0] ) 
            ) {
          shift @pathchunks ;
          shift @basechunks ;
      }
  
      # No need to catdir, we know these are well formed.
      $path_directories = CORE::join( '/', @pathchunks );
      $base_directories = CORE::join( '/', @basechunks );
  
      # $base_directories now contains the directories the resulting relative
      # path must ascend out of before it can descend to $path_directory.  So, 
      # replace all names with $parentDir
  
      #FA Need to replace between backslashes...
      $base_directories =~ s|[^\\/]+|..|g ;
  
      # Glue the two together, using a separator if necessary, and preventing an
      # empty result.
  
      #FA Must check that new directories are not empty.
      if ( $path_directories ne '' && $base_directories ne '' ) {
          $path_directories = "$base_directories/$path_directories" ;
      } else {
          $path_directories = "$base_directories$path_directories" ;
      }
  
      return $self->canonpath( 
          $self->catpath( "", $path_directories, $path_file ) 
      ) ;
  }
  
  
  sub rel2abs {
      my ($self,$path,$base ) = @_;
  
      if ( ! $self->file_name_is_absolute( $path ) ) {
  
          if ( !defined( $base ) || $base eq '' ) {
  	    $base = $self->_cwd();
          }
          elsif ( ! $self->file_name_is_absolute( $base ) ) {
              $base = $self->rel2abs( $base ) ;
          }
          else {
              $base = $self->canonpath( $base ) ;
          }
  
          my ( $path_directories, $path_file ) =
              ($self->splitpath( $path, 1 ))[1,2] ;
  
          my ( $base_volume, $base_directories ) =
              $self->splitpath( $base, 1 ) ;
  
          $path = $self->catpath( 
              $base_volume, 
              $self->catdir( $base_directories, $path_directories ), 
              $path_file
          ) ;
      }
  
      return $self->canonpath( $path ) ;
  }
  
  1;
  __END__
  
  =head1 NAME
  
  File::Spec::OS2 - methods for OS/2 file specs
  
  =head1 SYNOPSIS
  
   require File::Spec::OS2; # Done internally by File::Spec if needed
  
  =head1 DESCRIPTION
  
  See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
  implementation of these methods, not the semantics.
  
  Amongst the changes made for OS/2 are...
  
  =over 4
  
  =item tmpdir
  
  Modifies the list of places temp directory information is looked for.
  
      $ENV{TMPDIR}
      $ENV{TEMP}
      $ENV{TMP}
      /tmp
      /
  
  =item splitpath
  
  Volumes can be drive letters or UNC sharenames (\\server\share).
  
  =back
  
  =head1 COPYRIGHT
  
  Copyright (c) 2004 by the Perl 5 Porters.  All rights reserved.
  
  This program is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself.
  
  =cut
X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC_OS2

$fatpacked{"x86_64-linux-gnu-thread-multi/File/Spec/Unix.pm"} = <<'X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC_UNIX';
  package File::Spec::Unix;
  
  use strict;
  use vars qw($VERSION);
  
  $VERSION = '3.40';
  $VERSION =~ tr/_//;
  
  =head1 NAME
  
  File::Spec::Unix - File::Spec for Unix, base for other File::Spec modules
  
  =head1 SYNOPSIS
  
   require File::Spec::Unix; # Done automatically by File::Spec
  
  =head1 DESCRIPTION
  
  Methods for manipulating file specifications.  Other File::Spec
  modules, such as File::Spec::Mac, inherit from File::Spec::Unix and
  override specific methods.
  
  =head1 METHODS
  
  =over 2
  
  =item canonpath()
  
  No physical check on the filesystem, but a logical cleanup of a
  path. On UNIX eliminates successive slashes and successive "/.".
  
      $cpath = File::Spec->canonpath( $path ) ;
  
  Note that this does *not* collapse F<x/../y> sections into F<y>.  This
  is by design.  If F</foo> on your system is a symlink to F</bar/baz>,
  then F</foo/../quux> is actually F</bar/quux>, not F</quux> as a naive
  F<../>-removal would give you.  If you want to do this kind of
  processing, you probably want C<Cwd>'s C<realpath()> function to
  actually traverse the filesystem cleaning up paths like this.
  
  =cut
  
  sub canonpath {
      my ($self,$path) = @_;
      return unless defined $path;
      
      # Handle POSIX-style node names beginning with double slash (qnx, nto)
      # (POSIX says: "a pathname that begins with two successive slashes
      # may be interpreted in an implementation-defined manner, although
      # more than two leading slashes shall be treated as a single slash.")
      my $node = '';
      my $double_slashes_special = $^O eq 'qnx' || $^O eq 'nto';
  
  
      if ( $double_slashes_special
           && ( $path =~ s{^(//[^/]+)/?\z}{}s || $path =~ s{^(//[^/]+)/}{/}s ) ) {
        $node = $1;
      }
      # This used to be
      # $path =~ s|/+|/|g unless ($^O eq 'cygwin');
      # but that made tests 29, 30, 35, 46, and 213 (as of #13272) to fail
      # (Mainly because trailing "" directories didn't get stripped).
      # Why would cygwin avoid collapsing multiple slashes into one? --jhi
      $path =~ s|/{2,}|/|g;                            # xx////xx  -> xx/xx
      $path =~ s{(?:/\.)+(?:/|\z)}{/}g;                # xx/././xx -> xx/xx
      $path =~ s|^(?:\./)+||s unless $path eq "./";    # ./xx      -> xx
      $path =~ s|^/(?:\.\./)+|/|;                      # /../../xx -> xx
      $path =~ s|^/\.\.$|/|;                         # /..       -> /
      $path =~ s|/\z|| unless $path eq "/";          # xx/       -> xx
      return "$node$path";
  }
  
  =item catdir()
  
  Concatenate two or more directory names to form a complete path ending
  with a directory. But remove the trailing slash from the resulting
  string, because it doesn't look good, isn't necessary and confuses
  OS2. Of course, if this is the root directory, don't cut off the
  trailing slash :-)
  
  =cut
  
  sub catdir {
      my $self = shift;
  
      $self->canonpath(join('/', @_, '')); # '' because need a trailing '/'
  }
  
  =item catfile
  
  Concatenate one or more directory names and a filename to form a
  complete path ending with a filename
  
  =cut
  
  sub catfile {
      my $self = shift;
      my $file = $self->canonpath(pop @_);
      return $file unless @_;
      my $dir = $self->catdir(@_);
      $dir .= "/" unless substr($dir,-1) eq "/";
      return $dir.$file;
  }
  
  =item curdir
  
  Returns a string representation of the current directory.  "." on UNIX.
  
  =cut
  
  sub curdir { '.' }
  
  =item devnull
  
  Returns a string representation of the null device. "/dev/null" on UNIX.
  
  =cut
  
  sub devnull { '/dev/null' }
  
  =item rootdir
  
  Returns a string representation of the root directory.  "/" on UNIX.
  
  =cut
  
  sub rootdir { '/' }
  
  =item tmpdir
  
  Returns a string representation of the first writable directory from
  the following list or the current directory if none from the list are
  writable:
  
      $ENV{TMPDIR}
      /tmp
  
  If running under taint mode, and if $ENV{TMPDIR}
  is tainted, it is not used.
  
  =cut
  
  my $tmpdir;
  sub _tmpdir {
      return $tmpdir if defined $tmpdir;
      my $self = shift;
      my @dirlist = @_;
      {
  	no strict 'refs';
  	if (${"\cTAINT"}) { # Check for taint mode on perl >= 5.8.0
              require Scalar::Util;
  	    @dirlist = grep { ! Scalar::Util::tainted($_) } @dirlist;
  	}
  	elsif ($] < 5.007) { # No ${^TAINT} before 5.8
  	    @dirlist = grep { eval { eval('1'.substr $_,0,0) } } @dirlist;
  	}
      }
      foreach (@dirlist) {
  	next unless defined && -d && -w _;
  	$tmpdir = $_;
  	last;
      }
      $tmpdir = $self->curdir unless defined $tmpdir;
      $tmpdir = defined $tmpdir && $self->canonpath($tmpdir);
      return $tmpdir;
  }
  
  sub tmpdir {
      return $tmpdir if defined $tmpdir;
      $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp" );
  }
  
  =item updir
  
  Returns a string representation of the parent directory.  ".." on UNIX.
  
  =cut
  
  sub updir { '..' }
  
  =item no_upwards
  
  Given a list of file names, strip out those that refer to a parent
  directory. (Does not strip symlinks, only '.', '..', and equivalents.)
  
  =cut
  
  sub no_upwards {
      my $self = shift;
      return grep(!/^\.{1,2}\z/s, @_);
  }
  
  =item case_tolerant
  
  Returns a true or false value indicating, respectively, that alphabetic
  is not or is significant when comparing file specifications.
  
  =cut
  
  sub case_tolerant { 0 }
  
  =item file_name_is_absolute
  
  Takes as argument a path and returns true if it is an absolute path.
  
  This does not consult the local filesystem on Unix, Win32, OS/2 or Mac 
  OS (Classic).  It does consult the working environment for VMS (see
  L<File::Spec::VMS/file_name_is_absolute>).
  
  =cut
  
  sub file_name_is_absolute {
      my ($self,$file) = @_;
      return scalar($file =~ m:^/:s);
  }
  
  =item path
  
  Takes no argument, returns the environment variable PATH as an array.
  
  =cut
  
  sub path {
      return () unless exists $ENV{PATH};
      my @path = split(':', $ENV{PATH});
      foreach (@path) { $_ = '.' if $_ eq '' }
      return @path;
  }
  
  =item join
  
  join is the same as catfile.
  
  =cut
  
  sub join {
      my $self = shift;
      return $self->catfile(@_);
  }
  
  =item splitpath
  
      ($volume,$directories,$file) = File::Spec->splitpath( $path );
      ($volume,$directories,$file) = File::Spec->splitpath( $path,
                                                            $no_file );
  
  Splits a path into volume, directory, and filename portions. On systems
  with no concept of volume, returns '' for volume. 
  
  For systems with no syntax differentiating filenames from directories, 
  assumes that the last file is a path unless $no_file is true or a 
  trailing separator or /. or /.. is present. On Unix this means that $no_file
  true makes this return ( '', $path, '' ).
  
  The directory portion may or may not be returned with a trailing '/'.
  
  The results can be passed to L</catpath()> to get back a path equivalent to
  (usually identical to) the original path.
  
  =cut
  
  sub splitpath {
      my ($self,$path, $nofile) = @_;
  
      my ($volume,$directory,$file) = ('','','');
  
      if ( $nofile ) {
          $directory = $path;
      }
      else {
          $path =~ m|^ ( (?: .* / (?: \.\.?\z )? )? ) ([^/]*) |xs;
          $directory = $1;
          $file      = $2;
      }
  
      return ($volume,$directory,$file);
  }
  
  
  =item splitdir
  
  The opposite of L</catdir()>.
  
      @dirs = File::Spec->splitdir( $directories );
  
  $directories must be only the directory portion of the path on systems 
  that have the concept of a volume or that have path syntax that differentiates
  files from directories.
  
  Unlike just splitting the directories on the separator, empty
  directory names (C<''>) can be returned, because these are significant
  on some OSs.
  
  On Unix,
  
      File::Spec->splitdir( "/a/b//c/" );
  
  Yields:
  
      ( '', 'a', 'b', '', 'c', '' )
  
  =cut
  
  sub splitdir {
      return split m|/|, $_[1], -1;  # Preserve trailing fields
  }
  
  
  =item catpath()
  
  Takes volume, directory and file portions and returns an entire path. Under
  Unix, $volume is ignored, and directory and file are concatenated.  A '/' is
  inserted if needed (though if the directory portion doesn't start with
  '/' it is not added).  On other OSs, $volume is significant.
  
  =cut
  
  sub catpath {
      my ($self,$volume,$directory,$file) = @_;
  
      if ( $directory ne ''                && 
           $file ne ''                     && 
           substr( $directory, -1 ) ne '/' && 
           substr( $file, 0, 1 ) ne '/' 
      ) {
          $directory .= "/$file" ;
      }
      else {
          $directory .= $file ;
      }
  
      return $directory ;
  }
  
  =item abs2rel
  
  Takes a destination path and an optional base path returns a relative path
  from the base path to the destination path:
  
      $rel_path = File::Spec->abs2rel( $path ) ;
      $rel_path = File::Spec->abs2rel( $path, $base ) ;
  
  If $base is not present or '', then L<cwd()|Cwd> is used. If $base is
  relative, then it is converted to absolute form using
  L</rel2abs()>. This means that it is taken to be relative to
  L<cwd()|Cwd>.
  
  On systems that have a grammar that indicates filenames, this ignores the 
  $base filename. Otherwise all path components are assumed to be
  directories.
  
  If $path is relative, it is converted to absolute form using L</rel2abs()>.
  This means that it is taken to be relative to L<cwd()|Cwd>.
  
  No checks against the filesystem are made, so the result may not be correct if
  C<$base> contains symbolic links.  (Apply
  L<Cwd::abs_path()|Cwd/abs_path> beforehand if that
  is a concern.)  On VMS, there is interaction with the working environment, as
  logicals and macros are expanded.
  
  Based on code written by Shigio Yamaguchi.
  
  =cut
  
  sub abs2rel {
      my($self,$path,$base) = @_;
      $base = $self->_cwd() unless defined $base and length $base;
  
      ($path, $base) = map $self->canonpath($_), $path, $base;
  
      my $path_directories;
      my $base_directories;
  
      if (grep $self->file_name_is_absolute($_), $path, $base) {
  	($path, $base) = map $self->rel2abs($_), $path, $base;
  
      my ($path_volume) = $self->splitpath($path, 1);
      my ($base_volume) = $self->splitpath($base, 1);
  
      # Can't relativize across volumes
      return $path unless $path_volume eq $base_volume;
  
  	$path_directories = ($self->splitpath($path, 1))[1];
  	$base_directories = ($self->splitpath($base, 1))[1];
  
      # For UNC paths, the user might give a volume like //foo/bar that
      # strictly speaking has no directory portion.  Treat it as if it
      # had the root directory for that volume.
      if (!length($base_directories) and $self->file_name_is_absolute($base)) {
        $base_directories = $self->rootdir;
      }
      }
      else {
  	my $wd= ($self->splitpath($self->_cwd(), 1))[1];
  	$path_directories = $self->catdir($wd, $path);
  	$base_directories = $self->catdir($wd, $base);
      }
  
      # Now, remove all leading components that are the same
      my @pathchunks = $self->splitdir( $path_directories );
      my @basechunks = $self->splitdir( $base_directories );
  
      if ($base_directories eq $self->rootdir) {
        return $self->curdir if $path_directories eq $self->rootdir;
        shift @pathchunks;
        return $self->canonpath( $self->catpath('', $self->catdir( @pathchunks ), '') );
      }
  
      my @common;
      while (@pathchunks && @basechunks && $self->_same($pathchunks[0], $basechunks[0])) {
          push @common, shift @pathchunks ;
          shift @basechunks ;
      }
      return $self->curdir unless @pathchunks || @basechunks;
  
      # @basechunks now contains the directories the resulting relative path 
      # must ascend out of before it can descend to $path_directory.  If there
      # are updir components, we must descend into the corresponding directories
      # (this only works if they are no symlinks).
      my @reverse_base;
      while( defined(my $dir= shift @basechunks) ) {
  	if( $dir ne $self->updir ) {
  	    unshift @reverse_base, $self->updir;
  	    push @common, $dir;
  	}
  	elsif( @common ) {
  	    if( @reverse_base && $reverse_base[0] eq $self->updir ) {
  		shift @reverse_base;
  		pop @common;
  	    }
  	    else {
  		unshift @reverse_base, pop @common;
  	    }
  	}
      }
      my $result_dirs = $self->catdir( @reverse_base, @pathchunks );
      return $self->canonpath( $self->catpath('', $result_dirs, '') );
  }
  
  sub _same {
    $_[1] eq $_[2];
  }
  
  =item rel2abs()
  
  Converts a relative path to an absolute path. 
  
      $abs_path = File::Spec->rel2abs( $path ) ;
      $abs_path = File::Spec->rel2abs( $path, $base ) ;
  
  If $base is not present or '', then L<cwd()|Cwd> is used. If $base is
  relative, then it is converted to absolute form using
  L</rel2abs()>. This means that it is taken to be relative to
  L<cwd()|Cwd>.
  
  On systems that have a grammar that indicates filenames, this ignores
  the $base filename. Otherwise all path components are assumed to be
  directories.
  
  If $path is absolute, it is cleaned up and returned using L</canonpath()>.
  
  No checks against the filesystem are made.  On VMS, there is
  interaction with the working environment, as logicals and
  macros are expanded.
  
  Based on code written by Shigio Yamaguchi.
  
  =cut
  
  sub rel2abs {
      my ($self,$path,$base ) = @_;
  
      # Clean up $path
      if ( ! $self->file_name_is_absolute( $path ) ) {
          # Figure out the effective $base and clean it up.
          if ( !defined( $base ) || $base eq '' ) {
  	    $base = $self->_cwd();
          }
          elsif ( ! $self->file_name_is_absolute( $base ) ) {
              $base = $self->rel2abs( $base ) ;
          }
          else {
              $base = $self->canonpath( $base ) ;
          }
  
          # Glom them together
          $path = $self->catdir( $base, $path ) ;
      }
  
      return $self->canonpath( $path ) ;
  }
  
  =back
  
  =head1 COPYRIGHT
  
  Copyright (c) 2004 by the Perl 5 Porters.  All rights reserved.
  
  This program is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself.
  
  Please submit bug reports and patches to perlbug@perl.org.
  
  =head1 SEE ALSO
  
  L<File::Spec>
  
  =cut
  
  # Internal routine to File::Spec, no point in making this public since
  # it is the standard Cwd interface.  Most of the platform-specific
  # File::Spec subclasses use this.
  sub _cwd {
      require Cwd;
      Cwd::getcwd();
  }
  
  
  # Internal method to reduce xx\..\yy -> yy
  sub _collapse {
      my($fs, $path) = @_;
  
      my $updir  = $fs->updir;
      my $curdir = $fs->curdir;
  
      my($vol, $dirs, $file) = $fs->splitpath($path);
      my @dirs = $fs->splitdir($dirs);
      pop @dirs if @dirs && $dirs[-1] eq '';
  
      my @collapsed;
      foreach my $dir (@dirs) {
          if( $dir eq $updir              and   # if we have an updir
              @collapsed                  and   # and something to collapse
              length $collapsed[-1]       and   # and its not the rootdir
              $collapsed[-1] ne $updir    and   # nor another updir
              $collapsed[-1] ne $curdir         # nor the curdir
            ) 
          {                                     # then
              pop @collapsed;                   # collapse
          }
          else {                                # else
              push @collapsed, $dir;            # just hang onto it
          }
      }
  
      return $fs->catpath($vol,
                          $fs->catdir(@collapsed),
                          $file
                         );
  }
  
  
  1;
X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC_UNIX

$fatpacked{"x86_64-linux-gnu-thread-multi/File/Spec/VMS.pm"} = <<'X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC_VMS';
  package File::Spec::VMS;
  
  use strict;
  use vars qw(@ISA $VERSION);
  require File::Spec::Unix;
  
  $VERSION = '3.40';
  $VERSION =~ tr/_//;
  
  @ISA = qw(File::Spec::Unix);
  
  use File::Basename;
  use VMS::Filespec;
  
  =head1 NAME
  
  File::Spec::VMS - methods for VMS file specs
  
  =head1 SYNOPSIS
  
   require File::Spec::VMS; # Done internally by File::Spec if needed
  
  =head1 DESCRIPTION
  
  See File::Spec::Unix for a documentation of the methods provided
  there. This package overrides the implementation of these methods, not
  the semantics.
  
  The default behavior is to allow either VMS or Unix syntax on input and to 
  return VMS syntax on output unless Unix syntax has been explicity requested
  via the C<DECC$FILENAME_UNIX_REPORT> CRTL feature.
  
  =over 4
  
  =cut
  
  # Need to look up the feature settings.  The preferred way is to use the
  # VMS::Feature module, but that may not be available to dual life modules.
  
  my $use_feature;
  BEGIN {
      if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
          $use_feature = 1;
      }
  }
  
  # Need to look up the UNIX report mode.  This may become a dynamic mode
  # in the future.
  sub _unix_rpt {
      my $unix_rpt;
      if ($use_feature) {
          $unix_rpt = VMS::Feature::current("filename_unix_report");
      } else {
          my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
          $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; 
      }
      return $unix_rpt;
  }
  
  =item canonpath (override)
  
  Removes redundant portions of file specifications and returns results
  in native syntax unless Unix filename reporting has been enabled.
  
  =cut
  
  
  sub canonpath {
      my($self,$path) = @_;
  
      return undef unless defined $path;
  
      my $unix_rpt = $self->_unix_rpt;
  
      if ($path =~ m|/|) {
        my $pathify = $path =~ m|/\Z(?!\n)|;
        $path = $self->SUPER::canonpath($path);
  
        return $path if $unix_rpt;
        $path = $pathify ? vmspath($path) : vmsify($path);
      }
  
      $path =~ s/(?<!\^)</[/;			# < and >       ==> [ and ]
      $path =~ s/(?<!\^)>/]/;
      $path =~ s/(?<!\^)\]\[\./\.\]\[/g;		# ][.		==> .][
      $path =~ s/(?<!\^)\[000000\.\]\[/\[/g;	# [000000.][	==> [
      $path =~ s/(?<!\^)\[000000\./\[/g;		# [000000.	==> [
      $path =~ s/(?<!\^)\.\]\[000000\]/\]/g;	# .][000000]	==> ]
      $path =~ s/(?<!\^)\.\]\[/\./g;		# foo.][bar     ==> foo.bar
      1 while ($path =~ s/(?<!\^)([\[\.])(-+)\.(-+)([\.\]])/$1$2$3$4/);
  						# That loop does the following
  						# with any amount of dashes:
  						# .-.-.		==> .--.
  						# [-.-.		==> [--.
  						# .-.-]		==> .--]
  						# [-.-]		==> [--]
      1 while ($path =~ s/(?<!\^)([\[\.])[^\]\.]+\.-(-+)([\]\.])/$1$2$3/);
  						# That loop does the following
  						# with any amount (minimum 2)
  						# of dashes:
  						# .foo.--.	==> .-.
  						# .foo.--]	==> .-]
  						# [foo.--.	==> [-.
  						# [foo.--]	==> [-]
  						#
  						# And then, the remaining cases
      $path =~ s/(?<!\^)\[\.-/[-/;		# [.-		==> [-
      $path =~ s/(?<!\^)\.[^\]\.]+\.-\./\./g;	# .foo.-.	==> .
      $path =~ s/(?<!\^)\[[^\]\.]+\.-\./\[/g;	# [foo.-.	==> [
      $path =~ s/(?<!\^)\.[^\]\.]+\.-\]/\]/g;	# .foo.-]	==> ]
  						# [foo.-]       ==> [000000]
      $path =~ s/(?<!\^)\[[^\]\.]+\.-\]/\[000000\]/g;
  						# []		==>
      $path =~ s/(?<!\^)\[\]// unless $path eq '[]';
      return $unix_rpt ? unixify($path) : $path;
  }
  
  =item catdir (override)
  
  Concatenates a list of file specifications, and returns the result as a
  native directory specification unless the Unix filename reporting feature
  has been enabled.  No check is made for "impossible" cases (e.g. elements
  other than the first being absolute filespecs).
  
  =cut
  
  sub catdir {
      my $self = shift;
      my $dir = pop;
  
      my $unix_rpt = $self->_unix_rpt;
  
      my @dirs = grep {defined() && length()} @_;
  
      my $rslt;
      if (@dirs) {
  	my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
  	my ($spath,$sdir) = ($path,$dir);
  	$spath =~ s/\.dir\Z(?!\n)//i; $sdir =~ s/\.dir\Z(?!\n)//i; 
  
  	if ($unix_rpt) {
  	    $spath = unixify($spath) unless $spath =~ m#/#;
  	    $sdir= unixify($sdir) unless $sdir =~ m#/#;
              return $self->SUPER::catdir($spath, $sdir)
              }
  
  	$sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\Z(?!\n)/s;
  	    $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",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 ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; }
  
                  } else {
  	# Single directory. Return an empty string on null input; otherwise
  	# just return a canonical path.
  
  	if    (not defined $dir or not length $dir) {
  	    $rslt = '';
              } else {
  	    $rslt = $unix_rpt ? $dir : vmspath($dir);
  	}
      }
      return $self->canonpath($rslt);
  }
  
  =item catfile (override)
  
  Concatenates a list of directory specifications with a filename specification
  to build a path.
  
  =cut
  
  sub catfile {
      my $self = shift;
      my $tfile = pop();
      my $file = $self->canonpath($tfile);
      my @files = grep {defined() && length()} @_;
  
      my $unix_rpt = $self->_unix_rpt;
  
      my $rslt;
      if (@files) {
  	my $path = (@files == 1 ? $files[0] : $self->catdir(@files));
  	my $spath = $path;
  
          # Something building a VMS path in pieces may try to pass a
          # directory name in filename format, so normalize it.
  	$spath =~ s/\.dir\Z(?!\n)//i;
  
          # If the spath ends with a directory delimiter and the file is bare,
          # then just concatenate them.
  	if ($spath =~ /^(?<!\^)[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) {
  	    $rslt = "$spath$file";
  	} else {
  		$rslt = $self->eliminate_macros($spath);
             $rslt .= (defined($rslt) && length($rslt) ? '/' : '') . unixify($file);
             $rslt = vmsify($rslt) unless $unix_rpt;
  	}
      }
      else {
          # Only passed a single file?
          my $xfile = (defined($file) && length($file)) ? $file : '';
  
          $rslt = $unix_rpt ? $file : vmsify($file);
      }
      return $self->canonpath($rslt) unless $unix_rpt;
  
      # In Unix report mode, do not strip off redundant path information.
      return $rslt;
  }
  
  
  =item curdir (override)
  
  Returns a string representation of the current directory: '[]' or '.'
  
  =cut
  
  sub curdir {
      my $self = shift @_;
      return '.' if ($self->_unix_rpt);
      return '[]';
  }
  
  =item devnull (override)
  
  Returns a string representation of the null device: '_NLA0:' or '/dev/null'
  
  =cut
  
  sub devnull {
      my $self = shift @_;
      return '/dev/null' if ($self->_unix_rpt);
      return "_NLA0:";
  }
  
  =item rootdir (override)
  
  Returns a string representation of the root directory: 'SYS$DISK:[000000]'
  or '/'
  
  =cut
  
  sub rootdir {
      my $self = shift @_;
      if ($self->_unix_rpt) {
         # Root may exist, try it first.
         my $try = '/';
         my ($dev1, $ino1) = stat('/');
         my ($dev2, $ino2) = stat('.');
  
         # Perl falls back to '.' if it can not determine '/'
         if (($dev1 != $dev2) || ($ino1 != $ino2)) {
             return $try;
         }
         # Fall back to UNIX format sys$disk.
         return '/sys$disk/';
      }
      return 'SYS$DISK:[000000]';
  }
  
  =item tmpdir (override)
  
  Returns a string representation of the first writable directory
  from the following list or '' if none are writable:
  
      /tmp if C<DECC$FILENAME_UNIX_REPORT> is enabled.
      sys$scratch:
      $ENV{TMPDIR}
  
  Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR}
  is tainted, it is not used.
  
  =cut
  
  my $tmpdir;
  sub tmpdir {
      my $self = shift @_;
      return $tmpdir if defined $tmpdir;
      if ($self->_unix_rpt) {
          $tmpdir = $self->_tmpdir('/tmp', '/sys$scratch', $ENV{TMPDIR});
          return $tmpdir;
      }
  
      $tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} );
  }
  
  =item updir (override)
  
  Returns a string representation of the parent directory: '[-]' or '..'
  
  =cut
  
  sub updir {
      my $self = shift @_;
      return '..' if ($self->_unix_rpt);
      return '[-]';
  }
  
  =item case_tolerant (override)
  
  VMS file specification syntax is case-tolerant.
  
  =cut
  
  sub case_tolerant {
      return 1;
  }
  
  =item path (override)
  
  Translate logical name DCL$PATH as a searchlist, rather than trying
  to C<split> string value of C<$ENV{'PATH'}>.
  
  =cut
  
  sub path {
      my (@dirs,$dir,$i);
      while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
      return @dirs;
  }
  
  =item file_name_is_absolute (override)
  
  Checks for VMS directory spec as well as Unix separators.
  
  =cut
  
  sub file_name_is_absolute {
      my ($self,$file) = @_;
      # If it's a logical name, expand it.
      $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file};
      return scalar($file =~ m!^/!s             ||
  		  $file =~ m![<\[][^.\-\]>]!  ||
  		  $file =~ /:[^<\[]/);
  }
  
  =item splitpath (override)
  
      ($volume,$directories,$file) = File::Spec->splitpath( $path );
      ($volume,$directories,$file) = File::Spec->splitpath( $path,
                                                            $no_file );
  
  Passing a true value for C<$no_file> indicates that the path being
  split only contains directory components, even on systems where you
  can usually (when not supporting a foreign syntax) tell the difference
  between directories and files at a glance.
  
  =cut
  
  sub splitpath {
      my($self,$path, $nofile) = @_;
      my($dev,$dir,$file)      = ('','','');
      my $vmsify_path = vmsify($path);
  
      if ( $nofile ) {
          #vmsify('d1/d2/d3') returns '[.d1.d2]d3'
          #vmsify('/d1/d2/d3') returns 'd1:[d2]d3'
          if( $vmsify_path =~ /(.*)\](.+)/ ){
              $vmsify_path = $1.'.'.$2.']';
          }
          $vmsify_path =~ /(.+:)?(.*)/s;
          $dir = defined $2 ? $2 : ''; # dir can be '0'
          return ($1 || '',$dir,$file);
      }
      else {
          $vmsify_path =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
          return ($1 || '',$2 || '',$3);
      }
  }
  
  =item splitdir (override)
  
  Split a directory specification into the components.
  
  =cut
  
  sub splitdir {
      my($self,$dirspec) = @_;
      my @dirs = ();
      return @dirs if ( (!defined $dirspec) || ('' eq $dirspec) );
  
      $dirspec =~ s/(?<!\^)</[/;                  # < and >	==> [ and ]
      $dirspec =~ s/(?<!\^)>/]/;
      $dirspec =~ s/(?<!\^)\]\[\./\.\]\[/g;	# ][.		==> .][
      $dirspec =~ s/(?<!\^)\[000000\.\]\[/\[/g;	# [000000.][	==> [
      $dirspec =~ s/(?<!\^)\[000000\./\[/g;	# [000000.	==> [
      $dirspec =~ s/(?<!\^)\.\]\[000000\]/\]/g;	# .][000000]	==> ]
      $dirspec =~ s/(?<!\^)\.\]\[/\./g;		# foo.][bar	==> foo.bar
      while ($dirspec =~ s/(^|[\[\<\.])\-(\-+)($|[\]\>\.])/$1-.$2$3/g) {}
  						# That loop does the following
  						# with any amount of dashes:
  						# .--.		==> .-.-.
  						# [--.		==> [-.-.
  						# .--]		==> .-.-]
  						# [--]		==> [-.-]
      $dirspec = "[$dirspec]" unless $dirspec =~ /(?<!\^)[\[<]/; # make legal
      $dirspec =~ s/^(\[|<)\./$1/;
      @dirs = split /(?<!\^)\./, vmspath($dirspec);
      $dirs[0] =~ s/^[\[<]//s;  $dirs[-1] =~ s/[\]>]\Z(?!\n)//s;
      @dirs;
  }
  
  
  =item catpath (override)
  
  Construct a complete filespec.
  
  =cut
  
  sub catpath {
      my($self,$dev,$dir,$file) = @_;
      
      # We look for a volume in $dev, then in $dir, but not both
          my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir);
          $dev = $dir_volume unless length $dev;
      $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) : $dir_dir;
      
      if ($dev =~ m|^(?<!\^)/+([^/]+)|) { $dev = "$1:"; }
      else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; }
      if (length($dev) or length($dir)) {
          $dir = "[$dir]" unless $dir =~ /(?<!\^)[\[<\/]/;
            $dir = vmspath($dir);
        }
      $dir = '' if length($dev) && ($dir eq '[]' || $dir eq '<>');
      "$dev$dir$file";
  }
  
  =item abs2rel (override)
  
  Attempt to convert an absolute file specification to a relative specification.
  
  =cut
  
  sub abs2rel {
      my $self = shift;
      return vmspath(File::Spec::Unix::abs2rel( $self, @_ ))
          if grep m{/}, @_;
  
      my($path,$base) = @_;
      $base = $self->_cwd() unless defined $base and length $base;
  
      for ($path, $base) { $_ = $self->canonpath($_) }
  
      # Are we even starting $path on the same (node::)device as $base?  Note that
      # logical paths or nodename differences may be on the "same device" 
      # but the comparison that ignores device differences so as to concatenate 
      # [---] up directory specs is not even a good idea in cases where there is 
      # a logical path difference between $path and $base nodename and/or device.
      # Hence we fall back to returning the absolute $path spec
      # if there is a case blind device (or node) difference of any sort
      # and we do not even try to call $parse() or consult %ENV for $trnlnm()
      # (this module needs to run on non VMS platforms after all).
      
      my ($path_volume, $path_directories, $path_file) = $self->splitpath($path);
      my ($base_volume, $base_directories, $base_file) = $self->splitpath($base);
      return $path unless lc($path_volume) eq lc($base_volume);
  
      for ($path, $base) { $_ = $self->rel2abs($_) }
  
      # Now, remove all leading components that are the same
      my @pathchunks = $self->splitdir( $path_directories );
      my $pathchunks = @pathchunks;
      unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000';
      my @basechunks = $self->splitdir( $base_directories );
      my $basechunks = @basechunks;
      unshift(@basechunks,'000000') unless $basechunks[0] eq '000000';
  
      while ( @pathchunks && 
              @basechunks && 
              lc( $pathchunks[0] ) eq lc( $basechunks[0] ) 
            ) {
          shift @pathchunks ;
          shift @basechunks ;
      }
  
      # @basechunks now contains the directories to climb out of,
      # @pathchunks now has the directories to descend in to.
      if ((@basechunks > 0) || ($basechunks != $pathchunks)) {
        $path_directories = join '.', ('-' x @basechunks, @pathchunks) ;
      }
      else {
        $path_directories = join '.', @pathchunks;
      }
      $path_directories = '['.$path_directories.']';
      return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;
  }
  
  
  =item rel2abs (override)
  
  Return an absolute file specification from a relative one.
  
  =cut
  
  sub rel2abs {
      my $self = shift ;
      my ($path,$base ) = @_;
      return undef unless defined $path;
          if ($path =~ m/\//) {
  	    $path = ( -d $path || $path =~ m/\/\z/  # educated guessing about
  		       ? vmspath($path)             # whether it's a directory
  		       : vmsify($path) );
          }
      $base = vmspath($base) if defined $base && $base =~ m/\//;
  
      # Clean up and split up $path
      if ( ! $self->file_name_is_absolute( $path ) ) {
          # Figure out the effective $base and clean it up.
          if ( !defined( $base ) || $base eq '' ) {
              $base = $self->_cwd;
          }
          elsif ( ! $self->file_name_is_absolute( $base ) ) {
              $base = $self->rel2abs( $base ) ;
          }
          else {
              $base = $self->canonpath( $base ) ;
          }
  
          # Split up paths
          my ( $path_directories, $path_file ) =
              ($self->splitpath( $path ))[1,2] ;
  
          my ( $base_volume, $base_directories ) =
              $self->splitpath( $base ) ;
  
          $path_directories = '' if $path_directories eq '[]' ||
                                    $path_directories eq '<>';
          my $sep = '' ;
              $sep = '.'
                  if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} &&
                       $path_directories =~ m{^[^.\[<]}s
                  ) ;
              $base_directories = "$base_directories$sep$path_directories";
              $base_directories =~ s{\.?[\]>][\[<]\.?}{.};
  
          $path = $self->catpath( $base_volume, $base_directories, $path_file );
     }
  
      return $self->canonpath( $path ) ;
  }
  
  
  # eliminate_macros() and fixpath() are MakeMaker-specific methods
  # which are used inside catfile() and catdir().  MakeMaker has its own
  # copies as of 6.06_03 which are the canonical ones.  We leave these
  # here, in peace, so that File::Spec continues to work with MakeMakers
  # prior to 6.06_03.
  # 
  # Please consider these two methods deprecated.  Do not patch them,
  # patch the ones in ExtUtils::MM_VMS instead.
  #
  # Update:  MakeMaker 6.48 is still using these routines on VMS.
  # so they need to be kept up to date with ExtUtils::MM_VMS.
  
  sub eliminate_macros {
      my($self,$path) = @_;
      return '' unless (defined $path) && ($path ne '');
      $self = {} unless ref $self;
  
      if ($path =~ /\s/) {
        return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path;
      }
  
      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 = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; }
              $npath = "$head$macro$tail";
          }
      }
      if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
      $npath;
  }
  
  # Deprecated.  See the note above for eliminate_macros().
  
  # 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.
  
  sub fixpath {
      my($self,$path,$force_path) = @_;
      return '' unless $path;
      $self = bless {}, $self unless ref $self;
      my($fixedpath,$prefix,$name);
  
      if ($path =~ /\s/) {
        return join ' ',
               map { $self->fixpath($_,$force_path) }
  	     split /\s+/, $path;
      }
  
      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/^[^\[<]+//; }
      $fixedpath;
  }
  
  
  =back
  
  =head1 COPYRIGHT
  
  Copyright (c) 2004 by the Perl 5 Porters.  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
  
  See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
  implementation of these methods, not the semantics.
  
  An explanation of VMS file specs can be found at
  L<http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files>.
  
  =cut
  
  1;
X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC_VMS

$fatpacked{"x86_64-linux-gnu-thread-multi/File/Spec/Win32.pm"} = <<'X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC_WIN32';
  package File::Spec::Win32;
  
  use strict;
  
  use vars qw(@ISA $VERSION);
  require File::Spec::Unix;
  
  $VERSION = '3.40';
  $VERSION =~ tr/_//;
  
  @ISA = qw(File::Spec::Unix);
  
  # Some regexes we use for path splitting
  my $DRIVE_RX = '[a-zA-Z]:';
  my $UNC_RX = '(?:\\\\\\\\|//)[^\\\\/]+[\\\\/][^\\\\/]+';
  my $VOL_RX = "(?:$DRIVE_RX|$UNC_RX)";
  
  
  =head1 NAME
  
  File::Spec::Win32 - methods for Win32 file specs
  
  =head1 SYNOPSIS
  
   require File::Spec::Win32; # Done internally by File::Spec if needed
  
  =head1 DESCRIPTION
  
  See File::Spec::Unix for a documentation of the methods provided
  there. This package overrides the implementation of these methods, not
  the semantics.
  
  =over 4
  
  =item devnull
  
  Returns a string representation of the null device.
  
  =cut
  
  sub devnull {
      return "nul";
  }
  
  sub rootdir { '\\' }
  
  
  =item tmpdir
  
  Returns a string representation of the first existing directory
  from the following list:
  
      $ENV{TMPDIR}
      $ENV{TEMP}
      $ENV{TMP}
      SYS:/temp
      C:\system\temp
      C:/temp
      /tmp
      /
  
  The SYS:/temp is preferred in Novell NetWare and the C:\system\temp
  for Symbian (the File::Spec::Win32 is used also for those platforms).
  
  Since Perl 5.8.0, if running under taint mode, and if the environment
  variables are tainted, they are not used.
  
  =cut
  
  my $tmpdir;
  sub tmpdir {
      return $tmpdir if defined $tmpdir;
      $tmpdir = $_[0]->_tmpdir( map( $ENV{$_}, qw(TMPDIR TEMP TMP) ),
  			      'SYS:/temp',
  			      'C:\system\temp',
  			      'C:/temp',
  			      '/tmp',
  			      '/'  );
  }
  
  =item case_tolerant
  
  MSWin32 case-tolerance depends on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE,
  indicating the case significance when comparing file specifications.
  Since XP FS_CASE_SENSITIVE is effectively disabled for the NT subsubsystem.
  See http://cygwin.com/ml/cygwin/2007-07/msg00891.html
  Default: 1
  
  =cut
  
  sub case_tolerant {
    eval { require Win32API::File; } or return 1;
    my $drive = shift || "C:";
    my $osFsType = "\0"x256;
    my $osVolName = "\0"x256;
    my $ouFsFlags = 0;
    Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 );
    if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; }
    else { return 1; }
  }
  
  =item file_name_is_absolute
  
  As of right now, this returns 2 if the path is absolute with a
  volume, 1 if it's absolute with no volume, 0 otherwise.
  
  =cut
  
  sub file_name_is_absolute {
  
      my ($self,$file) = @_;
  
      if ($file =~ m{^($VOL_RX)}o) {
        my $vol = $1;
        return ($vol =~ m{^$UNC_RX}o ? 2
  	      : $file =~ m{^$DRIVE_RX[\\/]}o ? 2
  	      : 0);
      }
      return $file =~  m{^[\\/]} ? 1 : 0;
  }
  
  =item catfile
  
  Concatenate one or more directory names and a filename to form a
  complete path ending with a filename
  
  =cut
  
  sub catfile {
      shift;
  
      # Legacy / compatibility support
      #
      shift, return _canon_cat( "/", @_ )
  	if $_[0] eq "";
  
      # Compatibility with File::Spec <= 3.26:
      #     catfile('A:', 'foo') should return 'A:\foo'.
      return _canon_cat( ($_[0].'\\'), @_[1..$#_] )
          if $_[0] =~ m{^$DRIVE_RX\z}o;
  
      return _canon_cat( @_ );
  }
  
  sub catdir {
      shift;
  
      # Legacy / compatibility support
      #
      return ""
      	unless @_;
      shift, return _canon_cat( "/", @_ )
  	if $_[0] eq "";
  
      # Compatibility with File::Spec <= 3.26:
      #     catdir('A:', 'foo') should return 'A:\foo'.
      return _canon_cat( ($_[0].'\\'), @_[1..$#_] )
          if $_[0] =~ m{^$DRIVE_RX\z}o;
  
      return _canon_cat( @_ );
  }
  
  sub path {
      my @path = split(';', $ENV{PATH});
      s/"//g for @path;
      @path = grep length, @path;
      unshift(@path, ".");
      return @path;
  }
  
  =item canonpath
  
  No physical check on the filesystem, but a logical cleanup of a
  path. On UNIX eliminated successive slashes and successive "/.".
  On Win32 makes 
  
  	dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
  	dir1\dir2\dir3\...\dir4   -> \dir\dir4
  
  =cut
  
  sub canonpath {
      # Legacy / compatibility support
      #
      return $_[1] if !defined($_[1]) or $_[1] eq '';
      return _canon_cat( $_[1] );
  }
  
  =item splitpath
  
      ($volume,$directories,$file) = File::Spec->splitpath( $path );
      ($volume,$directories,$file) = File::Spec->splitpath( $path,
                                                            $no_file );
  
  Splits a path into volume, directory, and filename portions. Assumes that 
  the last file is a path unless the path ends in '\\', '\\.', '\\..'
  or $no_file is true.  On Win32 this means that $no_file true makes this return 
  ( $volume, $path, '' ).
  
  Separators accepted are \ and /.
  
  Volumes can be drive letters or UNC sharenames (\\server\share).
  
  The results can be passed to L</catpath> to get back a path equivalent to
  (usually identical to) the original path.
  
  =cut
  
  sub splitpath {
      my ($self,$path, $nofile) = @_;
      my ($volume,$directory,$file) = ('','','');
      if ( $nofile ) {
          $path =~ 
              m{^ ( $VOL_RX ? ) (.*) }sox;
          $volume    = $1;
          $directory = $2;
      }
      else {
          $path =~ 
              m{^ ( $VOL_RX ? )
                  ( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? )
                  (.*)
               }sox;
          $volume    = $1;
          $directory = $2;
          $file      = $3;
      }
  
      return ($volume,$directory,$file);
  }
  
  
  =item splitdir
  
  The opposite of L<catdir()|File::Spec/catdir>.
  
      @dirs = File::Spec->splitdir( $directories );
  
  $directories must be only the directory portion of the path on systems 
  that have the concept of a volume or that have path syntax that differentiates
  files from directories.
  
  Unlike just splitting the directories on the separator, leading empty and 
  trailing directory entries can be returned, because these are significant
  on some OSs. So,
  
      File::Spec->splitdir( "/a/b/c" );
  
  Yields:
  
      ( '', 'a', 'b', '', 'c', '' )
  
  =cut
  
  sub splitdir {
      my ($self,$directories) = @_ ;
      #
      # split() likes to forget about trailing null fields, so here we
      # check to be sure that there will not be any before handling the
      # simple case.
      #
      if ( $directories !~ m|[\\/]\Z(?!\n)| ) {
          return split( m|[\\/]|, $directories );
      }
      else {
          #
          # since there was a trailing separator, add a file name to the end, 
          # then do the split, then replace it with ''.
          #
          my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
          $directories[ $#directories ]= '' ;
          return @directories ;
      }
  }
  
  
  =item catpath
  
  Takes volume, directory and file portions and returns an entire path. Under
  Unix, $volume is ignored, and this is just like catfile(). On other OSs,
  the $volume become significant.
  
  =cut
  
  sub catpath {
      my ($self,$volume,$directory,$file) = @_;
  
      # If it's UNC, make sure the glue separator is there, reusing
      # whatever separator is first in the $volume
      my $v;
      $volume .= $v
          if ( (($v) = $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s) &&
               $directory =~ m@^[^\\/]@s
             ) ;
  
      $volume .= $directory ;
  
      # If the volume is not just A:, make sure the glue separator is 
      # there, reusing whatever separator is first in the $volume if possible.
      if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
           $volume =~ m@[^\\/]\Z(?!\n)@      &&
           $file   =~ m@[^\\/]@
         ) {
          $volume =~ m@([\\/])@ ;
          my $sep = $1 ? $1 : '\\' ;
          $volume .= $sep ;
      }
  
      $volume .= $file ;
  
      return $volume ;
  }
  
  sub _same {
    lc($_[1]) eq lc($_[2]);
  }
  
  sub rel2abs {
      my ($self,$path,$base ) = @_;
  
      my $is_abs = $self->file_name_is_absolute($path);
  
      # Check for volume (should probably document the '2' thing...)
      return $self->canonpath( $path ) if $is_abs == 2;
  
      if ($is_abs) {
        # It's missing a volume, add one
        my $vol = ($self->splitpath( $self->_cwd() ))[0];
        return $self->canonpath( $vol . $path );
      }
  
      if ( !defined( $base ) || $base eq '' ) {
        require Cwd ;
        $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ;
        $base = $self->_cwd() unless defined $base ;
      }
      elsif ( ! $self->file_name_is_absolute( $base ) ) {
        $base = $self->rel2abs( $base ) ;
      }
      else {
        $base = $self->canonpath( $base ) ;
      }
  
      my ( $path_directories, $path_file ) =
        ($self->splitpath( $path, 1 ))[1,2] ;
  
      my ( $base_volume, $base_directories ) =
        $self->splitpath( $base, 1 ) ;
  
      $path = $self->catpath( 
  			   $base_volume, 
  			   $self->catdir( $base_directories, $path_directories ), 
  			   $path_file
  			  ) ;
  
      return $self->canonpath( $path ) ;
  }
  
  =back
  
  =head2 Note For File::Spec::Win32 Maintainers
  
  Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
  
  =head1 COPYRIGHT
  
  Copyright (c) 2004,2007 by the Perl 5 Porters.  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
  
  See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
  implementation of these methods, not the semantics.
  
  =cut
  
  
  sub _canon_cat				# @path -> path
  {
      my ($first, @rest) = @_;
  
      my $volume = $first =~ s{ \A ([A-Za-z]:) ([\\/]?) }{}x	# drive letter
      	       ? ucfirst( $1 ).( $2 ? "\\" : "" )
  	       : $first =~ s{ \A (?:\\\\|//) ([^\\/]+)
  				 (?: [\\/] ([^\\/]+) )?
  	       			 [\\/]? }{}xs			# UNC volume
  	       ? "\\\\$1".( defined $2 ? "\\$2" : "" )."\\"
  	       : $first =~ s{ \A [\\/] }{}x			# root dir
  	       ? "\\"
  	       : "";
      my $path   = join "\\", $first, @rest;
  
      $path =~ tr#\\/#\\\\#s;		# xx/yy --> xx\yy & xx\\yy --> xx\yy
  
      					# xx/././yy --> xx/yy
      $path =~ s{(?:
  		(?:\A|\\)		# at begin or after a slash
  		\.
  		(?:\\\.)*		# and more
  		(?:\\|\z) 		# at end or followed by slash
  	       )+			# performance boost -- I do not know why
  	     }{\\}gx;
  
      # XXX I do not know whether more dots are supported by the OS supporting
      #     this ... annotation (NetWare or symbian but not MSWin32).
      #     Then .... could easily become ../../.. etc:
      # Replace \.\.\. by (\.\.\.+)  and substitute with
      # { $1 . ".." . "\\.." x (length($2)-2) }gex
  	     				# ... --> ../..
      $path =~ s{ (\A|\\)			# at begin or after a slash
      		\.\.\.
  		(?=\\|\z) 		# at end or followed by slash
  	     }{$1..\\..}gx;
      					# xx\yy\..\zz --> xx\zz
      while ( $path =~ s{(?:
  		(?:\A|\\)		# at begin or after a slash
  		[^\\]+			# rip this 'yy' off
  		\\\.\.
  		(?<!\A\.\.\\\.\.)	# do *not* replace ^..\..
  		(?<!\\\.\.\\\.\.)	# do *not* replace \..\..
  		(?:\\|\z) 		# at end or followed by slash
  	       )+			# performance boost -- I do not know why
  	     }{\\}sx ) {}
  
      $path =~ s#\A\\##;			# \xx --> xx  NOTE: this is *not* root
      $path =~ s#\\\z##;			# xx\ --> xx
  
      if ( $volume =~ m#\\\z# )
      {					# <vol>\.. --> <vol>\
  	$path =~ s{ \A			# at begin
  		    \.\.
  		    (?:\\\.\.)*		# and more
  		    (?:\\|\z) 		# at end or followed by slash
  		 }{}x;
  
  	return $1			# \\HOST\SHARE\ --> \\HOST\SHARE
  	    if    $path eq ""
  	      and $volume =~ m#\A(\\\\.*)\\\z#s;
      }
      return $path ne "" || $volume ? $volume.$path : ".";
  }
  
  1;
X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC_WIN32

s/^  //mg for values %fatpacked;

unshift @INC, sub {
  if (my $fat = $fatpacked{$_[1]}) {
    if ($] < 5.008) {
      return sub {
        return 0 unless length $fat;
        $fat =~ s/^([^\n]*\n?)//;
        $_ = $1;
        return 1;
      };
    }
    open my $fh, '<', \$fat
      or die "FatPacker error loading $_[1] (could be a perl installation issue?)";
    return $fh;
  }
  return
};

} # END OF FATPACK CODE


# Copyright (C) 2013,2014 Ole Tange, Mike DeGiorgio, Anna-Sapfo
# Malaspinas, Jose Victor Moreno-Mayar, Yong Wang and Free Software
# Foundation, Inc.
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 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.
# 
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.

use local::lib;
use Text::CSV;

my $file = shift;
# Assume we can guess the CSV format from the first 100KB.
my $sniff_length = 100_000;

my @rows;

my @csv_file_types = 
  ( { binary => 1 },
    { binary => 1, sep_char => "\t" },
    { binary => 1, sep_char => "," },
  );

#    $csv = Text::CSV->new ({
#            quote_char          => '"',
#            escape_char         => '"',
#                        => ',',
#            eol                 => $\,
#            always_quote        => 0,
#            quote_space         => 1,
#            quote_null          => 1,
#            binary              => 0,
#            keep_meta_info      => 0,
#            allow_loose_quotes  => 0,
#            allow_loose_escapes => 0,
#            allow_whitespace    => 0,
#            blank_is_undef      => 0,
#            empty_is_undef      => 0,
#            verbatim            => 0,
#            auto_diag           => 0,
#            });

open(my $fh, "<:encoding(utf8)", $file) or die "Cannot open $file: $!";
my @lines = <$fh>;
close $fh;

my $succesful_csv_type;
my $csv;
for my $csv_file_type (@csv_file_types) {
  $csv = Text::CSV->new ( $csv_file_type )  # should set binary attribute.
    or die "Cannot use CSV: ($csv_file_type) ".Text::CSV->error_diag ();
  $succesful_csv_type = $csv_file_type;
  for my $line (@lines) {
    if(not $csv->parse($line)) {
      $succesful_csv_type = 0;
      last;
    }
  }
}
if(not $succesful_csv_type) {
  $csv->error_diag();
}

$csv = Text::CSV->new ( $succesful_csv_type )  # should set binary attribute.
  or die "Cannot use CSV: ".Text::CSV->error_diag ();
my @table;
my $max_columns;
my $i = 0;
for my $line (@lines) {
  $csv->parse($line);
  my @columns = $csv->fields();
  for(my $j=0; $j<= $#columns; $j++) {
    $table[$i][$j] = $columns[$j];
  }
  $max_columns = max($max_columns,$#columns);
  $i++;
}

# Remove lines starting with '#'
@table = grep { $$_[0] !~ /^#/ } @table;
# Remove empty lines
@table = grep { grep { /\S/ } @$_ and $_  } @table;

# Empty value = see above (Get value from previous line)
my @above = @{$table[0]};
for(my $i = 0; $i <= $#table; $i++) {
  for(my $j = 0; $j <= $max_columns; $j++) {
    if($table[$i][$j] =~ /^\s*$/) {
      $table[$i][$j] = $above[$j];
    }
  }
  @above = @{$table[$i]};
}

my @predefined_colnames = qw(Population pop_label Individual indv_label sample order Color pch cex);
my @colnames = @{$table[0]};
my %col;
@col{@colnames} = 0..$#colnames;

# Get the columns number of the predefined names
my($Population, $pop_label, $Individual, $indv_label, $sample, $order, $Color, $pch, $cex) =
  @col{@predefined_colnames};

# Find population default values
for my $row (@table) {
  if($row->[$Individual] eq "*") {
    my %values;
    @values{@predefined_colnames} =  @$row[@col{@predefined_colnames}];
    $default{$row->[$Population]} = \%values;
  }
}

$default->{'*'}{'cex'} = 0.8;
$default->{'*'}{'sample'} = 0;

# Replace population default values
for my $row (@table) {
  if($row->[$Individual] eq "*") {
    # This is a population line
    if($row->[$pop_label] eq "*") {
      # pop_label == *  => pop_label = Population
      $default->{$row->[$Population]}{'pop_label'} = $row->[$Population];
      $row->[$pop_label] = $default->{$row->[$Population]}{'pop_label'};
    } else {
      $default->{$row->[$Population]}{'pop_label'} = $row->[$pop_label];
    }

    if($row->[$sample] eq "*") {
      # sample == * => sample = sample[*]
      $default->{$row->[$Population]}{'sample'} = $default->{'*'}{'sample'};
      $row->[$sample] = $default->{$row->[$Population]}{'sample'};
    } else {
      $default->{$row->[$Population]}{'sample'} = $row->[$sample];
    }

    if($row->[$Color] eq "*") {
      # Color == * 
      # Skip: Will be done later
    }

    if($row->[$pch] eq "*") {
      # pch == * => pch = FirstChar of pop_label
      $default->{$row->[$Population]}{'pch'} = substr($row->[$pop_label],0,1);
      $row->[$pch] = $default->{$row->[$Population]}{'pch'};
      if($row->[$sample] eq 1) {
	# Sample => Default to [n]
	$row->[$pch] = "[".$row->[$pch]."]";
      }
    } else {
      $default->{$row->[$Population]}{'pch'} = $row->[$pch];
    }
    
    if($row->[$cex] eq "*") {
      # cex == * => cex = cex[*];
      $default->{$row->[$Population]}{'cex'} = $default->{'*'}{'cex'};
      $row->[$cex] = $default->{$row->[$Population]}{'cex'};
    } else {
      $default->{$row->[$Population]}{'cex'} = $row->[$cex];
    }
  }
}

# Replace values
my ($uniq_pop, $uniq_individual);

for my $row (@table) {
  # Population = * => Done in finding default values

  if($row->[$pop_label] eq "*") {
    # pop_label == *  => pop_label[Population]
    $row->[$pop_label] = $default->{$row->[$Population]}{'pop_label'};
  }
  $uniq_pop{$row->[$pop_label]}++;

  # Individual = * => Done in finding default values

  if($row->[$indv_label] eq "*") {
    # indv_label == *  => indv_label = Individual
    $row->[$indv_label] = $row->[$Individual];
  }
  $uniq_individual{$row->[$indv_label]}++;
}

my (%known_position,$pop_id,$indv_id);
my $i = 1;
for my $row (@table) {
  if($row->[$sample] eq "*") {
    # sample == * => sample = sample[Population]
    $row->[$sample] = $default->{$row->[$Population]}{'sample'} || $default->{'*'}{'sample'};
  }

  if($row->[$order] eq "*") {
    # order == *  => order = lineno
    $row->[$order] = $i*10;
  }

  if($row->[$Color] eq "*") {
    # Color == * => color = hash(indv_label or pop_label)
    my ($name,$position);
    if($row->[$Individual] eq "*") {
      # This is a population line
      $name = $row->[$pop_label];
      if(not $known_position{$name}) {
	  # If we have not seen this name before: Get new color
	  $known_position{$name} = $pop_id++/(keys %uniq_pop);
      }
      $position = $known_position{$name};
    } else {
      # This is an individual line
      $name = $row->[$indv_label];
      $position = $indv_id++/(keys %uniq_individual);
    }
    if($row->[$sample] eq 1) {
      # This is a sample. We make that black
      $row->[$Color] = color_from_position(0,0,0);
    } else {
      # Not a sample -> pastel color
      $row->[$Color] = color_from_position($position,0.6,1);
    }
  }

  if($row->[$pch] eq "*") {
    if(not $row->[$Individual] eq "*") {
      # This is an individual line
      # pch == * => pch = hash(indv_label);
      $row->[$pch] = pch_from_name($row->[$indv_label]);
      if($row->[$sample] eq 1) {
	# Sample => Default to [n]
	$row->[$pch] = "[".$row->[$pch]."]";
      }
    }
  }

  if($row->[$cex] eq "*") {
    # cex == * => cex = cex[Population];
    $row->[$cex] = $default->{$row->[$Population]}{'cex'} || $default->{'*'}{'cex'};
  }
  $i++;
}


$csv = Text::CSV->new ({ binary => 1 })  # should set binary attribute.
  or die "Cannot use CSV: ".Text::CSV->error_diag ();
for my $row (@table) {
  my @columns = @$row[@col{@predefined_colnames}];
  $status = $csv->combine(@columns);    # combine columns into a string
  $line   = $csv->string();             # get the combined string
  print $line,"\n";
}

sub color_from_position {
  # Compute the HSV color for the value
  # Input:
  #   h = 0.0 .. 1.0
  #   s = 0.0 .. 1.0
  #   v = 0.0 .. 1.0
  # Output:
  #   $hex = "#xxxxx" hex color value
  my $h = shift;
  my $s = shift;
  my $v = shift;
  my ($r,$g,$b) = hsv2rgb($h*360,$s,$v);
  return sprintf('#%02x%02x%02x', $r*255, $g*255, $b*255);
}  

sub hsv2rgb {
  my ( $h, $s, $v ) = @_;

  use POSIX;
  
  if ( $s == 0 ) {
    return $v, $v, $v;
  }
  
  $h /= 60;
  my $i = floor( $h );
  my $f = $h - $i;
  my $p = $v * ( 1 - $s );
  my $q = $v * ( 1 - $s * $f );
  my $t = $v * ( 1 - $s * ( 1 - $f ) );
  
  if ( $i == 0 ) {
    return $v, $t, $p;
  }
  elsif ( $i == 1 ) {
    return $q, $v, $t;
  }
  elsif ( $i == 2 ) {
    return $p, $v, $t;
  }
  elsif ( $i == 3 ) {
    return $p, $q, $v;
  }
  elsif ( $i == 4 ) {
    return $t, $p, $v;
  }
  else {
    return $v, $p, $q;
  }
}

sub color_from_name {
  # Input:
  #   $name = name to give a color
  # Output:
  #   $hex = "#xxxxx" hex color value
  my $name = shift;
  use Digest::MD5 qw(md5);
  my $str = substr( md5($name), 0, 3 );
  my ($b_R,$b_G,$b_B) = unpack('CCC', $str);
  return sprintf('#%02x%02x%02x', $b_R, $b_G, $b_B);
}


sub pch_from_name {
  my $name = shift;
  my @pch_values=("A".."Z","a".."z",0..9);
  use Digest::MD5 qw(md5 md5_hex);
  my ($val64bit) = unpack('Q', md5($name));
  my $mod = $val64bit % ($#pch_values+1);
  return $pch_values[$mod];
}

sub my_dump {
    # Returns:
    #   ascii expression of object if Data::Dump(er) is installed
    #   error code otherwise
    my @dump_this = (@_);
    eval "use Data::Dump qw(dump);";
    if ($@) {
        # Data::Dump not installed
        eval "use Data::Dumper;";
        if ($@) {
            my $err =  "Neither Data::Dump nor Data::Dumper is installed\n".
                "Not dumping output\n";
            print $Global::original_stderr $err;
            return $err;
        } else {
            return Dumper(@dump_this);
        }
    } else {
	# Create a dummy Data::Dump:dump as Hans Schou sometimes has
	# it undefined
	eval "sub Data::Dump:dump {}";
        eval "use Data::Dump qw(dump);";
        return (Data::Dump::dump(@dump_this));
    }
}

sub max {
    # Returns:
    #   Maximum value of array
    my $max;
    for (@_) {
        # Skip undefs
        defined $_ or next;
        defined $max or do { $max = $_; next; }; # Set $_ to the first non-undef
        $max = ($max > $_) ? $max : $_;
    }
    return $max;
}

