#!/usr/bin/perl -w

# 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{"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{"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 strict;
use local::lib;
use Getopt::Long;

$Global::progname = "bamdamage";
$Global::version = "20140328";

Getopt::Long::Configure("bundling");
my @retval = GetOptions
    ("debug|D" => \$opt::debug,
     "verbose|v" => \$opt::verbose,
     "help|h" => \$opt::help,
     "mapquality|m=i" => \$opt::mapq,
     "basequality|b=i" => \$opt::baseq,
     "sample|s=s" => \$opt::sample,
     "version|V" => \$opt::version,
    ) or usage(1);

if($opt::help) { usage(0); }

if($opt::version) {
  version();
  exit(0);
}

my $mapqual_lb = $opt::mapq || 30; # Default minimum mapping quality 30
my $seqqual_ub = 50; # Ignore qualities > 50
my $seqqual_os = 33; # quality score offset
my $seqqual_lb = $opt::baseq || 20; # Default minimum base quality 20
my $length_lb = 20;
my $length_ub = 100; # Max sequence length
my $position_ub = 80; # Max position
my $damage_ub = 20;

my $file = $ARGV[0];
my @out;
if($file and -r $file) {
    open(IN,"-|","samtools","view","-h",$file) or error("Cannot read $file\n");
    if($opt::debug) {
	open(OUT,">",$file.".stat") or error("Cannot write ${file}.stat\n");
    } else {
	open(OUT,">/dev/null") or error("Cannot write ${file}.stat\n");
    }
} else {
    usage(1);
    exit(1);
}
my $outfile = $file;
$outfile =~ s:.*/::; # Remove full path
$outfile =~ s/\.....?$//; # Remove extension if any
$outfile .= ".dam.pdf";

my %ACGT = ("A" => 0, "C" => 1, "G" => 2, "T" => 3);
my @count_by_length;
my @count_by_qual;
my @count_by_mut5;
my @count_by_mut3;
my @count_by_damage;

for(my $i=$seqqual_lb;$i<$seqqual_ub;$i++) {
	$count_by_qual[$i]=0;
}

for(my $i=$length_lb;$i<$length_ub;$i++) {
	$count_by_length[$i]=0;
}

for(my $i=0;$i<$damage_ub;$i++) {
	$count_by_damage[$i]=0;
}

for(my $i=0;$i<4;$i++) {
    for (my $j=0;$j<4;$j++) {
	for(my $k=0;$k<$position_ub;$k++){
	    $count_by_mut5[$i][$j][$k]=0;
	    $count_by_mut3[$i][$j][$k]=0;
	}
    }
}


