File Coverage

bin/require-perl-tags-packed

Criterion	Covered	Total	%
statement	139	449	30.9
branch	5	140	3.5
condition	1	34	2.9
subroutine	39	109	35.7
pod	44	48	91.6
total	228	780	29.2

#!/usr/bin/env perl

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

$fatpacked{"App/Perl/Tags.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_PERL_TAGS';
  #!/usr/bin/env perl
  use 5.006;
  use strict; use warnings;

  package App::Perl::Tags;
  use Getopt::Long ();
  use Pod::Usage qw/pod2usage/;
  use File::Find::Rule;

  use Perl::Tags;
  use Perl::Tags::Hybrid;
  use Perl::Tags::Naive::Moose; # includes ::Naive

  our $VERSION = '0.02';

  sub run {
    my $class = shift;

    my %options = (
      outfile => 'perltags',
      files => undef,
      depth => 10,
      variables => 1,
      ppi => 0,
      prune => [ ],
      help => sub { $class->usage() },
      version => sub { $class->version() },
    );

    Getopt::Long::GetOptions(
      \%options,
      'help|h',
      'version|v',
      'outfile|o=s',
      'files|L=s',
      'prune=s@',
      'depth|d=i',
      'variables|vars!',
      'ppi|p!',
    );

    if (defined $options{files}) {
      # Do not descend into explicitly specified files.
      $options{depth} = 1;
    } else {
      # If not files are specified via -files options, we expect some
      # paths after all the options.
      $class->usage() unless @ARGV
    }

    $options{paths} = \@ARGV;

    my $self = $class->new(%options);
    $self->main();
    exit();
  }

  sub new {
    my ($class, %options) = @_;
    $options{prune} = [ '.git', '.svn' ] unless @{ $options{prune} || [] };
    return bless \%options, $class;
  }

  sub version {
    print "perl-tags v. $VERSION (Perl Tags v. $Perl::Tags::VERSION)\n";
    exit();
  }

  sub usage {
    pod2usage(0);
  }

  sub main {
    my $self = shift;

    my %args = (
      max_level    => $self->{depth},
      exts         => 1,
      do_variables => $self->{variables},
    );

    my @taggers = ( Perl::Tags::Naive::Moose->new( %args ) );
    if ($self->{ppi}) {
      require Perl::Tags::PPI;
      push @taggers, Perl::Tags::PPI->new( %args );
    }

    my $ptag = Perl::Tags::Hybrid->new( %args, \@taggers );

    my @files = do {
      if (defined $self->{files}) {
        if ('-' eq $self->{files}) {
          map { chomp; $_ } <STDIN>;
        } else {
          my $fh = IO::File->new($self->{files})
            or die "cannot open $$self{files} for reading: $!";
          map { chomp; $_ } <$fh>;
        }
      } else {
        $self->get_files;
      }
    };

    $ptag->process(files => \@files);
    $ptag->output(outfile => $self->{outfile});
    return;
  }

  sub get_files {
    my $self = shift;
    my @prune = @{ $self->{prune} };
    my @paths = @{ $self->{paths} };

    my $rule = File::Find::Rule->new;

    my @files =
      $rule->or(
        $rule->new
             ->directory
             ->name(@prune)
             ->prune
             ->discard,
        $rule->new
          ->file,
      )->in(@paths);

    return @files;
  }

  =head1 AUTHOR

  Copyright 2009-2014, Steffen Mueller, with contributions from osfameron

  =cut

  # vim:ts=2:sw=2

  1;
APP_PERL_TAGS

$fatpacked{"Carp.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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.3301';

  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) <[e-mail]> divested Carp into an independent
  distribution.

  =head1 COPYRIGHT

  Copyright (C) 1994-2013 Larry Wall

  Copyright (C) 2011, 2012, 2013 Andrew Main (Zefram) <[e-mail]>

  =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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARP_HEAVY';
  package Carp::Heavy;

  use Carp ();

  our $VERSION = '1.3301';

  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{"Module/Locate.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_LOCATE';
  {
    package Module::Locate;

    use warnings;
    use 5.8.8;

    our $VERSION  = '1.79';
    our $Cache    = 0;
    our $Global   = 1;

    my $ident_re = qr{[_a-z]\w*}i;
    my $sep_re   = qr{'|::};
    our $PkgRe    = qr{\A(?:$ident_re(?:$sep_re$ident_re)*)\z};

    my @All      = qw(
      locate get_source acts_like_fh
      mod_to_path is_mod_loaded is_pkg_loaded
    );

    sub import {
      my $pkg = caller;
      my @args = @_[ 1 .. $#_ ];

      while(local $_ = shift @args) {
        *{ "$pkg\::$_" } = \&$_ and next
          if defined &$_;

        $Cache = shift @args, next
          if /^cache$/i;

        $Global = shift @args, next
          if /^global$/i;

        if(/^:all$/i) {
          *{ "$pkg\::$_" } = \&$_
            for @All;
          next;
        }

        warn("not in ".__PACKAGE__." import list: '$_'");
      }
    }

    use strict;

    use IO::File;
    use overload ();
    use Carp 'croak';
    use File::Spec::Functions 'catfile';

    sub get_source {
      my $pkg = $_[-1];

      my $f = locate($pkg);

      my $fh = ( acts_like_fh($f) ?
        $f
      :
        do { my $tmp = IO::File->new($f)
               or croak("invalid module '$pkg' [$f] - $!"); $tmp }
      );

      local $/;
      return <$fh>;
    }

    sub locate {
      my $pkg = $_[-1];

      croak("Undefined filename provided")
        unless defined $pkg;

      my $inc_path = mod_to_path($pkg);

      return $INC{$inc_path} if exists($INC{$inc_path}) && !wantarray;

      # On Windows the inc_path will use '/' for directory separator,
      # but when looking for a module, we need to use the OS's separator.
      my $partial_path = _mod_to_partial_path($pkg);

      my @paths;

      for(@INC) {
        if(ref $_) {
          my $ret = coderefs_in_INC($_, $inc_path);

          next
            unless defined $ret;

          croak("invalid \@INC subroutine return $ret")
            unless acts_like_fh($ret);

          return $ret;
        }

        my $fullpath = catfile($_, $partial_path);
        push(@paths, $fullpath) if -f $fullpath;
      }

      return unless @paths > 0;

      return wantarray ? @paths : $paths[0];
    }

    sub mod_to_path {
      my $pkg  = shift;
      my $path = $pkg;

      croak("Invalid package name '$pkg'")
        unless $pkg =~ $Module::Locate::PkgRe;

      # %INC always uses / as a directory separator, even on Windows
      $path =~ s!::!/!g;
      $path .= '.pm' unless $path =~ m!\.pm$!;

      return $path;
    }

    sub coderefs_in_INC {
      my($path, $c) = reverse @_;

      my $ret = ref($c) eq 'CODE' ?
        $c->( $c, $path )
      :
        ref($c) eq 'ARRAY' ?
          $c->[0]->( $c, $path )
        :
          UNIVERSAL::can($c, 'INC') ?
            $c->INC( $path )
          :
            warn("invalid reference in \@INC '$c'")
      ;

      return $ret;
    }

    sub acts_like_fh {
      no strict 'refs';
      return ( ref $_[0] and (
           ( ref $_[0] eq 'GLOB' and defined *{$_[0]}{IO} )
        or ( UNIVERSAL::isa($_[0], 'IO::Handle')          )
        or ( overload::Method($_[0], '<>')                )
      ) or ref \$_[0] eq 'GLOB' and defined *{$_[0]}{IO}  );
    }

    sub is_mod_loaded {
      my $mod  = shift;

      croak("Invalid package name '$mod'")
        unless $mod =~ $Module::Locate::PkgRe;

      ## it looks like %INC entries automagically use / as a separator
      my $path = join '/', split '::' => "$mod.pm";

      return (exists $INC{$path} && defined $INC{$path});
    }

    sub _mod_to_partial_path {
      my $package = shift;

      return catfile(split(/::/, $package)).'.pm';
    }

    sub is_pkg_loaded {
      my $pkg = shift;

      croak("Invalid package name '$pkg'")
        unless $pkg =~ $Module::Locate::PkgRe;

      my @tbls = map "${_}::", split('::' => $pkg);
      my $tbl  = \%main::;

      for(@tbls) {
        return unless exists $tbl->{$_};
        $tbl = $tbl->{$_};
      }

      return !!$pkg;
    }
  }

  q[ That better be make-up, and it better be good ];

  =pod

  =head1 NAME

  Module::Locate - locate modules in the same fashion as C<require> and C<use>

  =head1 SYNOPSIS

    use Module::Locate qw/ locate get_source /;

    add_plugin( locate "This::Module" );
    eval 'use strict; ' . get_source('legacy_code.plx');

  =head1 DESCRIPTION

  Using C<locate()>, return the path that C<require> would find for a given
  module or filename (it can also return a filehandle if a reference in C<@INC>
  has been used). This means you can test for the existence, or find the path
  for, modules without having to evaluate the code they contain.

  This module also comes with accompanying utility functions that are used within
  the module itself (except for C<get_source>) and are available for import.

  =head1 FUNCTIONS

  =over 4

  =item C<import>

  Given function names, the appropriate functions will be exported into the
  caller's package.

  If C<:all> is passed then all subroutines are exported.

  The B<Global> and B<Cache> options are no longer supported.
  See the BUGS section below.


  =item C<locate($module_name)>

  Given a module name as a string (in standard perl bareword format) locate the
  path of the module. If called in a scalar context the first path found will be
  returned, if called in a list context a list of paths where the module was
  found. Also, if references have been placed in C<@INC> then a filehandle will
  be returned, as defined in the C<require> documentation. An empty C<return> is
  used if the module couldn't be located.

  As of version C<1.7> a filename can also be provided to further mimic the lookup
  behaviour of C<require>/C<use>.

  =item C<get_source($module_name)>

  When provided with a package name, gets the path using C<locate()>.
  If C<locate()> returned a path, then the contents of that file are returned
  by C<get_source()> in a scalar.

  =item C<acts_like_fh>

  Given a scalar, check if it behaves like a filehandle. Firstly it checks if it
  is a bareword filehandle, then if it inherits from C<IO::Handle> and lastly if
  it overloads the C<E<lt>E<gt>> operator. If this is missing any other standard
  filehandle behaviour, please send me an e-mail.

  =item C<mod_to_path($module_name)>

  Given a module name,
  converts it to a relative path e.g C<Foo::Bar> would become C<Foo/Bar.pm>.

  Note that this path will always use '/' for the directory separator,
  even on Windows,
  as that's the format used in C<%INC>.

  =item C<is_mod_loaded($module_name)>

  Given a module name, return true if the module has been
  loaded (i.e exists in the C<%INC> hash).

  =item C<is_pkg_loaded($package_name)>

  Given a package name (like C<locate()>), check if the package has an existing
  symbol table loaded (checks by walking the C<%main::> stash).

  =back

  =head1 SEE ALSO

  A review of modules that can be used to get the path (and often other information)
  for one or more modules: L<http://neilb.org/reviews/module-path.html>.

  L<App::Module::Locate> and L<mlocate>.

  =head1 REPOSITORY

  L<https://github.com/neilbowers/Module-Locate>

  =head1 BUGS

  In previous versions of this module, if you specified C<Global =E<gt> 1>
  when use'ing this module,
  then looking up a module's path would update C<%INC>,
  even if the module hadn't actually been loaded (yet).
  This meant that if you subsequently tried to load the module,
  it would wrongly not be loaded.

  Bugs are tracked using RT (bug you can also raise Github issues if you prefer):

  L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Module-Locate>

  =head1 AUTHOR

  Dan Brook C<< <[e-mail]> >>

  =head1 LICENSE

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

  =cut
MODULE_LOCATE

$fatpacked{"Perl/Tags.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERL_TAGS';
  #!/usr/bin/perl

  =head1 NAME

  Perl::Tags - Generate (possibly exuberant) Ctags style tags for Perl sourcecode

  =head1 SYNOPSIS

  =head2 Using Perl::Tags to assist your development

  C<Perl::Tags> is designed to be integrated into your development
  environment.  Here are a few ways to use it:

  =head3 With Vim

  C<Perl::Tags> was originally designed to be used with vim.  See
  L<https://github.com/osfameron/perl-tags-vim> for an easily installable Plugin.

  NB: You will need to have a vim with perl compiled in it.  Debuntu packages
  this as C<vim-perl>. Alternatively you can compile from source (you'll need
  Perl + the development headers C<libperl-dev>).

  (Note that C<perl-tags-vim> includes its own copy of C<Perl::Tags> through
  the magic of git submodules and L<App::FatPacker>, so you don't need to install
  this module from CPAN if you are only intending to use it with Vim as above!)

  =head3 From the Command Line

  See the L<bin/perl-tags> script provided.

  =head3 From other editors

  Any editor that supports ctags should be able to use this output.  Documentation
  and code patches on how to do this are welcome.

  =head2 Using the Perl::Tags module within your code

          use Perl::Tags;
          my $naive_tagger = Perl::Tags::Naive->new( max_level=>2 );
          $naive_tagger->process(
              files => ['Foo.pm', 'bar.pl'],
              refresh=>1
          );

          print $naive_tagger; # stringifies to ctags file

  Recursively follows C<use> and C<require> statements, up to a maximum
  of C<max_level>.

  =head1 DETAILS

  There are several taggers distributed with this distribution, including:

  =over 4

  =item L<Perl::Tags::Naive>

  This is a more-or-less straight ripoff, slightly updated, of the original
  pltags code.  This is a "naive" tagger, in that it makes pragmatic assumptions
  about what Perl code usually looks like (e.g. it doesn't actually parse the
  code.)  This is fast, lightweight, and often Good Enough.

  This has additional subclasses such as L<Perl::Tags::Naive::Moose> to parse
  Moose declarations, and L<Perl::Tags::Naive::Lib> to parse C<use lib>.

  =item L<Perl::Tags::PPI>

  Uses the L<PPI> module to do a deeper analysis and parsing of your Perl code.
  This is more accurate, but slower.

  =item L<Perl::Tags::Hybrid>

  Can run multiple taggers, such as ::Naive and ::PPI, combining the results.

  =back

  =head1 EXTENDING

  Documentation patches are welcome: in the meantime, have a look at
  L<Perl::Tags::Naive> and its subclasses for a simple line-by-line method of
  tagging files.  Alternatively L<Perl::Tags::PPI> uses L<PPI>'s built in
  method of parsing Perl documents.

  In general, you will want to override the C<get_tags_for_file> method,
  returning a list of C<Perl::Tags::Tag> objects to be registered.

  For recursively checking other modules, return a C<Perl::Tags::Tag::Recurse>
  object, which does I<not> create a new tag in the resulting perltags file,
  but instead processes the next file recursively.

  =head1 FEATURES

      * Recursive, incremental tagging.
      * parses `use_ok`/`require_ok` line from Test::More

  =head1 METHODS

  =cut

  package Perl::Tags;

  use strict; use warnings;

  use Perl::Tags::Tag;
  use Data::Dumper;
  use File::Spec;

  use overload q("") => \&to_string;
  our $VERSION = 0.28;

  =head2 C<new>

  L<Perl::Tags> is an abstract baseclass.  Use a class such as
  L<Perl::Tags::Naive> and instantiate it with C<new>.

      $naive_tagger = Perl::Tags::Naive->new( max_level=>2 );

  Accepts the following parameters

      max_level:    levels of "use" statements to descend into, default 2
      do_variables: tag variables?  default 1 (true)
      exts:         use the Exuberant extensions

  =cut

  sub new {
      my $class = shift;
      my %options = (
          max_level    => 2, # go into next file, but not down the whole tree
          do_variables => 1,
          @_);

      my $self = \%options;

      return bless $self, $class;
  }

  =head2 C<to_string>

  A L<Perl::Tags> object will stringify to a textual representation of a ctags
  file.

      print $tagger;

  =cut

  sub to_string {
      my $self = shift;
      my $tags = $self->{tags} or return '';
      my %tags = %$tags;

      my $s; # to test

      my @lines;

      # the structure is an HoHoA of
      #
      #   {tag_name}
      #       {file_name}
      #           [ tags ]
      #
      #   where the file_name level is to allow us to prioritize tags from
      #   first-included files (on the basis that they may well be the files we
      #   want to see first.

      my $ord = $self->{order};
      my @names = sort keys %$tags;
      for (@names) {
          my $files = $tags{$_};
          push @lines, map { @{$files->{$_}} }
              sort { $ord->{$a} <=> $ord->{$b} } keys %$files;
      }
      return join "\n", @lines;
  }

  =head2 C<clean_file>

  Delete all tags, but without touching the "order" seen, that way, if the tags
  are recreated, they will remain near the top of the "interestingness" tree

  =cut

  sub clean_file {
      my ($self, $file) = @_;

      my $tags = $self->{tags} or die "Trying to clean '$file', but there's no tags";

      for my $name (keys %$tags) {
          delete $tags->{$name}{$file};
      }
      delete $self->{seen}{$file};
      # we don't delete the {order} though
  }

  =head2 C<output>

  Save the file to disk if it has changed.  (The private C<{is_dirty}> attribute
  is used, as the tags object may be made up incrementally and recursively within
  your IDE.

  =cut

  sub output {
      my $self = shift;
      my %options = @_;
      my $outfile = $options{outfile} or die "No file to write to";

      return unless $self->{is_dirty} || ! -e $outfile;

      open (my $OUT, '>', $outfile) or die "Couldn't open $outfile for write: $!";
  	binmode STDOUT, ":encoding(UTF-8)";
      print $OUT $self;
      close $OUT or die "Couldn't close $outfile for write: $!";

      $self->{is_dirty} = 0;
  }

  =head2 C<process>

  Scan one or more Perl file for tags

      $tagger->process(
          files => [ 'Module.pm',  'script.pl' ]
      );
      $tagger->process(
          files   => 'script.pl',
          refresh => 1,
      );

  =cut

  sub process {
      my $self = shift;
      my %options = @_;
      my $files = $options{files} || die "No file passed to process";
      my @files = ref $files ? @$files : ($files);

      $self->queue( map {
                            { file=>$_, level=>1, refresh=>$options{refresh} }
                        } @files);

      while (my $file = $self->popqueue) {
          $self->process_item( %options, %$file );
      }
      return 1;
  }

  =head2 C<queue>, C<popqueue>

  Internal methods managing the processing

  =cut

  sub queue {
      my $self = shift;
      for (@_) {
          push @{$self->{queue}}, $_ unless $_->{level} > $self->{max_level};
      }
  }

  sub popqueue {
      my $self = shift;
      return pop @{$self->{queue}};
  }

  =head2 C<process_item>, C<process_file>, C<get_tags_for_file>

  Do the heavy lifting for C<process> above.

  Taggers I<must> override the abstract method C<get_tags_for_file>.

  =cut

  sub process_item {
      my $self = shift;
      my %options = @_;
      my $file  = $options{file} || die "No file passed to proces";

      # make filename absolute, (this could become an option if appropriately
      # refactored) but because of my usage (tags_$PID file in /tmp) I need the
      # absolute path anyway, and it prevents the file being included twice under
      # slightly different names (unless you have 2 hardlinked copies, as I do
      # for my .vim/ directory... bah)

      $file = File::Spec->rel2abs( $file ) ;

      if ($self->{seen}{$file}++) {
          return unless $options{refresh};
          $self->clean_file( $file );
      }

      $self->{is_dirty}++; # we haven't yet been written out

      $self->{order}{$file} = $self->{curr_order}++ || 0;

      $self->{current} = {
          file          => $file,
          package_name  => '',
          has_subs      => 0,
          var_continues => 0,
          level         => $options{level},
      };

      $self->process_file( $file );

      return $self->{tags};
  }

  sub process_file {
      my ($self, $file) = @_;

      my @tags = $self->get_tags_for_file( $file );

      $self->register( $file, @tags );
  }

  sub get_tags_for_file {
      use Carp 'confess';
      confess "Abstract method get_tags_for_file called";
  }

  =head2 C<register>

  The parsing is done by a number of lightweight objects (parsers) which look for
  subroutine references, variables, module inclusion etc.  When they are
  successful, they call the C<register> method in the main tags object.

  Note that if your tagger wants to register not a new I<declaration> but rather
  a I<usage> of another module, then your tagger should return a
  C<Perl::Tags::Tag::Recurse> object.  This is a pseudo-tag which causes the linked
  module to be scanned in turn.  See L<Perl::Tags::Naive>'s handling of C<use>
  statements as an example!

  =cut

  sub register {
      my ($self, $file, @tags) = @_;
      for my $tag (@tags) {
          $tag->on_register( $self ) or next;
          $tag->{pkg} ||=  $self->{current}{package_name};
          $tag->{exts} ||= $self->{exts};

          # and copy absolute file if requested
          # $tag->{file} = $file if $self->{absolute};

          my $name = $tag->{name};
          push @{ $self->{tags}{$name}{$file} }, $tag;
      }
  }

  ##
  1;

  =head1 SEE ALSO

  L<bin/perl-tags>

  =head1 CONTRIBUTIONS

  Contributions are always welcome.  The repo is in git:

      http://github.com/osfameron/perl-tags

  Please fork and make pull request.  Maint bits available on request.

  =over 4

  =item wolverian

  ::PPI subclass

  =item Ian Tegebo

  patch to use File::Temp

  =item DMITRI

  patch to parse constant and label declarations

  =item drbean

  ::Naive::Moose, ::Naive::Spiffy and ::Naive::Lib subclasses

  =item Alias

  prodding me to make repo public

  =item nothingmuch

  ::PPI fixes

  =item tsee

  Command line interface, applying patches

  =back

  =head1 AUTHOR and LICENSE

      osfameron (2006-2009) - [e-mail]
                              and contributors, as above

  For support, try emailing me or grabbing me on irc #london.pm on irc.perl.org

  This was originally ripped off pltags.pl, as distributed with vim
  and available from L<http://www.mscha.com/mscha.html?pltags#tools>
  Version 2.3, 28 February 2002
  Written by Michael Schaap <[e-mail]>.

  This is licensed under the same terms as Perl itself.  (Or as Vim if you prefer).

  =cut
PERL_TAGS

$fatpacked{"Perl/Tags/Hybrid.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERL_TAGS_HYBRID';
  package Perl::Tags::Hybrid;

  use strict; use warnings;
  use parent 'Perl::Tags';

  =head1 C<Perl::Tags::Hybrid>

  Combine the results of multiple parsers, for example C<Perl::Tags::Naive>
  and C<Perl::Tags::PPI>.

  =head1 SYNOPSIS

      my $parser = Perl::Tags::Hybrid->new(
          taggers => [
              Perl::Tags::Naive->new,
              Perl::Tags::PPI->new,
          ],
      );

  =head2 C<get_tags_for_file>

  Registers the results from running each sub-taggers

  =cut

  sub get_taggers {
      my $self = shift;
      return @{ $self->{taggers} || [] };
  }

  sub get_tags_for_file {
      my ($self, $file) = @_;

      my @taggers = $self->get_taggers;

      return map { $_->get_tags_for_file( $file ) } @taggers;
  }

  1;
PERL_TAGS_HYBRID

$fatpacked{"Perl/Tags/Naive.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERL_TAGS_NAIVE';
  package Perl::Tags::Naive;

  use strict; use warnings;
  use parent 'Perl::Tags';

  =head1 C<Perl::Tags::Naive>

  A naive implementation.  That is to say, it's based on the classic C<pltags.pl>
  script distributed with Perl, which is by and large a better bet than the
  results produced by C<ctags>.  But a "better" approach may be to integrate this
  with PPI.

  =head2 Subclassing

  See L<TodoTagger> in the C<t/> directory of the distribution for a fully
  working example (tested in <t/02_subclass.t>).  You may want to reuse parsers
  in the ::Naive package, or use all of the existing parsers and add your own.

      package My::Tagger;
      use Perl::Tags;
      use parent 'Perl::Tags::Naive';

      sub get_parsers {
          my $self = shift;
          return (
              $self->can('todo_line'),     # a new parser
              $self->SUPER::get_parsers(), # all ::Naive's parsers
              # or maybe...
              $self->can('variable'),      # one of ::Naive's parsers
          );
      }

      sub todo_line {
          # your new parser code here!
      }
      sub package_line {
          # override one of ::Naive's parsers
      }

  Because ::Naive uses C<can('parser')> instead of C<\&parser>, you
  can just override a particular parser by redefining in the subclass.

  =head2 C<get_tags_for_file>

  ::Naive uses a simple line-by-line analysis of Perl code, comparing
  each line against an array of parsers returned by the L<get_parsers> method.

  The first of these parsers that matches (if any) will return the
  tag/control to be registred by the tagger.

  =cut

  {
      # Tags that start POD:
      my @start_tags = qw(pod head1 head2 head3 head4 over item back begin
                          end for encoding);
      my @end_tags = qw(cut);

      my $startpod = '^=(?:' . join('|', @start_tags) . ')\b';
      my $endpod = '^=(?:' . join('|', @end_tags) . ')\b';

      sub STARTPOD { qr/$startpod/ }
      sub ENDPOD { qr/$endpod/ }
  }

  sub get_tags_for_file {
      my ($self, $file) = @_;

      my @parsers = $self->get_parsers(); # function refs

      open (my $IN, '<', $file) or die "Couldn't open file `$file`: $!\n";

      my $start = STARTPOD();
      my $end = ENDPOD();

      my @all_tags;

      while (<$IN>) {
          next if (/$start/o .. /$end/o);     # Skip over POD.
          chomp;
          my $statement = my $line = $_;
          PARSELOOP: for my $parser (@parsers) {
              my @tags = $parser->(
                  $self,
                $line,
                $statement,
                $file
              );
              push @all_tags, @tags;
          }
      }
      return @all_tags;
  }

  =head2 C<get_parsers>

  The following parsers are defined by this module.

  =over 4

  =cut

  sub get_parsers {
      my $self = shift;
      return (
          $self->can('trim'),
          $self->can('variable'),
          $self->can('package_line'),
          $self->can('sub_line'),
          $self->can('use_constant'),
          $self->can('use_line'),
          $self->can('label_line'),
      );
  }

  =item C<trim>

  A filter rather than a parser, removes whitespace and comments.

  =cut

  sub trim {
      shift;
      # naughtily work on arg inplace
      $_[1] =~ s/#.*//;  # remove comment.  Naively
      $_[1] =~ s/^\s*//; # Trim spaces
      $_[1] =~ s/\s*$//;

      return;
  }

  =item C<variable>

  Tags definitions of C<my>, C<our>, and C<local> variables.

  Returns a L<Perl::Tags::Tag::Var> if found

  =cut

  sub variable {
      # don't handle continuing thingy for now
      my ($self, $line, $statement, $file) = @_;

      return unless $self->{do_variables};
          # I'm not sure I see this as all that useful

      if ($self->{var_continues} || $statement =~/^(my|our|local)\b/) {

          $self->{current}{var_continues} = ! ($statement=~/;$/);
          $statement =~s/=.*$//;
              # remove RHS with extreme prejudice
              # and also not accounting for things like
              # my $x=my $y=my $z;

          my @vars = $statement=~/[\$@%]((?:\w|:)+)\b/g;

          # use Data::Dumper;
          # print Dumper({ vars => \@vars, statement => $statement });

          return map {
              Perl::Tags::Tag::Var->new(
                  name => $_,
                  file => $file,
                  line => $line,
                  linenum => $.,
              );
          } @vars;
      }
      return;
  }

  =item C<package_line>

  Parse a package declaration, returning a L<Perl::Tags::Tag::Package> if found.

  =cut

  sub package_line {
      my ($self, $line, $statement, $file) = @_;

      if ($statement=~/^package\s+((?:\w|:)+)\b/) {
          return (
              Perl::Tags::Tag::Package->new(
                  name => $1,
                  file => $file,
                  line => $line,
                  linenum => $.,
              )
          );
      }
      return;
  }

  =item C<sub_line>

  Parse the declaration of a subroutine, returning a L<Perl::Tags::Tag::Sub> if found.

  =cut

  sub sub_line {
      my ($self, $line, $statement, $file) = @_;
      if ($statement=~/sub\s+(\w+)\b/) {
          return (
              Perl::Tags::Tag::Sub->new(
                  name => $1,
                  file => $file,
                  line => $line,
                  linenum => $.,
              )
          );
      }

      return;
  }

  =item C<use_constant>

  Parse a use constant directive

  =cut

  sub use_constant {
      my ($self, $line, $statement, $file) = @_;
      if ($statement =~/^\s*use\s+constant\s+([^=[:space:]]+)/) {
          return (
              Perl::Tags::Tag::Constant->new(
                  name    => $1,
                  file    => $file,
                  line    => $line,
                  linenum => $.,
              )
          );
      }
      return;
  }

  =item C<use_line>

  Parse a use, require, and also a use_ok line (from Test::More).
  Uses a dummy tag (L<Perl::Tags::Tag::Recurse> to do so).

  =cut

  sub use_line {
      my ($self, $line, $statement, $file) = @_;

      my @ret;
      if ($statement=~/^(?:use|require)(_ok\(?)?\s+(.*)/) {
          my @packages = split /\s+/, $2; # may be more than one if base
          @packages = ($packages[0]) if $1; # if use_ok ecc. from Test::More

          for (@packages) {
              s/^q[wq]?[[:punct:]]//;
              /((?:\w|:)+)/;
              $1 and push @ret, Perl::Tags::Tag::Recurse->new(
                  name => $1,
                  line=>'dummy' );
          }
      }
      return @ret;
  }

  =item C<label_line>

  Parse label declaration

  =cut

  sub label_line {
      my ($self, $line, $statement, $file) = @_;
      if ($statement=~/^\s*([a-zA-Z_][a-zA-Z0-9_]*)\s*:(?:[^:]|$)/) {
          return (
              Perl::Tags::Tag::Label->new(
                  name    => $1,
                  file    => $file,
                  line    => $line,
                  linenum => $.,
              )
          );
      }
      return;
  }

  =back

  =cut

  1;
PERL_TAGS_NAIVE

$fatpacked{"Perl/Tags/Naive/Lib.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERL_TAGS_NAIVE_LIB';
  package Perl::Tags::Naive::Lib;

  use strict; use warnings;
  use parent 'Perl::Tags::Naive';

  =head2 C<get_parsers>

  The following parsers are defined by this module.

  =over 4

  =cut

  sub get_parsers
  {
          my $self = shift;
          return (
                  $self->SUPER::get_parsers(),
                  $self->can('uselib_line'),
          );
  }


  =item C<uselib_line>

  Parse a use/require lib line
  Unshift libraries found onto @INC.

  =cut

  sub uselib_line {
      my ($self, $line, $statement, $file) = @_;

      my @ret;
      if ($statement=~/^(?:use|require)\s+lib\s+(.*)/) {
          my @libraries = split /\s+/, $1; # may be more than one

          for (@libraries) {
              s/^q[wq]?[[:punct:]]//;
              /((?:\w|:)+)/;
              $1 and unshift @INC, $1;
          }
      }
      return @ret;
  }

  1;

  =back

  #package Perl::Tags::Tag::Recurse::Lib;
  #
  #our @ISA = qw/Perl::Tags::Tag::Recurse/;
  #
  #=head1 C<Perl::Tags::Tag::Recurse::Lib>
  #
  #=head2 C<type>: dummy
  #
  #=head2 C<on_register>
  #
  #Recurse adding this new module accessible from a use lib statement to the queue.
  #
  #=cut
  #
  #package Perl::Tags::Tag::Recurse;
  #
  #sub on_register {
  #    my ($self, $tags) = @_;
  #
  #    my $name = $self->{name};
  #    my $path;
  #    my @INC_ORIG = @INC;
  #    my @INC =
  #    eval {
  #        $path = locate( $name ); # or warn "Couldn't find path for $module";
  #    };
  #    # return if $@;
  #    return unless $path;
  #    $tags->queue( { file=>$path, level=>$tags->{current}{level}+1 , refresh=>0} +);
  #    return; # don't get added
  #}

  ##

  1;

  =head1 AUTHOR and LICENSE

      dr bean - drbean at sign cpan a dot org
      osfameron (2006) - [e-mail]

  For support, try emailing me or grabbing me on irc #london.pm on irc.perl.org

  This was originally ripped off pltags.pl, as distributed with vim
  and available from L<http://www.mscha.com/mscha.html?pltags#tools>
  Version 2.3, 28 February 2002
  Written by Michael Schaap <[e-mail]>.

  This is licensed under the same terms as Perl itself.  (Or as Vim if you +prefer).

  =cut
PERL_TAGS_NAIVE_LIB

$fatpacked{"Perl/Tags/Naive/Moose.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERL_TAGS_NAIVE_MOOSE';
  use strict; use warnings;
  package Perl::Tags::Naive::Moose;

  use parent 'Perl::Tags::Naive';

  =head2 C<get_parsers>

  The following parsers are defined by this module.

  =over 4

  =cut

  sub get_parsers
  {
  	my $self = shift;
  	return (
  		$self->SUPER::get_parsers(),
  		$self->can('extends_line'),
  		$self->can('with_line'),
  		$self->can('has_line'),
  		$self->can('around_line'),
  		$self->can('before_line'),
  		$self->can('after_line'),
  		$self->can('override_line'),
  		$self->can('augment_line'),
  		$self->can('class_line'),
  		$self->can('method_line'),
  		$self->can('role_line'),
  	);
  }

  =item C<extends_line>

  Parse the declaration of a 'extends' Moose keyword, returning a L<Perl::Tags::Tag::Extends> if found.

  =cut

  sub extends_line {
      my ($self, $line, $statement, $file) = @_;
      if ($statement=~/extends\s+["']?((?:\w+|::)+)\b/) {
  	return Perl::Tags::Tag::Recurse->new(
  	    name    => $1,
  	    line    => 'dummy',
  	);
      }
      return;
  }

  =item C<with_line>

  Parse the declaration of a 'with' Moose keyword, returning a L<Perl::Tags::Tag::With> tag if found.

  =cut

  sub with_line {
      my ( $self, $line, $statement, $file ) = @_;
      if ( $statement =~ m/\bwith\s+(?:qw.)?\W*([a-zA-Z0-9_: ]+)/ ) {
          my @roles = split /\s+/, $1;
          my @returns;
          foreach my $role (@roles) {
              push @returns, Perl::Tags::Tag::Recurse->new(
  		name    => $role,
  		line    => 'dummy',
              );
          }
          return @returns;
      }
      return;
  }

  =item C<has_line>

  Parse the declaration of a 'has' Moose keyword, returning a L<Perl::Tags::Tag::Has> if found.

  =cut

  sub has_line {
      my ($self, $line, $statement, $file) = @_;
      if ($statement=~/\bhas\s+["']?(\w+)\b/) {
          return (
              Perl::Tags::Tag::Has->new(
                  name => $1,
                  file => $file,
                  line => $line,
                  linenum => $.,
              )
          );
      }
      return;
  }

  =item C<around_line>

  Parse the declaration of a 'around' Moose keyword, returning a L<Perl::Tags::Tag::Around> tag if found.

  =cut

  sub around_line {
      my ($self, $line, $statement, $file) = @_;
      if ($statement=~/around\s+["'](\w+)\b/) {
          return (
              Perl::Tags::Tag::Around->new(
                  name => $1,
                  file => $file,
                  line => $line,
                  linenum => $.,
              )
          );
      }
      return;
  }

  =item C<before_line>

  Parse the declaration of a 'before' Moose keyword, returning a L<Perl::Tags::Tag::Before> tag if found.

  =cut

  sub before_line {
      my ($self, $line, $statement, $file) = @_;
      if ($statement=~/before\s+["'](\w+)\b/) {
          return (
              Perl::Tags::Tag::Before->new(
                  name => $1,
                  file => $file,
                  line => $line,
                  linenum => $.,
              )
          );
      }
      return;
  }

  =item C<after_line>

  Parse the declaration of a 'after' Moose keyword, returning a L<Perl::Tags::Tag::After> tag if found.

  =cut

  sub after_line {
      my ($self, $line, $statement, $file) = @_;
      if ($statement=~/after\s+["'](\w+)\b/) {
          return (
              Perl::Tags::Tag::After->new(
                  name => $1,
                  file => $file,
                  line => $line,
                  linenum => $.,
              )
          );
      }
      return;
  }

  =item C<override_line>

  Parse the declaration of a 'override' Moose keyword, returning a L<Perl::Tags::Tag::Override> tag if found.

  =cut

  sub override_line {
      my ($self, $line, $statement, $file) = @_;
      if ($statement=~/override\s+["'](\w+)\b/) {
          return (
              Perl::Tags::Tag::Override->new(
                  name => $1,
                  file => $file,
                  line => $line,
                  linenum => $.,
              )
          );
      }
      return;
  }

  =item C<augment_line>

  Parse the declaration of a 'augment' Moose keyword, returning a L<Perl::Tags::Tag::Augment> tag if found.

  =cut

  sub augment_line {
      my ($self, $line, $statement, $file) = @_;
      if ($statement=~/augment\s+["']?(\w+)\b/) {
          return (
              Perl::Tags::Tag::Augment->new(
                  name => $1,
                  file => $file,
                  line => $line,
                  linenum => $.,
              )
          );
      }
      return;
  }

  =item C<class_line>

  Parse the declaration of a 'class' Moose keyword, returning a L<Perl::Tags::Tag::Class> tag if found.

  =cut

  sub class_line {
      my ($self, $line, $statement, $file) = @_;
      if ($statement=~/class\s+(\w+)\b/) {
          return (
              Perl::Tags::Tag::Class->new(
                  name => $1,
                  file => $file,
                  line => $line,
                  linenum => $.,
              )
          );
      }
      return;
  }

  =item C<method_line>

  Parse the declaration of a 'method' Moose keyword, returning a L<Perl::Tags::Tag::Method> tag if found.

  =cut

  sub method_line {
      my ($self, $line, $statement, $file) = @_;
      if ($statement=~/method\s+(\w+)\b/) {
          return (
              Perl::Tags::Tag::Method->new(
                  name => $1,
                  file => $file,
                  line => $line,
                  linenum => $.,
              )
          );
      }
      return;
  }

  =item C<role_line>

  Parse the declaration of a 'role' Moose keyword, returning a L<Perl::Tags::Tag::Role> tag if found.

  =cut

  sub role_line {
      my ($self, $line, $statement, $file) = @_;
      if ($statement=~/role\s+(\w+)\b/) {
          return (
              Perl::Tags::Tag::Role->new(
                  name => $1,
                  file => $file,
                  line => $line,
                  linenum => $.,
              )
          );
      }
      return;
  }

  =head1 C<Perl::Tags::Tag::Method>

  =head2 C<type>: Method

  =cut

  package Perl::Tags::Tag::Method;
  our @ISA = qw/Perl::Tags::Tag::Sub/;

  sub type { 'Method' }


  =head1 C<Perl::Tags::Tag::Has>

  =head2 C<type>: Has

  =cut

  package Perl::Tags::Tag::Has;
  our @ISA = qw/Perl::Tags::Tag::Method/;

  sub type { 'Has' }

  =head1 C<Perl::Tags::Tag::Around>

  =head2 C<type>: Around

  =cut

  package Perl::Tags::Tag::Around;
  our @ISA = qw/Perl::Tags::Tag::Method/;

  sub type { 'Around' }

  =head1 C<Perl::Tags::Tag::Before>

  =head2 C<type>: Before

  =cut

  package Perl::Tags::Tag::Before;
  our @ISA = qw/Perl::Tags::Tag::Method/;

  sub type { 'Before' }

  =head1 C<Perl::Tags::Tag::After>

  =head2 C<type>: After

  =cut

  package Perl::Tags::Tag::After;
  our @ISA = qw/Perl::Tags::Tag::Method/;

  sub type { 'After' }

  =head1 C<Perl::Tags::Tag::Override>

  =head2 C<type>: Override

  =cut

  package Perl::Tags::Tag::Override;
  our @ISA = qw/Perl::Tags::Tag::Method/;

  sub type { 'Override' }

  =head1 C<Perl::Tags::Tag::Augment>

  =head2 C<type>: Augment

  =cut

  package Perl::Tags::Tag::Augment;
  our @ISA = qw/Perl::Tags::Tag::Method/;

  sub type { 'Augment' }

  =head1 C<Perl::Tags::Tag::Class>

  =head2 C<type>: Class

  =cut

  package Perl::Tags::Tag::Class;
  our @ISA = qw/Perl::Tags::Tag::Package/;

  sub type { 'Class' }

  =head1 C<Perl::Tags::Tag::Role>

  =head2 C<type>: Role

  =cut

  package Perl::Tags::Tag::Role;
  our @ISA = qw/Perl::Tags::Tag::Package/;

  sub type { 'Role' }

  1;

  =head1 AUTHOR and LICENSE

      dr bean - drbean at sign cpan a dot org

  This is licensed under the same terms as Perl itself.  (Or as Vim if you +prefer).

  =cut

  # vim: set ts=8 sts=4 sw=4 noet:
PERL_TAGS_NAIVE_MOOSE

$fatpacked{"Perl/Tags/Naive/Spiffy.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERL_TAGS_NAIVE_SPIFFY';
  package Perl::Tags::Naive::Spiffy;

  use strict; use warnings;
  use parent 'Perl::Tags::Naive';

  =head2 C<get_parsers>

  The following parsers are defined by this module.

  =over 4

  =cut

  sub get_parsers
  {
  	my $self = shift;
  	return (
  		$self->SUPER::get_parsers(),
  		$self->can('field_line'),
  		$self->can('stub_line'),
  	);
  }

  =item C<field_line>

  Parse the declaration of a Spiffy class accessor method, returning a L<Perl::Tags::Tag::Field> if found.

  =cut

  sub field_line {
      my ($self, $line, $statement, $file) = @_;
      if ($statement=~/field\s+["']?(\w+)\b/) {
          return (
              Perl::Tags::Tag::Field->new(
                  name => $1,
                  file => $file,
                  line => $line,
                  linenum => $.,
              )
          );
      }
      return;
  }

  =item C<stub_line>

  Parse the declaration of a Spiffy stub method, returning a L<Perl::Tags::Tag::Stub> if found.

  =cut

  sub stub_line {
      my ($self, $line, $statement, $file) = @_;
      if ($statement=~/stub\s+["']?(\w+)\b/) {
          return (
              Perl::Tags::Tag::Stub->new(
                  name => $1,
                  file => $file,
                  line => $line,
                  linenum => $.,
              )
          );
      }
      return;
  }

  =back

  =head1 C<Perl::Tags::Tag::Field>

  =head2 C<type>: Field

  =cut

  package Perl::Tags::Tag::Field;
  our @ISA = qw/Perl::Tags::Tag/;

  sub type { 'Field' }

  =head1 C<Perl::Tags::Tag::Stub>

  =head2 C<type>: Stub

  =cut

  package Perl::Tags::Tag::Stub;
  our @ISA = qw/Perl::Tags::Tag/;

  sub type { 'Stub' }

  1;

  =head1 AUTHOR and LICENSE

      dr bean - drbean at sign cpan a dot org
      osfameron (2006) - [e-mail]

  For support, try emailing me or grabbing me on irc #london.pm on irc.perl.org

  This was originally ripped off pltags.pl, as distributed with vim
  and available from L<http://www.mscha.com/mscha.html?pltags#tools>
  Version 2.3, 28 February 2002
  Written by Michael Schaap <[e-mail]>.

  This is licensed under the same terms as Perl itself.  (Or as Vim if you +prefer).

  =cut
PERL_TAGS_NAIVE_SPIFFY

$fatpacked{"Perl/Tags/PPI.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERL_TAGS_PPI';
  package Perl::Tags::PPI;

  use strict; use warnings;

  use base qw(Perl::Tags);

  use PPI;

  sub ppi_all {
      my ( $self, $file ) = @_;

      my $doc = PPI::Document->new($file) || return;

      $doc->index_locations;

      return map { $self->_tagify( $_, "$file" ) }
        @{ $doc->find(sub { $_[1]->isa("PPI::Statement") }) || [] }
  }

  sub get_tags_for_file {
      my ( $self, $file, @parsers ) = @_;

      my @tags = $self->ppi_all( $file );

      return @tags;
  }

  sub _tagify {
      my ( $self, $thing, $file ) = @_;

      my $class = $thing->class;

      my ( $first_line ) = split /\n/, $thing;

      if ( my ( $subtype ) = ( $class =~ /^PPI::Statement::(.*)$/ ) ) {

          my $method = "_tagify_" . lc($subtype);

          if ( $self->can($method) ) {
              return $self->$method( $thing, $file, $first_line );
          }
      }

      return $self->_tagify_statement($thing, $file, $first_line);
  }

  # catch all
  sub _tagify_statement {
      my ( $self, $thing, $file, $first_line ) = @_;

      return;
  }

  sub _tagify_sub {
      my ( $self, $thing, $file, $line ) = @_;

      return Perl::Tags::Tag::Sub->new(
          name    => $thing->name,
          file    => $file,
          line    => $line,
          linenum => $thing->location->[0],
          pkg     => $thing->guess_package
      );
  }

  sub _tagify_variable {
      my ( $self, $thing, $file, $line ) = @_;
      return map {
          Perl::Tags::Tag::Var->new(
              name    => $_,
              file    => $file,
              line    => $line,
              linenum => $thing->location->[0],
            )
      } $thing->variables;
  }

  sub _tagify_package {
      my ( $self, $thing, $file, $line ) = @_;

      return Perl::Tags::Tag::Package->new(
          name    => $thing->namespace,
          file    => $file,
          line    => $line,
          linenum => $thing->location->[0],
      );
  }

  sub _tagify_include {
      my ( $self, $thing, $file ) = @_;

      if ( my $module = $thing->module ) {
          return Perl::Tags::Tag::Recurse->new(
              name    => $module,
              line    => "dummy",
          );
      }

      return;
  }

  sub PPI::Statement::Sub::guess_package {
      my ($self) = @_;

      my $temp = $self;
      my $package;

      while (1) {
          $temp = $temp->sprevious_sibling
            or last;

          if ( $temp->class eq 'PPI::Statement::Package' ) {
              $package = $temp;
              last;
          }
      }

      return $package;
  }

  =head1 NAME

  Perl::Tags::PPI - use PPI to parse

  =head1 DESCRIPTION

  This is a drop-in replacement for the basic L<Perl::Tags> parser.  Please see that module's
  perldoc, and test C<t/04_ppi.t> for details.

  (Doc patches very welcome!)

  =head1 AUTHOR

   (c) Wolverian 2006

  Modifications by nothingmuch

  =cut

  1;
PERL_TAGS_PPI

$fatpacked{"Perl/Tags/Tag.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERL_TAGS_TAG';
  package Perl::Tags::Tag;
  use strict; use warnings;

  use overload q("") => \&to_string;

  =head2 C<new>

  Returns a new tag object

  =cut

  sub new {
      my $class = shift;
      my %options = @_;

      $options{type} = $class->type;

      # chomp and escape line
      chomp (my $line = $options{line});

      $line =~ s{\\}{\\\\}g;
      $line =~ s{/}{\\/}g;
      # $line =~ s{\$}{\\\$}g;

      my $self = bless {
          name   => $options{name},
          file   => $options{file},
          type   => $options{type},
          is_static => $options{is_static},
          line   => $line,
          linenum => $options{linenum},
          exts   => $options{exts}, # exuberant?
          pkg    => $options{pkg},  # package name
      }, $class;

      $self->modify_options();
      return $self;
  }

  =head2 C<type>, C<modify_options>

  Abstract methods

  =cut

  sub type {
      die "Tried to call 'type' on virtual superclass";
  }

  sub modify_options { return } # no change

  =head2 C<to_string>

  A tag stringifies to an appropriate line in a ctags file.

  =cut

  sub to_string {
      my $self = shift;

      my $name = $self->{name} or die;
      my $file = $self->{file} or die;
      my $line = $self->{line} or die;
      my $linenum = $self->{linenum};
      my $pkg  = $self->{pkg} || '';

      my $tagline = "$name\t$file\t/$line/";

      # Exuberant extensions
      if ($self->{exts}) {
          $tagline .= qq(;"\t$self->{type});
          $tagline .= "\tline:$linenum";
          $tagline .= ($self->{is_static} ? "\tfile:" : '');
          $tagline .= ($self->{pkg} ? "\tclass:$self->{pkg}" : '');
      }
      return $tagline;
  }

  =head2 C<on_register>

  Allows tag to meddle with process when registered with the main tagger object.
  Return false if want to prevent registration (e.g. for control tags such as
  C<Perl::Tags::Tag::Recurse>.)

  =cut

  sub on_register {
      # my $self = shift;
      # my $tags = shift;
      # .... do stuff in subclasses

      return 1;  # or undef to prevent registration
  }

  =head1 C<Perl::Tags::Tag::Package>

  =head2 C<type>: p

  =head2 C<modify_options>

  Sets static=0

  =head2 C<on_register>

  Sets the package name

  =cut

  package Perl::Tags::Tag::Package;
  our @ISA = qw/Perl::Tags::Tag/;

      # QUOTE:
          # Make a tag for this package unless we're told not to.  A
          # package is never static.

  sub type { 'p' }

  sub modify_options {
      my $self = shift;
      $self->{is_static} = 0;
  }

  sub on_register {
      my ($self, $tags) = @_;
      $tags->{current}{package_name} = $self->{name};
  }

  =head1 C<Perl::Tags::Tag::Var>

  =head2 C<type>: v

  =head2 C<on_register>

          Make a tag for this variable unless we're told not to.  We
          assume that a variable is always static, unless it appears
          in a package before any sub.  (Not necessarily true, but
          it's ok for most purposes and Vim works fine even if it is
          incorrect)
              - pltags.pl comments

  =cut

  package Perl::Tags::Tag::Var;
  our @ISA = qw/Perl::Tags::Tag/;

  sub type { 'v' }

      # QUOTE:

  sub on_register {
      my ($self, $tags) = @_;
      $self->{is_static} = ( $tags->{current}{package_name} || $tags->{current}{has_subs} ) ? 1 : 0;

      return 1;
  }
  =head1 C<Perl::Tags::Tag::Sub>

  =head2 C<type>: s

  =head2 C<on_register>

          Make a tag for this sub unless we're told not to.  We assume
          that a sub is static, unless it appears in a package.  (Not
          necessarily true, but it's ok for most purposes and Vim works
          fine even if it is incorrect)
              - pltags comments

  =cut

  package Perl::Tags::Tag::Sub;
  our @ISA = qw/Perl::Tags::Tag/;

  sub type { 's' }

  sub on_register {
      my ($self, $tags) = @_;
      $tags->{current}{has_subs}++ ;
      $self->{is_static}++ unless $tags->{current}{package_name};

      return 1;
  }

  =head1 C<Perl::Tags::Tag::Constant>

  =head2 C<type>: c

  =cut

  package Perl::Tags::Tag::Constant;
  our @ISA = qw/Perl::Tags::Tag/;

  sub type { 'c' }

  =head1 C<Perl::Tags::Tag::Label>

  =head2 C<type>: l

  =cut

  package Perl::Tags::Tag::Label;
  our @ISA = qw/Perl::Tags::Tag/;

  sub type { 'l' }

  =head1 C<Perl::Tags::Tag::Recurse>

  =head2 C<type>: dummy

  This is a pseudo-tag, see L<Perl::Tags/register>.

  =head2 C<on_register>

  Recurse adding this new module to the queue.

  =cut

  package Perl::Tags::Tag::Recurse;
  our @ISA = qw/Perl::Tags::Tag/;

  use Module::Locate qw/locate/;

  sub type { 'dummy' }

  sub on_register {
      my ($self, $tags) = @_;

      my $name = $self->{name};
      my $path;
      eval {
          $path = locate( $name ); # or warn "Couldn't find path for $name";
      };
      # return if $@;
      return unless $path;
      $tags->queue( { file=>$path, level=>$tags->{current}{level}+1 , refresh=>0} );
      return; # don't get added
  }

  1;
PERL_TAGS_TAG

$fatpacked{"Test/Perl/Tags.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TEST_PERL_TAGS';
  package Test::Perl::Tags;

  use strict; use warnings;
  use parent 'Test::Builder::Module';

  use Path::Tiny 'path';

  our @EXPORT = qw(tag_ok);

  =head1 NAME

  Test::Perl::Tags - testing output of L<Perl::Tags>

  =head1 SYNOPSIS

      use Test::Perl::Tags;

      # do some tagging

      tag_ok $tagger,
          SYMBOL => 'path/to/file.pm' => 'searchable bookmark',
          'Description of this test';

      tag_ok $tagger,
          SYMBOL => 'path/to/file.pm' => 'searchable bookmark' => 'p' => 'line:3' => 'class:Test',
          'Add additional parameters for exuberant extension';

  =cut

  sub tag_ok {
      my ($tagger, $symbol, $path, $bookmark) = splice(@_, 0, 4);
      my $description = pop;

      my $canonpath = path($path)->absolute->canonpath;

      my $tag = join "\t",
          $symbol,
          $canonpath,
          "/$bookmark/";

      # exuberant extensions
      if (@_) {
          $tag .= join "\t",
              q<;">,
              @_;
      }

      my $ok = $tagger =~ /
              ^
              \Q$tag\E
              $
              /mx;
      my $builder = __PACKAGE__->builder;

      $builder->ok( $ok, $description )
          or $builder->diag( "Tags did not match:\n$tag" );
  }

  1;
TEST_PERL_TAGS

s/^  //mg for values %fatpacked;

my $class = 'FatPacked::'.(0+\%fatpacked);
no strict 'refs';
*{"${class}::files"} = sub { keys %{$_[0]} };

if ($] < 5.008) {
  *{"${class}::INC"} = sub {
     if (my $fat = $_[0]{$_[1]}) {
       return sub {
         return 0 unless length $fat;
         $fat =~ s/^([^\n]*\n?)//;
         $_ = $1;
         return 1;
       };
     }
     return;
  };
}

else {
  *{"${class}::INC"} = sub {
    if (my $fat = $_[0]{$_[1]}) {
      open my $fh, '<', \$fat
        or die "FatPacker error loading $_[1] (could be a perl installation issue?)";
      return $fh;
    }
    return;
  };
}

unshift @INC, bless \%fatpacked, $class;
  } # END OF FATPACK CODE

use 5.006;
use strict; use warnings;

use Perl::Tags;
use Perl::Tags::Hybrid;
use Perl::Tags::Naive::Moose; # includes ::Naive

## fatpacked file doesn't contain PPI.  Need to investigate
## this.  In mean time, disabling, which will result in a lighter
## weight file for editor use in any case.
# use Perl::Tags::PPI;

# it is intended to be able to `require` this file, to be called
# simply from an Editor, and to be fatpackable

1;