view release on metacpan or  search on metacpan

bin/cpant  view on Meta::CPAN

    if ( $handle ) {
      $self->_parse_fh($handle);
    }
    else {
      $self->_parse_file();
    }
  
    unless($self->{module} and length($self->{module})) {
      my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
      if($f =~ /\.pm$/) {
        $f =~ s/\..+$//;
        my @candidates = grep /$f$/, @{$self->{packages}};
        $self->{module} = shift(@candidates); # punt
      }
      else {
        if(grep /main/, @{$self->{packages}}) {
          $self->{module} = 'main';
        }
        else {
          $self->{module} = $self->{packages}[0] || '';
        }
      }
    }
  
    $self->{version} = $self->{versions}{$self->{module}}
        if defined( $self->{module} );
  
    return $self;
  }
  
  # class method
  sub _do_find_module {
    my $class   = shift;
    my $module  = shift || die 'find_module_by_name() requires a package name';
    my $dirs    = shift || \@INC;
  
    my $file = File::Spec->catfile(split( /::/, $module));
    foreach my $dir ( @$dirs ) {
      my $testfile = File::Spec->catfile($dir, $file);
      return [ File::Spec->rel2abs( $testfile ), $dir ]
  	if -e $testfile and !-d _;  # For stuff like ExtUtils::xsubpp
      return [ File::Spec->rel2abs( "$testfile.pm" ), $dir ]
  	if -e "$testfile.pm";
    }
    return;
  }
  
  # class method
  sub find_module_by_name {
    my $found = shift()->_do_find_module(@_) or return;
    return $found->[0];
  }
  
  # class method
  sub find_module_dir_by_name {
    my $found = shift()->_do_find_module(@_) or return;
    return $found->[1];
  }
  
  
  # given a line of perl code, attempt to parse it if it looks like a
  # $VERSION assignment, returning sigil, full name, & package name
  sub _parse_version_expression {
    my $self = shift;
    my $line = shift;
  
    my( $sig, $var, $pkg );
    if ( $line =~ $VERS_REGEXP ) {
      ( $sig, $var, $pkg ) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
      if ( $pkg ) {
        $pkg = ($pkg eq '::') ? 'main' : $pkg;
        $pkg =~ s/::$//;
      }
    }
  
    return ( $sig, $var, $pkg );
  }
  
  sub _parse_file {
    my $self = shift;
  
    my $filename = $self->{filename};
    my $fh = IO::File->new( $filename )
      or die( "Can't open '$filename': $!" );
  
    $self->_parse_fh($fh);
  }
  
  sub _parse_fh {
    my ($self, $fh) = @_;
  
    my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 );
    my( @pkgs, %vers, %pod, @pod );
    my $pkg = 'main';
    my $pod_sect = '';
    my $pod_data = '';
  
    while (defined( my $line = <$fh> )) {
      my $line_num = $.;
  
      chomp( $line );
      next if $line =~ /^\s*#/;
  
      $in_pod = ($line =~ /^=(?!cut)/) ? 1 : ($line =~ /^=cut/) ? 0 : $in_pod;
  
      # Would be nice if we could also check $in_string or something too
      last if !$in_pod && $line =~ /^__(?:DATA|END)__$/;
  
      if ( $in_pod || $line =~ /^=cut/ ) {
  
        if ( $line =~ /^=head\d\s+(.+)\s*$/ ) {
  	push( @pod, $1 );
  	if ( $self->{collect_pod} && length( $pod_data ) ) {
            $pod{$pod_sect} = $pod_data;
            $pod_data = '';
          }
  	$pod_sect = $1;
  
  
        } elsif ( $self->{collect_pod} ) {
  	$pod_data .= "$line\n";

bin/cpant  view on Meta::CPAN

      bless [ @_ ];
    }
  
    sub DESTROY {
      my @guts = @{ shift() };
      my $code = shift @guts;
      $code->(@guts);
    }
  }
  
  __PACKAGE__
  
  __END__
  
TRY_TINY

$fatpacked{"lib/core/only.pm"} = <<'LIB_CORE_ONLY';
  package lib::core::only;
  
  use strict;
  use warnings FATAL => 'all';
  use Config;
  
  sub import {
    @INC = @Config{qw(privlibexp archlibexp)};
    return
  }
  
  1;
LIB_CORE_ONLY

$fatpacked{"local/lib.pm"} = <<'LOCAL_LIB';
  use strict;
  use warnings;
  
  package local::lib;
  
  use 5.008001; # probably works with earlier versions but I'm not supporting them
                # (patches would, of course, be welcome)
  
  use File::Spec ();
  use File::Path ();
  use Carp ();
  use Config;
  
  our $VERSION = '1.008001'; # 1.8.1
  
  our @KNOWN_FLAGS = qw(--self-contained);
  
  sub import {
    my ($class, @args) = @_;
  
    # Remember what PERL5LIB was when we started
    my $perl5lib = $ENV{PERL5LIB} || '';
  
    my %arg_store;
    for my $arg (@args) {
      # check for lethal dash first to stop processing before causing problems
      if ($arg =~ /−/) {
        die <<'DEATH';
  WHOA THERE! It looks like you've got some fancy dashes in your commandline!
  These are *not* the traditional -- dashes that software recognizes. You
  probably got these by copy-pasting from the perldoc for this module as
  rendered by a UTF8-capable formatter. This most typically happens on an OS X
  terminal, but can happen elsewhere too. Please try again after replacing the
  dashes with normal minus signs.
  DEATH
      }
      elsif(grep { $arg eq $_ } @KNOWN_FLAGS) {
        (my $flag = $arg) =~ s/--//;
        $arg_store{$flag} = 1;
      }
      elsif($arg =~ /^--/) {
        die "Unknown import argument: $arg";
      }
      else {
        # assume that what's left is a path
        $arg_store{path} = $arg;
      }
    }
  
    if($arg_store{'self-contained'}) {
      die "FATAL: The local::lib --self-contained flag has never worked reliably and the original author, Mark Stosberg, was unable or unwilling to maintain it. As such, this flag has been removed from the local::lib codebase in order to prevent misu...
    }
  
    $arg_store{path} = $class->resolve_path($arg_store{path});
    $class->setup_local_lib_for($arg_store{path});
  
    for (@INC) { # Untaint @INC
      next if ref; # Skip entry if it is an ARRAY, CODE, blessed, etc.
      m/(.*)/ and $_ = $1;
    }
  }
  
  sub pipeline;
  
  sub pipeline {
    my @methods = @_;
    my $last = pop(@methods);
    if (@methods) {
      \sub {
        my ($obj, @args) = @_;
        $obj->${pipeline @methods}(
          $obj->$last(@args)
        );
      };
    } else {
      \sub {
        shift->$last(@_);
      };
    }
  }
  
  sub _uniq {
      my %seen;
      grep { ! $seen{$_}++ } @_;
  }
  
  sub resolve_path {
    my ($class, $path) = @_;
    $class->${pipeline qw(