my $line;
my $linecount = 0;
my $curres;
my $unparsable_warning_printed = 0;
my $unexpected_md_warning_printed = 0;
while ($line=<IN>) {
    if ($line=~/^@/) {
	if ($opt::debug) {print $line;}
	next;
    }
    #===== Extract Info =======#
    if($line =~ /^\S+\t(\S+)\t\S+\t\S+\t(\S+)\t(\S+)\t\S+\t\S+\t\S+\t(\S+)\t(\S+)\t/) {
	# The line parses: Go on
    } else {
	if($opt::verbose) {
	    warning("This line is not parsable: $line");
	} else {
	    if($unparsable_warning_printed++) {
		# skip
	    } else {
		warning("The bam file contains unparsable lines. Use -v to see them.\n");
	    }
	}
	next;
    }
    my $mapflag = $1;
    my $mapqual = $2;
    my $CIGAR = $3;
    my $read = $4;
    my $qual_string = $5;
    my $reverseflag = 0;
    if ($mapflag & 16) {
	$reverseflag=1;
    } else {
	$reverseflag=0;
    }

    # Maping quality too low
    if ($mapqual < $mapqual_lb) { next; }

    # Count length
    my $len = length($qual_string);
    my $hlen = $len;
    if ($hlen >= $length_ub) { $hlen = $length_ub - 1; }
    $count_by_length[$hlen]++;

    # Count sequencing quality
    my @usesite;
    for (my $i = 0; $i<$len; $i++) {
	my $ch = substr($qual_string,$i,1);
	my $qual = ord($ch) - $seqqual_os;
	if ($qual >= $seqqual_lb) {
	    $usesite[$i]=1;
	} else {
	    $usesite[$i]=0;
	}
	if ($qual >= $seqqual_ub) { $qual = $seqqual_ub-1; }
	$count_by_qual[$qual]++;
    }

    #===== Pharse CIGAR string to create a draft reference (with INDEL)  ========#
    my $CIGARBK = $CIGAR;
    my $ref = "";
    my $pos = 0;
    my $check = 0;
    my $nDAM = 0;

    my $cigar_expanded = "";

    while (length($CIGAR)>0) {
	$CIGAR =~ s/^(\d+)([A-Z])//;
	my $seglen = $1;
	my $sym = uc($2);	
	if ($sym eq "M") {
	    $ref .= substr($read,$pos,$seglen);
	    $cigar_expanded = $cigar_expanded . ("M" x $seglen);
	    $pos += $seglen;
	} elsif ($sym eq "I") {
	    $ref .= "-" x $seglen;
	    $cigar_expanded = $cigar_expanded . ("I" x $seglen);
	    $pos += $seglen;
	} elsif ($sym eq "D") {
	    # skip
	} elsif ($sym eq "N") {
	    $ref .= "N" x $seglen;
	    $cigar_expanded = $cigar_expanded . ("N" x $seglen);
	    $pos += $seglen;
	    $check = 1;
	} elsif ($sym eq "P") {
	    $check = 1;
	} elsif ($sym eq "H") {
	    $check = 1;
	} elsif ($sym eq "S") {
	    $ref .= "N" x $seglen;
	    $cigar_expanded = $cigar_expanded . ("S" x $seglen);
	    $pos += $seglen;
	    $check = 1;
	} else {
	    $check = 1;
	}
    }

    #==== Pharse MD string to reverse mutation back to create final reference ======#
    #==== and counting the number of all matches/mismatches and damages ====#	
    $line =~ /MD:Z:(.*?)[\s\n]/;
    my $mismstr = $1;
    my $mismstrbk = $1;
    
    $mismstr=~s/^(\d+)//;
    my $matchl=$1;
    $pos = 0;
    my $count_CG=0;

    for(my $i=0; $i<$matchl;) {
	$curres = uc(substr($ref,$pos,1));
	#unless ($curres eq "-" || $curres eq "N") {$i++;}
	unless (substr($cigar_expanded, $pos, 1) ne "M") {$i++;}
	if ($usesite[$pos]) {
	    if (($curres eq "C" && $reverseflag == 0) || ($curres eq "G" && $reverseflag == 1)) {
		$count_CG++;
	    }
	    if ($curres=~/[ACGT]/) {
		my $refno = $ACGT{$curres};
		if ($pos<$position_ub && $refno>=0) {
		    unless ($reverseflag) {
			$count_by_mut5[$refno][$refno][$pos]++;
		    } else {
			$count_by_mut3[3-$refno][3-$refno][$pos]++;
		    }
		}
		my $pos3 = $len-$pos-1;
		if ($pos3<$position_ub && $pos3>=0 && $refno>=0) {
		    unless ($reverseflag) {
			$count_by_mut3[$refno][$refno][$pos3]++;
		    } else {
			$count_by_mut5[3-$refno][3-$refno][$pos3]++;
		    }
		}
	    }
	}
	$pos++;
    }

    while (length($mismstr)>0) {
	$mismstr=~s/^(.*?)(\d+)//;
	my $curstr=$1;
	my $matchl=$2;
	if ($curstr=~/\^/) {
	    # skip
	} else {
	    my $refres=uc(substr($ref,$pos,1));
	    while(substr($cigar_expanded, $pos, 1) ne "M") {
		$pos++;
		$refres=uc(substr($ref,$pos,1));
	    }	
	    $refres = uc($curstr);
	    #added the option to have an N nucleotide
	    unless ($refres=~/[ACGTN]/) {
		if($unexpected_md_warning_printed++) {
		    if($opt::verbose) {
			warning("unexpected MD string $mismstrbk $curstr $refres\n");
		    }
		} else {
		    warning("The bam file contains unexpected MD strings. Use -v to see them.\nIf you have used GATK to realign your reads followed by samtools calmd, this is to be expected.\n");
		}
	    }
	    my $readres = uc(substr($read,$pos,1));
	    #added the option to have an N nucleotide
	    unless ($readres=~/[ACGTN]/) {
		if($unexpected_md_warning_printed++) {
		    if($opt::verbose) {
			warning("unexpected MD string $mismstrbk $read $readres\n");
		    }
		} else {
		    warning("The bam file contains unexpected MD strings. Use -v to see them.\nIf you have used GATK to realign your reads followed by samtools calmd, this is to be expected.\n");
		}
	    }
				
	    if ($usesite[$pos]) {
		if ( ($readres eq "T" && $refres eq "C" && $reverseflag == 0) 
		     ||
		     ($readres eq "    A" && $refres eq "G" && $reverseflag == 1)) {
		    $nDAM++;
		}
		if (($curres eq "C" && $reverseflag==0)
		    ||
		    ($curres eq "G" && $reverseflag==1)) {
		    $count_CG++;
		}
		my $readno = $ACGT{$readres};
		my $refno = $ACGT{$refres};
		if (defined($refno) and $pos < $position_ub && $refno >= 0 && $readno >= 0) {
		    unless ($reverseflag) {
			$count_by_mut5[$readno][$refno][$pos]++;
		    } else {
			$count_by_mut3[3-$readno][3-$refno][$pos]++;
		    }
		}
		my $pos3 = $len-$pos-1;
		if (defined($refno) and $pos3<$position_ub && $pos3>=0 && $refno>=0 && $readno>=0) {
		    unless ($reverseflag) {
			$count_by_mut3[$readno][$refno][$pos3]++;
		    } else {
			$count_by_mut5[3-$readno][3-$refno][$pos3]++;
		    }
		}
	    }		
	    substr($ref,$pos,1)=$refres;
	    $pos++;
	}
	for(my $i=0; $i<$matchl;) {
	    $curres=uc(substr($ref,$pos,1));	
	    unless (substr($cigar_expanded, $pos, 1) ne "M") {$i++;}
	    if ($usesite[$pos]) {
		if (($curres eq "C" && $reverseflag==0)||($curres eq "G" && $reverseflag==1)) {
		    $count_CG++;
		}
		if ($curres =~ /[ACGT]/) {
		    my $refno = $ACGT{$curres};
		    if ($pos<$position_ub && $refno>=0) {
			unless ($reverseflag) {
			    $count_by_mut5[$refno][$refno][$pos]++;
			} else {
			    $count_by_mut3[3-$refno][3-$refno][$pos]++;
			}
		    }
		    my $pos3=$len-$pos-1;
		    if ($pos3<$position_ub && $pos3>=0 && $refno>=0) {
			unless ($reverseflag) {
			    $count_by_mut3[$refno][$refno][$pos3]++;
			} else {
			    $count_by_mut5[3-$refno][3-$refno][$pos3]++;
			}
		    }
		}
	    }
	    $pos++;
	}
    }

    #=== Print New SAM file with Reference ====#
    chomp($line);
    if ($opt::debug) {
	if ($nDAM>0) {
	    warning("$line\t","$ref\n");	
	}
	if ($check==1) {
	    warning("$CIGARBK\n",
		    "$mismstrbk\n",
		    "$read\n",
		    "$ref\n\n",);
	}
    }

    #=== Calculate damage rate ======#
    if ($count_CG>0) {
	$nDAM = int($nDAM*100/$count_CG);
	if ($nDAM >= $damage_ub) { $nDAM = $damage_ub-1; }
	$count_by_damage[$nDAM]++;
    }        

    #=== On screen output: how many lines processed ====#
    $linecount++;
    if($opt::verbose) {
	if (int($linecount/10000)*10000 == $linecount) {
	    print STDERR "$linecount lines processed\n";
	}
    }
}

for (my $i=$seqqual_lb;$i<$seqqual_ub;$i++) {
	print OUT "$i ";
	push @out, "$i ";
}
print OUT "\n";
push @out, "\n";
for (my $i=$seqqual_lb;$i<$seqqual_ub;$i++) {
	print OUT "$count_by_qual[$i] ";
	push @out, "$count_by_qual[$i] ";
}
print OUT "\n";
push @out, "\n";
#=== Output Read length Distribution =====#
for (my $i=$length_lb;$i<$length_ub;$i++) {
	print OUT "$i ";
	push @out, "$i ";
}
print OUT "\n";
push @out, "\n";
for (my $i=$length_lb;$i<$length_ub;$i++) {
	print OUT "$count_by_length[$i] ";
	push @out, "$count_by_length[$i] ";
}
print OUT "\n";
push @out, "\n";

#=== Output Damage Rate Distribution =====#
for (my $i=0;$i<$damage_ub;$i++) {
	print OUT "$i ";
	push @out, "$i ";
}
print OUT "\n";
push @out, "\n";
for (my $i=0;$i<$damage_ub;$i++) {
	print OUT "$count_by_damage[$i] ";
	push @out, "$count_by_damage[$i] ";
}
print OUT "\n";
push @out, "\n";

#=== Output Mismatch Patterns =====#
for (my $i=0;$i<4;$i++) {
    for (my $j=0;$j<4;$j++) {
	for(my $k=0;$k<$position_ub;$k++) {
	    my $mutrate;
	    my $totalres = $count_by_mut5[0][$j][$k] + $count_by_mut5[1][$j][$k] 
		+ $count_by_mut5[2][$j][$k] + $count_by_mut5[3][$j][$k];
	    if ($totalres==0) {
		$mutrate=0;
	    } else {
		$mutrate=$count_by_mut5[$i][$j][$k]/$totalres;
	    }
	    print OUT "$mutrate ";
	    push @out, "$mutrate ";
	}
	print OUT "\n";
	push @out, "\n";
    }
}

for (my $i=0;$i<4;$i++) {
    for (my $j=0;$j<4;$j++) {
	for(my $k=0;$k<$position_ub;$k++) {
	    my $mutrate;
	    my $totalres = $count_by_mut3[0][$j][$k] + $count_by_mut3[1][$j][$k]
		+ $count_by_mut3[2][$j][$k] + $count_by_mut3[3][$j][$k];
	    if ($totalres == 0) {
		$mutrate = 0;
	    } else {
		$mutrate = $count_by_mut3[$i][$j][$k]/$totalres;
	    }
	    print OUT "$mutrate ";
	    push @out, "$mutrate ";
	}
	print OUT "\n";
	push @out, "\n";
    }
}

close(IN);
close(OUT);

my $file_no_bam = $file;
$file_no_bam =~ s:.*/::; # Remove full path
$file_no_bam =~ s/\.bam$//i;
open(R,"|-","R --vanilla > /dev/null") || die;
print R R_script($opt::sample||$file_no_bam, $outfile, @out);
close R;
print STDERR "Saved $outfile\n";

sub debug {
    # Returns: N/A
    $opt::debug or return;
    @_ = grep { defined $_ ? $_ : "" } @_;
    if($Global::fd{1}) {
	# Original stdout was saved
	my $stdout = $Global::fd{1};
        print $stdout @_;
    } else {
        print @_;
    }
}

sub version {
    # Returns: N/A
    print join("\n",
               "$Global::progname $Global::version",
               "Copyright (C) 2013,2014 Yong Wang, Ole Tange and Free Software Foundation, Inc.",
               "License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>",
               "This is free software: you are free to change and redistribute it.",
               "GNU $Global::progname comes with no warranty.",
               "",
               "Web site: http://www.nongnu.org/software/bammds\n",
	       "When using $Global::progname to process data for publication please cite:\n",
	       "<<INSERT ARTICLE HERE>>\n",
        );
}

sub usage {
    my $exit = shift;
    version();
    print "\nUsage:\n\n",
    "  bamdamage [--mapquality qual] [--basequality qual] [--sample name] [file.bam]\n",
    "  bamdamage [-m qual] [-b qual] [-s name] file.bam\n";
    exit($exit);
}

sub error {
    my @w = @_;
    my $fh = $Global::original_stderr || *STDERR;
    my $prog = $Global::progname || "bamdamage";
    print $fh $prog, ": Error: ", @w;
    exit(1);
}

sub warning {
    my @w = @_;
    my $fh = $Global::original_stderr || *STDERR;
    my $prog = $Global::progname || "bamdamage";
    print $fh $prog, ": Warning: ", @w;
}

sub R_script {
    my $sample_name = shift;
    my $pdffile = shift;
    my @values = @_;
    
    my @script =
	(
	 qq(
           sample_name <- "$sample_name"
           pdfname <- "$pdffile"
           str <- "@values"),
	 q(
open_plot_file <- function(mds_file) {
  if(grepl(".pdf$", mds_file, ignore.case = T)) {
    pdf(mds_file, height=7, width=14);
  } else if(grepl(".png$", mds_file, ignore.case = T)) {
    save_file <- gsub("(....)$", ".%1d\\1", mds_file)
    png(save_file, height=1000, width=2000);
    mds_file <<- gsub("(....)$", ".*\\1", mds_file)
  } else if(grepl(".svg$", mds_file, ignore.case = T)) {
    save_file <- gsub("(....)$", ".%1d\\1", mds_file)
    svg(save_file, height=7, width=14);
    mds_file <<- gsub("(....)$", ".*\\1", mds_file)
  } else if(grepl(".jpg$", mds_file, ignore.case = T)) {
    save_file <- gsub("(....)$", ".%1d\\1", mds_file)
    jpeg(save_file, height=1000, width=2000);
    mds_file <<- gsub("(....)$", ".*\\1", mds_file)
  } else if(grepl(".jpeg$", mds_file, ignore.case = T)) {
    save_file <- gsub("(.....)$", ".%1d\\1", mds_file)
    jpeg(save_file, height=1000, width=2000);
    mds_file <<- gsub("(.....)$", ".*\\1", mds_file)
  } else if(grepl(".tif$", mds_file, ignore.case = T)) {
    save_file <- gsub("(....)$", ".%1d\\1", mds_file)
    tiff(save_file, height=1000, width=2000);
    mds_file <<- gsub("(....)$", ".*\\1", mds_file)
  } else if(grepl(".tiff$", mds_file, ignore.case = T)) {
    save_file <- gsub("(.....)$", ".%1d\\1", mds_file)
    tiff(save_file, height=1000, width=2000);
    mds_file <<- gsub("(.....)$", ".*\\1", mds_file)
  } else {
    ## Unknown format
    error <- paste("Unknown plot format:",mds_file);
    write(error, stderr());
    quit("no",1);
  }
}

open_plot_file(pdfname);

## plot the quality distribution: remove!
# ifn1 <- textConnection(str);
# data1<-read.table(ifn1,header=F,nrows=2,skip=0)
# data1[2,]<-data1[2,]/sum(as.numeric(data1[2,]))
# mat1<-as.matrix(data1[2,])

#barplot(mat1,main="sequencing quality distribution",xlab="quality score",ylab="frequency",col="dodgerblue4",names.arg=data1[1,],legend=sample_name)

##plot of the read length distribution
par(mfrow=c(1,2))
ifn1 <- textConnection(str);
data1<-read.table(ifn1,header=F,nrows=2,skip=2)
values = data1[1,]
counts = data1[2,]

data1[2,]<-data1[2,]/sum(as.numeric(data1[2,]))
freqs = data1[2,]
average = sum(as.vector(values)*as.vector(freqs))
mat2<-as.matrix(data1[2,])

barplot(mat2,main="read length distribution",xlab="read length",ylab="frequency",col="dodgerblue4",names.arg=data1[1,])
legend("topleft",paste(sample_name,", average: ",round(average,2),sep=""),fill="dodgerblue4")

## plot of the damage distribution
#ifn1 <- textConnection(str);
#data1<-read.table(ifn1,header=F,nrows=2,skip=4)
#data1[2,]<-data1[2,]/sum(as.numeric(data1[2,]))
#mat3<-as.matrix(data1[2,])
#barplot(mat3,main="damage distribution",xlab="damage %",ylab="frequency",col="dodgerblue4",names.arg=data1[1,],legend=sample_name)
  
## plot damage from 5 end
par(mfrow=c(1,2))

ifn1 <- textConnection(str);
data1<-read.table(ifn1,header=F,nrows=16,skip=6)
tmp <- t(data1)
dam <- cbind(rowSums(tmp),tmp[,1:16])
nda <- dam
yma <- max(nda[1:25,c(3:6,8:11,13:16)])
yma <- round(yma*1000+0.5)/1000

Colors = c("olivedrab3","deepskyblue1","violetred","olivedrab3","gold","darkorange","deepskyblue1","gold","darkblue","violetred","darkorange","darkblue")
Linetypes = c(1,1,1,2,1,2,2,2,1,1,1,2)
plot(nda[,3], main=paste("Damage Pattern 5' end",sample_name,sep=" "),xlab="Position from 5 end",ylab="Frequency",ylim=c(0,yma),col=2,type="l",lwd=1);
points(nda[,4],type="l",col="deepskyblue1",lwd=3);
points(nda[,15],type="l",col="darkorange",lwd=3);
count = 0;
for (i in 5:16) {
        if (i!=7 && i!=12 && i!=15) {
          count=count+1;
          points(nda[,i],type="l",col=Colors[count],lty=Linetypes[count]);
        }
}

legend("topright",legend=c("C->A","G->A","T->A","A->C","G->C","T->C","A->G","C->G","T->G","A->T","C->T","G->T"),col=Colors,lwd=c(1,3,1,1,1,1,1,1,1,1,3,1),lty=c(1,1,1,2,1,2,2,2,1,1,1,2),cex=0.5);

ifn1 <- textConnection(str);
data1<-read.table(ifn1,header=F,nrows=16,skip=22)
tmp <- t(data1)
dam <- cbind(rowSums(tmp),tmp[,1:16])
nda <- dam;
yma <- max(nda[1:25,c(3:6,8:11,13:16)]);
yma <- round(yma*1000+0.5)/1000;

plot(nda[,3], main=paste("Damage Pattern 3' end",sample_name,sep=" "),xlab="Position from 3 end",ylab="Frequency",ylim=c(0,yma),col=2,type="l",lwd=1);
points(nda[,4],type="l",col="deepskyblue1",lwd=3);
points(nda[,15],type="l",,col="darkorange",lwd=3);
count = 0;

for (i in 5:16) {
        if (i!=7 && i!=12 && i!=15) {
          count=count+1;
          points(nda[,i],type="l",col=Colors[count],lty=Linetypes[count]);
        }
}
legend("topright",legend=c("C->A","G->A","T->A","A->C","G->C","T->C","A->G","C->G","T->G","A->T","C->T","G->T"),col=c("olivedrab3","deepskyblue1","violetred","olivedrab3","gold","darkorange","deepskyblue1","gold","darkblue","violetred","darkorange","darkblue"),lwd=c(1,3,1,1,1,1,1,1,1,1,3,1),lty=c(1,1,1,2,1,2,2,2,1,1,1,2),cex=0.5);


dev.off()

    ));

    return @script;
}
