Remove obsolete stuffs
This commit is contained in:
leokhoa
@@ -0,0 +1,96 @@
|
||||
package AnyDBM_File;
|
||||
use warnings;
|
||||
use strict;
|
||||
|
||||
use 5.006_001;
|
||||
our $VERSION = '1.01';
|
||||
our @ISA = qw(NDBM_File DB_File GDBM_File SDBM_File ODBM_File) unless @ISA;
|
||||
|
||||
my $mod;
|
||||
for $mod (@ISA) {
|
||||
if (eval "require $mod") {
|
||||
@ISA = ($mod); # if we leave @ISA alone, warnings abound
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
|
||||
die "No DBM package was successfully found or installed";
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
AnyDBM_File - provide framework for multiple DBMs
|
||||
|
||||
NDBM_File, DB_File, GDBM_File, SDBM_File, ODBM_File - various DBM implementations
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use AnyDBM_File;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module is a "pure virtual base class"--it has nothing of its own.
|
||||
It's just there to inherit from one of the various DBM packages. It
|
||||
prefers ndbm for compatibility reasons with Perl 4, then Berkeley DB (See
|
||||
L<DB_File>), GDBM, SDBM (which is always there--it comes with Perl), and
|
||||
finally ODBM. This way old programs that used to use NDBM via dbmopen()
|
||||
can still do so, but new ones can reorder @ISA:
|
||||
|
||||
BEGIN { @AnyDBM_File::ISA = qw(DB_File GDBM_File NDBM_File) }
|
||||
use AnyDBM_File;
|
||||
|
||||
Having multiple DBM implementations makes it trivial to copy database formats:
|
||||
|
||||
use Fcntl; use NDBM_File; use DB_File;
|
||||
tie %newhash, 'DB_File', $new_filename, O_CREAT|O_RDWR;
|
||||
tie %oldhash, 'NDBM_File', $old_filename, 1, 0;
|
||||
%newhash = %oldhash;
|
||||
|
||||
=head2 DBM Comparisons
|
||||
|
||||
Here's a partial table of features the different packages offer:
|
||||
|
||||
odbm ndbm sdbm gdbm bsd-db
|
||||
---- ---- ---- ---- ------
|
||||
Linkage comes w/ perl yes yes yes yes yes
|
||||
Src comes w/ perl no no yes no no
|
||||
Comes w/ many unix os yes yes[0] no no no
|
||||
Builds ok on !unix ? ? yes yes ?
|
||||
Code Size ? ? small big big
|
||||
Database Size ? ? small big? ok[1]
|
||||
Speed ? ? slow ok fast
|
||||
FTPable no no yes yes yes
|
||||
Easy to build N/A N/A yes yes ok[2]
|
||||
Size limits 1k 4k 1k[3] none none
|
||||
Byte-order independent no no no no yes
|
||||
Licensing restrictions ? ? no yes no
|
||||
|
||||
|
||||
=over 4
|
||||
|
||||
=item [0]
|
||||
|
||||
on mixed universe machines, may be in the bsd compat library,
|
||||
which is often shunned.
|
||||
|
||||
=item [1]
|
||||
|
||||
Can be trimmed if you compile for one access method.
|
||||
|
||||
=item [2]
|
||||
|
||||
See L<DB_File>.
|
||||
Requires symbolic links.
|
||||
|
||||
=item [3]
|
||||
|
||||
By default, but can be redefined.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
dbm(3), ndbm(3), DB_File(3), L<perldbmfilter>
|
||||
|
||||
=cut
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,829 @@
|
||||
package App::Prove;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use TAP::Harness::Env;
|
||||
use Text::ParseWords qw(shellwords);
|
||||
use File::Spec;
|
||||
use Getopt::Long;
|
||||
use App::Prove::State;
|
||||
use Carp;
|
||||
|
||||
use base 'TAP::Object';
|
||||
|
||||
=head1 NAME
|
||||
|
||||
App::Prove - Implements the C<prove> command.
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Version 3.44
|
||||
|
||||
=cut
|
||||
|
||||
our $VERSION = '3.44';
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Test::Harness> provides a command, C<prove>, which runs a TAP based
|
||||
test suite and prints a report. The C<prove> command is a minimal
|
||||
wrapper around an instance of this module.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use App::Prove;
|
||||
|
||||
my $app = App::Prove->new;
|
||||
$app->process_args(@ARGV);
|
||||
$app->run;
|
||||
|
||||
=cut
|
||||
|
||||
use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
|
||||
use constant IS_VMS => $^O eq 'VMS';
|
||||
use constant IS_UNIXY => !( IS_VMS || IS_WIN32 );
|
||||
|
||||
use constant STATE_FILE => IS_UNIXY ? '.prove' : '_prove';
|
||||
use constant RC_FILE => IS_UNIXY ? '.proverc' : '_proverc';
|
||||
|
||||
use constant PLUGINS => 'App::Prove::Plugin';
|
||||
|
||||
my @ATTR;
|
||||
|
||||
BEGIN {
|
||||
@ATTR = qw(
|
||||
archive argv blib show_count color directives exec failures comments
|
||||
formatter harness includes modules plugins jobs lib merge parse quiet
|
||||
really_quiet recurse backwards shuffle taint_fail taint_warn timer
|
||||
verbose warnings_fail warnings_warn show_help show_man show_version
|
||||
state_class test_args state dry extensions ignore_exit rules state_manager
|
||||
normalize sources tapversion trap
|
||||
statefile
|
||||
);
|
||||
__PACKAGE__->mk_methods(@ATTR);
|
||||
}
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 Class Methods
|
||||
|
||||
=head3 C<new>
|
||||
|
||||
Create a new C<App::Prove>. Optionally a hash ref of attribute
|
||||
initializers may be passed.
|
||||
|
||||
=cut
|
||||
|
||||
# new() implementation supplied by TAP::Object
|
||||
|
||||
sub _initialize {
|
||||
my $self = shift;
|
||||
my $args = shift || {};
|
||||
|
||||
my @is_array = qw(
|
||||
argv rc_opts includes modules state plugins rules sources
|
||||
);
|
||||
|
||||
# setup defaults:
|
||||
for my $key (@is_array) {
|
||||
$self->{$key} = [];
|
||||
}
|
||||
|
||||
for my $attr (@ATTR) {
|
||||
if ( exists $args->{$attr} ) {
|
||||
|
||||
# TODO: Some validation here
|
||||
$self->{$attr} = $args->{$attr};
|
||||
}
|
||||
}
|
||||
|
||||
$self->state_class('App::Prove::State');
|
||||
return $self;
|
||||
}
|
||||
|
||||
=head3 C<state_class>
|
||||
|
||||
Getter/setter for the name of the class used for maintaining state. This
|
||||
class should either subclass from C<App::Prove::State> or provide an identical
|
||||
interface.
|
||||
|
||||
=head3 C<state_manager>
|
||||
|
||||
Getter/setter for the instance of the C<state_class>.
|
||||
|
||||
=cut
|
||||
|
||||
=head3 C<add_rc_file>
|
||||
|
||||
$prove->add_rc_file('myproj/.proverc');
|
||||
|
||||
Called before C<process_args> to prepend the contents of an rc file to
|
||||
the options.
|
||||
|
||||
=cut
|
||||
|
||||
sub add_rc_file {
|
||||
my ( $self, $rc_file ) = @_;
|
||||
|
||||
local *RC;
|
||||
open RC, "<$rc_file" or croak "Can't read $rc_file ($!)";
|
||||
while ( defined( my $line = <RC> ) ) {
|
||||
push @{ $self->{rc_opts} },
|
||||
grep { defined and not /^#/ }
|
||||
$line =~ m{ ' ([^']*) ' | " ([^"]*) " | (\#.*) | (\S+) }xg;
|
||||
}
|
||||
close RC;
|
||||
}
|
||||
|
||||
=head3 C<process_args>
|
||||
|
||||
$prove->process_args(@args);
|
||||
|
||||
Processes the command-line arguments. Attributes will be set
|
||||
appropriately. Any filenames may be found in the C<argv> attribute.
|
||||
|
||||
Dies on invalid arguments.
|
||||
|
||||
=cut
|
||||
|
||||
sub process_args {
|
||||
my $self = shift;
|
||||
|
||||
my @rc = RC_FILE;
|
||||
unshift @rc, glob '~/' . RC_FILE if IS_UNIXY;
|
||||
|
||||
# Preprocess meta-args.
|
||||
my @args;
|
||||
while ( defined( my $arg = shift ) ) {
|
||||
if ( $arg eq '--norc' ) {
|
||||
@rc = ();
|
||||
}
|
||||
elsif ( $arg eq '--rc' ) {
|
||||
defined( my $rc = shift )
|
||||
or croak "Missing argument to --rc";
|
||||
push @rc, $rc;
|
||||
}
|
||||
elsif ( $arg =~ m{^--rc=(.+)$} ) {
|
||||
push @rc, $1;
|
||||
}
|
||||
else {
|
||||
push @args, $arg;
|
||||
}
|
||||
}
|
||||
|
||||
# Everything after the arisdottle '::' gets passed as args to
|
||||
# test programs.
|
||||
if ( defined( my $stop_at = _first_pos( '::', @args ) ) ) {
|
||||
my @test_args = splice @args, $stop_at;
|
||||
shift @test_args;
|
||||
$self->{test_args} = \@test_args;
|
||||
}
|
||||
|
||||
# Grab options from RC files
|
||||
$self->add_rc_file($_) for grep -f, @rc;
|
||||
unshift @args, @{ $self->{rc_opts} };
|
||||
|
||||
if ( my @bad = map {"-$_"} grep {/^-(man|help)$/} @args ) {
|
||||
die "Long options should be written with two dashes: ",
|
||||
join( ', ', @bad ), "\n";
|
||||
}
|
||||
|
||||
# And finally...
|
||||
|
||||
{
|
||||
local @ARGV = @args;
|
||||
Getopt::Long::Configure(qw(no_ignore_case bundling pass_through));
|
||||
|
||||
# Don't add coderefs to GetOptions
|
||||
GetOptions(
|
||||
'v|verbose' => \$self->{verbose},
|
||||
'f|failures' => \$self->{failures},
|
||||
'o|comments' => \$self->{comments},
|
||||
'l|lib' => \$self->{lib},
|
||||
'b|blib' => \$self->{blib},
|
||||
's|shuffle' => \$self->{shuffle},
|
||||
'color!' => \$self->{color},
|
||||
'colour!' => \$self->{color},
|
||||
'count!' => \$self->{show_count},
|
||||
'c' => \$self->{color},
|
||||
'D|dry' => \$self->{dry},
|
||||
'ext=s@' => sub {
|
||||
my ( $opt, $val ) = @_;
|
||||
|
||||
# Workaround for Getopt::Long 2.25 handling of
|
||||
# multivalue options
|
||||
push @{ $self->{extensions} ||= [] }, $val;
|
||||
},
|
||||
'harness=s' => \$self->{harness},
|
||||
'ignore-exit' => \$self->{ignore_exit},
|
||||
'source=s@' => $self->{sources},
|
||||
'formatter=s' => \$self->{formatter},
|
||||
'r|recurse' => \$self->{recurse},
|
||||
'reverse' => \$self->{backwards},
|
||||
'p|parse' => \$self->{parse},
|
||||
'q|quiet' => \$self->{quiet},
|
||||
'Q|QUIET' => \$self->{really_quiet},
|
||||
'e|exec=s' => \$self->{exec},
|
||||
'm|merge' => \$self->{merge},
|
||||
'I=s@' => $self->{includes},
|
||||
'M=s@' => $self->{modules},
|
||||
'P=s@' => $self->{plugins},
|
||||
'state=s@' => $self->{state},
|
||||
'statefile=s' => \$self->{statefile},
|
||||
'directives' => \$self->{directives},
|
||||
'h|help|?' => \$self->{show_help},
|
||||
'H|man' => \$self->{show_man},
|
||||
'V|version' => \$self->{show_version},
|
||||
'a|archive=s' => \$self->{archive},
|
||||
'j|jobs=i' => \$self->{jobs},
|
||||
'timer' => \$self->{timer},
|
||||
'T' => \$self->{taint_fail},
|
||||
't' => \$self->{taint_warn},
|
||||
'W' => \$self->{warnings_fail},
|
||||
'w' => \$self->{warnings_warn},
|
||||
'normalize' => \$self->{normalize},
|
||||
'rules=s@' => $self->{rules},
|
||||
'tapversion=s' => \$self->{tapversion},
|
||||
'trap' => \$self->{trap},
|
||||
) or croak('Unable to continue');
|
||||
|
||||
# Stash the remainder of argv for later
|
||||
$self->{argv} = [@ARGV];
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub _first_pos {
|
||||
my $want = shift;
|
||||
for ( 0 .. $#_ ) {
|
||||
return $_ if $_[$_] eq $want;
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
sub _help {
|
||||
my ( $self, $verbosity ) = @_;
|
||||
|
||||
eval('use Pod::Usage 1.12 ()');
|
||||
if ( my $err = $@ ) {
|
||||
die 'Please install Pod::Usage for the --help option '
|
||||
. '(or try `perldoc prove`.)'
|
||||
. "\n ($@)";
|
||||
}
|
||||
|
||||
Pod::Usage::pod2usage( { -verbose => $verbosity } );
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub _color_default {
|
||||
my $self = shift;
|
||||
|
||||
return -t STDOUT && !$ENV{HARNESS_NOTTY};
|
||||
}
|
||||
|
||||
sub _get_args {
|
||||
my $self = shift;
|
||||
|
||||
my %args;
|
||||
|
||||
$args{trap} = 1 if $self->trap;
|
||||
|
||||
if ( defined $self->color ? $self->color : $self->_color_default ) {
|
||||
$args{color} = 1;
|
||||
}
|
||||
if ( !defined $self->show_count ) {
|
||||
$args{show_count} = 1;
|
||||
}
|
||||
else {
|
||||
$args{show_count} = $self->show_count;
|
||||
}
|
||||
|
||||
if ( $self->archive ) {
|
||||
$self->require_harness( archive => 'TAP::Harness::Archive' );
|
||||
$args{archive} = $self->archive;
|
||||
}
|
||||
|
||||
if ( my $jobs = $self->jobs ) {
|
||||
$args{jobs} = $jobs;
|
||||
}
|
||||
|
||||
if ( my $harness_opt = $self->harness ) {
|
||||
$self->require_harness( harness => $harness_opt );
|
||||
}
|
||||
|
||||
if ( my $formatter = $self->formatter ) {
|
||||
$args{formatter_class} = $formatter;
|
||||
}
|
||||
|
||||
for my $handler ( @{ $self->sources } ) {
|
||||
my ( $name, $config ) = $self->_parse_source($handler);
|
||||
$args{sources}->{$name} = $config;
|
||||
}
|
||||
|
||||
if ( $self->ignore_exit ) {
|
||||
$args{ignore_exit} = 1;
|
||||
}
|
||||
|
||||
if ( $self->taint_fail && $self->taint_warn ) {
|
||||
die '-t and -T are mutually exclusive';
|
||||
}
|
||||
|
||||
if ( $self->warnings_fail && $self->warnings_warn ) {
|
||||
die '-w and -W are mutually exclusive';
|
||||
}
|
||||
|
||||
for my $a (qw( lib switches )) {
|
||||
my $method = "_get_$a";
|
||||
my $val = $self->$method();
|
||||
$args{$a} = $val if defined $val;
|
||||
}
|
||||
|
||||
# Handle verbose, quiet, really_quiet flags
|
||||
my %verb_map = ( verbose => 1, quiet => -1, really_quiet => -2, );
|
||||
|
||||
my @verb_adj = map { $self->$_() ? $verb_map{$_} : () }
|
||||
keys %verb_map;
|
||||
|
||||
die "Only one of verbose, quiet or really_quiet should be specified\n"
|
||||
if @verb_adj > 1;
|
||||
|
||||
$args{verbosity} = shift @verb_adj if @verb_adj;
|
||||
|
||||
for my $a (qw( merge failures comments timer directives normalize )) {
|
||||
$args{$a} = 1 if $self->$a();
|
||||
}
|
||||
|
||||
$args{errors} = 1 if $self->parse;
|
||||
|
||||
# defined but zero-length exec runs test files as binaries
|
||||
$args{exec} = [ split( /\s+/, $self->exec ) ]
|
||||
if ( defined( $self->exec ) );
|
||||
|
||||
$args{version} = $self->tapversion if defined( $self->tapversion );
|
||||
|
||||
if ( defined( my $test_args = $self->test_args ) ) {
|
||||
$args{test_args} = $test_args;
|
||||
}
|
||||
|
||||
if ( @{ $self->rules } ) {
|
||||
my @rules;
|
||||
for ( @{ $self->rules } ) {
|
||||
if (/^par=(.*)/) {
|
||||
push @rules, $1;
|
||||
}
|
||||
elsif (/^seq=(.*)/) {
|
||||
push @rules, { seq => $1 };
|
||||
}
|
||||
}
|
||||
$args{rules} = { par => [@rules] };
|
||||
}
|
||||
$args{harness_class} = $self->{harness_class} if $self->{harness_class};
|
||||
|
||||
return \%args;
|
||||
}
|
||||
|
||||
sub _find_module {
|
||||
my ( $self, $class, @search ) = @_;
|
||||
|
||||
croak "Bad module name $class"
|
||||
unless $class =~ /^ \w+ (?: :: \w+ ) *$/x;
|
||||
|
||||
for my $pfx (@search) {
|
||||
my $name = join( '::', $pfx, $class );
|
||||
eval "require $name";
|
||||
return $name unless $@;
|
||||
}
|
||||
|
||||
eval "require $class";
|
||||
return $class unless $@;
|
||||
return;
|
||||
}
|
||||
|
||||
sub _load_extension {
|
||||
my ( $self, $name, @search ) = @_;
|
||||
|
||||
my @args = ();
|
||||
if ( $name =~ /^(.*?)=(.*)/ ) {
|
||||
$name = $1;
|
||||
@args = split( /,/, $2 );
|
||||
}
|
||||
|
||||
if ( my $class = $self->_find_module( $name, @search ) ) {
|
||||
$class->import(@args);
|
||||
if ( $class->can('load') ) {
|
||||
$class->load( { app_prove => $self, args => [@args] } );
|
||||
}
|
||||
}
|
||||
else {
|
||||
croak "Can't load module $name";
|
||||
}
|
||||
}
|
||||
|
||||
sub _load_extensions {
|
||||
my ( $self, $ext, @search ) = @_;
|
||||
$self->_load_extension( $_, @search ) for @$ext;
|
||||
}
|
||||
|
||||
sub _parse_source {
|
||||
my ( $self, $handler ) = @_;
|
||||
|
||||
# Load any options.
|
||||
( my $opt_name = lc $handler ) =~ s/::/-/g;
|
||||
local @ARGV = @{ $self->{argv} };
|
||||
my %config;
|
||||
Getopt::Long::GetOptions(
|
||||
"$opt_name-option=s%" => sub {
|
||||
my ( $name, $k, $v ) = @_;
|
||||
if ( $v =~ /(?<!\\)=/ ) {
|
||||
|
||||
# It's a hash option.
|
||||
croak "Option $name must be consistently used as a hash"
|
||||
if exists $config{$k} && ref $config{$k} ne 'HASH';
|
||||
$config{$k} ||= {};
|
||||
my ( $hk, $hv ) = split /(?<!\\)=/, $v, 2;
|
||||
$config{$k}{$hk} = $hv;
|
||||
}
|
||||
else {
|
||||
$v =~ s/\\=/=/g;
|
||||
if ( exists $config{$k} ) {
|
||||
$config{$k} = [ $config{$k} ]
|
||||
unless ref $config{$k} eq 'ARRAY';
|
||||
push @{ $config{$k} } => $v;
|
||||
}
|
||||
else {
|
||||
$config{$k} = $v;
|
||||
}
|
||||
}
|
||||
}
|
||||
);
|
||||
$self->{argv} = \@ARGV;
|
||||
return ( $handler, \%config );
|
||||
}
|
||||
|
||||
=head3 C<run>
|
||||
|
||||
Perform whatever actions the command line args specified. The C<prove>
|
||||
command line tool consists of the following code:
|
||||
|
||||
use App::Prove;
|
||||
|
||||
my $app = App::Prove->new;
|
||||
$app->process_args(@ARGV);
|
||||
exit( $app->run ? 0 : 1 ); # if you need the exit code
|
||||
|
||||
=cut
|
||||
|
||||
sub run {
|
||||
my $self = shift;
|
||||
|
||||
unless ( $self->state_manager ) {
|
||||
$self->state_manager(
|
||||
$self->state_class->new( { store => $self->statefile || STATE_FILE } ) );
|
||||
}
|
||||
|
||||
if ( $self->show_help ) {
|
||||
$self->_help(1);
|
||||
}
|
||||
elsif ( $self->show_man ) {
|
||||
$self->_help(2);
|
||||
}
|
||||
elsif ( $self->show_version ) {
|
||||
$self->print_version;
|
||||
}
|
||||
elsif ( $self->dry ) {
|
||||
print "$_\n" for $self->_get_tests;
|
||||
}
|
||||
else {
|
||||
|
||||
$self->_load_extensions( $self->modules );
|
||||
$self->_load_extensions( $self->plugins, PLUGINS );
|
||||
|
||||
local $ENV{TEST_VERBOSE} = 1 if $self->verbose;
|
||||
|
||||
return $self->_runtests( $self->_get_args, $self->_get_tests );
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _get_tests {
|
||||
my $self = shift;
|
||||
|
||||
my $state = $self->state_manager;
|
||||
my $ext = $self->extensions;
|
||||
$state->extensions($ext) if defined $ext;
|
||||
if ( defined( my $state_switch = $self->state ) ) {
|
||||
$state->apply_switch(@$state_switch);
|
||||
}
|
||||
|
||||
my @tests = $state->get_tests( $self->recurse, @{ $self->argv } );
|
||||
|
||||
$self->_shuffle(@tests) if $self->shuffle;
|
||||
@tests = reverse @tests if $self->backwards;
|
||||
|
||||
return @tests;
|
||||
}
|
||||
|
||||
sub _runtests {
|
||||
my ( $self, $args, @tests ) = @_;
|
||||
my $harness = TAP::Harness::Env->create($args);
|
||||
|
||||
my $state = $self->state_manager;
|
||||
|
||||
$harness->callback(
|
||||
after_test => sub {
|
||||
$state->observe_test(@_);
|
||||
}
|
||||
);
|
||||
|
||||
$harness->callback(
|
||||
after_runtests => sub {
|
||||
$state->commit(@_);
|
||||
}
|
||||
);
|
||||
|
||||
my $aggregator = $harness->runtests(@tests);
|
||||
|
||||
return !$aggregator->has_errors;
|
||||
}
|
||||
|
||||
sub _get_switches {
|
||||
my $self = shift;
|
||||
my @switches;
|
||||
|
||||
# notes that -T or -t must be at the front of the switches!
|
||||
if ( $self->taint_fail ) {
|
||||
push @switches, '-T';
|
||||
}
|
||||
elsif ( $self->taint_warn ) {
|
||||
push @switches, '-t';
|
||||
}
|
||||
if ( $self->warnings_fail ) {
|
||||
push @switches, '-W';
|
||||
}
|
||||
elsif ( $self->warnings_warn ) {
|
||||
push @switches, '-w';
|
||||
}
|
||||
|
||||
return @switches ? \@switches : ();
|
||||
}
|
||||
|
||||
sub _get_lib {
|
||||
my $self = shift;
|
||||
my @libs;
|
||||
if ( $self->lib ) {
|
||||
push @libs, 'lib';
|
||||
}
|
||||
if ( $self->blib ) {
|
||||
push @libs, 'blib/lib', 'blib/arch';
|
||||
}
|
||||
if ( @{ $self->includes } ) {
|
||||
push @libs, @{ $self->includes };
|
||||
}
|
||||
|
||||
#24926
|
||||
@libs = map { File::Spec->rel2abs($_) } @libs;
|
||||
|
||||
# Huh?
|
||||
return @libs ? \@libs : ();
|
||||
}
|
||||
|
||||
sub _shuffle {
|
||||
my $self = shift;
|
||||
|
||||
# Fisher-Yates shuffle
|
||||
my $i = @_;
|
||||
while ($i) {
|
||||
my $j = rand $i--;
|
||||
@_[ $i, $j ] = @_[ $j, $i ];
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
=head3 C<require_harness>
|
||||
|
||||
Load a harness replacement class.
|
||||
|
||||
$prove->require_harness($for => $class_name);
|
||||
|
||||
=cut
|
||||
|
||||
sub require_harness {
|
||||
my ( $self, $for, $class ) = @_;
|
||||
|
||||
my ($class_name) = $class =~ /^(\w+(?:::\w+)*)/;
|
||||
|
||||
# Emulate Perl's -MModule=arg1,arg2 behaviour
|
||||
$class =~ s!^(\w+(?:::\w+)*)=(.*)$!$1 split(/,/,q{$2})!;
|
||||
|
||||
eval("use $class;");
|
||||
die "$class_name is required to use the --$for feature: $@" if $@;
|
||||
|
||||
$self->{harness_class} = $class_name;
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
=head3 C<print_version>
|
||||
|
||||
Display the version numbers of the loaded L<TAP::Harness> and the
|
||||
current Perl.
|
||||
|
||||
=cut
|
||||
|
||||
sub print_version {
|
||||
my $self = shift;
|
||||
require TAP::Harness;
|
||||
printf(
|
||||
"TAP::Harness v%s and Perl v%vd\n",
|
||||
$TAP::Harness::VERSION, $^V
|
||||
);
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# vim:ts=4:sw=4:et:sta
|
||||
|
||||
__END__
|
||||
|
||||
=head2 Attributes
|
||||
|
||||
After command line parsing the following attributes reflect the values
|
||||
of the corresponding command line switches. They may be altered before
|
||||
calling C<run>.
|
||||
|
||||
=over
|
||||
|
||||
=item C<archive>
|
||||
|
||||
=item C<argv>
|
||||
|
||||
=item C<backwards>
|
||||
|
||||
=item C<blib>
|
||||
|
||||
=item C<color>
|
||||
|
||||
=item C<directives>
|
||||
|
||||
=item C<dry>
|
||||
|
||||
=item C<exec>
|
||||
|
||||
=item C<extensions>
|
||||
|
||||
=item C<failures>
|
||||
|
||||
=item C<comments>
|
||||
|
||||
=item C<formatter>
|
||||
|
||||
=item C<harness>
|
||||
|
||||
=item C<ignore_exit>
|
||||
|
||||
=item C<includes>
|
||||
|
||||
=item C<jobs>
|
||||
|
||||
=item C<lib>
|
||||
|
||||
=item C<merge>
|
||||
|
||||
=item C<modules>
|
||||
|
||||
=item C<parse>
|
||||
|
||||
=item C<plugins>
|
||||
|
||||
=item C<quiet>
|
||||
|
||||
=item C<really_quiet>
|
||||
|
||||
=item C<recurse>
|
||||
|
||||
=item C<rules>
|
||||
|
||||
=item C<show_count>
|
||||
|
||||
=item C<show_help>
|
||||
|
||||
=item C<show_man>
|
||||
|
||||
=item C<show_version>
|
||||
|
||||
=item C<shuffle>
|
||||
|
||||
=item C<state>
|
||||
|
||||
=item C<state_class>
|
||||
|
||||
=item C<taint_fail>
|
||||
|
||||
=item C<taint_warn>
|
||||
|
||||
=item C<test_args>
|
||||
|
||||
=item C<timer>
|
||||
|
||||
=item C<verbose>
|
||||
|
||||
=item C<warnings_fail>
|
||||
|
||||
=item C<warnings_warn>
|
||||
|
||||
=item C<tapversion>
|
||||
|
||||
=item C<trap>
|
||||
|
||||
=back
|
||||
|
||||
=head1 PLUGINS
|
||||
|
||||
C<App::Prove> provides support for 3rd-party plugins. These are currently
|
||||
loaded at run-time, I<after> arguments have been parsed (so you can not
|
||||
change the way arguments are processed, sorry), typically with the
|
||||
C<< -PI<plugin> >> switch, eg:
|
||||
|
||||
prove -PMyPlugin
|
||||
|
||||
This will search for a module named C<App::Prove::Plugin::MyPlugin>, or failing
|
||||
that, C<MyPlugin>. If the plugin can't be found, C<prove> will complain & exit.
|
||||
|
||||
You can pass an argument to your plugin by appending an C<=> after the plugin
|
||||
name, eg C<-PMyPlugin=foo>. You can pass multiple arguments using commas:
|
||||
|
||||
prove -PMyPlugin=foo,bar,baz
|
||||
|
||||
These are passed in to your plugin's C<load()> class method (if it has one),
|
||||
along with a reference to the C<App::Prove> object that is invoking your plugin:
|
||||
|
||||
sub load {
|
||||
my ($class, $p) = @_;
|
||||
|
||||
my @args = @{ $p->{args} };
|
||||
# @args will contain ( 'foo', 'bar', 'baz' )
|
||||
$p->{app_prove}->do_something;
|
||||
...
|
||||
}
|
||||
|
||||
Note that the user's arguments are also passed to your plugin's C<import()>
|
||||
function as a list, eg:
|
||||
|
||||
sub import {
|
||||
my ($class, @args) = @_;
|
||||
# @args will contain ( 'foo', 'bar', 'baz' )
|
||||
...
|
||||
}
|
||||
|
||||
This is for backwards compatibility, and may be deprecated in the future.
|
||||
|
||||
=head2 Sample Plugin
|
||||
|
||||
Here's a sample plugin, for your reference:
|
||||
|
||||
package App::Prove::Plugin::Foo;
|
||||
|
||||
# Sample plugin, try running with:
|
||||
# prove -PFoo=bar -r -j3
|
||||
# prove -PFoo -Q
|
||||
# prove -PFoo=bar,My::Formatter
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
sub load {
|
||||
my ($class, $p) = @_;
|
||||
my @args = @{ $p->{args} };
|
||||
my $app = $p->{app_prove};
|
||||
|
||||
print "loading plugin: $class, args: ", join(', ', @args ), "\n";
|
||||
|
||||
# turn on verbosity
|
||||
$app->verbose( 1 );
|
||||
|
||||
# set the formatter?
|
||||
$app->formatter( $args[1] ) if @args > 1;
|
||||
|
||||
# print some of App::Prove's state:
|
||||
for my $attr (qw( jobs quiet really_quiet recurse verbose )) {
|
||||
my $val = $app->$attr;
|
||||
$val = 'undef' unless defined( $val );
|
||||
print "$attr: $val\n";
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<prove>, L<TAP::Harness>
|
||||
|
||||
=cut
|
||||
@@ -0,0 +1,548 @@
|
||||
package App::Prove::State;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use File::Find;
|
||||
use File::Spec;
|
||||
use Carp;
|
||||
|
||||
use App::Prove::State::Result;
|
||||
use TAP::Parser::YAMLish::Reader ();
|
||||
use TAP::Parser::YAMLish::Writer ();
|
||||
use base 'TAP::Base';
|
||||
|
||||
BEGIN {
|
||||
__PACKAGE__->mk_methods('result_class');
|
||||
}
|
||||
|
||||
use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
|
||||
use constant NEED_GLOB => IS_WIN32;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
App::Prove::State - State storage for the C<prove> command.
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Version 3.44
|
||||
|
||||
=cut
|
||||
|
||||
our $VERSION = '3.44';
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The C<prove> command supports a C<--state> option that instructs it to
|
||||
store persistent state across runs. This module implements that state
|
||||
and the operations that may be performed on it.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# Re-run failed tests
|
||||
$ prove --state=failed,save -rbv
|
||||
|
||||
=cut
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 Class Methods
|
||||
|
||||
=head3 C<new>
|
||||
|
||||
Accepts a hashref with the following key/value pairs:
|
||||
|
||||
=over 4
|
||||
|
||||
=item * C<store>
|
||||
|
||||
The filename of the data store holding the data that App::Prove::State reads.
|
||||
|
||||
=item * C<extensions> (optional)
|
||||
|
||||
The test name extensions. Defaults to C<.t>.
|
||||
|
||||
=item * C<result_class> (optional)
|
||||
|
||||
The name of the C<result_class>. Defaults to C<App::Prove::State::Result>.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
# override TAP::Base::new:
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my %args = %{ shift || {} };
|
||||
|
||||
my $self = bless {
|
||||
select => [],
|
||||
seq => 1,
|
||||
store => delete $args{store},
|
||||
extensions => ( delete $args{extensions} || ['.t'] ),
|
||||
result_class =>
|
||||
( delete $args{result_class} || 'App::Prove::State::Result' ),
|
||||
}, $class;
|
||||
|
||||
$self->{_} = $self->result_class->new(
|
||||
{ tests => {},
|
||||
generation => 1,
|
||||
}
|
||||
);
|
||||
my $store = $self->{store};
|
||||
$self->load($store)
|
||||
if defined $store && -f $store;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
=head2 C<result_class>
|
||||
|
||||
Getter/setter for the name of the class used for tracking test results. This
|
||||
class should either subclass from C<App::Prove::State::Result> or provide an
|
||||
identical interface.
|
||||
|
||||
=cut
|
||||
|
||||
=head2 C<extensions>
|
||||
|
||||
Get or set the list of extensions that files must have in order to be
|
||||
considered tests. Defaults to ['.t'].
|
||||
|
||||
=cut
|
||||
|
||||
sub extensions {
|
||||
my $self = shift;
|
||||
$self->{extensions} = shift if @_;
|
||||
return $self->{extensions};
|
||||
}
|
||||
|
||||
=head2 C<results>
|
||||
|
||||
Get the results of the last test run. Returns a C<result_class()> instance.
|
||||
|
||||
=cut
|
||||
|
||||
sub results {
|
||||
my $self = shift;
|
||||
$self->{_} || $self->result_class->new;
|
||||
}
|
||||
|
||||
=head2 C<commit>
|
||||
|
||||
Save the test results. Should be called after all tests have run.
|
||||
|
||||
=cut
|
||||
|
||||
sub commit {
|
||||
my $self = shift;
|
||||
if ( $self->{should_save} ) {
|
||||
$self->save;
|
||||
}
|
||||
}
|
||||
|
||||
=head2 Instance Methods
|
||||
|
||||
=head3 C<apply_switch>
|
||||
|
||||
$self->apply_switch('failed,save');
|
||||
|
||||
Apply a list of switch options to the state, updating the internal
|
||||
object state as a result. Nothing is returned.
|
||||
|
||||
Diagnostics:
|
||||
- "Illegal state option: %s"
|
||||
|
||||
=over
|
||||
|
||||
=item C<last>
|
||||
|
||||
Run in the same order as last time
|
||||
|
||||
=item C<failed>
|
||||
|
||||
Run only the failed tests from last time
|
||||
|
||||
=item C<passed>
|
||||
|
||||
Run only the passed tests from last time
|
||||
|
||||
=item C<all>
|
||||
|
||||
Run all tests in normal order
|
||||
|
||||
=item C<hot>
|
||||
|
||||
Run the tests that most recently failed first
|
||||
|
||||
=item C<todo>
|
||||
|
||||
Run the tests ordered by number of todos.
|
||||
|
||||
=item C<slow>
|
||||
|
||||
Run the tests in slowest to fastest order.
|
||||
|
||||
=item C<fast>
|
||||
|
||||
Run test tests in fastest to slowest order.
|
||||
|
||||
=item C<new>
|
||||
|
||||
Run the tests in newest to oldest order.
|
||||
|
||||
=item C<old>
|
||||
|
||||
Run the tests in oldest to newest order.
|
||||
|
||||
=item C<save>
|
||||
|
||||
Save the state on exit.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub apply_switch {
|
||||
my $self = shift;
|
||||
my @opts = @_;
|
||||
|
||||
my $last_gen = $self->results->generation - 1;
|
||||
my $last_run_time = $self->results->last_run_time;
|
||||
my $now = $self->get_time;
|
||||
|
||||
my @switches = map { split /,/ } @opts;
|
||||
|
||||
my %handler = (
|
||||
last => sub {
|
||||
$self->_select(
|
||||
limit => shift,
|
||||
where => sub { $_->generation >= $last_gen },
|
||||
order => sub { $_->sequence }
|
||||
);
|
||||
},
|
||||
failed => sub {
|
||||
$self->_select(
|
||||
limit => shift,
|
||||
where => sub { $_->result != 0 },
|
||||
order => sub { -$_->result }
|
||||
);
|
||||
},
|
||||
passed => sub {
|
||||
$self->_select(
|
||||
limit => shift,
|
||||
where => sub { $_->result == 0 }
|
||||
);
|
||||
},
|
||||
all => sub {
|
||||
$self->_select( limit => shift );
|
||||
},
|
||||
todo => sub {
|
||||
$self->_select(
|
||||
limit => shift,
|
||||
where => sub { $_->num_todo != 0 },
|
||||
order => sub { -$_->num_todo; }
|
||||
);
|
||||
},
|
||||
hot => sub {
|
||||
$self->_select(
|
||||
limit => shift,
|
||||
where => sub { defined $_->last_fail_time },
|
||||
order => sub { $now - $_->last_fail_time }
|
||||
);
|
||||
},
|
||||
slow => sub {
|
||||
$self->_select(
|
||||
limit => shift,
|
||||
order => sub { -$_->elapsed }
|
||||
);
|
||||
},
|
||||
fast => sub {
|
||||
$self->_select(
|
||||
limit => shift,
|
||||
order => sub { $_->elapsed }
|
||||
);
|
||||
},
|
||||
new => sub {
|
||||
$self->_select(
|
||||
limit => shift,
|
||||
order => sub { -$_->mtime }
|
||||
);
|
||||
},
|
||||
old => sub {
|
||||
$self->_select(
|
||||
limit => shift,
|
||||
order => sub { $_->mtime }
|
||||
);
|
||||
},
|
||||
fresh => sub {
|
||||
$self->_select(
|
||||
limit => shift,
|
||||
where => sub { $_->mtime >= $last_run_time }
|
||||
);
|
||||
},
|
||||
save => sub {
|
||||
$self->{should_save}++;
|
||||
},
|
||||
adrian => sub {
|
||||
unshift @switches, qw( hot all save );
|
||||
},
|
||||
);
|
||||
|
||||
while ( defined( my $ele = shift @switches ) ) {
|
||||
my ( $opt, $arg )
|
||||
= ( $ele =~ /^([^:]+):(.*)/ )
|
||||
? ( $1, $2 )
|
||||
: ( $ele, undef );
|
||||
my $code = $handler{$opt}
|
||||
|| croak "Illegal state option: $opt";
|
||||
$code->($arg);
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
sub _select {
|
||||
my ( $self, %spec ) = @_;
|
||||
push @{ $self->{select} }, \%spec;
|
||||
}
|
||||
|
||||
=head3 C<get_tests>
|
||||
|
||||
Given a list of args get the names of tests that should run
|
||||
|
||||
=cut
|
||||
|
||||
sub get_tests {
|
||||
my $self = shift;
|
||||
my $recurse = shift;
|
||||
my @argv = @_;
|
||||
my %seen;
|
||||
|
||||
my @selected = $self->_query;
|
||||
|
||||
unless ( @argv || @{ $self->{select} } ) {
|
||||
@argv = $recurse ? '.' : 't';
|
||||
croak qq{No tests named and '@argv' directory not found}
|
||||
unless -d $argv[0];
|
||||
}
|
||||
|
||||
push @selected, $self->_get_raw_tests( $recurse, @argv ) if @argv;
|
||||
return grep { !$seen{$_}++ } @selected;
|
||||
}
|
||||
|
||||
sub _query {
|
||||
my $self = shift;
|
||||
if ( my @sel = @{ $self->{select} } ) {
|
||||
warn "No saved state, selection will be empty\n"
|
||||
unless $self->results->num_tests;
|
||||
return map { $self->_query_clause($_) } @sel;
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
sub _query_clause {
|
||||
my ( $self, $clause ) = @_;
|
||||
my @got;
|
||||
my $results = $self->results;
|
||||
my $where = $clause->{where} || sub {1};
|
||||
|
||||
# Select
|
||||
for my $name ( $results->test_names ) {
|
||||
next unless -f $name;
|
||||
local $_ = $results->test($name);
|
||||
push @got, $name if $where->();
|
||||
}
|
||||
|
||||
# Sort
|
||||
if ( my $order = $clause->{order} ) {
|
||||
@got = map { $_->[0] }
|
||||
sort {
|
||||
( defined $b->[1] <=> defined $a->[1] )
|
||||
|| ( ( $a->[1] || 0 ) <=> ( $b->[1] || 0 ) )
|
||||
} map {
|
||||
[ $_,
|
||||
do { local $_ = $results->test($_); $order->() }
|
||||
]
|
||||
} @got;
|
||||
}
|
||||
|
||||
if ( my $limit = $clause->{limit} ) {
|
||||
@got = splice @got, 0, $limit if @got > $limit;
|
||||
}
|
||||
|
||||
return @got;
|
||||
}
|
||||
|
||||
sub _get_raw_tests {
|
||||
my $self = shift;
|
||||
my $recurse = shift;
|
||||
my @argv = @_;
|
||||
my @tests;
|
||||
|
||||
# Do globbing on Win32.
|
||||
if (NEED_GLOB) {
|
||||
eval "use File::Glob::Windows"; # [49732]
|
||||
@argv = map { glob "$_" } @argv;
|
||||
}
|
||||
my $extensions = $self->{extensions};
|
||||
|
||||
for my $arg (@argv) {
|
||||
if ( '-' eq $arg ) {
|
||||
push @argv => <STDIN>;
|
||||
chomp(@argv);
|
||||
next;
|
||||
}
|
||||
|
||||
push @tests,
|
||||
sort -d $arg
|
||||
? $recurse
|
||||
? $self->_expand_dir_recursive( $arg, $extensions )
|
||||
: map { glob( File::Spec->catfile( $arg, "*$_" ) ) }
|
||||
@{$extensions}
|
||||
: $arg;
|
||||
}
|
||||
return @tests;
|
||||
}
|
||||
|
||||
sub _expand_dir_recursive {
|
||||
my ( $self, $dir, $extensions ) = @_;
|
||||
|
||||
my @tests;
|
||||
my $ext_string = join( '|', map {quotemeta} @{$extensions} );
|
||||
|
||||
find(
|
||||
{ follow => 1, #21938
|
||||
follow_skip => 2,
|
||||
wanted => sub {
|
||||
-f
|
||||
&& /(?:$ext_string)$/
|
||||
&& push @tests => $File::Find::name;
|
||||
}
|
||||
},
|
||||
$dir
|
||||
);
|
||||
return @tests;
|
||||
}
|
||||
|
||||
=head3 C<observe_test>
|
||||
|
||||
Store the results of a test.
|
||||
|
||||
=cut
|
||||
|
||||
# Store:
|
||||
# last fail time
|
||||
# last pass time
|
||||
# last run time
|
||||
# most recent result
|
||||
# most recent todos
|
||||
# total failures
|
||||
# total passes
|
||||
# state generation
|
||||
# parser
|
||||
|
||||
sub observe_test {
|
||||
|
||||
my ( $self, $test_info, $parser ) = @_;
|
||||
my $name = $test_info->[0];
|
||||
my $fail = scalar( $parser->failed ) + ( $parser->has_problems ? 1 : 0 );
|
||||
my $todo = scalar( $parser->todo );
|
||||
my $start_time = $parser->start_time;
|
||||
my $end_time = $parser->end_time,
|
||||
|
||||
my $test = $self->results->test($name);
|
||||
|
||||
$test->sequence( $self->{seq}++ );
|
||||
$test->generation( $self->results->generation );
|
||||
|
||||
$test->run_time($end_time);
|
||||
$test->result($fail);
|
||||
$test->num_todo($todo);
|
||||
$test->elapsed( $end_time - $start_time );
|
||||
|
||||
$test->parser($parser);
|
||||
|
||||
if ($fail) {
|
||||
$test->total_failures( $test->total_failures + 1 );
|
||||
$test->last_fail_time($end_time);
|
||||
}
|
||||
else {
|
||||
$test->total_passes( $test->total_passes + 1 );
|
||||
$test->last_pass_time($end_time);
|
||||
}
|
||||
}
|
||||
|
||||
=head3 C<save>
|
||||
|
||||
Write the state to a file.
|
||||
|
||||
=cut
|
||||
|
||||
sub save {
|
||||
my ($self) = @_;
|
||||
|
||||
my $store = $self->{store} or return;
|
||||
$self->results->last_run_time( $self->get_time );
|
||||
|
||||
my $writer = TAP::Parser::YAMLish::Writer->new;
|
||||
local *FH;
|
||||
open FH, ">$store" or croak "Can't write $store ($!)";
|
||||
$writer->write( $self->results->raw, \*FH );
|
||||
close FH;
|
||||
}
|
||||
|
||||
=head3 C<load>
|
||||
|
||||
Load the state from a file
|
||||
|
||||
=cut
|
||||
|
||||
sub load {
|
||||
my ( $self, $name ) = @_;
|
||||
my $reader = TAP::Parser::YAMLish::Reader->new;
|
||||
local *FH;
|
||||
open FH, "<$name" or croak "Can't read $name ($!)";
|
||||
|
||||
# XXX this is temporary
|
||||
$self->{_} = $self->result_class->new(
|
||||
$reader->read(
|
||||
sub {
|
||||
my $line = <FH>;
|
||||
defined $line && chomp $line;
|
||||
return $line;
|
||||
}
|
||||
)
|
||||
);
|
||||
|
||||
# $writer->write( $self->{tests} || {}, \*FH );
|
||||
close FH;
|
||||
$self->_regen_seq;
|
||||
$self->_prune_and_stamp;
|
||||
$self->results->generation( $self->results->generation + 1 );
|
||||
}
|
||||
|
||||
sub _prune_and_stamp {
|
||||
my $self = shift;
|
||||
|
||||
my $results = $self->results;
|
||||
my @tests = $self->results->tests;
|
||||
for my $test (@tests) {
|
||||
my $name = $test->name;
|
||||
if ( my @stat = stat $name ) {
|
||||
$test->mtime( $stat[9] );
|
||||
}
|
||||
else {
|
||||
$results->remove($name);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub _regen_seq {
|
||||
my $self = shift;
|
||||
for my $test ( $self->results->tests ) {
|
||||
$self->{seq} = $test->sequence + 1
|
||||
if defined $test->sequence && $test->sequence >= $self->{seq};
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,233 @@
|
||||
package App::Prove::State::Result;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp 'croak';
|
||||
|
||||
use App::Prove::State::Result::Test;
|
||||
|
||||
use constant STATE_VERSION => 1;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
App::Prove::State::Result - Individual test suite results.
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Version 3.44
|
||||
|
||||
=cut
|
||||
|
||||
our $VERSION = '3.44';
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The C<prove> command supports a C<--state> option that instructs it to
|
||||
store persistent state across runs. This module encapsulates the results for a
|
||||
single test suite run.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# Re-run failed tests
|
||||
$ prove --state=failed,save -rbv
|
||||
|
||||
=cut
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 Class Methods
|
||||
|
||||
=head3 C<new>
|
||||
|
||||
my $result = App::Prove::State::Result->new({
|
||||
generation => $generation,
|
||||
tests => \%tests,
|
||||
});
|
||||
|
||||
Returns a new C<App::Prove::State::Result> instance.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my ( $class, $arg_for ) = @_;
|
||||
$arg_for ||= {};
|
||||
my %instance_data = %$arg_for; # shallow copy
|
||||
$instance_data{version} = $class->state_version;
|
||||
my $tests = delete $instance_data{tests} || {};
|
||||
my $self = bless \%instance_data => $class;
|
||||
$self->_initialize($tests);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub _initialize {
|
||||
my ( $self, $tests ) = @_;
|
||||
my %tests;
|
||||
while ( my ( $name, $test ) = each %$tests ) {
|
||||
$tests{$name} = $self->test_class->new(
|
||||
{ %$test,
|
||||
name => $name
|
||||
}
|
||||
);
|
||||
}
|
||||
$self->tests( \%tests );
|
||||
return $self;
|
||||
}
|
||||
|
||||
=head2 C<state_version>
|
||||
|
||||
Returns the current version of state storage.
|
||||
|
||||
=cut
|
||||
|
||||
sub state_version {STATE_VERSION}
|
||||
|
||||
=head2 C<test_class>
|
||||
|
||||
Returns the name of the class used for tracking individual tests. This class
|
||||
should either subclass from C<App::Prove::State::Result::Test> or provide an
|
||||
identical interface.
|
||||
|
||||
=cut
|
||||
|
||||
sub test_class {
|
||||
return 'App::Prove::State::Result::Test';
|
||||
}
|
||||
|
||||
my %methods = (
|
||||
generation => { method => 'generation', default => 0 },
|
||||
last_run_time => { method => 'last_run_time', default => undef },
|
||||
);
|
||||
|
||||
while ( my ( $key, $description ) = each %methods ) {
|
||||
my $default = $description->{default};
|
||||
no strict 'refs';
|
||||
*{ $description->{method} } = sub {
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{$key} = shift;
|
||||
return $self;
|
||||
}
|
||||
return $self->{$key} || $default;
|
||||
};
|
||||
}
|
||||
|
||||
=head3 C<generation>
|
||||
|
||||
Getter/setter for the "generation" of the test suite run. The first
|
||||
generation is 1 (one) and subsequent generations are 2, 3, etc.
|
||||
|
||||
=head3 C<last_run_time>
|
||||
|
||||
Getter/setter for the time of the test suite run.
|
||||
|
||||
=head3 C<tests>
|
||||
|
||||
Returns the tests for a given generation. This is a hashref or a hash,
|
||||
depending on context called. The keys to the hash are the individual
|
||||
test names and the value is a hashref with various interesting values.
|
||||
Each k/v pair might resemble something like this:
|
||||
|
||||
't/foo.t' => {
|
||||
elapsed => '0.0428488254547119',
|
||||
gen => '7',
|
||||
last_pass_time => '1219328376.07815',
|
||||
last_result => '0',
|
||||
last_run_time => '1219328376.07815',
|
||||
last_todo => '0',
|
||||
mtime => '1191708862',
|
||||
seq => '192',
|
||||
total_passes => '6',
|
||||
}
|
||||
|
||||
=cut
|
||||
|
||||
sub tests {
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{tests} = shift;
|
||||
return $self;
|
||||
}
|
||||
my %tests = %{ $self->{tests} };
|
||||
my @tests = sort { $a->sequence <=> $b->sequence } values %tests;
|
||||
return wantarray ? @tests : \@tests;
|
||||
}
|
||||
|
||||
=head3 C<test>
|
||||
|
||||
my $test = $result->test('t/customer/create.t');
|
||||
|
||||
Returns an individual C<App::Prove::State::Result::Test> instance for the
|
||||
given test name (usually the filename). Will return a new
|
||||
C<App::Prove::State::Result::Test> instance if the name is not found.
|
||||
|
||||
=cut
|
||||
|
||||
sub test {
|
||||
my ( $self, $name ) = @_;
|
||||
croak("test() requires a test name") unless defined $name;
|
||||
|
||||
my $tests = $self->{tests} ||= {};
|
||||
if ( my $test = $tests->{$name} ) {
|
||||
return $test;
|
||||
}
|
||||
else {
|
||||
my $test = $self->test_class->new( { name => $name } );
|
||||
$self->{tests}->{$name} = $test;
|
||||
return $test;
|
||||
}
|
||||
}
|
||||
|
||||
=head3 C<test_names>
|
||||
|
||||
Returns an list of test names, sorted by run order.
|
||||
|
||||
=cut
|
||||
|
||||
sub test_names {
|
||||
my $self = shift;
|
||||
return map { $_->name } $self->tests;
|
||||
}
|
||||
|
||||
=head3 C<remove>
|
||||
|
||||
$result->remove($test_name); # remove the test
|
||||
my $test = $result->test($test_name); # fatal error
|
||||
|
||||
Removes a given test from results. This is a no-op if the test name is not
|
||||
found.
|
||||
|
||||
=cut
|
||||
|
||||
sub remove {
|
||||
my ( $self, $name ) = @_;
|
||||
delete $self->{tests}->{$name};
|
||||
return $self;
|
||||
}
|
||||
|
||||
=head3 C<num_tests>
|
||||
|
||||
Returns the number of tests for a given test suite result.
|
||||
|
||||
=cut
|
||||
|
||||
sub num_tests { keys %{ shift->{tests} } }
|
||||
|
||||
=head3 C<raw>
|
||||
|
||||
Returns a hashref of raw results, suitable for serialization by YAML.
|
||||
|
||||
=cut
|
||||
|
||||
sub raw {
|
||||
my $self = shift;
|
||||
my %raw = %$self;
|
||||
|
||||
my %tests;
|
||||
for my $test ( $self->tests ) {
|
||||
$tests{ $test->name } = $test->raw;
|
||||
}
|
||||
$raw{tests} = \%tests;
|
||||
return \%raw;
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,152 @@
|
||||
package App::Prove::State::Result::Test;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
App::Prove::State::Result::Test - Individual test results.
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Version 3.44
|
||||
|
||||
=cut
|
||||
|
||||
our $VERSION = '3.44';
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The C<prove> command supports a C<--state> option that instructs it to
|
||||
store persistent state across runs. This module encapsulates the results for a
|
||||
single test.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# Re-run failed tests
|
||||
$ prove --state=failed,save -rbv
|
||||
|
||||
=cut
|
||||
|
||||
my %methods = (
|
||||
name => { method => 'name' },
|
||||
elapsed => { method => 'elapsed', default => 0 },
|
||||
gen => { method => 'generation', default => 1 },
|
||||
last_pass_time => { method => 'last_pass_time', default => undef },
|
||||
last_fail_time => { method => 'last_fail_time', default => undef },
|
||||
last_result => { method => 'result', default => 0 },
|
||||
last_run_time => { method => 'run_time', default => undef },
|
||||
last_todo => { method => 'num_todo', default => 0 },
|
||||
mtime => { method => 'mtime', default => undef },
|
||||
seq => { method => 'sequence', default => 1 },
|
||||
total_passes => { method => 'total_passes', default => 0 },
|
||||
total_failures => { method => 'total_failures', default => 0 },
|
||||
parser => { method => 'parser' },
|
||||
);
|
||||
|
||||
while ( my ( $key, $description ) = each %methods ) {
|
||||
my $default = $description->{default};
|
||||
no strict 'refs';
|
||||
*{ $description->{method} } = sub {
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{$key} = shift;
|
||||
return $self;
|
||||
}
|
||||
return $self->{$key} || $default;
|
||||
};
|
||||
}
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 Class Methods
|
||||
|
||||
=head3 C<new>
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my ( $class, $arg_for ) = @_;
|
||||
$arg_for ||= {};
|
||||
bless $arg_for => $class;
|
||||
}
|
||||
|
||||
=head2 Instance Methods
|
||||
|
||||
=head3 C<name>
|
||||
|
||||
The name of the test. Usually a filename.
|
||||
|
||||
=head3 C<elapsed>
|
||||
|
||||
The total elapsed times the test took to run, in seconds from the epoch..
|
||||
|
||||
=head3 C<generation>
|
||||
|
||||
The number for the "generation" of the test run. The first generation is 1
|
||||
(one) and subsequent generations are 2, 3, etc.
|
||||
|
||||
=head3 C<last_pass_time>
|
||||
|
||||
The last time the test program passed, in seconds from the epoch.
|
||||
|
||||
Returns C<undef> if the program has never passed.
|
||||
|
||||
=head3 C<last_fail_time>
|
||||
|
||||
The last time the test suite failed, in seconds from the epoch.
|
||||
|
||||
Returns C<undef> if the program has never failed.
|
||||
|
||||
=head3 C<mtime>
|
||||
|
||||
Returns the mtime of the test, in seconds from the epoch.
|
||||
|
||||
=head3 C<raw>
|
||||
|
||||
Returns a hashref of raw test data, suitable for serialization by YAML.
|
||||
|
||||
=head3 C<result>
|
||||
|
||||
Currently, whether or not the test suite passed with no 'problems' (such as
|
||||
TODO passed).
|
||||
|
||||
=head3 C<run_time>
|
||||
|
||||
The total time it took for the test to run, in seconds. If C<Time::HiRes> is
|
||||
available, it will have finer granularity.
|
||||
|
||||
=head3 C<num_todo>
|
||||
|
||||
The number of tests with TODO directives.
|
||||
|
||||
=head3 C<sequence>
|
||||
|
||||
The order in which this test was run for the given test suite result.
|
||||
|
||||
=head3 C<total_passes>
|
||||
|
||||
The number of times the test has passed.
|
||||
|
||||
=head3 C<total_failures>
|
||||
|
||||
The number of times the test has failed.
|
||||
|
||||
=head3 C<parser>
|
||||
|
||||
The underlying parser object. This is useful if you need the full
|
||||
information for the test program.
|
||||
|
||||
=cut
|
||||
|
||||
sub raw {
|
||||
my $self = shift;
|
||||
my %raw = %$self;
|
||||
|
||||
# this is backwards-compatibility hack and is not guaranteed.
|
||||
delete $raw{name};
|
||||
delete $raw{parser};
|
||||
return \%raw;
|
||||
}
|
||||
|
||||
1;
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,127 @@
|
||||
package Archive::Tar::Constant;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use vars qw[$VERSION @ISA @EXPORT];
|
||||
|
||||
BEGIN {
|
||||
require Exporter;
|
||||
|
||||
$VERSION = '2.40';
|
||||
@ISA = qw[Exporter];
|
||||
|
||||
require Time::Local if $^O eq "MacOS";
|
||||
}
|
||||
|
||||
@EXPORT = Archive::Tar::Constant->_list_consts( __PACKAGE__ );
|
||||
|
||||
use constant FILE => 0;
|
||||
use constant HARDLINK => 1;
|
||||
use constant SYMLINK => 2;
|
||||
use constant CHARDEV => 3;
|
||||
use constant BLOCKDEV => 4;
|
||||
use constant DIR => 5;
|
||||
use constant FIFO => 6;
|
||||
use constant SOCKET => 8;
|
||||
use constant UNKNOWN => 9;
|
||||
use constant LONGLINK => 'L';
|
||||
use constant LABEL => 'V';
|
||||
|
||||
use constant BUFFER => 4096;
|
||||
use constant HEAD => 512;
|
||||
use constant BLOCK => 512;
|
||||
|
||||
use constant COMPRESS_GZIP => 9;
|
||||
use constant COMPRESS_BZIP => 'bzip2';
|
||||
use constant COMPRESS_XZ => 'xz';
|
||||
|
||||
use constant BLOCK_SIZE => sub { my $n = int($_[0]/BLOCK); $n++ if $_[0] % BLOCK; $n * BLOCK };
|
||||
use constant TAR_PAD => sub { my $x = shift || return; return "\0" x (BLOCK - ($x % BLOCK) ) };
|
||||
use constant TAR_END => "\0" x BLOCK;
|
||||
|
||||
use constant READ_ONLY => sub { shift() ? 'rb' : 'r' };
|
||||
use constant WRITE_ONLY => sub { $_[0] ? 'wb' . shift : 'w' };
|
||||
use constant MODE_READ => sub { $_[0] =~ /^r/ ? 1 : 0 };
|
||||
|
||||
# Pointless assignment to make -w shut up
|
||||
my $getpwuid; $getpwuid = 'unknown' unless eval { my $f = getpwuid (0); };
|
||||
my $getgrgid; $getgrgid = 'unknown' unless eval { my $f = getgrgid (0); };
|
||||
use constant UNAME => sub { $getpwuid || scalar getpwuid( shift() ) || '' };
|
||||
use constant GNAME => sub { $getgrgid || scalar getgrgid( shift() ) || '' };
|
||||
use constant UID => $>;
|
||||
use constant GID => (split ' ', $) )[0];
|
||||
|
||||
use constant MODE => do { 0666 & (0777 & ~umask) };
|
||||
use constant STRIP_MODE => sub { shift() & 0777 };
|
||||
use constant CHECK_SUM => " ";
|
||||
|
||||
use constant UNPACK => 'a100 a8 a8 a8 a12 a12 a8 a1 a100 A6 a2 a32 a32 a8 a8 a155 x12'; # cdrake - size must be a12 - not A12 - or else screws up huge file sizes (>8gb)
|
||||
use constant PACK => 'a100 a8 a8 a8 a12 a12 A8 a1 a100 a6 a2 a32 a32 a8 a8 a155 x12';
|
||||
use constant NAME_LENGTH => 100;
|
||||
use constant PREFIX_LENGTH => 155;
|
||||
|
||||
use constant TIME_OFFSET => ($^O eq "MacOS") ? Time::Local::timelocal(0,0,0,1,0,1970) : 0;
|
||||
use constant MAGIC => "ustar";
|
||||
use constant TAR_VERSION => "00";
|
||||
use constant LONGLINK_NAME => '././@LongLink';
|
||||
use constant PAX_HEADER => 'pax_global_header';
|
||||
|
||||
### allow ZLIB to be turned off using ENV: DEBUG only
|
||||
use constant ZLIB => do { !$ENV{'PERL5_AT_NO_ZLIB'} and
|
||||
eval { require IO::Zlib };
|
||||
$ENV{'PERL5_AT_NO_ZLIB'} || $@ ? 0 : 1
|
||||
};
|
||||
|
||||
### allow BZIP to be turned off using ENV: DEBUG only
|
||||
use constant BZIP => do { !$ENV{'PERL5_AT_NO_BZIP'} and
|
||||
eval { require IO::Uncompress::Bunzip2;
|
||||
require IO::Compress::Bzip2; };
|
||||
$ENV{'PERL5_AT_NO_BZIP'} || $@ ? 0 : 1
|
||||
};
|
||||
|
||||
### allow XZ to be turned off using ENV: DEBUG only
|
||||
use constant XZ => do { !$ENV{'PERL5_AT_NO_XZ'} and
|
||||
eval { require IO::Compress::Xz;
|
||||
require IO::Uncompress::UnXz; };
|
||||
$ENV{'PERL5_AT_NO_XZ'} || $@ ? 0 : 1
|
||||
};
|
||||
|
||||
use constant GZIP_MAGIC_NUM => qr/^(?:\037\213|\037\235)/;
|
||||
|
||||
# ASCII: B Z h 0 9
|
||||
use constant BZIP_MAGIC_NUM => qr/^\x42\x5A\x68[\x30-\x39]/;
|
||||
|
||||
use constant XZ_MAGIC_NUM => qr/^\xFD\x37\x7A\x58\x5A\x00/;
|
||||
|
||||
use constant CAN_CHOWN => sub { ($> == 0 and $^O ne "MacOS" and $^O ne "MSWin32") };
|
||||
use constant CAN_READLINK => ($^O ne 'MSWin32' and $^O !~ /RISC(?:[ _])?OS/i and $^O ne 'VMS');
|
||||
use constant ON_UNIX => ($^O ne 'MSWin32' and $^O ne 'MacOS' and $^O ne 'VMS');
|
||||
use constant ON_VMS => $^O eq 'VMS';
|
||||
|
||||
sub _list_consts {
|
||||
my $class = shift;
|
||||
my $pkg = shift;
|
||||
return unless defined $pkg; # some joker might use '0' as a pkg...
|
||||
|
||||
my @rv;
|
||||
{ no strict 'refs';
|
||||
my $stash = $pkg . '::';
|
||||
|
||||
for my $name (sort keys %$stash ) {
|
||||
|
||||
### is it a subentry?
|
||||
my $sub = $pkg->can( $name );
|
||||
next unless defined $sub;
|
||||
|
||||
next unless defined prototype($sub) and
|
||||
not length prototype($sub);
|
||||
|
||||
push @rv, $name;
|
||||
}
|
||||
}
|
||||
|
||||
return sort @rv;
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,716 @@
|
||||
package Archive::Tar::File;
|
||||
use strict;
|
||||
|
||||
use Carp ();
|
||||
use IO::File;
|
||||
use File::Spec::Unix ();
|
||||
use File::Spec ();
|
||||
use File::Basename ();
|
||||
|
||||
use Archive::Tar::Constant;
|
||||
|
||||
use vars qw[@ISA $VERSION];
|
||||
#@ISA = qw[Archive::Tar];
|
||||
$VERSION = '2.40';
|
||||
|
||||
### set value to 1 to oct() it during the unpack ###
|
||||
|
||||
my $tmpl = [
|
||||
name => 0, # string A100
|
||||
mode => 1, # octal A8
|
||||
uid => 1, # octal A8
|
||||
gid => 1, # octal A8
|
||||
size => 0, # octal # cdrake - not *always* octal.. A12
|
||||
mtime => 1, # octal A12
|
||||
chksum => 1, # octal A8
|
||||
type => 0, # character A1
|
||||
linkname => 0, # string A100
|
||||
magic => 0, # string A6
|
||||
version => 0, # 2 bytes A2
|
||||
uname => 0, # string A32
|
||||
gname => 0, # string A32
|
||||
devmajor => 1, # octal A8
|
||||
devminor => 1, # octal A8
|
||||
prefix => 0, # A155 x 12
|
||||
|
||||
### end UNPACK items ###
|
||||
raw => 0, # the raw data chunk
|
||||
data => 0, # the data associated with the file --
|
||||
# This might be very memory intensive
|
||||
];
|
||||
|
||||
### install get/set accessors for this object.
|
||||
for ( my $i=0; $i<scalar @$tmpl ; $i+=2 ) {
|
||||
my $key = $tmpl->[$i];
|
||||
no strict 'refs';
|
||||
*{__PACKAGE__."::$key"} = sub {
|
||||
my $self = shift;
|
||||
$self->{$key} = $_[0] if @_;
|
||||
|
||||
### just in case the key is not there or undef or something ###
|
||||
{ local $^W = 0;
|
||||
return $self->{$key};
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Archive::Tar::File - a subclass for in-memory extracted file from Archive::Tar
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my @items = $tar->get_files;
|
||||
|
||||
print $_->name, ' ', $_->size, "\n" for @items;
|
||||
|
||||
print $object->get_content;
|
||||
$object->replace_content('new content');
|
||||
|
||||
$object->rename( 'new/full/path/to/file.c' );
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Archive::Tar::Files provides a neat little object layer for in-memory
|
||||
extracted files. It's mostly used internally in Archive::Tar to tidy
|
||||
up the code, but there's no reason users shouldn't use this API as
|
||||
well.
|
||||
|
||||
=head2 Accessors
|
||||
|
||||
A lot of the methods in this package are accessors to the various
|
||||
fields in the tar header:
|
||||
|
||||
=over 4
|
||||
|
||||
=item name
|
||||
|
||||
The file's name
|
||||
|
||||
=item mode
|
||||
|
||||
The file's mode
|
||||
|
||||
=item uid
|
||||
|
||||
The user id owning the file
|
||||
|
||||
=item gid
|
||||
|
||||
The group id owning the file
|
||||
|
||||
=item size
|
||||
|
||||
File size in bytes
|
||||
|
||||
=item mtime
|
||||
|
||||
Modification time. Adjusted to mac-time on MacOS if required
|
||||
|
||||
=item chksum
|
||||
|
||||
Checksum field for the tar header
|
||||
|
||||
=item type
|
||||
|
||||
File type -- numeric, but comparable to exported constants -- see
|
||||
Archive::Tar's documentation
|
||||
|
||||
=item linkname
|
||||
|
||||
If the file is a symlink, the file it's pointing to
|
||||
|
||||
=item magic
|
||||
|
||||
Tar magic string -- not useful for most users
|
||||
|
||||
=item version
|
||||
|
||||
Tar version string -- not useful for most users
|
||||
|
||||
=item uname
|
||||
|
||||
The user name that owns the file
|
||||
|
||||
=item gname
|
||||
|
||||
The group name that owns the file
|
||||
|
||||
=item devmajor
|
||||
|
||||
Device major number in case of a special file
|
||||
|
||||
=item devminor
|
||||
|
||||
Device minor number in case of a special file
|
||||
|
||||
=item prefix
|
||||
|
||||
Any directory to prefix to the extraction path, if any
|
||||
|
||||
=item raw
|
||||
|
||||
Raw tar header -- not useful for most users
|
||||
|
||||
=back
|
||||
|
||||
=head1 Methods
|
||||
|
||||
=head2 Archive::Tar::File->new( file => $path )
|
||||
|
||||
Returns a new Archive::Tar::File object from an existing file.
|
||||
|
||||
Returns undef on failure.
|
||||
|
||||
=head2 Archive::Tar::File->new( data => $path, $data, $opt )
|
||||
|
||||
Returns a new Archive::Tar::File object from data.
|
||||
|
||||
C<$path> defines the file name (which need not exist), C<$data> the
|
||||
file contents, and C<$opt> is a reference to a hash of attributes
|
||||
which may be used to override the default attributes (fields in the
|
||||
tar header), which are described above in the Accessors section.
|
||||
|
||||
Returns undef on failure.
|
||||
|
||||
=head2 Archive::Tar::File->new( chunk => $chunk )
|
||||
|
||||
Returns a new Archive::Tar::File object from a raw 512-byte tar
|
||||
archive chunk.
|
||||
|
||||
Returns undef on failure.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $what = shift;
|
||||
|
||||
my $obj = ($what eq 'chunk') ? __PACKAGE__->_new_from_chunk( @_ ) :
|
||||
($what eq 'file' ) ? __PACKAGE__->_new_from_file( @_ ) :
|
||||
($what eq 'data' ) ? __PACKAGE__->_new_from_data( @_ ) :
|
||||
undef;
|
||||
|
||||
return $obj;
|
||||
}
|
||||
|
||||
### copies the data, creates a clone ###
|
||||
sub clone {
|
||||
my $self = shift;
|
||||
return bless { %$self }, ref $self;
|
||||
}
|
||||
|
||||
sub _new_from_chunk {
|
||||
my $class = shift;
|
||||
my $chunk = shift or return; # 512 bytes of tar header
|
||||
my %hash = @_;
|
||||
|
||||
### filter any arguments on defined-ness of values.
|
||||
### this allows overriding from what the tar-header is saying
|
||||
### about this tar-entry. Particularly useful for @LongLink files
|
||||
my %args = map { $_ => $hash{$_} } grep { defined $hash{$_} } keys %hash;
|
||||
|
||||
### makes it start at 0 actually... :) ###
|
||||
my $i = -1;
|
||||
my %entry = map {
|
||||
my ($s,$v)=($tmpl->[++$i],$tmpl->[++$i]); # cdrake
|
||||
($_)=($_=~/^([^\0]*)/) unless($s eq 'size'); # cdrake
|
||||
$s=> $v ? oct $_ : $_ # cdrake
|
||||
# $tmpl->[++$i] => $tmpl->[++$i] ? oct $_ : $_ # removed by cdrake - mucks up binary sizes >8gb
|
||||
} unpack( UNPACK, $chunk ); # cdrake
|
||||
# } map { /^([^\0]*)/ } unpack( UNPACK, $chunk ); # old - replaced now by cdrake
|
||||
|
||||
|
||||
if(substr($entry{'size'}, 0, 1) eq "\x80") { # binary size extension for files >8gigs (> octal 77777777777777) # cdrake
|
||||
my @sz=unpack("aCSNN",$entry{'size'}); $entry{'size'}=$sz[4]+(2**32)*$sz[3]+$sz[2]*(2**64); # Use the low 80 bits (should use the upper 15 as well, but as at year 2011, that seems unlikely to ever be needed - the numbers are just too big...) # cdrake
|
||||
} else { # cdrake
|
||||
($entry{'size'})=($entry{'size'}=~/^([^\0]*)/); $entry{'size'}=oct $entry{'size'}; # cdrake
|
||||
} # cdrake
|
||||
|
||||
|
||||
my $obj = bless { %entry, %args }, $class;
|
||||
|
||||
### magic is a filetype string.. it should have something like 'ustar' or
|
||||
### something similar... if the chunk is garbage, skip it
|
||||
return unless $obj->magic !~ /\W/;
|
||||
|
||||
### store the original chunk ###
|
||||
$obj->raw( $chunk );
|
||||
|
||||
$obj->type(FILE) if ( (!length $obj->type) or ($obj->type =~ /\W/) );
|
||||
$obj->type(DIR) if ( ($obj->is_file) && ($obj->name =~ m|/$|) );
|
||||
|
||||
|
||||
return $obj;
|
||||
|
||||
}
|
||||
|
||||
sub _new_from_file {
|
||||
my $class = shift;
|
||||
my $path = shift;
|
||||
|
||||
### path has to at least exist
|
||||
return unless defined $path;
|
||||
|
||||
my $type = __PACKAGE__->_filetype($path);
|
||||
my $data = '';
|
||||
|
||||
READ: {
|
||||
unless ($type == DIR ) {
|
||||
my $fh = IO::File->new;
|
||||
|
||||
unless( $fh->open($path) ) {
|
||||
### dangling symlinks are fine, stop reading but continue
|
||||
### creating the object
|
||||
last READ if $type == SYMLINK;
|
||||
|
||||
### otherwise, return from this function --
|
||||
### anything that's *not* a symlink should be
|
||||
### resolvable
|
||||
return;
|
||||
}
|
||||
|
||||
### binmode needed to read files properly on win32 ###
|
||||
binmode $fh;
|
||||
$data = do { local $/; <$fh> };
|
||||
close $fh;
|
||||
}
|
||||
}
|
||||
|
||||
my @items = qw[mode uid gid size mtime];
|
||||
my %hash = map { shift(@items), $_ } (lstat $path)[2,4,5,7,9];
|
||||
|
||||
if (ON_VMS) {
|
||||
### VMS has two UID modes, traditional and POSIX. Normally POSIX is
|
||||
### not used. We currently do not have an easy way to see if we are in
|
||||
### POSIX mode. In traditional mode, the UID is actually the VMS UIC.
|
||||
### The VMS UIC has the upper 16 bits is the GID, which in many cases
|
||||
### the VMS UIC will be larger than 209715, the largest that TAR can
|
||||
### handle. So for now, assume it is traditional if the UID is larger
|
||||
### than 0x10000.
|
||||
|
||||
if ($hash{uid} > 0x10000) {
|
||||
$hash{uid} = $hash{uid} & 0xFFFF;
|
||||
}
|
||||
|
||||
### The file length from stat() is the physical length of the file
|
||||
### However the amount of data read in may be more for some file types.
|
||||
### Fixed length files are read past the logical EOF to end of the block
|
||||
### containing. Other file types get expanded on read because record
|
||||
### delimiters are added.
|
||||
|
||||
my $data_len = length $data;
|
||||
$hash{size} = $data_len if $hash{size} < $data_len;
|
||||
|
||||
}
|
||||
### you *must* set size == 0 on symlinks, or the next entry will be
|
||||
### though of as the contents of the symlink, which is wrong.
|
||||
### this fixes bug #7937
|
||||
$hash{size} = 0 if ($type == DIR or $type == SYMLINK);
|
||||
$hash{mtime} -= TIME_OFFSET;
|
||||
|
||||
### strip the high bits off the mode, which we don't need to store
|
||||
$hash{mode} = STRIP_MODE->( $hash{mode} );
|
||||
|
||||
|
||||
### probably requires some file path munging here ... ###
|
||||
### name and prefix are set later
|
||||
my $obj = {
|
||||
%hash,
|
||||
name => '',
|
||||
chksum => CHECK_SUM,
|
||||
type => $type,
|
||||
linkname => ($type == SYMLINK and CAN_READLINK)
|
||||
? readlink $path
|
||||
: '',
|
||||
magic => MAGIC,
|
||||
version => TAR_VERSION,
|
||||
uname => UNAME->( $hash{uid} ),
|
||||
gname => GNAME->( $hash{gid} ),
|
||||
devmajor => 0, # not handled
|
||||
devminor => 0, # not handled
|
||||
prefix => '',
|
||||
data => $data,
|
||||
};
|
||||
|
||||
bless $obj, $class;
|
||||
|
||||
### fix up the prefix and file from the path
|
||||
my($prefix,$file) = $obj->_prefix_and_file( $path );
|
||||
$obj->prefix( $prefix );
|
||||
$obj->name( $file );
|
||||
|
||||
return $obj;
|
||||
}
|
||||
|
||||
sub _new_from_data {
|
||||
my $class = shift;
|
||||
my $path = shift; return unless defined $path;
|
||||
my $data = shift; return unless defined $data;
|
||||
my $opt = shift;
|
||||
|
||||
my $obj = {
|
||||
data => $data,
|
||||
name => '',
|
||||
mode => MODE,
|
||||
uid => UID,
|
||||
gid => GID,
|
||||
size => length $data,
|
||||
mtime => time - TIME_OFFSET,
|
||||
chksum => CHECK_SUM,
|
||||
type => FILE,
|
||||
linkname => '',
|
||||
magic => MAGIC,
|
||||
version => TAR_VERSION,
|
||||
uname => UNAME->( UID ),
|
||||
gname => GNAME->( GID ),
|
||||
devminor => 0,
|
||||
devmajor => 0,
|
||||
prefix => '',
|
||||
};
|
||||
|
||||
### overwrite with user options, if provided ###
|
||||
if( $opt and ref $opt eq 'HASH' ) {
|
||||
for my $key ( keys %$opt ) {
|
||||
|
||||
### don't write bogus options ###
|
||||
next unless exists $obj->{$key};
|
||||
$obj->{$key} = $opt->{$key};
|
||||
}
|
||||
}
|
||||
|
||||
bless $obj, $class;
|
||||
|
||||
### fix up the prefix and file from the path
|
||||
my($prefix,$file) = $obj->_prefix_and_file( $path );
|
||||
$obj->prefix( $prefix );
|
||||
$obj->name( $file );
|
||||
|
||||
return $obj;
|
||||
}
|
||||
|
||||
sub _prefix_and_file {
|
||||
my $self = shift;
|
||||
my $path = shift;
|
||||
|
||||
my ($vol, $dirs, $file) = File::Spec->splitpath( $path, $self->is_dir );
|
||||
my @dirs = File::Spec->splitdir( File::Spec->canonpath($dirs) );
|
||||
|
||||
### if it's a directory, then $file might be empty
|
||||
$file = pop @dirs if $self->is_dir and not length $file;
|
||||
|
||||
### splitting ../ gives you the relative path in native syntax
|
||||
### Remove the root (000000) directory
|
||||
### The volume from splitpath will also be in native syntax
|
||||
if (ON_VMS) {
|
||||
map { $_ = '..' if $_ eq '-'; $_ = '' if $_ eq '000000' } @dirs;
|
||||
if (length($vol)) {
|
||||
$vol = VMS::Filespec::unixify($vol);
|
||||
unshift @dirs, $vol;
|
||||
}
|
||||
}
|
||||
|
||||
my $prefix = File::Spec::Unix->catdir(@dirs);
|
||||
return( $prefix, $file );
|
||||
}
|
||||
|
||||
sub _filetype {
|
||||
my $self = shift;
|
||||
my $file = shift;
|
||||
|
||||
return unless defined $file;
|
||||
|
||||
return SYMLINK if (-l $file); # Symlink
|
||||
|
||||
return FILE if (-f _); # Plain file
|
||||
|
||||
return DIR if (-d _); # Directory
|
||||
|
||||
return FIFO if (-p _); # Named pipe
|
||||
|
||||
return SOCKET if (-S _); # Socket
|
||||
|
||||
return BLOCKDEV if (-b _); # Block special
|
||||
|
||||
return CHARDEV if (-c _); # Character special
|
||||
|
||||
### shouldn't happen, this is when making archives, not reading ###
|
||||
return LONGLINK if ( $file eq LONGLINK_NAME );
|
||||
|
||||
return UNKNOWN; # Something else (like what?)
|
||||
|
||||
}
|
||||
|
||||
### this method 'downgrades' a file to plain file -- this is used for
|
||||
### symlinks when FOLLOW_SYMLINKS is true.
|
||||
sub _downgrade_to_plainfile {
|
||||
my $entry = shift;
|
||||
$entry->type( FILE );
|
||||
$entry->mode( MODE );
|
||||
$entry->linkname('');
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
=head2 $bool = $file->extract( [ $alternative_name ] )
|
||||
|
||||
Extract this object, optionally to an alternative name.
|
||||
|
||||
See C<< Archive::Tar->extract_file >> for details.
|
||||
|
||||
Returns true on success and false on failure.
|
||||
|
||||
=cut
|
||||
|
||||
sub extract {
|
||||
my $self = shift;
|
||||
|
||||
local $Carp::CarpLevel += 1;
|
||||
|
||||
### avoid circular use, so only require;
|
||||
require Archive::Tar;
|
||||
return Archive::Tar->_extract_file( $self, @_ );
|
||||
}
|
||||
|
||||
=head2 $path = $file->full_path
|
||||
|
||||
Returns the full path from the tar header; this is basically a
|
||||
concatenation of the C<prefix> and C<name> fields.
|
||||
|
||||
=cut
|
||||
|
||||
sub full_path {
|
||||
my $self = shift;
|
||||
|
||||
### if prefix field is empty
|
||||
return $self->name unless defined $self->prefix and length $self->prefix;
|
||||
|
||||
### or otherwise, catfile'd
|
||||
return File::Spec::Unix->catfile( $self->prefix, $self->name );
|
||||
}
|
||||
|
||||
|
||||
=head2 $bool = $file->validate
|
||||
|
||||
Done by Archive::Tar internally when reading the tar file:
|
||||
validate the header against the checksum to ensure integer tar file.
|
||||
|
||||
Returns true on success, false on failure
|
||||
|
||||
=cut
|
||||
|
||||
sub validate {
|
||||
my $self = shift;
|
||||
|
||||
my $raw = $self->raw;
|
||||
|
||||
### don't know why this one is different from the one we /write/ ###
|
||||
substr ($raw, 148, 8) = " ";
|
||||
|
||||
### bug #43513: [PATCH] Accept wrong checksums from SunOS and HP-UX tar
|
||||
### like GNU tar does. See here for details:
|
||||
### http://www.gnu.org/software/tar/manual/tar.html#SEC139
|
||||
### so we do both a signed AND unsigned validate. if one succeeds, that's
|
||||
### good enough
|
||||
return ( (unpack ("%16C*", $raw) == $self->chksum)
|
||||
or (unpack ("%16c*", $raw) == $self->chksum)) ? 1 : 0;
|
||||
}
|
||||
|
||||
=head2 $bool = $file->has_content
|
||||
|
||||
Returns a boolean to indicate whether the current object has content.
|
||||
Some special files like directories and so on never will have any
|
||||
content. This method is mainly to make sure you don't get warnings
|
||||
for using uninitialized values when looking at an object's content.
|
||||
|
||||
=cut
|
||||
|
||||
sub has_content {
|
||||
my $self = shift;
|
||||
return defined $self->data() && length $self->data() ? 1 : 0;
|
||||
}
|
||||
|
||||
=head2 $content = $file->get_content
|
||||
|
||||
Returns the current content for the in-memory file
|
||||
|
||||
=cut
|
||||
|
||||
sub get_content {
|
||||
my $self = shift;
|
||||
$self->data( );
|
||||
}
|
||||
|
||||
=head2 $cref = $file->get_content_by_ref
|
||||
|
||||
Returns the current content for the in-memory file as a scalar
|
||||
reference. Normal users won't need this, but it will save memory if
|
||||
you are dealing with very large data files in your tar archive, since
|
||||
it will pass the contents by reference, rather than make a copy of it
|
||||
first.
|
||||
|
||||
=cut
|
||||
|
||||
sub get_content_by_ref {
|
||||
my $self = shift;
|
||||
|
||||
return \$self->{data};
|
||||
}
|
||||
|
||||
=head2 $bool = $file->replace_content( $content )
|
||||
|
||||
Replace the current content of the file with the new content. This
|
||||
only affects the in-memory archive, not the on-disk version until
|
||||
you write it.
|
||||
|
||||
Returns true on success, false on failure.
|
||||
|
||||
=cut
|
||||
|
||||
sub replace_content {
|
||||
my $self = shift;
|
||||
my $data = shift || '';
|
||||
|
||||
$self->data( $data );
|
||||
$self->size( length $data );
|
||||
return 1;
|
||||
}
|
||||
|
||||
=head2 $bool = $file->rename( $new_name )
|
||||
|
||||
Rename the current file to $new_name.
|
||||
|
||||
Note that you must specify a Unix path for $new_name, since per tar
|
||||
standard, all files in the archive must be Unix paths.
|
||||
|
||||
Returns true on success and false on failure.
|
||||
|
||||
=cut
|
||||
|
||||
sub rename {
|
||||
my $self = shift;
|
||||
my $path = shift;
|
||||
|
||||
return unless defined $path;
|
||||
|
||||
my ($prefix,$file) = $self->_prefix_and_file( $path );
|
||||
|
||||
$self->name( $file );
|
||||
$self->prefix( $prefix );
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
=head2 $bool = $file->chmod $mode)
|
||||
|
||||
Change mode of $file to $mode. The mode can be a string or a number
|
||||
which is interpreted as octal whether or not a leading 0 is given.
|
||||
|
||||
Returns true on success and false on failure.
|
||||
|
||||
=cut
|
||||
|
||||
sub chmod {
|
||||
my $self = shift;
|
||||
my $mode = shift; return unless defined $mode && $mode =~ /^[0-7]{1,4}$/;
|
||||
$self->{mode} = oct($mode);
|
||||
return 1;
|
||||
}
|
||||
|
||||
=head2 $bool = $file->chown( $user [, $group])
|
||||
|
||||
Change owner of $file to $user. If a $group is given that is changed
|
||||
as well. You can also pass a single parameter with a colon separating the
|
||||
use and group as in 'root:wheel'.
|
||||
|
||||
Returns true on success and false on failure.
|
||||
|
||||
=cut
|
||||
|
||||
sub chown {
|
||||
my $self = shift;
|
||||
my $uname = shift;
|
||||
return unless defined $uname;
|
||||
my $gname;
|
||||
if (-1 != index($uname, ':')) {
|
||||
($uname, $gname) = split(/:/, $uname);
|
||||
} else {
|
||||
$gname = shift if @_ > 0;
|
||||
}
|
||||
|
||||
$self->uname( $uname );
|
||||
$self->gname( $gname ) if $gname;
|
||||
return 1;
|
||||
}
|
||||
|
||||
=head1 Convenience methods
|
||||
|
||||
To quickly check the type of a C<Archive::Tar::File> object, you can
|
||||
use the following methods:
|
||||
|
||||
=over 4
|
||||
|
||||
=item $file->is_file
|
||||
|
||||
Returns true if the file is of type C<file>
|
||||
|
||||
=item $file->is_dir
|
||||
|
||||
Returns true if the file is of type C<dir>
|
||||
|
||||
=item $file->is_hardlink
|
||||
|
||||
Returns true if the file is of type C<hardlink>
|
||||
|
||||
=item $file->is_symlink
|
||||
|
||||
Returns true if the file is of type C<symlink>
|
||||
|
||||
=item $file->is_chardev
|
||||
|
||||
Returns true if the file is of type C<chardev>
|
||||
|
||||
=item $file->is_blockdev
|
||||
|
||||
Returns true if the file is of type C<blockdev>
|
||||
|
||||
=item $file->is_fifo
|
||||
|
||||
Returns true if the file is of type C<fifo>
|
||||
|
||||
=item $file->is_socket
|
||||
|
||||
Returns true if the file is of type C<socket>
|
||||
|
||||
=item $file->is_longlink
|
||||
|
||||
Returns true if the file is of type C<LongLink>.
|
||||
Should not happen after a successful C<read>.
|
||||
|
||||
=item $file->is_label
|
||||
|
||||
Returns true if the file is of type C<Label>.
|
||||
Should not happen after a successful C<read>.
|
||||
|
||||
=item $file->is_unknown
|
||||
|
||||
Returns true if the file type is C<unknown>
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
#stupid perl5.5.3 needs to warn if it's not numeric
|
||||
sub is_file { local $^W; FILE == $_[0]->type }
|
||||
sub is_dir { local $^W; DIR == $_[0]->type }
|
||||
sub is_hardlink { local $^W; HARDLINK == $_[0]->type }
|
||||
sub is_symlink { local $^W; SYMLINK == $_[0]->type }
|
||||
sub is_chardev { local $^W; CHARDEV == $_[0]->type }
|
||||
sub is_blockdev { local $^W; BLOCKDEV == $_[0]->type }
|
||||
sub is_fifo { local $^W; FIFO == $_[0]->type }
|
||||
sub is_socket { local $^W; SOCKET == $_[0]->type }
|
||||
sub is_unknown { local $^W; UNKNOWN == $_[0]->type }
|
||||
sub is_longlink { local $^W; LONGLINK eq $_[0]->type }
|
||||
sub is_label { local $^W; LABEL eq $_[0]->type }
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,987 @@
|
||||
package Attribute::Handlers;
|
||||
use 5.006;
|
||||
use Carp;
|
||||
use warnings;
|
||||
use strict;
|
||||
our $AUTOLOAD;
|
||||
our $VERSION = '1.03'; # remember to update version in POD!
|
||||
# $DB::single=1;
|
||||
my $debug= $ENV{DEBUG_ATTRIBUTE_HANDLERS} || 0;
|
||||
my %symcache;
|
||||
sub findsym {
|
||||
my ($pkg, $ref, $type) = @_;
|
||||
return $symcache{$pkg,$ref} if $symcache{$pkg,$ref};
|
||||
$type ||= ref($ref);
|
||||
no strict 'refs';
|
||||
my $symtab = \%{$pkg."::"};
|
||||
for ( keys %$symtab ) { for my $sym ( $$symtab{$_} ) {
|
||||
if (ref $sym && $sym == $ref) {
|
||||
return $symcache{$pkg,$ref} = \*{"$pkg:\:$_"};
|
||||
}
|
||||
use strict;
|
||||
next unless ref ( \$sym ) eq 'GLOB';
|
||||
return $symcache{$pkg,$ref} = \$sym
|
||||
if *{$sym}{$type} && *{$sym}{$type} == $ref;
|
||||
}}
|
||||
}
|
||||
|
||||
my %validtype = (
|
||||
VAR => [qw[SCALAR ARRAY HASH]],
|
||||
ANY => [qw[SCALAR ARRAY HASH CODE]],
|
||||
"" => [qw[SCALAR ARRAY HASH CODE]],
|
||||
SCALAR => [qw[SCALAR]],
|
||||
ARRAY => [qw[ARRAY]],
|
||||
HASH => [qw[HASH]],
|
||||
CODE => [qw[CODE]],
|
||||
);
|
||||
my %lastattr;
|
||||
my @declarations;
|
||||
my %raw;
|
||||
my %phase;
|
||||
my %sigil = (SCALAR=>'$', ARRAY=>'@', HASH=>'%');
|
||||
my $global_phase = 0;
|
||||
my %global_phases = (
|
||||
BEGIN => 0,
|
||||
CHECK => 1,
|
||||
INIT => 2,
|
||||
END => 3,
|
||||
);
|
||||
my @global_phases = qw(BEGIN CHECK INIT END);
|
||||
|
||||
sub _usage_AH_ {
|
||||
croak "Usage: use $_[0] autotie => {AttrName => TieClassName,...}";
|
||||
}
|
||||
|
||||
my $qual_id = qr/^[_a-z]\w*(::[_a-z]\w*)*$/i;
|
||||
|
||||
sub import {
|
||||
my $class = shift @_;
|
||||
return unless $class eq "Attribute::Handlers";
|
||||
while (@_) {
|
||||
my $cmd = shift;
|
||||
if ($cmd =~ /^autotie((?:ref)?)$/) {
|
||||
my $tiedata = ($1 ? '$ref, ' : '') . '@$data';
|
||||
my $mapping = shift;
|
||||
_usage_AH_ $class unless ref($mapping) eq 'HASH';
|
||||
while (my($attr, $tieclass) = each %$mapping) {
|
||||
$tieclass =~ s/^([_a-z]\w*(::[_a-z]\w*)*)(.*)/$1/is;
|
||||
my $args = $3||'()';
|
||||
_usage_AH_ $class unless $attr =~ $qual_id
|
||||
&& $tieclass =~ $qual_id
|
||||
&& eval "use base q\0$tieclass\0; 1";
|
||||
if ($tieclass->isa('Exporter')) {
|
||||
local $Exporter::ExportLevel = 2;
|
||||
$tieclass->import(eval $args);
|
||||
}
|
||||
my $code = qq{
|
||||
: ATTR(VAR) {
|
||||
my (\$ref, \$data) = \@_[2,4];
|
||||
my \$was_arrayref = ref \$data eq 'ARRAY';
|
||||
\$data = [ \$data ] unless \$was_arrayref;
|
||||
my \$type = ref(\$ref)||"value (".(\$ref||"<undef>").")";
|
||||
(\$type eq 'SCALAR')? tie \$\$ref,'$tieclass',$tiedata
|
||||
:(\$type eq 'ARRAY') ? tie \@\$ref,'$tieclass',$tiedata
|
||||
:(\$type eq 'HASH') ? tie \%\$ref,'$tieclass',$tiedata
|
||||
: die "Can't autotie a \$type\n"
|
||||
}
|
||||
};
|
||||
|
||||
if ($attr =~ /\A__CALLER__::/) {
|
||||
no strict 'refs';
|
||||
my $add_import = caller;
|
||||
my $next = defined &{ $add_import . '::import' } && \&{ $add_import . '::import' };
|
||||
*{ $add_import . '::import' } = sub {
|
||||
my $caller = caller;
|
||||
my $full_attr = $attr;
|
||||
$full_attr =~ s/__CALLER__/$caller/;
|
||||
eval qq{ sub $full_attr $code 1; }
|
||||
or die "Internal error: $@";
|
||||
|
||||
goto &$next
|
||||
if $next;
|
||||
my $uni = defined &UNIVERSAL::import && \&UNIVERSAL::import;
|
||||
for my $isa (@{ $add_import . '::ISA' }) {
|
||||
if (my $import = $isa->can('import')) {
|
||||
goto &$import
|
||||
if $import != $uni;
|
||||
}
|
||||
}
|
||||
goto &$uni
|
||||
if $uni;
|
||||
};
|
||||
}
|
||||
else {
|
||||
$attr = caller()."::".$attr unless $attr =~ /::/;
|
||||
eval qq{ sub $attr $code 1; }
|
||||
or die "Internal error: $@";
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
croak "Can't understand $_";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# On older perls, code attribute handlers run before the sub gets placed
|
||||
# in its package. Since the :ATTR handlers need to know the name of the
|
||||
# sub they're applied to, the name lookup (via findsym) needs to be
|
||||
# delayed: we do it immediately before we might need to find attribute
|
||||
# handlers from their name. However, on newer perls (which fix some
|
||||
# problems relating to attribute application), a sub gets placed in its
|
||||
# package before its attributes are processed. In this case, the
|
||||
# delayed name lookup might be too late, because the sub we're looking
|
||||
# for might have already been replaced. So we need to detect which way
|
||||
# round this perl does things, and time the name lookup accordingly.
|
||||
BEGIN {
|
||||
my $delayed;
|
||||
sub Attribute::Handlers::_TEST_::MODIFY_CODE_ATTRIBUTES {
|
||||
$delayed = \&Attribute::Handlers::_TEST_::t != $_[1];
|
||||
return ();
|
||||
}
|
||||
sub Attribute::Handlers::_TEST_::t :T { }
|
||||
*_delayed_name_resolution = sub() { $delayed };
|
||||
undef &Attribute::Handlers::_TEST_::MODIFY_CODE_ATTRIBUTES;
|
||||
undef &Attribute::Handlers::_TEST_::t;
|
||||
}
|
||||
|
||||
sub _resolve_lastattr {
|
||||
return unless $lastattr{ref};
|
||||
my $sym = findsym @lastattr{'pkg','ref'}
|
||||
or die "Internal error: $lastattr{pkg} symbol went missing";
|
||||
my $name = *{$sym}{NAME};
|
||||
warn "Declaration of $name attribute in package $lastattr{pkg} may clash with future reserved word\n"
|
||||
if $^W and $name !~ /[A-Z]/;
|
||||
foreach ( @{$validtype{$lastattr{type}}} ) {
|
||||
no strict 'refs';
|
||||
*{"$lastattr{pkg}::_ATTR_${_}_${name}"} = $lastattr{ref};
|
||||
}
|
||||
%lastattr = ();
|
||||
}
|
||||
|
||||
sub AUTOLOAD {
|
||||
return if $AUTOLOAD =~ /::DESTROY$/;
|
||||
my ($class) = $AUTOLOAD =~ m/(.*)::/g;
|
||||
$AUTOLOAD =~ m/_ATTR_(.*?)_(.*)/ or
|
||||
croak "Can't locate class method '$AUTOLOAD' via package '$class'";
|
||||
croak "Attribute handler '$2' doesn't handle $1 attributes";
|
||||
}
|
||||
|
||||
my $builtin = $] ge '5.027000'
|
||||
? qr/lvalue|method|shared/
|
||||
: qr/lvalue|method|locked|shared|unique/;
|
||||
|
||||
sub _gen_handler_AH_() {
|
||||
return sub {
|
||||
_resolve_lastattr if _delayed_name_resolution;
|
||||
my ($pkg, $ref, @attrs) = @_;
|
||||
my (undef, $filename, $linenum) = caller 2;
|
||||
foreach (@attrs) {
|
||||
my ($attr, $data) = /^([a-z_]\w*)(?:[(](.*)[)])?$/is or next;
|
||||
if ($attr eq 'ATTR') {
|
||||
no strict 'refs';
|
||||
$data ||= "ANY";
|
||||
$raw{$ref} = $data =~ s/\s*,?\s*RAWDATA\s*,?\s*//;
|
||||
$phase{$ref}{BEGIN} = 1
|
||||
if $data =~ s/\s*,?\s*(BEGIN)\s*,?\s*//;
|
||||
$phase{$ref}{INIT} = 1
|
||||
if $data =~ s/\s*,?\s*(INIT)\s*,?\s*//;
|
||||
$phase{$ref}{END} = 1
|
||||
if $data =~ s/\s*,?\s*(END)\s*,?\s*//;
|
||||
$phase{$ref}{CHECK} = 1
|
||||
if $data =~ s/\s*,?\s*(CHECK)\s*,?\s*//
|
||||
|| ! keys %{$phase{$ref}};
|
||||
# Added for cleanup to not pollute next call.
|
||||
(%lastattr = ()),
|
||||
croak "Can't have two ATTR specifiers on one subroutine"
|
||||
if keys %lastattr;
|
||||
croak "Bad attribute type: ATTR($data)"
|
||||
unless $validtype{$data};
|
||||
%lastattr=(pkg=>$pkg,ref=>$ref,type=>$data);
|
||||
_resolve_lastattr unless _delayed_name_resolution;
|
||||
}
|
||||
else {
|
||||
my $type = ref $ref;
|
||||
my $handler = $pkg->can("_ATTR_${type}_${attr}");
|
||||
next unless $handler;
|
||||
my $decl = [$pkg, $ref, $attr, $data,
|
||||
$raw{$handler}, $phase{$handler}, $filename, $linenum];
|
||||
foreach my $gphase (@global_phases) {
|
||||
_apply_handler_AH_($decl,$gphase)
|
||||
if $global_phases{$gphase} <= $global_phase;
|
||||
}
|
||||
if ($global_phase != 0) {
|
||||
# if _gen_handler_AH_ is being called after
|
||||
# CHECK it's for a lexical, so make sure
|
||||
# it didn't want to run anything later
|
||||
|
||||
local $Carp::CarpLevel = 2;
|
||||
carp "Won't be able to apply END handler"
|
||||
if $phase{$handler}{END};
|
||||
}
|
||||
else {
|
||||
push @declarations, $decl
|
||||
}
|
||||
}
|
||||
$_ = undef;
|
||||
}
|
||||
return grep {defined && !/$builtin/} @attrs;
|
||||
}
|
||||
}
|
||||
|
||||
{
|
||||
no strict 'refs';
|
||||
*{"Attribute::Handlers::UNIVERSAL::MODIFY_${_}_ATTRIBUTES"} =
|
||||
_gen_handler_AH_ foreach @{$validtype{ANY}};
|
||||
}
|
||||
push @UNIVERSAL::ISA, 'Attribute::Handlers::UNIVERSAL'
|
||||
unless grep /^Attribute::Handlers::UNIVERSAL$/, @UNIVERSAL::ISA;
|
||||
|
||||
sub _apply_handler_AH_ {
|
||||
my ($declaration, $phase) = @_;
|
||||
my ($pkg, $ref, $attr, $data, $raw, $handlerphase, $filename, $linenum) = @$declaration;
|
||||
return unless $handlerphase->{$phase};
|
||||
print STDERR "Handling $attr on $ref in $phase with [$data]\n"
|
||||
if $debug;
|
||||
my $type = ref $ref;
|
||||
my $handler = "_ATTR_${type}_${attr}";
|
||||
my $sym = findsym($pkg, $ref);
|
||||
$sym ||= $type eq 'CODE' ? 'ANON' : 'LEXICAL';
|
||||
no warnings;
|
||||
if (!$raw && defined($data)) {
|
||||
if ($data ne '') {
|
||||
# keeping the minimum amount of code inside the eval string
|
||||
# makes debugging perl internals issues with this logic easier.
|
||||
my $code= "package $pkg; my \$ref= [$data]; \$data= \$ref; 1";
|
||||
print STDERR "Evaling: '$code'\n"
|
||||
if $debug;
|
||||
local $SIG{__WARN__} = sub{ die };
|
||||
no strict;
|
||||
no warnings;
|
||||
# Note in production we do not need to use the return value from
|
||||
# the eval or even consult $@ after the eval - if the evaled code
|
||||
# compiles and runs successfully then it will update $data with
|
||||
# the compiled form, if it fails then $data stays unchanged. The
|
||||
# return value and $@ are only used for debugging purposes.
|
||||
# IOW we could just replace the following with eval($code);
|
||||
eval($code) or do {
|
||||
print STDERR "Eval failed: $@"
|
||||
if $debug;
|
||||
};
|
||||
}
|
||||
else { $data = undef }
|
||||
}
|
||||
|
||||
# now call the handler with the $data decoded (maybe)
|
||||
$pkg->$handler($sym,
|
||||
(ref $sym eq 'GLOB' ? *{$sym}{ref $ref}||$ref : $ref),
|
||||
$attr,
|
||||
$data,
|
||||
$phase,
|
||||
$filename,
|
||||
$linenum,
|
||||
);
|
||||
return 1;
|
||||
}
|
||||
|
||||
{
|
||||
no warnings 'void';
|
||||
CHECK {
|
||||
$global_phase++;
|
||||
_resolve_lastattr if _delayed_name_resolution;
|
||||
foreach my $decl (@declarations) {
|
||||
_apply_handler_AH_($decl, 'CHECK');
|
||||
}
|
||||
}
|
||||
|
||||
INIT {
|
||||
$global_phase++;
|
||||
foreach my $decl (@declarations) {
|
||||
_apply_handler_AH_($decl, 'INIT');
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
END {
|
||||
$global_phase++;
|
||||
foreach my $decl (@declarations) {
|
||||
_apply_handler_AH_($decl, 'END');
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Attribute::Handlers - Simpler definition of attribute handlers
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
This document describes version 1.03 of Attribute::Handlers.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package MyClass;
|
||||
require 5.006;
|
||||
use Attribute::Handlers;
|
||||
no warnings 'redefine';
|
||||
|
||||
|
||||
sub Good : ATTR(SCALAR) {
|
||||
my ($package, $symbol, $referent, $attr, $data) = @_;
|
||||
|
||||
# Invoked for any scalar variable with a :Good attribute,
|
||||
# provided the variable was declared in MyClass (or
|
||||
# a derived class) or typed to MyClass.
|
||||
|
||||
# Do whatever to $referent here (executed in CHECK phase).
|
||||
...
|
||||
}
|
||||
|
||||
sub Bad : ATTR(SCALAR) {
|
||||
# Invoked for any scalar variable with a :Bad attribute,
|
||||
# provided the variable was declared in MyClass (or
|
||||
# a derived class) or typed to MyClass.
|
||||
...
|
||||
}
|
||||
|
||||
sub Good : ATTR(ARRAY) {
|
||||
# Invoked for any array variable with a :Good attribute,
|
||||
# provided the variable was declared in MyClass (or
|
||||
# a derived class) or typed to MyClass.
|
||||
...
|
||||
}
|
||||
|
||||
sub Good : ATTR(HASH) {
|
||||
# Invoked for any hash variable with a :Good attribute,
|
||||
# provided the variable was declared in MyClass (or
|
||||
# a derived class) or typed to MyClass.
|
||||
...
|
||||
}
|
||||
|
||||
sub Ugly : ATTR(CODE) {
|
||||
# Invoked for any subroutine declared in MyClass (or a
|
||||
# derived class) with an :Ugly attribute.
|
||||
...
|
||||
}
|
||||
|
||||
sub Omni : ATTR {
|
||||
# Invoked for any scalar, array, hash, or subroutine
|
||||
# with an :Omni attribute, provided the variable or
|
||||
# subroutine was declared in MyClass (or a derived class)
|
||||
# or the variable was typed to MyClass.
|
||||
# Use ref($_[2]) to determine what kind of referent it was.
|
||||
...
|
||||
}
|
||||
|
||||
|
||||
use Attribute::Handlers autotie => { Cycle => Tie::Cycle };
|
||||
|
||||
my $next : Cycle(['A'..'Z']);
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module, when inherited by a package, allows that package's class to
|
||||
define attribute handler subroutines for specific attributes. Variables
|
||||
and subroutines subsequently defined in that package, or in packages
|
||||
derived from that package may be given attributes with the same names as
|
||||
the attribute handler subroutines, which will then be called in one of
|
||||
the compilation phases (i.e. in a C<BEGIN>, C<CHECK>, C<INIT>, or C<END>
|
||||
block). (C<UNITCHECK> blocks don't correspond to a global compilation
|
||||
phase, so they can't be specified here.)
|
||||
|
||||
To create a handler, define it as a subroutine with the same name as
|
||||
the desired attribute, and declare the subroutine itself with the
|
||||
attribute C<:ATTR>. For example:
|
||||
|
||||
package LoudDecl;
|
||||
use Attribute::Handlers;
|
||||
|
||||
sub Loud :ATTR {
|
||||
my ($package, $symbol, $referent, $attr, $data, $phase,
|
||||
$filename, $linenum) = @_;
|
||||
print STDERR
|
||||
ref($referent), " ",
|
||||
*{$symbol}{NAME}, " ",
|
||||
"($referent) ", "was just declared ",
|
||||
"and ascribed the ${attr} attribute ",
|
||||
"with data ($data)\n",
|
||||
"in phase $phase\n",
|
||||
"in file $filename at line $linenum\n";
|
||||
}
|
||||
|
||||
This creates a handler for the attribute C<:Loud> in the class LoudDecl.
|
||||
Thereafter, any subroutine declared with a C<:Loud> attribute in the class
|
||||
LoudDecl:
|
||||
|
||||
package LoudDecl;
|
||||
|
||||
sub foo: Loud {...}
|
||||
|
||||
causes the above handler to be invoked, and passed:
|
||||
|
||||
=over
|
||||
|
||||
=item [0]
|
||||
|
||||
the name of the package into which it was declared;
|
||||
|
||||
=item [1]
|
||||
|
||||
a reference to the symbol table entry (typeglob) containing the subroutine;
|
||||
|
||||
=item [2]
|
||||
|
||||
a reference to the subroutine;
|
||||
|
||||
=item [3]
|
||||
|
||||
the name of the attribute;
|
||||
|
||||
=item [4]
|
||||
|
||||
any data associated with that attribute;
|
||||
|
||||
=item [5]
|
||||
|
||||
the name of the phase in which the handler is being invoked;
|
||||
|
||||
=item [6]
|
||||
|
||||
the filename in which the handler is being invoked;
|
||||
|
||||
=item [7]
|
||||
|
||||
the line number in this file.
|
||||
|
||||
=back
|
||||
|
||||
Likewise, declaring any variables with the C<:Loud> attribute within the
|
||||
package:
|
||||
|
||||
package LoudDecl;
|
||||
|
||||
my $foo :Loud;
|
||||
my @foo :Loud;
|
||||
my %foo :Loud;
|
||||
|
||||
will cause the handler to be called with a similar argument list (except,
|
||||
of course, that C<$_[2]> will be a reference to the variable).
|
||||
|
||||
The package name argument will typically be the name of the class into
|
||||
which the subroutine was declared, but it may also be the name of a derived
|
||||
class (since handlers are inherited).
|
||||
|
||||
If a lexical variable is given an attribute, there is no symbol table to
|
||||
which it belongs, so the symbol table argument (C<$_[1]>) is set to the
|
||||
string C<'LEXICAL'> in that case. Likewise, ascribing an attribute to
|
||||
an anonymous subroutine results in a symbol table argument of C<'ANON'>.
|
||||
|
||||
The data argument passes in the value (if any) associated with the
|
||||
attribute. For example, if C<&foo> had been declared:
|
||||
|
||||
sub foo :Loud("turn it up to 11, man!") {...}
|
||||
|
||||
then a reference to an array containing the string
|
||||
C<"turn it up to 11, man!"> would be passed as the last argument.
|
||||
|
||||
Attribute::Handlers makes strenuous efforts to convert
|
||||
the data argument (C<$_[4]>) to a usable form before passing it to
|
||||
the handler (but see L<"Non-interpretive attribute handlers">).
|
||||
If those efforts succeed, the interpreted data is passed in an array
|
||||
reference; if they fail, the raw data is passed as a string.
|
||||
For example, all of these:
|
||||
|
||||
sub foo :Loud(till=>ears=>are=>bleeding) {...}
|
||||
sub foo :Loud(qw/till ears are bleeding/) {...}
|
||||
sub foo :Loud(qw/till, ears, are, bleeding/) {...}
|
||||
sub foo :Loud(till,ears,are,bleeding) {...}
|
||||
|
||||
causes it to pass C<['till','ears','are','bleeding']> as the handler's
|
||||
data argument. While:
|
||||
|
||||
sub foo :Loud(['till','ears','are','bleeding']) {...}
|
||||
|
||||
causes it to pass C<[ ['till','ears','are','bleeding'] ]>; the array
|
||||
reference specified in the data being passed inside the standard
|
||||
array reference indicating successful interpretation.
|
||||
|
||||
However, if the data can't be parsed as valid Perl, then
|
||||
it is passed as an uninterpreted string. For example:
|
||||
|
||||
sub foo :Loud(my,ears,are,bleeding) {...}
|
||||
sub foo :Loud(qw/my ears are bleeding) {...}
|
||||
|
||||
cause the strings C<'my,ears,are,bleeding'> and
|
||||
C<'qw/my ears are bleeding'> respectively to be passed as the
|
||||
data argument.
|
||||
|
||||
If no value is associated with the attribute, C<undef> is passed.
|
||||
|
||||
=head2 Typed lexicals
|
||||
|
||||
Regardless of the package in which it is declared, if a lexical variable is
|
||||
ascribed an attribute, the handler that is invoked is the one belonging to
|
||||
the package to which it is typed. For example, the following declarations:
|
||||
|
||||
package OtherClass;
|
||||
|
||||
my LoudDecl $loudobj : Loud;
|
||||
my LoudDecl @loudobjs : Loud;
|
||||
my LoudDecl %loudobjex : Loud;
|
||||
|
||||
causes the LoudDecl::Loud handler to be invoked (even if OtherClass also
|
||||
defines a handler for C<:Loud> attributes).
|
||||
|
||||
|
||||
=head2 Type-specific attribute handlers
|
||||
|
||||
If an attribute handler is declared and the C<:ATTR> specifier is
|
||||
given the name of a built-in type (C<SCALAR>, C<ARRAY>, C<HASH>, or C<CODE>),
|
||||
the handler is only applied to declarations of that type. For example,
|
||||
the following definition:
|
||||
|
||||
package LoudDecl;
|
||||
|
||||
sub RealLoud :ATTR(SCALAR) { print "Yeeeeow!" }
|
||||
|
||||
creates an attribute handler that applies only to scalars:
|
||||
|
||||
|
||||
package Painful;
|
||||
use base LoudDecl;
|
||||
|
||||
my $metal : RealLoud; # invokes &LoudDecl::RealLoud
|
||||
my @metal : RealLoud; # error: unknown attribute
|
||||
my %metal : RealLoud; # error: unknown attribute
|
||||
sub metal : RealLoud {...} # error: unknown attribute
|
||||
|
||||
You can, of course, declare separate handlers for these types as well
|
||||
(but you'll need to specify C<no warnings 'redefine'> to do it quietly):
|
||||
|
||||
package LoudDecl;
|
||||
use Attribute::Handlers;
|
||||
no warnings 'redefine';
|
||||
|
||||
sub RealLoud :ATTR(SCALAR) { print "Yeeeeow!" }
|
||||
sub RealLoud :ATTR(ARRAY) { print "Urrrrrrrrrr!" }
|
||||
sub RealLoud :ATTR(HASH) { print "Arrrrrgggghhhhhh!" }
|
||||
sub RealLoud :ATTR(CODE) { croak "Real loud sub torpedoed" }
|
||||
|
||||
You can also explicitly indicate that a single handler is meant to be
|
||||
used for all types of referents like so:
|
||||
|
||||
package LoudDecl;
|
||||
use Attribute::Handlers;
|
||||
|
||||
sub SeriousLoud :ATTR(ANY) { warn "Hearing loss imminent" }
|
||||
|
||||
(I.e. C<ATTR(ANY)> is a synonym for C<:ATTR>).
|
||||
|
||||
|
||||
=head2 Non-interpretive attribute handlers
|
||||
|
||||
Occasionally the strenuous efforts Attribute::Handlers makes to convert
|
||||
the data argument (C<$_[4]>) to a usable form before passing it to
|
||||
the handler get in the way.
|
||||
|
||||
You can turn off that eagerness-to-help by declaring
|
||||
an attribute handler with the keyword C<RAWDATA>. For example:
|
||||
|
||||
sub Raw : ATTR(RAWDATA) {...}
|
||||
sub Nekkid : ATTR(SCALAR,RAWDATA) {...}
|
||||
sub Au::Naturale : ATTR(RAWDATA,ANY) {...}
|
||||
|
||||
Then the handler makes absolutely no attempt to interpret the data it
|
||||
receives and simply passes it as a string:
|
||||
|
||||
my $power : Raw(1..100); # handlers receives "1..100"
|
||||
|
||||
=head2 Phase-specific attribute handlers
|
||||
|
||||
By default, attribute handlers are called at the end of the compilation
|
||||
phase (in a C<CHECK> block). This seems to be optimal in most cases because
|
||||
most things that can be defined are defined by that point but nothing has
|
||||
been executed.
|
||||
|
||||
However, it is possible to set up attribute handlers that are called at
|
||||
other points in the program's compilation or execution, by explicitly
|
||||
stating the phase (or phases) in which you wish the attribute handler to
|
||||
be called. For example:
|
||||
|
||||
sub Early :ATTR(SCALAR,BEGIN) {...}
|
||||
sub Normal :ATTR(SCALAR,CHECK) {...}
|
||||
sub Late :ATTR(SCALAR,INIT) {...}
|
||||
sub Final :ATTR(SCALAR,END) {...}
|
||||
sub Bookends :ATTR(SCALAR,BEGIN,END) {...}
|
||||
|
||||
As the last example indicates, a handler may be set up to be (re)called in
|
||||
two or more phases. The phase name is passed as the handler's final argument.
|
||||
|
||||
Note that attribute handlers that are scheduled for the C<BEGIN> phase
|
||||
are handled as soon as the attribute is detected (i.e. before any
|
||||
subsequently defined C<BEGIN> blocks are executed).
|
||||
|
||||
|
||||
=head2 Attributes as C<tie> interfaces
|
||||
|
||||
Attributes make an excellent and intuitive interface through which to tie
|
||||
variables. For example:
|
||||
|
||||
use Attribute::Handlers;
|
||||
use Tie::Cycle;
|
||||
|
||||
sub UNIVERSAL::Cycle : ATTR(SCALAR) {
|
||||
my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
|
||||
$data = [ $data ] unless ref $data eq 'ARRAY';
|
||||
tie $$referent, 'Tie::Cycle', $data;
|
||||
}
|
||||
|
||||
# and thereafter...
|
||||
|
||||
package main;
|
||||
|
||||
my $next : Cycle('A'..'Z'); # $next is now a tied variable
|
||||
|
||||
while (<>) {
|
||||
print $next;
|
||||
}
|
||||
|
||||
Note that, because the C<Cycle> attribute receives its arguments in the
|
||||
C<$data> variable, if the attribute is given a list of arguments, C<$data>
|
||||
will consist of a single array reference; otherwise, it will consist of the
|
||||
single argument directly. Since Tie::Cycle requires its cycling values to
|
||||
be passed as an array reference, this means that we need to wrap
|
||||
non-array-reference arguments in an array constructor:
|
||||
|
||||
$data = [ $data ] unless ref $data eq 'ARRAY';
|
||||
|
||||
Typically, however, things are the other way around: the tieable class expects
|
||||
its arguments as a flattened list, so the attribute looks like:
|
||||
|
||||
sub UNIVERSAL::Cycle : ATTR(SCALAR) {
|
||||
my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
|
||||
my @data = ref $data eq 'ARRAY' ? @$data : $data;
|
||||
tie $$referent, 'Tie::Whatever', @data;
|
||||
}
|
||||
|
||||
|
||||
This software pattern is so widely applicable that Attribute::Handlers
|
||||
provides a way to automate it: specifying C<'autotie'> in the
|
||||
C<use Attribute::Handlers> statement. So, the cycling example,
|
||||
could also be written:
|
||||
|
||||
use Attribute::Handlers autotie => { Cycle => 'Tie::Cycle' };
|
||||
|
||||
# and thereafter...
|
||||
|
||||
package main;
|
||||
|
||||
my $next : Cycle(['A'..'Z']); # $next is now a tied variable
|
||||
|
||||
while (<>) {
|
||||
print $next;
|
||||
}
|
||||
|
||||
Note that we now have to pass the cycling values as an array reference,
|
||||
since the C<autotie> mechanism passes C<tie> a list of arguments as a list
|
||||
(as in the Tie::Whatever example), I<not> as an array reference (as in
|
||||
the original Tie::Cycle example at the start of this section).
|
||||
|
||||
The argument after C<'autotie'> is a reference to a hash in which each key is
|
||||
the name of an attribute to be created, and each value is the class to which
|
||||
variables ascribed that attribute should be tied.
|
||||
|
||||
Note that there is no longer any need to import the Tie::Cycle module --
|
||||
Attribute::Handlers takes care of that automagically. You can even pass
|
||||
arguments to the module's C<import> subroutine, by appending them to the
|
||||
class name. For example:
|
||||
|
||||
use Attribute::Handlers
|
||||
autotie => { Dir => 'Tie::Dir qw(DIR_UNLINK)' };
|
||||
|
||||
If the attribute name is unqualified, the attribute is installed in the
|
||||
current package. Otherwise it is installed in the qualifier's package:
|
||||
|
||||
package Here;
|
||||
|
||||
use Attribute::Handlers autotie => {
|
||||
Other::Good => Tie::SecureHash, # tie attr installed in Other::
|
||||
Bad => Tie::Taxes, # tie attr installed in Here::
|
||||
UNIVERSAL::Ugly => Software::Patent # tie attr installed everywhere
|
||||
};
|
||||
|
||||
Autoties are most commonly used in the module to which they actually tie,
|
||||
and need to export their attributes to any module that calls them. To
|
||||
facilitate this, Attribute::Handlers recognizes a special "pseudo-class" --
|
||||
C<__CALLER__>, which may be specified as the qualifier of an attribute:
|
||||
|
||||
package Tie::Me::Kangaroo::Down::Sport;
|
||||
|
||||
use Attribute::Handlers autotie =>
|
||||
{ '__CALLER__::Roo' => __PACKAGE__ };
|
||||
|
||||
This causes Attribute::Handlers to define the C<Roo> attribute in the package
|
||||
that imports the Tie::Me::Kangaroo::Down::Sport module.
|
||||
|
||||
Note that it is important to quote the __CALLER__::Roo identifier because
|
||||
a bug in perl 5.8 will refuse to parse it and cause an unknown error.
|
||||
|
||||
=head3 Passing the tied object to C<tie>
|
||||
|
||||
Occasionally it is important to pass a reference to the object being tied
|
||||
to the TIESCALAR, TIEHASH, etc. that ties it.
|
||||
|
||||
The C<autotie> mechanism supports this too. The following code:
|
||||
|
||||
use Attribute::Handlers autotieref => { Selfish => Tie::Selfish };
|
||||
my $var : Selfish(@args);
|
||||
|
||||
has the same effect as:
|
||||
|
||||
tie my $var, 'Tie::Selfish', @args;
|
||||
|
||||
But when C<"autotieref"> is used instead of C<"autotie">:
|
||||
|
||||
use Attribute::Handlers autotieref => { Selfish => Tie::Selfish };
|
||||
my $var : Selfish(@args);
|
||||
|
||||
the effect is to pass the C<tie> call an extra reference to the variable
|
||||
being tied:
|
||||
|
||||
tie my $var, 'Tie::Selfish', \$var, @args;
|
||||
|
||||
|
||||
|
||||
=head1 EXAMPLES
|
||||
|
||||
If the class shown in L</SYNOPSIS> were placed in the MyClass.pm
|
||||
module, then the following code:
|
||||
|
||||
package main;
|
||||
use MyClass;
|
||||
|
||||
my MyClass $slr :Good :Bad(1**1-1) :Omni(-vorous);
|
||||
|
||||
package SomeOtherClass;
|
||||
use base MyClass;
|
||||
|
||||
sub tent { 'acle' }
|
||||
|
||||
sub fn :Ugly(sister) :Omni('po',tent()) {...}
|
||||
my @arr :Good :Omni(s/cie/nt/);
|
||||
my %hsh :Good(q/bye/) :Omni(q/bus/);
|
||||
|
||||
|
||||
would cause the following handlers to be invoked:
|
||||
|
||||
# my MyClass $slr :Good :Bad(1**1-1) :Omni(-vorous);
|
||||
|
||||
MyClass::Good:ATTR(SCALAR)( 'MyClass', # class
|
||||
'LEXICAL', # no typeglob
|
||||
\$slr, # referent
|
||||
'Good', # attr name
|
||||
undef # no attr data
|
||||
'CHECK', # compiler phase
|
||||
);
|
||||
|
||||
MyClass::Bad:ATTR(SCALAR)( 'MyClass', # class
|
||||
'LEXICAL', # no typeglob
|
||||
\$slr, # referent
|
||||
'Bad', # attr name
|
||||
0 # eval'd attr data
|
||||
'CHECK', # compiler phase
|
||||
);
|
||||
|
||||
MyClass::Omni:ATTR(SCALAR)( 'MyClass', # class
|
||||
'LEXICAL', # no typeglob
|
||||
\$slr, # referent
|
||||
'Omni', # attr name
|
||||
'-vorous' # eval'd attr data
|
||||
'CHECK', # compiler phase
|
||||
);
|
||||
|
||||
|
||||
# sub fn :Ugly(sister) :Omni('po',tent()) {...}
|
||||
|
||||
MyClass::UGLY:ATTR(CODE)( 'SomeOtherClass', # class
|
||||
\*SomeOtherClass::fn, # typeglob
|
||||
\&SomeOtherClass::fn, # referent
|
||||
'Ugly', # attr name
|
||||
'sister' # eval'd attr data
|
||||
'CHECK', # compiler phase
|
||||
);
|
||||
|
||||
MyClass::Omni:ATTR(CODE)( 'SomeOtherClass', # class
|
||||
\*SomeOtherClass::fn, # typeglob
|
||||
\&SomeOtherClass::fn, # referent
|
||||
'Omni', # attr name
|
||||
['po','acle'] # eval'd attr data
|
||||
'CHECK', # compiler phase
|
||||
);
|
||||
|
||||
|
||||
# my @arr :Good :Omni(s/cie/nt/);
|
||||
|
||||
MyClass::Good:ATTR(ARRAY)( 'SomeOtherClass', # class
|
||||
'LEXICAL', # no typeglob
|
||||
\@arr, # referent
|
||||
'Good', # attr name
|
||||
undef # no attr data
|
||||
'CHECK', # compiler phase
|
||||
);
|
||||
|
||||
MyClass::Omni:ATTR(ARRAY)( 'SomeOtherClass', # class
|
||||
'LEXICAL', # no typeglob
|
||||
\@arr, # referent
|
||||
'Omni', # attr name
|
||||
"" # eval'd attr data
|
||||
'CHECK', # compiler phase
|
||||
);
|
||||
|
||||
|
||||
# my %hsh :Good(q/bye) :Omni(q/bus/);
|
||||
|
||||
MyClass::Good:ATTR(HASH)( 'SomeOtherClass', # class
|
||||
'LEXICAL', # no typeglob
|
||||
\%hsh, # referent
|
||||
'Good', # attr name
|
||||
'q/bye' # raw attr data
|
||||
'CHECK', # compiler phase
|
||||
);
|
||||
|
||||
MyClass::Omni:ATTR(HASH)( 'SomeOtherClass', # class
|
||||
'LEXICAL', # no typeglob
|
||||
\%hsh, # referent
|
||||
'Omni', # attr name
|
||||
'bus' # eval'd attr data
|
||||
'CHECK', # compiler phase
|
||||
);
|
||||
|
||||
|
||||
Installing handlers into UNIVERSAL, makes them...err..universal.
|
||||
For example:
|
||||
|
||||
package Descriptions;
|
||||
use Attribute::Handlers;
|
||||
|
||||
my %name;
|
||||
sub name { return $name{$_[2]}||*{$_[1]}{NAME} }
|
||||
|
||||
sub UNIVERSAL::Name :ATTR {
|
||||
$name{$_[2]} = $_[4];
|
||||
}
|
||||
|
||||
sub UNIVERSAL::Purpose :ATTR {
|
||||
print STDERR "Purpose of ", &name, " is $_[4]\n";
|
||||
}
|
||||
|
||||
sub UNIVERSAL::Unit :ATTR {
|
||||
print STDERR &name, " measured in $_[4]\n";
|
||||
}
|
||||
|
||||
Let's you write:
|
||||
|
||||
use Descriptions;
|
||||
|
||||
my $capacity : Name(capacity)
|
||||
: Purpose(to store max storage capacity for files)
|
||||
: Unit(Gb);
|
||||
|
||||
|
||||
package Other;
|
||||
|
||||
sub foo : Purpose(to foo all data before barring it) { }
|
||||
|
||||
# etc.
|
||||
|
||||
=head1 UTILITY FUNCTIONS
|
||||
|
||||
This module offers a single utility function, C<findsym()>.
|
||||
|
||||
=over 4
|
||||
|
||||
=item findsym
|
||||
|
||||
my $symbol = Attribute::Handlers::findsym($package, $referent);
|
||||
|
||||
The function looks in the symbol table of C<$package> for the typeglob for
|
||||
C<$referent>, which is a reference to a variable or subroutine (SCALAR, ARRAY,
|
||||
HASH, or CODE). If it finds the typeglob, it returns it. Otherwise, it returns
|
||||
undef. Note that C<findsym> memoizes the typeglobs it has previously
|
||||
successfully found, so subsequent calls with the same arguments should be
|
||||
much faster.
|
||||
|
||||
=back
|
||||
|
||||
=head1 DIAGNOSTICS
|
||||
|
||||
=over
|
||||
|
||||
=item C<Bad attribute type: ATTR(%s)>
|
||||
|
||||
An attribute handler was specified with an C<:ATTR(I<ref_type>)>, but the
|
||||
type of referent it was defined to handle wasn't one of the five permitted:
|
||||
C<SCALAR>, C<ARRAY>, C<HASH>, C<CODE>, or C<ANY>.
|
||||
|
||||
=item C<Attribute handler %s doesn't handle %s attributes>
|
||||
|
||||
A handler for attributes of the specified name I<was> defined, but not
|
||||
for the specified type of declaration. Typically encountered when trying
|
||||
to apply a C<VAR> attribute handler to a subroutine, or a C<SCALAR>
|
||||
attribute handler to some other type of variable.
|
||||
|
||||
=item C<Declaration of %s attribute in package %s may clash with future reserved word>
|
||||
|
||||
A handler for an attributes with an all-lowercase name was declared. An
|
||||
attribute with an all-lowercase name might have a meaning to Perl
|
||||
itself some day, even though most don't yet. Use a mixed-case attribute
|
||||
name, instead.
|
||||
|
||||
=item C<Can't have two ATTR specifiers on one subroutine>
|
||||
|
||||
You just can't, okay?
|
||||
Instead, put all the specifications together with commas between them
|
||||
in a single C<ATTR(I<specification>)>.
|
||||
|
||||
=item C<Can't autotie a %s>
|
||||
|
||||
You can only declare autoties for types C<"SCALAR">, C<"ARRAY">, and
|
||||
C<"HASH">. They're the only things (apart from typeglobs -- which are
|
||||
not declarable) that Perl can tie.
|
||||
|
||||
=item C<Internal error: %s symbol went missing>
|
||||
|
||||
Something is rotten in the state of the program. An attributed
|
||||
subroutine ceased to exist between the point it was declared and the point
|
||||
at which its attribute handler(s) would have been called.
|
||||
|
||||
=item C<Won't be able to apply END handler>
|
||||
|
||||
You have defined an END handler for an attribute that is being applied
|
||||
to a lexical variable. Since the variable may not be available during END
|
||||
this won't happen.
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Damian Conway (damian@conway.org). The maintainer of this module is now Rafael
|
||||
Garcia-Suarez (rgarciasuarez@gmail.com).
|
||||
|
||||
Maintainer of the CPAN release is Steffen Mueller (smueller@cpan.org).
|
||||
Contact him with technical difficulties with respect to the packaging of the
|
||||
CPAN module.
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
There are undoubtedly serious bugs lurking somewhere in code this funky :-)
|
||||
Bug reports and other feedback are most welcome.
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright (c) 2001-2014, Damian Conway. All Rights Reserved.
|
||||
This module is free software. It may be used, redistributed
|
||||
and/or modified under the same terms as Perl itself.
|
||||
@@ -0,0 +1,453 @@
|
||||
package AutoLoader;
|
||||
|
||||
use strict;
|
||||
use 5.006_001;
|
||||
|
||||
our($VERSION, $AUTOLOAD);
|
||||
|
||||
my $is_dosish;
|
||||
my $is_epoc;
|
||||
my $is_vms;
|
||||
my $is_macos;
|
||||
|
||||
BEGIN {
|
||||
$is_dosish = $^O eq 'dos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare';
|
||||
$is_epoc = $^O eq 'epoc';
|
||||
$is_vms = $^O eq 'VMS';
|
||||
$is_macos = $^O eq 'MacOS';
|
||||
$VERSION = '5.74';
|
||||
}
|
||||
|
||||
AUTOLOAD {
|
||||
my $sub = $AUTOLOAD;
|
||||
autoload_sub($sub);
|
||||
goto &$sub;
|
||||
}
|
||||
|
||||
sub autoload_sub {
|
||||
my $sub = shift;
|
||||
|
||||
my $filename = AutoLoader::find_filename( $sub );
|
||||
|
||||
my $save = $@;
|
||||
local $!; # Do not munge the value.
|
||||
eval { local $SIG{__DIE__}; require $filename };
|
||||
if ($@) {
|
||||
if (substr($sub,-9) eq '::DESTROY') {
|
||||
no strict 'refs';
|
||||
*$sub = sub {};
|
||||
$@ = undef;
|
||||
} elsif ($@ =~ /^Can't locate/) {
|
||||
# The load might just have failed because the filename was too
|
||||
# long for some old SVR3 systems which treat long names as errors.
|
||||
# If we can successfully truncate a long name then it's worth a go.
|
||||
# There is a slight risk that we could pick up the wrong file here
|
||||
# but autosplit should have warned about that when splitting.
|
||||
if ($filename =~ s/(\w{12,})\.al$/substr($1,0,11).".al"/e){
|
||||
eval { local $SIG{__DIE__}; require $filename };
|
||||
}
|
||||
}
|
||||
if ($@){
|
||||
$@ =~ s/ at .*\n//;
|
||||
my $error = $@;
|
||||
require Carp;
|
||||
Carp::croak($error);
|
||||
}
|
||||
}
|
||||
$@ = $save;
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub find_filename {
|
||||
my $sub = shift;
|
||||
my $filename;
|
||||
# Braces used to preserve $1 et al.
|
||||
{
|
||||
# Try to find the autoloaded file from the package-qualified
|
||||
# name of the sub. e.g., if the sub needed is
|
||||
# Getopt::Long::GetOptions(), then $INC{Getopt/Long.pm} is
|
||||
# something like '/usr/lib/perl5/Getopt/Long.pm', and the
|
||||
# autoload file is '/usr/lib/perl5/auto/Getopt/Long/GetOptions.al'.
|
||||
#
|
||||
# However, if @INC is a relative path, this might not work. If,
|
||||
# for example, @INC = ('lib'), then $INC{Getopt/Long.pm} is
|
||||
# 'lib/Getopt/Long.pm', and we want to require
|
||||
# 'auto/Getopt/Long/GetOptions.al' (without the leading 'lib').
|
||||
# In this case, we simple prepend the 'auto/' and let the
|
||||
# C<require> take care of the searching for us.
|
||||
|
||||
my ($pkg,$func) = ($sub =~ /(.*)::([^:]+)$/);
|
||||
$pkg =~ s#::#/#g;
|
||||
if (defined($filename = $INC{"$pkg.pm"})) {
|
||||
if ($is_macos) {
|
||||
$pkg =~ tr#/#:#;
|
||||
$filename = undef
|
||||
unless $filename =~ s#^(.*)$pkg\.pm\z#$1auto:$pkg:$func.al#s;
|
||||
} else {
|
||||
$filename = undef
|
||||
unless $filename =~ s#^(.*)$pkg\.pm\z#$1auto/$pkg/$func.al#s;
|
||||
}
|
||||
|
||||
# if the file exists, then make sure that it is a
|
||||
# a fully anchored path (i.e either '/usr/lib/auto/foo/bar.al',
|
||||
# or './lib/auto/foo/bar.al'. This avoids C<require> searching
|
||||
# (and failing) to find the 'lib/auto/foo/bar.al' because it
|
||||
# looked for 'lib/lib/auto/foo/bar.al', given @INC = ('lib').
|
||||
|
||||
if (defined $filename and -r $filename) {
|
||||
unless ($filename =~ m|^/|s) {
|
||||
if ($is_dosish) {
|
||||
unless ($filename =~ m{^([a-z]:)?[\\/]}is) {
|
||||
if ($^O ne 'NetWare') {
|
||||
$filename = "./$filename";
|
||||
} else {
|
||||
$filename = "$filename";
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif ($is_epoc) {
|
||||
unless ($filename =~ m{^([a-z?]:)?[\\/]}is) {
|
||||
$filename = "./$filename";
|
||||
}
|
||||
}
|
||||
elsif ($is_vms) {
|
||||
# XXX todo by VMSmiths
|
||||
$filename = "./$filename";
|
||||
}
|
||||
elsif (!$is_macos) {
|
||||
$filename = "./$filename";
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
$filename = undef;
|
||||
}
|
||||
}
|
||||
unless (defined $filename) {
|
||||
# let C<require> do the searching
|
||||
$filename = "auto/$sub.al";
|
||||
$filename =~ s#::#/#g;
|
||||
}
|
||||
}
|
||||
return $filename;
|
||||
}
|
||||
|
||||
sub import {
|
||||
my $pkg = shift;
|
||||
my $callpkg = caller;
|
||||
|
||||
#
|
||||
# Export symbols, but not by accident of inheritance.
|
||||
#
|
||||
|
||||
if ($pkg eq 'AutoLoader') {
|
||||
if ( @_ and $_[0] =~ /^&?AUTOLOAD$/ ) {
|
||||
no strict 'refs';
|
||||
*{ $callpkg . '::AUTOLOAD' } = \&AUTOLOAD;
|
||||
}
|
||||
}
|
||||
|
||||
#
|
||||
# Try to find the autosplit index file. Eg., if the call package
|
||||
# is POSIX, then $INC{POSIX.pm} is something like
|
||||
# '/usr/local/lib/perl5/POSIX.pm', and the autosplit index file is in
|
||||
# '/usr/local/lib/perl5/auto/POSIX/autosplit.ix', so we require that.
|
||||
#
|
||||
# However, if @INC is a relative path, this might not work. If,
|
||||
# for example, @INC = ('lib'), then
|
||||
# $INC{POSIX.pm} is 'lib/POSIX.pm', and we want to require
|
||||
# 'auto/POSIX/autosplit.ix' (without the leading 'lib').
|
||||
#
|
||||
|
||||
(my $calldir = $callpkg) =~ s#::#/#g;
|
||||
my $path = $INC{$calldir . '.pm'};
|
||||
if (defined($path)) {
|
||||
# Try absolute path name, but only eval it if the
|
||||
# transformation from module path to autosplit.ix path
|
||||
# succeeded!
|
||||
my $replaced_okay;
|
||||
if ($is_macos) {
|
||||
(my $malldir = $calldir) =~ tr#/#:#;
|
||||
$replaced_okay = ($path =~ s#^(.*)$malldir\.pm\z#$1auto:$malldir:autosplit.ix#s);
|
||||
} else {
|
||||
$replaced_okay = ($path =~ s#^(.*)$calldir\.pm\z#$1auto/$calldir/autosplit.ix#);
|
||||
}
|
||||
|
||||
eval { require $path; } if $replaced_okay;
|
||||
# If that failed, try relative path with normal @INC searching.
|
||||
if (!$replaced_okay or $@) {
|
||||
$path ="auto/$calldir/autosplit.ix";
|
||||
eval { require $path; };
|
||||
}
|
||||
if ($@) {
|
||||
my $error = $@;
|
||||
require Carp;
|
||||
Carp::carp($error);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub unimport {
|
||||
my $callpkg = caller;
|
||||
|
||||
no strict 'refs';
|
||||
|
||||
for my $exported (qw( AUTOLOAD )) {
|
||||
my $symname = $callpkg . '::' . $exported;
|
||||
undef *{ $symname } if \&{ $symname } == \&{ $exported };
|
||||
*{ $symname } = \&{ $symname };
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
AutoLoader - load subroutines only on demand
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package Foo;
|
||||
use AutoLoader 'AUTOLOAD'; # import the default AUTOLOAD subroutine
|
||||
|
||||
package Bar;
|
||||
use AutoLoader; # don't import AUTOLOAD, define our own
|
||||
sub AUTOLOAD {
|
||||
...
|
||||
$AutoLoader::AUTOLOAD = "...";
|
||||
goto &AutoLoader::AUTOLOAD;
|
||||
}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The B<AutoLoader> module works with the B<AutoSplit> module and the
|
||||
C<__END__> token to defer the loading of some subroutines until they are
|
||||
used rather than loading them all at once.
|
||||
|
||||
To use B<AutoLoader>, the author of a module has to place the
|
||||
definitions of subroutines to be autoloaded after an C<__END__> token.
|
||||
(See L<perldata>.) The B<AutoSplit> module can then be run manually to
|
||||
extract the definitions into individual files F<auto/funcname.al>.
|
||||
|
||||
B<AutoLoader> implements an AUTOLOAD subroutine. When an undefined
|
||||
subroutine in is called in a client module of B<AutoLoader>,
|
||||
B<AutoLoader>'s AUTOLOAD subroutine attempts to locate the subroutine in a
|
||||
file with a name related to the location of the file from which the
|
||||
client module was read. As an example, if F<POSIX.pm> is located in
|
||||
F</usr/local/lib/perl5/POSIX.pm>, B<AutoLoader> will look for perl
|
||||
subroutines B<POSIX> in F</usr/local/lib/perl5/auto/POSIX/*.al>, where
|
||||
the C<.al> file has the same name as the subroutine, sans package. If
|
||||
such a file exists, AUTOLOAD will read and evaluate it,
|
||||
thus (presumably) defining the needed subroutine. AUTOLOAD will then
|
||||
C<goto> the newly defined subroutine.
|
||||
|
||||
Once this process completes for a given function, it is defined, so
|
||||
future calls to the subroutine will bypass the AUTOLOAD mechanism.
|
||||
|
||||
=head2 Subroutine Stubs
|
||||
|
||||
In order for object method lookup and/or prototype checking to operate
|
||||
correctly even when methods have not yet been defined it is necessary to
|
||||
"forward declare" each subroutine (as in C<sub NAME;>). See
|
||||
L<perlsub/"SYNOPSIS">. Such forward declaration creates "subroutine
|
||||
stubs", which are place holders with no code.
|
||||
|
||||
The AutoSplit and B<AutoLoader> modules automate the creation of forward
|
||||
declarations. The AutoSplit module creates an 'index' file containing
|
||||
forward declarations of all the AutoSplit subroutines. When the
|
||||
AutoLoader module is 'use'd it loads these declarations into its callers
|
||||
package.
|
||||
|
||||
Because of this mechanism it is important that B<AutoLoader> is always
|
||||
C<use>d and not C<require>d.
|
||||
|
||||
=head2 Using B<AutoLoader>'s AUTOLOAD Subroutine
|
||||
|
||||
In order to use B<AutoLoader>'s AUTOLOAD subroutine you I<must>
|
||||
explicitly import it:
|
||||
|
||||
use AutoLoader 'AUTOLOAD';
|
||||
|
||||
=head2 Overriding B<AutoLoader>'s AUTOLOAD Subroutine
|
||||
|
||||
Some modules, mainly extensions, provide their own AUTOLOAD subroutines.
|
||||
They typically need to check for some special cases (such as constants)
|
||||
and then fallback to B<AutoLoader>'s AUTOLOAD for the rest.
|
||||
|
||||
Such modules should I<not> import B<AutoLoader>'s AUTOLOAD subroutine.
|
||||
Instead, they should define their own AUTOLOAD subroutines along these
|
||||
lines:
|
||||
|
||||
use AutoLoader;
|
||||
use Carp;
|
||||
|
||||
sub AUTOLOAD {
|
||||
my $sub = $AUTOLOAD;
|
||||
(my $constname = $sub) =~ s/.*:://;
|
||||
my $val = constant($constname, @_ ? $_[0] : 0);
|
||||
if ($! != 0) {
|
||||
if ($! =~ /Invalid/ || $!{EINVAL}) {
|
||||
$AutoLoader::AUTOLOAD = $sub;
|
||||
goto &AutoLoader::AUTOLOAD;
|
||||
}
|
||||
else {
|
||||
croak "Your vendor has not defined constant $constname";
|
||||
}
|
||||
}
|
||||
*$sub = sub { $val }; # same as: eval "sub $sub { $val }";
|
||||
goto &$sub;
|
||||
}
|
||||
|
||||
If any module's own AUTOLOAD subroutine has no need to fallback to the
|
||||
AutoLoader's AUTOLOAD subroutine (because it doesn't have any AutoSplit
|
||||
subroutines), then that module should not use B<AutoLoader> at all.
|
||||
|
||||
=head2 Package Lexicals
|
||||
|
||||
Package lexicals declared with C<my> in the main block of a package
|
||||
using B<AutoLoader> will not be visible to auto-loaded subroutines, due to
|
||||
the fact that the given scope ends at the C<__END__> marker. A module
|
||||
using such variables as package globals will not work properly under the
|
||||
B<AutoLoader>.
|
||||
|
||||
The C<vars> pragma (see L<perlmod/"vars">) may be used in such
|
||||
situations as an alternative to explicitly qualifying all globals with
|
||||
the package namespace. Variables pre-declared with this pragma will be
|
||||
visible to any autoloaded routines (but will not be invisible outside
|
||||
the package, unfortunately).
|
||||
|
||||
=head2 Not Using AutoLoader
|
||||
|
||||
You can stop using AutoLoader by simply
|
||||
|
||||
no AutoLoader;
|
||||
|
||||
=head2 B<AutoLoader> vs. B<SelfLoader>
|
||||
|
||||
The B<AutoLoader> is similar in purpose to B<SelfLoader>: both delay the
|
||||
loading of subroutines.
|
||||
|
||||
B<SelfLoader> uses the C<__DATA__> marker rather than C<__END__>.
|
||||
While this avoids the use of a hierarchy of disk files and the
|
||||
associated open/close for each routine loaded, B<SelfLoader> suffers a
|
||||
startup speed disadvantage in the one-time parsing of the lines after
|
||||
C<__DATA__>, after which routines are cached. B<SelfLoader> can also
|
||||
handle multiple packages in a file.
|
||||
|
||||
B<AutoLoader> only reads code as it is requested, and in many cases
|
||||
should be faster, but requires a mechanism like B<AutoSplit> be used to
|
||||
create the individual files. L<ExtUtils::MakeMaker> will invoke
|
||||
B<AutoSplit> automatically if B<AutoLoader> is used in a module source
|
||||
file.
|
||||
|
||||
=head2 Forcing AutoLoader to Load a Function
|
||||
|
||||
Sometimes, it can be necessary or useful to make sure that a certain
|
||||
function is fully loaded by AutoLoader. This is the case, for example,
|
||||
when you need to wrap a function to inject debugging code. It is also
|
||||
helpful to force early loading of code before forking to make use of
|
||||
copy-on-write as much as possible.
|
||||
|
||||
Starting with AutoLoader 5.73, you can call the
|
||||
C<AutoLoader::autoload_sub> function with the fully-qualified name of
|
||||
the function to load from its F<.al> file. The behaviour is exactly
|
||||
the same as if you called the function, triggering the regular
|
||||
C<AUTOLOAD> mechanism, but it does not actually execute the
|
||||
autoloaded function.
|
||||
|
||||
=head1 CAVEATS
|
||||
|
||||
AutoLoaders prior to Perl 5.002 had a slightly different interface. Any
|
||||
old modules which use B<AutoLoader> should be changed to the new calling
|
||||
style. Typically this just means changing a require to a use, adding
|
||||
the explicit C<'AUTOLOAD'> import if needed, and removing B<AutoLoader>
|
||||
from C<@ISA>.
|
||||
|
||||
On systems with restrictions on file name length, the file corresponding
|
||||
to a subroutine may have a shorter name that the routine itself. This
|
||||
can lead to conflicting file names. The I<AutoSplit> package warns of
|
||||
these potential conflicts when used to split a module.
|
||||
|
||||
AutoLoader may fail to find the autosplit files (or even find the wrong
|
||||
ones) in cases where C<@INC> contains relative paths, B<and> the program
|
||||
does C<chdir>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<SelfLoader> - an autoloader that doesn't use external files.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
C<AutoLoader> is maintained by the perl5-porters. Please direct
|
||||
any questions to the canonical mailing list. Anything that
|
||||
is applicable to the CPAN release can be sent to its maintainer,
|
||||
though.
|
||||
|
||||
Author and Maintainer: The Perl5-Porters <perl5-porters@perl.org>
|
||||
|
||||
Maintainer of the CPAN release: Steffen Mueller <smueller@cpan.org>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This package has been part of the perl core since the first release
|
||||
of perl5. It has been released separately to CPAN so older installations
|
||||
can benefit from bug fixes.
|
||||
|
||||
This package has the same copyright and license as the perl core:
|
||||
|
||||
Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
|
||||
2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
|
||||
2011, 2012, 2013
|
||||
by Larry Wall and others
|
||||
|
||||
All rights reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify
|
||||
it under the terms of either:
|
||||
|
||||
a) the GNU General Public License as published by the Free
|
||||
Software Foundation; either version 1, or (at your option) any
|
||||
later version, or
|
||||
|
||||
b) the "Artistic License" which comes with this Kit.
|
||||
|
||||
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 either
|
||||
the GNU General Public License or the Artistic License for more details.
|
||||
|
||||
You should have received a copy of the Artistic License with this
|
||||
Kit, in the file named "Artistic". If not, I'll be glad to provide one.
|
||||
|
||||
You should also have received a copy of the GNU General Public License
|
||||
along with this program in the file named "Copying". If not, write to the
|
||||
Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
|
||||
MA 02110-1301, USA or visit their web page on the internet at
|
||||
http://www.gnu.org/copyleft/gpl.html.
|
||||
|
||||
For those of you that choose to use the GNU General Public License,
|
||||
my interpretation of the GNU General Public License is that no Perl
|
||||
script falls under the terms of the GPL unless you explicitly put
|
||||
said script under the terms of the GPL yourself. Furthermore, any
|
||||
object code linked with perl does not automatically fall under the
|
||||
terms of the GPL, provided such object code only adds definitions
|
||||
of subroutines and variables, and does not otherwise impair the
|
||||
resulting interpreter from executing any standard Perl script. I
|
||||
consider linking in C subroutines in this manner to be the moral
|
||||
equivalent of defining subroutines in the Perl language itself. You
|
||||
may sell such an object file as proprietary provided that you provide
|
||||
or offer to provide the Perl source, as specified by the GNU General
|
||||
Public License. (This is merely an alternate way of specifying input
|
||||
to the program.) You may also sell a binary produced by the dumping of
|
||||
a running Perl script that belongs to you, provided that you provide or
|
||||
offer to provide the Perl source as specified by the GPL. (The
|
||||
fact that a Perl interpreter and your code are in the same binary file
|
||||
is, in this case, a form of mere aggregation.) This is my interpretation
|
||||
of the GPL. If you still have concerns or difficulties understanding
|
||||
my intent, feel free to contact me. Of course, the Artistic License
|
||||
spells all this out for your protection, so you may prefer to use that.
|
||||
|
||||
=cut
|
||||
@@ -0,0 +1,592 @@
|
||||
package AutoSplit;
|
||||
|
||||
use Exporter ();
|
||||
use Config qw(%Config);
|
||||
use File::Basename ();
|
||||
use File::Path qw(mkpath);
|
||||
use File::Spec::Functions qw(curdir catfile catdir);
|
||||
use strict;
|
||||
our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Verbose, $Keep, $Maxlen,
|
||||
$CheckForAutoloader, $CheckModTime);
|
||||
|
||||
$VERSION = "1.06";
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(&autosplit &autosplit_lib_modules);
|
||||
@EXPORT_OK = qw($Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
AutoSplit - split a package for autoloading
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
autosplit($file, $dir, $keep, $check, $modtime);
|
||||
|
||||
autosplit_lib_modules(@modules);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This function will split up your program into files that the AutoLoader
|
||||
module can handle. It is used by both the standard perl libraries and by
|
||||
the MakeMaker utility, to automatically configure libraries for autoloading.
|
||||
|
||||
The C<autosplit> interface splits the specified file into a hierarchy
|
||||
rooted at the directory C<$dir>. It creates directories as needed to reflect
|
||||
class hierarchy, and creates the file F<autosplit.ix>. This file acts as
|
||||
both forward declaration of all package routines, and as timestamp for the
|
||||
last update of the hierarchy.
|
||||
|
||||
The remaining three arguments to C<autosplit> govern other options to
|
||||
the autosplitter.
|
||||
|
||||
=over 2
|
||||
|
||||
=item $keep
|
||||
|
||||
If the third argument, I<$keep>, is false, then any
|
||||
pre-existing C<*.al> files in the autoload directory are removed if
|
||||
they are no longer part of the module (obsoleted functions).
|
||||
$keep defaults to 0.
|
||||
|
||||
=item $check
|
||||
|
||||
The
|
||||
fourth argument, I<$check>, instructs C<autosplit> to check the module
|
||||
currently being split to ensure that it includes a C<use>
|
||||
specification for the AutoLoader module, and skips the module if
|
||||
AutoLoader is not detected.
|
||||
$check defaults to 1.
|
||||
|
||||
=item $modtime
|
||||
|
||||
Lastly, the I<$modtime> argument specifies
|
||||
that C<autosplit> is to check the modification time of the module
|
||||
against that of the C<autosplit.ix> file, and only split the module if
|
||||
it is newer.
|
||||
$modtime defaults to 1.
|
||||
|
||||
=back
|
||||
|
||||
Typical use of AutoSplit in the perl MakeMaker utility is via the command-line
|
||||
with:
|
||||
|
||||
perl -e 'use AutoSplit; autosplit($ARGV[0], $ARGV[1], 0, 1, 1)'
|
||||
|
||||
Defined as a Make macro, it is invoked with file and directory arguments;
|
||||
C<autosplit> will split the specified file into the specified directory and
|
||||
delete obsolete C<.al> files, after checking first that the module does use
|
||||
the AutoLoader, and ensuring that the module is not already currently split
|
||||
in its current form (the modtime test).
|
||||
|
||||
The C<autosplit_lib_modules> form is used in the building of perl. It takes
|
||||
as input a list of files (modules) that are assumed to reside in a directory
|
||||
B<lib> relative to the current directory. Each file is sent to the
|
||||
autosplitter one at a time, to be split into the directory B<lib/auto>.
|
||||
|
||||
In both usages of the autosplitter, only subroutines defined following the
|
||||
perl I<__END__> token are split out into separate files. Some
|
||||
routines may be placed prior to this marker to force their immediate loading
|
||||
and parsing.
|
||||
|
||||
=head2 Multiple packages
|
||||
|
||||
As of version 1.01 of the AutoSplit module it is possible to have
|
||||
multiple packages within a single file. Both of the following cases
|
||||
are supported:
|
||||
|
||||
package NAME;
|
||||
__END__
|
||||
sub AAA { ... }
|
||||
package NAME::option1;
|
||||
sub BBB { ... }
|
||||
package NAME::option2;
|
||||
sub BBB { ... }
|
||||
|
||||
package NAME;
|
||||
__END__
|
||||
sub AAA { ... }
|
||||
sub NAME::option1::BBB { ... }
|
||||
sub NAME::option2::BBB { ... }
|
||||
|
||||
=head1 DIAGNOSTICS
|
||||
|
||||
C<AutoSplit> will inform the user if it is necessary to create the
|
||||
top-level directory specified in the invocation. It is preferred that
|
||||
the script or installation process that invokes C<AutoSplit> have
|
||||
created the full directory path ahead of time. This warning may
|
||||
indicate that the module is being split into an incorrect path.
|
||||
|
||||
C<AutoSplit> will warn the user of all subroutines whose name causes
|
||||
potential file naming conflicts on machines with drastically limited
|
||||
(8 characters or less) file name length. Since the subroutine name is
|
||||
used as the file name, these warnings can aid in portability to such
|
||||
systems.
|
||||
|
||||
Warnings are issued and the file skipped if C<AutoSplit> cannot locate
|
||||
either the I<__END__> marker or a "package Name;"-style specification.
|
||||
|
||||
C<AutoSplit> will also emit general diagnostics for inability to
|
||||
create directories or files.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
C<AutoSplit> is maintained by the perl5-porters. Please direct
|
||||
any questions to the canonical mailing list. Anything that
|
||||
is applicable to the CPAN release can be sent to its maintainer,
|
||||
though.
|
||||
|
||||
Author and Maintainer: The Perl5-Porters <perl5-porters@perl.org>
|
||||
|
||||
Maintainer of the CPAN release: Steffen Mueller <smueller@cpan.org>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This package has been part of the perl core since the first release
|
||||
of perl5. It has been released separately to CPAN so older installations
|
||||
can benefit from bug fixes.
|
||||
|
||||
This package has the same copyright and license as the perl core:
|
||||
|
||||
Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
|
||||
2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
|
||||
by Larry Wall and others
|
||||
|
||||
All rights reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify
|
||||
it under the terms of either:
|
||||
|
||||
a) the GNU General Public License as published by the Free
|
||||
Software Foundation; either version 1, or (at your option) any
|
||||
later version, or
|
||||
|
||||
b) the "Artistic License" which comes with this Kit.
|
||||
|
||||
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 either
|
||||
the GNU General Public License or the Artistic License for more details.
|
||||
|
||||
You should have received a copy of the Artistic License with this
|
||||
Kit, in the file named "Artistic". If not, I'll be glad to provide one.
|
||||
|
||||
You should also have received a copy of the GNU General Public License
|
||||
along with this program in the file named "Copying". If not, write to the
|
||||
Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
|
||||
02111-1307, USA or visit their web page on the internet at
|
||||
http://www.gnu.org/copyleft/gpl.html.
|
||||
|
||||
For those of you that choose to use the GNU General Public License,
|
||||
my interpretation of the GNU General Public License is that no Perl
|
||||
script falls under the terms of the GPL unless you explicitly put
|
||||
said script under the terms of the GPL yourself. Furthermore, any
|
||||
object code linked with perl does not automatically fall under the
|
||||
terms of the GPL, provided such object code only adds definitions
|
||||
of subroutines and variables, and does not otherwise impair the
|
||||
resulting interpreter from executing any standard Perl script. I
|
||||
consider linking in C subroutines in this manner to be the moral
|
||||
equivalent of defining subroutines in the Perl language itself. You
|
||||
may sell such an object file as proprietary provided that you provide
|
||||
or offer to provide the Perl source, as specified by the GNU General
|
||||
Public License. (This is merely an alternate way of specifying input
|
||||
to the program.) You may also sell a binary produced by the dumping of
|
||||
a running Perl script that belongs to you, provided that you provide or
|
||||
offer to provide the Perl source as specified by the GPL. (The
|
||||
fact that a Perl interpreter and your code are in the same binary file
|
||||
is, in this case, a form of mere aggregation.) This is my interpretation
|
||||
of the GPL. If you still have concerns or difficulties understanding
|
||||
my intent, feel free to contact me. Of course, the Artistic License
|
||||
spells all this out for your protection, so you may prefer to use that.
|
||||
|
||||
=cut
|
||||
|
||||
# for portability warn about names longer than $maxlen
|
||||
$Maxlen = 8; # 8 for dos, 11 (14-".al") for SYSVR3
|
||||
$Verbose = 1; # 0=none, 1=minimal, 2=list .al files
|
||||
$Keep = 0;
|
||||
$CheckForAutoloader = 1;
|
||||
$CheckModTime = 1;
|
||||
|
||||
my $IndexFile = "autosplit.ix"; # file also serves as timestamp
|
||||
my $maxflen = 255;
|
||||
$maxflen = 14 if $Config{'d_flexfnam'} ne 'define';
|
||||
if (defined (&Dos::UseLFN)) {
|
||||
$maxflen = Dos::UseLFN() ? 255 : 11;
|
||||
}
|
||||
my $Is_VMS = ($^O eq 'VMS');
|
||||
|
||||
# allow checking for valid ': attrlist' attachments.
|
||||
# extra jugglery required to support both 5.8 and 5.9/5.10 features
|
||||
# (support for 5.8 required for cross-compiling environments)
|
||||
|
||||
my $attr_list =
|
||||
$] >= 5.009005 ?
|
||||
eval <<'__QR__'
|
||||
qr{
|
||||
\s* : \s*
|
||||
(?:
|
||||
# one attribute
|
||||
(?> # no backtrack
|
||||
(?! \d) \w+
|
||||
(?<nested> \( (?: [^()]++ | (?&nested)++ )*+ \) ) ?
|
||||
)
|
||||
(?: \s* : \s* | \s+ (?! :) )
|
||||
)*
|
||||
}x
|
||||
__QR__
|
||||
:
|
||||
do {
|
||||
# In pre-5.9.5 world we have to do dirty tricks.
|
||||
# (we use 'our' rather than 'my' here, due to the rather complex and buggy
|
||||
# behaviour of lexicals with qr// and (??{$lex}) )
|
||||
our $trick1; # yes, cannot our and assign at the same time.
|
||||
$trick1 = qr{ \( (?: (?> [^()]+ ) | (??{ $trick1 }) )* \) }x;
|
||||
our $trick2 = qr{ (?> (?! \d) \w+ (?:$trick1)? ) (?:\s*\:\s*|\s+(?!\:)) }x;
|
||||
qr{ \s* : \s* (?: $trick2 )* }x;
|
||||
};
|
||||
|
||||
sub autosplit{
|
||||
my($file, $autodir, $keep, $ckal, $ckmt) = @_;
|
||||
# $file - the perl source file to be split (after __END__)
|
||||
# $autodir - the ".../auto" dir below which to write split subs
|
||||
# Handle optional flags:
|
||||
$keep = $Keep unless defined $keep;
|
||||
$ckal = $CheckForAutoloader unless defined $ckal;
|
||||
$ckmt = $CheckModTime unless defined $ckmt;
|
||||
autosplit_file($file, $autodir, $keep, $ckal, $ckmt);
|
||||
}
|
||||
|
||||
sub carp{
|
||||
require Carp;
|
||||
goto &Carp::carp;
|
||||
}
|
||||
|
||||
# This function is used during perl building/installation
|
||||
# ./miniperl -e 'use AutoSplit; autosplit_lib_modules(@ARGV)' ...
|
||||
|
||||
sub autosplit_lib_modules {
|
||||
my(@modules) = @_; # list of Module names
|
||||
local $_; # Avoid clobber.
|
||||
while (defined($_ = shift @modules)) {
|
||||
while (m#([^:]+)::([^:].*)#) { # in case specified as ABC::XYZ
|
||||
$_ = catfile($1, $2);
|
||||
}
|
||||
s|\\|/|g; # bug in ksh OS/2
|
||||
s#^lib/##s; # incase specified as lib/*.pm
|
||||
my($lib) = catfile(curdir(), "lib");
|
||||
if ($Is_VMS) { # may need to convert VMS-style filespecs
|
||||
$lib =~ s#^\[\]#.\/#;
|
||||
}
|
||||
s#^$lib\W+##s; # incase specified as ./lib/*.pm
|
||||
if ($Is_VMS && /[:>\]]/) { # may need to convert VMS-style filespecs
|
||||
my ($dir,$name) = (/(.*])(.*)/s);
|
||||
$dir =~ s/.*lib[\.\]]//s;
|
||||
$dir =~ s#[\.\]]#/#g;
|
||||
$_ = $dir . $name;
|
||||
}
|
||||
autosplit_file(catfile($lib, $_), catfile($lib, "auto"),
|
||||
$Keep, $CheckForAutoloader, $CheckModTime);
|
||||
}
|
||||
0;
|
||||
}
|
||||
|
||||
|
||||
# private functions
|
||||
|
||||
my $self_mod_time = (stat __FILE__)[9];
|
||||
|
||||
sub autosplit_file {
|
||||
my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time)
|
||||
= @_;
|
||||
my(@outfiles);
|
||||
local($_);
|
||||
local($/) = "\n";
|
||||
|
||||
# where to write output files
|
||||
$autodir ||= catfile(curdir(), "lib", "auto");
|
||||
if ($Is_VMS) {
|
||||
($autodir = VMS::Filespec::unixpath($autodir)) =~ s|/\z||;
|
||||
$filename = VMS::Filespec::unixify($filename); # may have dirs
|
||||
}
|
||||
unless (-d $autodir){
|
||||
mkpath($autodir,0,0755);
|
||||
# We should never need to create the auto dir
|
||||
# here. installperl (or similar) should have done
|
||||
# it. Expecting it to exist is a valuable sanity check against
|
||||
# autosplitting into some random directory by mistake.
|
||||
print "Warning: AutoSplit had to create top-level " .
|
||||
"$autodir unexpectedly.\n";
|
||||
}
|
||||
|
||||
# allow just a package name to be used
|
||||
$filename .= ".pm" unless ($filename =~ m/\.pm\z/);
|
||||
|
||||
open(my $in, "<$filename") or die "AutoSplit: Can't open $filename: $!\n";
|
||||
my($pm_mod_time) = (stat($filename))[9];
|
||||
my($autoloader_seen) = 0;
|
||||
my($in_pod) = 0;
|
||||
my($def_package,$last_package,$this_package,$fnr);
|
||||
while (<$in>) {
|
||||
# Skip pod text.
|
||||
$fnr++;
|
||||
$in_pod = 1 if /^=\w/;
|
||||
$in_pod = 0 if /^=cut/;
|
||||
next if ($in_pod || /^=cut/);
|
||||
next if /^\s*#/;
|
||||
|
||||
# record last package name seen
|
||||
$def_package = $1 if (m/^\s*package\s+([\w:]+)\s*;/);
|
||||
++$autoloader_seen if m/^\s*(use|require)\s+AutoLoader\b/;
|
||||
++$autoloader_seen if m/\bISA\s*=.*\bAutoLoader\b/;
|
||||
last if /^__END__/;
|
||||
}
|
||||
if ($check_for_autoloader && !$autoloader_seen){
|
||||
print "AutoSplit skipped $filename: no AutoLoader used\n"
|
||||
if ($Verbose>=2);
|
||||
return 0;
|
||||
}
|
||||
$_ or die "Can't find __END__ in $filename\n";
|
||||
|
||||
$def_package or die "Can't find 'package Name;' in $filename\n";
|
||||
|
||||
my($modpname) = _modpname($def_package);
|
||||
|
||||
# this _has_ to match so we have a reasonable timestamp file
|
||||
die "Package $def_package ($modpname.pm) does not ".
|
||||
"match filename $filename"
|
||||
unless ($filename =~ m/\Q$modpname.pm\E$/ or
|
||||
($^O eq 'dos') or ($^O eq 'MSWin32') or ($^O eq 'NetWare') or
|
||||
$Is_VMS && $filename =~ m/$modpname.pm/i);
|
||||
|
||||
my($al_idx_file) = catfile($autodir, $modpname, $IndexFile);
|
||||
|
||||
if ($check_mod_time){
|
||||
my($al_ts_time) = (stat("$al_idx_file"))[9] || 1;
|
||||
if ($al_ts_time >= $pm_mod_time and
|
||||
$al_ts_time >= $self_mod_time){
|
||||
print "AutoSplit skipped ($al_idx_file newer than $filename)\n"
|
||||
if ($Verbose >= 2);
|
||||
return undef; # one undef, not a list
|
||||
}
|
||||
}
|
||||
|
||||
my($modnamedir) = catdir($autodir, $modpname);
|
||||
print "AutoSplitting $filename ($modnamedir)\n"
|
||||
if $Verbose;
|
||||
|
||||
unless (-d $modnamedir){
|
||||
mkpath($modnamedir,0,0777);
|
||||
}
|
||||
|
||||
# We must try to deal with some SVR3 systems with a limit of 14
|
||||
# characters for file names. Sadly we *cannot* simply truncate all
|
||||
# file names to 14 characters on these systems because we *must*
|
||||
# create filenames which exactly match the names used by AutoLoader.pm.
|
||||
# This is a problem because some systems silently truncate the file
|
||||
# names while others treat long file names as an error.
|
||||
|
||||
my $Is83 = $maxflen==11; # plain, case INSENSITIVE dos filenames
|
||||
|
||||
my(@subnames, $subname, %proto, %package);
|
||||
my @cache = ();
|
||||
my $caching = 1;
|
||||
$last_package = '';
|
||||
my $out;
|
||||
while (<$in>) {
|
||||
$fnr++;
|
||||
$in_pod = 1 if /^=\w/;
|
||||
$in_pod = 0 if /^=cut/;
|
||||
next if ($in_pod || /^=cut/);
|
||||
# the following (tempting) old coding gives big troubles if a
|
||||
# cut is forgotten at EOF:
|
||||
# next if /^=\w/ .. /^=cut/;
|
||||
if (/^package\s+([\w:]+)\s*;/) {
|
||||
$this_package = $def_package = $1;
|
||||
}
|
||||
|
||||
if (/^sub\s+([\w:]+)(\s*(?:\(.*?\))?(?:$attr_list)?)/) {
|
||||
print $out "# end of $last_package\::$subname\n1;\n"
|
||||
if $last_package;
|
||||
$subname = $1;
|
||||
my $proto = $2 || '';
|
||||
if ($subname =~ s/(.*):://){
|
||||
$this_package = $1;
|
||||
} else {
|
||||
$this_package = $def_package;
|
||||
}
|
||||
my $fq_subname = "$this_package\::$subname";
|
||||
$package{$fq_subname} = $this_package;
|
||||
$proto{$fq_subname} = $proto;
|
||||
push(@subnames, $fq_subname);
|
||||
my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3));
|
||||
$modpname = _modpname($this_package);
|
||||
my($modnamedir) = catdir($autodir, $modpname);
|
||||
mkpath($modnamedir,0,0777);
|
||||
my($lpath) = catfile($modnamedir, "$lname.al");
|
||||
my($spath) = catfile($modnamedir, "$sname.al");
|
||||
my $path;
|
||||
|
||||
if (!$Is83 and open($out, ">$lpath")){
|
||||
$path=$lpath;
|
||||
print " writing $lpath\n" if ($Verbose>=2);
|
||||
} else {
|
||||
open($out, ">$spath") or die "Can't create $spath: $!\n";
|
||||
$path=$spath;
|
||||
print " writing $spath (with truncated name)\n"
|
||||
if ($Verbose>=1);
|
||||
}
|
||||
push(@outfiles, $path);
|
||||
my $lineno = $fnr - @cache;
|
||||
print $out <<EOT;
|
||||
# NOTE: Derived from $filename.
|
||||
# Changes made here will be lost when autosplit is run again.
|
||||
# See AutoSplit.pm.
|
||||
package $this_package;
|
||||
|
||||
#line $lineno "$filename (autosplit into $path)"
|
||||
EOT
|
||||
print $out @cache;
|
||||
@cache = ();
|
||||
$caching = 0;
|
||||
}
|
||||
if($caching) {
|
||||
push(@cache, $_) if @cache || /\S/;
|
||||
} else {
|
||||
print $out $_;
|
||||
}
|
||||
if(/^\}/) {
|
||||
if($caching) {
|
||||
print $out @cache;
|
||||
@cache = ();
|
||||
}
|
||||
print $out "\n";
|
||||
$caching = 1;
|
||||
}
|
||||
$last_package = $this_package if defined $this_package;
|
||||
}
|
||||
if ($subname) {
|
||||
print $out @cache,"1;\n# end of $last_package\::$subname\n";
|
||||
close($out);
|
||||
}
|
||||
close($in);
|
||||
|
||||
if (!$keep){ # don't keep any obsolete *.al files in the directory
|
||||
my(%outfiles);
|
||||
# @outfiles{@outfiles} = @outfiles;
|
||||
# perl downcases all filenames on VMS (which upcases all filenames) so
|
||||
# we'd better downcase the sub name list too, or subs with upper case
|
||||
# letters in them will get their .al files deleted right after they're
|
||||
# created. (The mixed case sub name won't match the all-lowercase
|
||||
# filename, and so be cleaned up as a scrap file)
|
||||
if ($Is_VMS or $Is83) {
|
||||
%outfiles = map {lc($_) => lc($_) } @outfiles;
|
||||
} else {
|
||||
@outfiles{@outfiles} = @outfiles;
|
||||
}
|
||||
my(%outdirs,@outdirs);
|
||||
for (@outfiles) {
|
||||
$outdirs{File::Basename::dirname($_)}||=1;
|
||||
}
|
||||
for my $dir (keys %outdirs) {
|
||||
opendir(my $outdir,$dir);
|
||||
foreach (sort readdir($outdir)){
|
||||
next unless /\.al\z/;
|
||||
my($file) = catfile($dir, $_);
|
||||
$file = lc $file if $Is83 or $Is_VMS;
|
||||
next if $outfiles{$file};
|
||||
print " deleting $file\n" if ($Verbose>=2);
|
||||
my($deleted,$thistime); # catch all versions on VMS
|
||||
do { $deleted += ($thistime = unlink $file) } while ($thistime);
|
||||
carp ("Unable to delete $file: $!") unless $deleted;
|
||||
}
|
||||
closedir($outdir);
|
||||
}
|
||||
}
|
||||
|
||||
open(my $ts,">$al_idx_file") or
|
||||
carp ("AutoSplit: unable to create timestamp file ($al_idx_file): $!");
|
||||
print $ts "# Index created by AutoSplit for $filename\n";
|
||||
print $ts "# (file acts as timestamp)\n";
|
||||
$last_package = '';
|
||||
for my $fqs (@subnames) {
|
||||
my($subname) = $fqs;
|
||||
$subname =~ s/.*:://;
|
||||
print $ts "package $package{$fqs};\n"
|
||||
unless $last_package eq $package{$fqs};
|
||||
print $ts "sub $subname $proto{$fqs};\n";
|
||||
$last_package = $package{$fqs};
|
||||
}
|
||||
print $ts "1;\n";
|
||||
close($ts);
|
||||
|
||||
_check_unique($filename, $Maxlen, 1, @outfiles);
|
||||
|
||||
@outfiles;
|
||||
}
|
||||
|
||||
sub _modpname ($) {
|
||||
my($package) = @_;
|
||||
my $modpname = $package;
|
||||
if ($^O eq 'MSWin32') {
|
||||
$modpname =~ s#::#\\#g;
|
||||
} else {
|
||||
my @modpnames = ();
|
||||
while ($modpname =~ m#(.*?[^:])::([^:].*)#) {
|
||||
push @modpnames, $1;
|
||||
$modpname = $2;
|
||||
}
|
||||
$modpname = catfile(@modpnames, $modpname);
|
||||
}
|
||||
if ($Is_VMS) {
|
||||
$modpname = VMS::Filespec::unixify($modpname); # may have dirs
|
||||
}
|
||||
$modpname;
|
||||
}
|
||||
|
||||
sub _check_unique {
|
||||
my($filename, $maxlen, $warn, @outfiles) = @_;
|
||||
my(%notuniq) = ();
|
||||
my(%shorts) = ();
|
||||
my(@toolong) = grep(
|
||||
length(File::Basename::basename($_))
|
||||
> $maxlen,
|
||||
@outfiles
|
||||
);
|
||||
|
||||
foreach (@toolong){
|
||||
my($dir) = File::Basename::dirname($_);
|
||||
my($file) = File::Basename::basename($_);
|
||||
my($trunc) = substr($file,0,$maxlen);
|
||||
$notuniq{$dir}{$trunc} = 1 if $shorts{$dir}{$trunc};
|
||||
$shorts{$dir}{$trunc} = $shorts{$dir}{$trunc} ?
|
||||
"$shorts{$dir}{$trunc}, $file" : $file;
|
||||
}
|
||||
if (%notuniq && $warn){
|
||||
print "$filename: some names are not unique when " .
|
||||
"truncated to $maxlen characters:\n";
|
||||
foreach my $dir (sort keys %notuniq){
|
||||
print " directory $dir:\n";
|
||||
foreach my $trunc (sort keys %{$notuniq{$dir}}) {
|
||||
print " $shorts{$dir}{$trunc} truncate to $trunc\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
# test functions so AutoSplit.pm can be applied to itself:
|
||||
sub test1 ($) { "test 1\n"; }
|
||||
sub test2 ($$) { "test 2\n"; }
|
||||
sub test3 ($$$) { "test 3\n"; }
|
||||
sub testtesttesttest4_1 { "test 4\n"; }
|
||||
sub testtesttesttest4_2 { "duplicate test 4\n"; }
|
||||
sub Just::Another::test5 { "another test 5\n"; }
|
||||
sub test6 { return join ":", __FILE__,__LINE__; }
|
||||
package Yet::Another::AutoSplit;
|
||||
sub testtesttesttest4_1 ($) { "another test 4\n"; }
|
||||
sub testtesttesttest4_2 ($$) { "another duplicate test 4\n"; }
|
||||
package Yet::More::Attributes;
|
||||
sub test_a1 ($) : locked :locked { 1; }
|
||||
sub test_a2 : locked { 1; }
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,934 @@
|
||||
# -*- mode: Perl; buffer-read-only: t -*-
|
||||
#
|
||||
# lib/B/Op_private.pm
|
||||
#
|
||||
# Copyright (C) 2014 by Larry Wall and others
|
||||
#
|
||||
# You may distribute under the terms of either the GNU General Public
|
||||
# License or the Artistic License, as specified in the README file.
|
||||
#
|
||||
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
|
||||
# This file is built by regen/opcode.pl from data in
|
||||
# regen/op_private and pod embedded in regen/opcode.pl.
|
||||
# Any changes made here will be lost!
|
||||
|
||||
=head1 NAME
|
||||
|
||||
B::Op_private - OP op_private flag definitions
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use B::Op_private;
|
||||
|
||||
# flag details for bit 7 of OP_AELEM's op_private:
|
||||
my $name = $B::Op_private::bits{aelem}{7}; # OPpLVAL_INTRO
|
||||
my $value = $B::Op_private::defines{$name}; # 128
|
||||
my $label = $B::Op_private::labels{$name}; # LVINTRO
|
||||
|
||||
# the bit field at bits 5..6 of OP_AELEM's op_private:
|
||||
my $bf = $B::Op_private::bits{aelem}{6};
|
||||
my $mask = $bf->{bitmask}; # etc
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides four global hashes:
|
||||
|
||||
%B::Op_private::bits
|
||||
%B::Op_private::defines
|
||||
%B::Op_private::labels
|
||||
%B::Op_private::ops_using
|
||||
|
||||
which contain information about the per-op meanings of the bits in the
|
||||
op_private field.
|
||||
|
||||
=head2 C<%bits>
|
||||
|
||||
This is indexed by op name and then bit number (0..7). For single bit flags,
|
||||
it returns the name of the define (if any) for that bit:
|
||||
|
||||
$B::Op_private::bits{aelem}{7} eq 'OPpLVAL_INTRO';
|
||||
|
||||
For bit fields, it returns a hash ref containing details about the field.
|
||||
The same reference will be returned for all bit positions that make
|
||||
up the bit field; so for example these both return the same hash ref:
|
||||
|
||||
$bitfield = $B::Op_private::bits{aelem}{5};
|
||||
$bitfield = $B::Op_private::bits{aelem}{6};
|
||||
|
||||
The general format of this hash ref is
|
||||
|
||||
{
|
||||
# The bit range and mask; these are always present.
|
||||
bitmin => 5,
|
||||
bitmax => 6,
|
||||
bitmask => 0x60,
|
||||
|
||||
# (The remaining keys are optional)
|
||||
|
||||
# The names of any defines that were requested:
|
||||
mask_def => 'OPpFOO_MASK',
|
||||
baseshift_def => 'OPpFOO_SHIFT',
|
||||
bitcount_def => 'OPpFOO_BITS',
|
||||
|
||||
# If present, Concise etc will display the value with a 'FOO='
|
||||
# prefix. If it equals '-', then Concise will treat the bit
|
||||
# field as raw bits and not try to interpret it.
|
||||
label => 'FOO',
|
||||
|
||||
# If present, specifies the names of some defines and the
|
||||
# display labels that are used to assign meaning to particu-
|
||||
# lar integer values within the bit field; e.g. 3 is dis-
|
||||
# played as 'C'.
|
||||
enum => [ qw(
|
||||
1 OPpFOO_A A
|
||||
2 OPpFOO_B B
|
||||
3 OPpFOO_C C
|
||||
)],
|
||||
|
||||
};
|
||||
|
||||
|
||||
=head2 C<%defines>
|
||||
|
||||
This gives the value of every C<OPp> define, e.g.
|
||||
|
||||
$B::Op_private::defines{OPpLVAL_INTRO} == 128;
|
||||
|
||||
=head2 C<%labels>
|
||||
|
||||
This gives the short display label for each define, as used by C<B::Concise>
|
||||
and C<perl -Dx>, e.g.
|
||||
|
||||
$B::Op_private::labels{OPpLVAL_INTRO} eq 'LVINTRO';
|
||||
|
||||
If the label equals '-', then Concise will treat the bit as a raw bit and
|
||||
not try to display it symbolically.
|
||||
|
||||
=head2 C<%ops_using>
|
||||
|
||||
For each define, this gives a reference to an array of op names that use
|
||||
the flag.
|
||||
|
||||
@ops_using_lvintro = @{ $B::Op_private::ops_using{OPp_LVAL_INTRO} };
|
||||
|
||||
=cut
|
||||
|
||||
package B::Op_private;
|
||||
|
||||
our %bits;
|
||||
|
||||
|
||||
our $VERSION = "5.038002";
|
||||
|
||||
$bits{$_}{3} = 'OPpENTERSUB_AMPER' for qw(entersub rv2cv);
|
||||
$bits{$_}{6} = 'OPpENTERSUB_DB' for qw(entersub rv2cv);
|
||||
$bits{$_}{2} = 'OPpENTERSUB_HASTARG' for qw(entersub rv2cv);
|
||||
$bits{$_}{6} = 'OPpFLIP_LINENUM' for qw(flip flop);
|
||||
$bits{$_}{1} = 'OPpFT_ACCESS' for qw(fteexec fteread ftewrite ftrexec ftrread ftrwrite);
|
||||
$bits{$_}{4} = 'OPpFT_AFTER_t' for qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero);
|
||||
$bits{$_}{2} = 'OPpFT_STACKED' for qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero);
|
||||
$bits{$_}{3} = 'OPpFT_STACKING' for qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero);
|
||||
$bits{$_}{1} = 'OPpHINT_STRICT_REFS' for qw(entersub multideref rv2av rv2cv rv2gv rv2hv rv2sv);
|
||||
$bits{$_}{5} = 'OPpHUSH_VMSISH' for qw(dbstate nextstate);
|
||||
$bits{$_}{6} = 'OPpINDEX_BOOLNEG' for qw(index rindex);
|
||||
$bits{$_}{1} = 'OPpITER_REVERSED' for qw(enteriter iter);
|
||||
$bits{$_}{7} = 'OPpLVALUE' for qw(leave leaveloop);
|
||||
$bits{$_}{6} = 'OPpLVAL_DEFER' for qw(aelem helem multideref);
|
||||
$bits{$_}{7} = 'OPpLVAL_INTRO' for qw(aelem aslice cond_expr delete emptyavhv enteriter entersub gvsv helem hslice list lvavref lvref lvrefslice multiconcat multideref padav padhv padrange padsv padsv_store pushmark refassign rv2av rv2gv rv2hv rv2sv split undef);
|
||||
$bits{$_}{2} = 'OPpLVREF_ELEM' for qw(lvref refassign);
|
||||
$bits{$_}{3} = 'OPpLVREF_ITER' for qw(lvref refassign);
|
||||
$bits{$_}{3} = 'OPpMAYBE_LVSUB' for qw(aassign aelem akeys aslice av2arylen avhvswitch helem hslice keys kvaslice kvhslice multideref padav padhv pos rv2av rv2gv rv2hv substr values vec);
|
||||
$bits{$_}{4} = 'OPpMAYBE_TRUEBOOL' for qw(blessed padhv ref rv2hv);
|
||||
$bits{$_}{7} = 'OPpOFFBYONE' for qw(caller runcv wantarray);
|
||||
$bits{$_}{5} = 'OPpOPEN_IN_CRLF' for qw(backtick open);
|
||||
$bits{$_}{4} = 'OPpOPEN_IN_RAW' for qw(backtick open);
|
||||
$bits{$_}{7} = 'OPpOPEN_OUT_CRLF' for qw(backtick open);
|
||||
$bits{$_}{6} = 'OPpOPEN_OUT_RAW' for qw(backtick open);
|
||||
$bits{$_}{6} = 'OPpOUR_INTRO' for qw(enteriter gvsv rv2av rv2hv rv2sv split);
|
||||
$bits{$_}{6} = 'OPpPAD_STATE' for qw(emptyavhv lvavref lvref padav padhv padsv padsv_store pushmark refassign undef);
|
||||
$bits{$_}{7} = 'OPpPV_IS_UTF8' for qw(dump goto last next redo);
|
||||
$bits{$_}{6} = 'OPpREFCOUNTED' for qw(leave leaveeval leavesub leavesublv leavewrite);
|
||||
$bits{$_}{2} = 'OPpSLICEWARNING' for qw(aslice hslice padav padhv rv2av rv2hv);
|
||||
$bits{$_}{4} = 'OPpTARGET_MY' for qw(abs add atan2 ceil chdir chmod chomp chown chr chroot concat cos crypt divide emptyavhv exec exp flock floor getpgrp getppid getpriority hex i_add i_divide i_modulo i_multiply i_subtract index int kill left_shift length link log mkdir modulo multiconcat multiply nbit_and nbit_or nbit_xor ncomplement oct ord pow push rand refaddr reftype rename right_shift rindex rmdir schomp scomplement setpgrp setpriority sin sleep sqrt srand stringify subtract symlink system time undef unlink unshift utime wait waitpid);
|
||||
$bits{$_}{0} = 'OPpTRANS_CAN_FORCE_UTF8' for qw(trans transr);
|
||||
$bits{$_}{5} = 'OPpTRANS_COMPLEMENT' for qw(trans transr);
|
||||
$bits{$_}{7} = 'OPpTRANS_DELETE' for qw(trans transr);
|
||||
$bits{$_}{6} = 'OPpTRANS_GROWS' for qw(trans transr);
|
||||
$bits{$_}{2} = 'OPpTRANS_IDENTICAL' for qw(trans transr);
|
||||
$bits{$_}{3} = 'OPpTRANS_SQUASH' for qw(trans transr);
|
||||
$bits{$_}{1} = 'OPpTRANS_USE_SVOP' for qw(trans transr);
|
||||
$bits{$_}{5} = 'OPpTRUEBOOL' for qw(blessed grepwhile index length padav padhv pos ref rindex rv2av rv2hv subst);
|
||||
$bits{$_}{2} = 'OPpUSEINT' for qw(bit_and bit_or bit_xor complement left_shift nbit_and nbit_or nbit_xor ncomplement right_shift sbit_and sbit_or sbit_xor);
|
||||
|
||||
my @bf = (
|
||||
{
|
||||
label => '-',
|
||||
mask_def => 'OPpARG1_MASK',
|
||||
bitmin => 0,
|
||||
bitmax => 0,
|
||||
bitmask => 1,
|
||||
},
|
||||
{
|
||||
label => '-',
|
||||
mask_def => 'OPpARG2_MASK',
|
||||
bitmin => 0,
|
||||
bitmax => 1,
|
||||
bitmask => 3,
|
||||
},
|
||||
{
|
||||
label => 'offset',
|
||||
mask_def => 'OPpAVHVSWITCH_MASK',
|
||||
bitmin => 0,
|
||||
bitmax => 1,
|
||||
bitmask => 3,
|
||||
},
|
||||
{
|
||||
label => '-',
|
||||
mask_def => 'OPpARG3_MASK',
|
||||
bitmin => 0,
|
||||
bitmax => 2,
|
||||
bitmask => 7,
|
||||
},
|
||||
{
|
||||
label => '-',
|
||||
mask_def => 'OPpARG4_MASK',
|
||||
bitmin => 0,
|
||||
bitmax => 3,
|
||||
bitmask => 15,
|
||||
},
|
||||
{
|
||||
label => 'range',
|
||||
mask_def => 'OPpPADRANGE_COUNTMASK',
|
||||
bitcount_def => 'OPpPADRANGE_COUNTSHIFT',
|
||||
bitmin => 0,
|
||||
bitmax => 6,
|
||||
bitmask => 127,
|
||||
},
|
||||
{
|
||||
label => 'key',
|
||||
bitmin => 0,
|
||||
bitmax => 7,
|
||||
bitmask => 255,
|
||||
},
|
||||
{
|
||||
mask_def => 'OPpARGELEM_MASK',
|
||||
bitmin => 1,
|
||||
bitmax => 2,
|
||||
bitmask => 6,
|
||||
enum => [
|
||||
0, 'OPpARGELEM_SV', 'SV',
|
||||
1, 'OPpARGELEM_AV', 'AV',
|
||||
2, 'OPpARGELEM_HV', 'HV',
|
||||
],
|
||||
},
|
||||
{
|
||||
mask_def => 'OPpDEREF',
|
||||
bitmin => 4,
|
||||
bitmax => 5,
|
||||
bitmask => 48,
|
||||
enum => [
|
||||
1, 'OPpDEREF_AV', 'DREFAV',
|
||||
2, 'OPpDEREF_HV', 'DREFHV',
|
||||
3, 'OPpDEREF_SV', 'DREFSV',
|
||||
],
|
||||
},
|
||||
{
|
||||
mask_def => 'OPpLVREF_TYPE',
|
||||
bitmin => 4,
|
||||
bitmax => 5,
|
||||
bitmask => 48,
|
||||
enum => [
|
||||
0, 'OPpLVREF_SV', 'SV',
|
||||
1, 'OPpLVREF_AV', 'AV',
|
||||
2, 'OPpLVREF_HV', 'HV',
|
||||
3, 'OPpLVREF_CV', 'CV',
|
||||
],
|
||||
},
|
||||
);
|
||||
|
||||
@{$bits{aassign}}{6,5,4,2,1,0} = ('OPpASSIGN_COMMON_SCALAR', 'OPpASSIGN_COMMON_RC1', 'OPpASSIGN_COMMON_AGG', 'OPpASSIGN_TRUEBOOL', $bf[1], $bf[1]);
|
||||
$bits{abs}{0} = $bf[0];
|
||||
@{$bits{accept}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{add}}{1,0} = ($bf[1], $bf[1]);
|
||||
$bits{aeach}{0} = $bf[0];
|
||||
@{$bits{aelem}}{5,4,1,0} = ($bf[8], $bf[8], $bf[1], $bf[1]);
|
||||
@{$bits{aelemfast}}{7,6,5,4,3,2,1,0} = ($bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6]);
|
||||
@{$bits{aelemfast_lex}}{7,6,5,4,3,2,1,0} = ($bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6]);
|
||||
@{$bits{aelemfastlex_store}}{7,6,5,4,3,2,1,0} = ($bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6]);
|
||||
$bits{akeys}{0} = $bf[0];
|
||||
$bits{alarm}{0} = $bf[0];
|
||||
$bits{and}{0} = $bf[0];
|
||||
$bits{andassign}{0} = $bf[0];
|
||||
$bits{anonconst}{0} = $bf[0];
|
||||
@{$bits{anonhash}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{anonlist}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{argcheck}{0} = $bf[0];
|
||||
@{$bits{argdefelem}}{7,6,0} = ('OPpARG_IF_UNDEF', 'OPpARG_IF_FALSE', $bf[0]);
|
||||
@{$bits{argelem}}{2,1,0} = ($bf[7], $bf[7], $bf[0]);
|
||||
@{$bits{atan2}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{av2arylen}{0} = $bf[0];
|
||||
$bits{avalues}{0} = $bf[0];
|
||||
@{$bits{avhvswitch}}{1,0} = ($bf[2], $bf[2]);
|
||||
$bits{backtick}{0} = $bf[0];
|
||||
@{$bits{bind}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{binmode}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{bless}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{blessed}{0} = $bf[0];
|
||||
@{$bits{caller}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{catch}{0} = $bf[0];
|
||||
$bits{ceil}{0} = $bf[0];
|
||||
@{$bits{chdir}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{chmod}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{chomp}{0} = $bf[0];
|
||||
$bits{chop}{0} = $bf[0];
|
||||
@{$bits{chown}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{chr}{0} = $bf[0];
|
||||
$bits{chroot}{0} = $bf[0];
|
||||
@{$bits{close}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{closedir}{0} = $bf[0];
|
||||
$bits{cmpchain_and}{0} = $bf[0];
|
||||
$bits{cmpchain_dup}{0} = $bf[0];
|
||||
@{$bits{concat}}{6,1,0} = ('OPpCONCAT_NESTED', $bf[1], $bf[1]);
|
||||
$bits{cond_expr}{0} = $bf[0];
|
||||
@{$bits{connect}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{const}}{6,4,3,2,1} = ('OPpCONST_BARE', 'OPpCONST_ENTERED', 'OPpCONST_STRICT', 'OPpCONST_SHORTCIRCUIT', 'OPpCONST_NOVER');
|
||||
@{$bits{coreargs}}{7,6,1,0} = ('OPpCOREARGS_PUSHMARK', 'OPpCOREARGS_SCALARMOD', 'OPpCOREARGS_DEREF2', 'OPpCOREARGS_DEREF1');
|
||||
$bits{cos}{0} = $bf[0];
|
||||
@{$bits{crypt}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{dbmclose}{0} = $bf[0];
|
||||
@{$bits{dbmopen}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{defined}{0} = $bf[0];
|
||||
@{$bits{delete}}{6,5,0} = ('OPpSLICE', 'OPpKVSLICE', $bf[0]);
|
||||
@{$bits{die}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{divide}}{1,0} = ($bf[1], $bf[1]);
|
||||
$bits{dofile}{0} = $bf[0];
|
||||
$bits{dor}{0} = $bf[0];
|
||||
$bits{dorassign}{0} = $bf[0];
|
||||
$bits{dump}{0} = $bf[0];
|
||||
$bits{each}{0} = $bf[0];
|
||||
@{$bits{emptyavhv}}{5,3,2,1,0} = ('OPpEMPTYAVHV_IS_HV', $bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{entereval}}{6,5,4,3,2,1,0} = ('OPpEVAL_EVALSV', 'OPpEVAL_RE_REPARSING', 'OPpEVAL_COPHH', 'OPpEVAL_BYTES', 'OPpEVAL_UNICODE', 'OPpEVAL_HAS_HH', $bf[0]);
|
||||
$bits{entergiven}{0} = $bf[0];
|
||||
$bits{enteriter}{3} = 'OPpITER_DEF';
|
||||
@{$bits{entersub}}{5,4,0} = ($bf[8], $bf[8], 'OPpENTERSUB_INARGS');
|
||||
$bits{entertry}{0} = $bf[0];
|
||||
$bits{entertrycatch}{0} = $bf[0];
|
||||
$bits{enterwhen}{0} = $bf[0];
|
||||
@{$bits{enterwrite}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{eof}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{eq}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{exec}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{exists}}{6,0} = ('OPpEXISTS_SUB', $bf[0]);
|
||||
@{$bits{exit}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{exp}{0} = $bf[0];
|
||||
$bits{fc}{0} = $bf[0];
|
||||
@{$bits{fcntl}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{fileno}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{flip}{0} = $bf[0];
|
||||
@{$bits{flock}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{floor}{0} = $bf[0];
|
||||
$bits{flop}{0} = $bf[0];
|
||||
@{$bits{formline}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{ftatime}{0} = $bf[0];
|
||||
$bits{ftbinary}{0} = $bf[0];
|
||||
$bits{ftblk}{0} = $bf[0];
|
||||
$bits{ftchr}{0} = $bf[0];
|
||||
$bits{ftctime}{0} = $bf[0];
|
||||
$bits{ftdir}{0} = $bf[0];
|
||||
$bits{fteexec}{0} = $bf[0];
|
||||
$bits{fteowned}{0} = $bf[0];
|
||||
$bits{fteread}{0} = $bf[0];
|
||||
$bits{ftewrite}{0} = $bf[0];
|
||||
$bits{ftfile}{0} = $bf[0];
|
||||
$bits{ftis}{0} = $bf[0];
|
||||
$bits{ftlink}{0} = $bf[0];
|
||||
$bits{ftmtime}{0} = $bf[0];
|
||||
$bits{ftpipe}{0} = $bf[0];
|
||||
$bits{ftrexec}{0} = $bf[0];
|
||||
$bits{ftrowned}{0} = $bf[0];
|
||||
$bits{ftrread}{0} = $bf[0];
|
||||
$bits{ftrwrite}{0} = $bf[0];
|
||||
$bits{ftsgid}{0} = $bf[0];
|
||||
$bits{ftsize}{0} = $bf[0];
|
||||
$bits{ftsock}{0} = $bf[0];
|
||||
$bits{ftsuid}{0} = $bf[0];
|
||||
$bits{ftsvtx}{0} = $bf[0];
|
||||
$bits{fttext}{0} = $bf[0];
|
||||
$bits{fttty}{0} = $bf[0];
|
||||
$bits{ftzero}{0} = $bf[0];
|
||||
@{$bits{ge}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{gelem}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{getc}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{getpeername}{0} = $bf[0];
|
||||
@{$bits{getpgrp}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{getpriority}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{getsockname}{0} = $bf[0];
|
||||
$bits{ggrgid}{0} = $bf[0];
|
||||
$bits{ggrnam}{0} = $bf[0];
|
||||
@{$bits{ghbyaddr}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{ghbyname}{0} = $bf[0];
|
||||
@{$bits{glob}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{gmtime}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{gnbyaddr}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{gnbyname}{0} = $bf[0];
|
||||
$bits{goto}{0} = $bf[0];
|
||||
$bits{gpbyname}{0} = $bf[0];
|
||||
@{$bits{gpbynumber}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{gpwnam}{0} = $bf[0];
|
||||
$bits{gpwuid}{0} = $bf[0];
|
||||
$bits{grepstart}{0} = $bf[0];
|
||||
$bits{grepwhile}{0} = $bf[0];
|
||||
@{$bits{gsbyname}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{gsbyport}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{gsockopt}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{gt}}{1,0} = ($bf[1], $bf[1]);
|
||||
$bits{gv}{5} = 'OPpEARLY_CV';
|
||||
@{$bits{helem}}{5,4,1,0} = ($bf[8], $bf[8], $bf[1], $bf[1]);
|
||||
@{$bits{helemexistsor}}{7,0} = ('OPpHELEMEXISTSOR_DELETE', $bf[0]);
|
||||
$bits{hex}{0} = $bf[0];
|
||||
@{$bits{i_add}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{i_divide}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{i_eq}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{i_ge}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{i_gt}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{i_le}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{i_lt}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{i_modulo}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{i_multiply}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{i_ncmp}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{i_ne}}{1,0} = ($bf[1], $bf[1]);
|
||||
$bits{i_negate}{0} = $bf[0];
|
||||
$bits{i_postdec}{0} = $bf[0];
|
||||
$bits{i_postinc}{0} = $bf[0];
|
||||
$bits{i_predec}{0} = $bf[0];
|
||||
$bits{i_preinc}{0} = $bf[0];
|
||||
@{$bits{i_subtract}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{index}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{initfield}}{2,1,0} = ('OPpINITFIELD_HV', 'OPpINITFIELD_AV', $bf[0]);
|
||||
$bits{int}{0} = $bf[0];
|
||||
@{$bits{ioctl}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{is_bool}{0} = $bf[0];
|
||||
$bits{is_tainted}{0} = $bf[0];
|
||||
$bits{is_weak}{0} = $bf[0];
|
||||
@{$bits{isa}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{join}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{keys}{0} = $bf[0];
|
||||
@{$bits{kill}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{last}{0} = $bf[0];
|
||||
$bits{lc}{0} = $bf[0];
|
||||
$bits{lcfirst}{0} = $bf[0];
|
||||
@{$bits{le}}{1,0} = ($bf[1], $bf[1]);
|
||||
$bits{leaveeval}{0} = $bf[0];
|
||||
$bits{leavegiven}{0} = $bf[0];
|
||||
@{$bits{leaveloop}}{1,0} = ($bf[1], $bf[1]);
|
||||
$bits{leavesub}{0} = $bf[0];
|
||||
$bits{leavesublv}{0} = $bf[0];
|
||||
$bits{leavewhen}{0} = $bf[0];
|
||||
$bits{leavewrite}{0} = $bf[0];
|
||||
$bits{length}{0} = $bf[0];
|
||||
@{$bits{link}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{list}{6} = 'OPpLIST_GUESSED';
|
||||
@{$bits{listen}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{localtime}{0} = $bf[0];
|
||||
$bits{lock}{0} = $bf[0];
|
||||
$bits{log}{0} = $bf[0];
|
||||
@{$bits{lslice}}{1,0} = ($bf[1], $bf[1]);
|
||||
$bits{lstat}{0} = $bf[0];
|
||||
@{$bits{lt}}{1,0} = ($bf[1], $bf[1]);
|
||||
$bits{lvavref}{0} = $bf[0];
|
||||
@{$bits{lvref}}{5,4,0} = ($bf[9], $bf[9], $bf[0]);
|
||||
$bits{mapstart}{0} = $bf[0];
|
||||
$bits{mapwhile}{0} = $bf[0];
|
||||
$bits{method}{0} = $bf[0];
|
||||
$bits{method_named}{0} = $bf[0];
|
||||
$bits{method_redir}{0} = $bf[0];
|
||||
$bits{method_redir_super}{0} = $bf[0];
|
||||
$bits{method_super}{0} = $bf[0];
|
||||
@{$bits{methstart}}{7,0} = ('OPpINITFIELDS', $bf[0]);
|
||||
@{$bits{mkdir}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{modulo}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{msgctl}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{msgget}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{msgrcv}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{msgsnd}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{multiconcat}}{6,5,3,0} = ('OPpMULTICONCAT_APPEND', 'OPpMULTICONCAT_FAKE', 'OPpMULTICONCAT_STRINGIFY', $bf[0]);
|
||||
@{$bits{multideref}}{5,4,0} = ('OPpMULTIDEREF_DELETE', 'OPpMULTIDEREF_EXISTS', $bf[0]);
|
||||
@{$bits{multiply}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{ncmp}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{ne}}{1,0} = ($bf[1], $bf[1]);
|
||||
$bits{negate}{0} = $bf[0];
|
||||
$bits{next}{0} = $bf[0];
|
||||
$bits{not}{0} = $bf[0];
|
||||
$bits{oct}{0} = $bf[0];
|
||||
$bits{once}{0} = $bf[0];
|
||||
@{$bits{open}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{open_dir}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{or}{0} = $bf[0];
|
||||
$bits{orassign}{0} = $bf[0];
|
||||
$bits{ord}{0} = $bf[0];
|
||||
@{$bits{pack}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{padhv}{0} = 'OPpPADHV_ISKEYS';
|
||||
@{$bits{padrange}}{6,5,4,3,2,1,0} = ($bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5]);
|
||||
@{$bits{padsv}}{5,4} = ($bf[8], $bf[8]);
|
||||
$bits{padsv_store}{0} = $bf[0];
|
||||
@{$bits{pipe_op}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{pop}{0} = $bf[0];
|
||||
$bits{pos}{0} = $bf[0];
|
||||
$bits{postdec}{0} = $bf[0];
|
||||
$bits{postinc}{0} = $bf[0];
|
||||
@{$bits{pow}}{1,0} = ($bf[1], $bf[1]);
|
||||
$bits{predec}{0} = $bf[0];
|
||||
$bits{preinc}{0} = $bf[0];
|
||||
$bits{prototype}{0} = $bf[0];
|
||||
@{$bits{push}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{pushdefer}}{7,0} = ('OPpDEFER_FINALLY', $bf[0]);
|
||||
$bits{quotemeta}{0} = $bf[0];
|
||||
@{$bits{rand}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{range}{0} = $bf[0];
|
||||
@{$bits{read}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{readdir}{0} = $bf[0];
|
||||
$bits{readline}{0} = $bf[0];
|
||||
$bits{readlink}{0} = $bf[0];
|
||||
@{$bits{recv}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{redo}{0} = $bf[0];
|
||||
$bits{ref}{0} = $bf[0];
|
||||
$bits{refaddr}{0} = $bf[0];
|
||||
@{$bits{refassign}}{5,4,1,0} = ($bf[9], $bf[9], $bf[1], $bf[1]);
|
||||
$bits{refgen}{0} = $bf[0];
|
||||
$bits{reftype}{0} = $bf[0];
|
||||
$bits{regcmaybe}{0} = $bf[0];
|
||||
$bits{regcomp}{0} = $bf[0];
|
||||
$bits{regcreset}{0} = $bf[0];
|
||||
@{$bits{rename}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{repeat}}{6,1,0} = ('OPpREPEAT_DOLIST', $bf[1], $bf[1]);
|
||||
$bits{require}{0} = $bf[0];
|
||||
@{$bits{reset}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{reverse}}{3,0} = ('OPpREVERSE_INPLACE', $bf[0]);
|
||||
$bits{rewinddir}{0} = $bf[0];
|
||||
@{$bits{rindex}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{rmdir}{0} = $bf[0];
|
||||
$bits{rv2av}{0} = $bf[0];
|
||||
@{$bits{rv2cv}}{7,5,0} = ('OPpENTERSUB_NOPAREN', 'OPpMAY_RETURN_CONSTANT', $bf[0]);
|
||||
@{$bits{rv2gv}}{6,5,4,2,0} = ('OPpALLOW_FAKE', $bf[8], $bf[8], 'OPpDONT_INIT_GV', $bf[0]);
|
||||
$bits{rv2hv}{0} = 'OPpRV2HV_ISKEYS';
|
||||
@{$bits{rv2sv}}{5,4,0} = ($bf[8], $bf[8], $bf[0]);
|
||||
@{$bits{sassign}}{7,6,1,0} = ('OPpASSIGN_CV_TO_GV', 'OPpASSIGN_BACKWARDS', $bf[1], $bf[1]);
|
||||
$bits{scalar}{0} = $bf[0];
|
||||
$bits{schomp}{0} = $bf[0];
|
||||
$bits{schop}{0} = $bf[0];
|
||||
@{$bits{scmp}}{1,0} = ($bf[1], $bf[1]);
|
||||
$bits{scomplement}{0} = $bf[0];
|
||||
@{$bits{seek}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{seekdir}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{select}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{semctl}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{semget}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{semop}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{send}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{seq}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{setpgrp}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{setpriority}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{sge}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{sgt}}{1,0} = ($bf[1], $bf[1]);
|
||||
$bits{shift}{0} = $bf[0];
|
||||
@{$bits{shmctl}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{shmget}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{shmread}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{shmwrite}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{shostent}{0} = $bf[0];
|
||||
@{$bits{shutdown}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{sin}{0} = $bf[0];
|
||||
@{$bits{sle}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{sleep}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{slt}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{smartmatch}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{sne}}{1,0} = ($bf[1], $bf[1]);
|
||||
$bits{snetent}{0} = $bf[0];
|
||||
@{$bits{socket}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{sockpair}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{sort}}{4,3,2,1,0} = ('OPpSORT_DESCEND', 'OPpSORT_INPLACE', 'OPpSORT_REVERSE', 'OPpSORT_INTEGER', 'OPpSORT_NUMERIC');
|
||||
@{$bits{splice}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{split}}{4,3,2} = ('OPpSPLIT_ASSIGN', 'OPpSPLIT_LEX', 'OPpSPLIT_IMPLIM');
|
||||
@{$bits{sprintf}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{sprotoent}{0} = $bf[0];
|
||||
$bits{sqrt}{0} = $bf[0];
|
||||
@{$bits{srand}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{srefgen}{0} = $bf[0];
|
||||
@{$bits{sselect}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{sservent}{0} = $bf[0];
|
||||
@{$bits{ssockopt}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{stat}{0} = $bf[0];
|
||||
@{$bits{stringify}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{study}{0} = $bf[0];
|
||||
$bits{substcont}{0} = $bf[0];
|
||||
@{$bits{substr}}{4,2,1,0} = ('OPpSUBSTR_REPL_FIRST', $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{subtract}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{symlink}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{syscall}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{sysopen}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{sysread}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{sysseek}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{system}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{syswrite}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{tell}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{telldir}{0} = $bf[0];
|
||||
@{$bits{tie}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{tied}{0} = $bf[0];
|
||||
@{$bits{truncate}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{uc}{0} = $bf[0];
|
||||
$bits{ucfirst}{0} = $bf[0];
|
||||
@{$bits{umask}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{undef}}{5,0} = ('OPpUNDEF_KEEP_PV', $bf[0]);
|
||||
@{$bits{unlink}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{unpack}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{unshift}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{untie}{0} = $bf[0];
|
||||
$bits{unweaken}{0} = $bf[0];
|
||||
@{$bits{utime}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{values}{0} = $bf[0];
|
||||
@{$bits{vec}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{waitpid}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{warn}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
$bits{weaken}{0} = $bf[0];
|
||||
@{$bits{xor}}{1,0} = ($bf[1], $bf[1]);
|
||||
|
||||
|
||||
our %defines = (
|
||||
OPpALLOW_FAKE => 64,
|
||||
OPpARG1_MASK => 1,
|
||||
OPpARG2_MASK => 3,
|
||||
OPpARG3_MASK => 7,
|
||||
OPpARG4_MASK => 15,
|
||||
OPpARGELEM_AV => 2,
|
||||
OPpARGELEM_HV => 4,
|
||||
OPpARGELEM_MASK => 6,
|
||||
OPpARGELEM_SV => 0,
|
||||
OPpARG_IF_FALSE => 64,
|
||||
OPpARG_IF_UNDEF => 128,
|
||||
OPpASSIGN_BACKWARDS => 64,
|
||||
OPpASSIGN_COMMON_AGG => 16,
|
||||
OPpASSIGN_COMMON_RC1 => 32,
|
||||
OPpASSIGN_COMMON_SCALAR => 64,
|
||||
OPpASSIGN_CV_TO_GV => 128,
|
||||
OPpASSIGN_TRUEBOOL => 4,
|
||||
OPpAVHVSWITCH_MASK => 3,
|
||||
OPpCONCAT_NESTED => 64,
|
||||
OPpCONST_BARE => 64,
|
||||
OPpCONST_ENTERED => 16,
|
||||
OPpCONST_NOVER => 2,
|
||||
OPpCONST_SHORTCIRCUIT => 4,
|
||||
OPpCONST_STRICT => 8,
|
||||
OPpCOREARGS_DEREF1 => 1,
|
||||
OPpCOREARGS_DEREF2 => 2,
|
||||
OPpCOREARGS_PUSHMARK => 128,
|
||||
OPpCOREARGS_SCALARMOD => 64,
|
||||
OPpDEFER_FINALLY => 128,
|
||||
OPpDEREF => 48,
|
||||
OPpDEREF_AV => 16,
|
||||
OPpDEREF_HV => 32,
|
||||
OPpDEREF_SV => 48,
|
||||
OPpDONT_INIT_GV => 4,
|
||||
OPpEARLY_CV => 32,
|
||||
OPpEMPTYAVHV_IS_HV => 32,
|
||||
OPpENTERSUB_AMPER => 8,
|
||||
OPpENTERSUB_DB => 64,
|
||||
OPpENTERSUB_HASTARG => 4,
|
||||
OPpENTERSUB_INARGS => 1,
|
||||
OPpENTERSUB_NOPAREN => 128,
|
||||
OPpEVAL_BYTES => 8,
|
||||
OPpEVAL_COPHH => 16,
|
||||
OPpEVAL_EVALSV => 64,
|
||||
OPpEVAL_HAS_HH => 2,
|
||||
OPpEVAL_RE_REPARSING => 32,
|
||||
OPpEVAL_UNICODE => 4,
|
||||
OPpEXISTS_SUB => 64,
|
||||
OPpFLIP_LINENUM => 64,
|
||||
OPpFT_ACCESS => 2,
|
||||
OPpFT_AFTER_t => 16,
|
||||
OPpFT_STACKED => 4,
|
||||
OPpFT_STACKING => 8,
|
||||
OPpHELEMEXISTSOR_DELETE => 128,
|
||||
OPpHINT_STRICT_REFS => 2,
|
||||
OPpHUSH_VMSISH => 32,
|
||||
OPpINDEX_BOOLNEG => 64,
|
||||
OPpINITFIELDS => 128,
|
||||
OPpINITFIELD_AV => 2,
|
||||
OPpINITFIELD_HV => 4,
|
||||
OPpITER_DEF => 8,
|
||||
OPpITER_REVERSED => 2,
|
||||
OPpKVSLICE => 32,
|
||||
OPpLIST_GUESSED => 64,
|
||||
OPpLVALUE => 128,
|
||||
OPpLVAL_DEFER => 64,
|
||||
OPpLVAL_INTRO => 128,
|
||||
OPpLVREF_AV => 16,
|
||||
OPpLVREF_CV => 48,
|
||||
OPpLVREF_ELEM => 4,
|
||||
OPpLVREF_HV => 32,
|
||||
OPpLVREF_ITER => 8,
|
||||
OPpLVREF_SV => 0,
|
||||
OPpLVREF_TYPE => 48,
|
||||
OPpMAYBE_LVSUB => 8,
|
||||
OPpMAYBE_TRUEBOOL => 16,
|
||||
OPpMAY_RETURN_CONSTANT => 32,
|
||||
OPpMULTICONCAT_APPEND => 64,
|
||||
OPpMULTICONCAT_FAKE => 32,
|
||||
OPpMULTICONCAT_STRINGIFY => 8,
|
||||
OPpMULTIDEREF_DELETE => 32,
|
||||
OPpMULTIDEREF_EXISTS => 16,
|
||||
OPpOFFBYONE => 128,
|
||||
OPpOPEN_IN_CRLF => 32,
|
||||
OPpOPEN_IN_RAW => 16,
|
||||
OPpOPEN_OUT_CRLF => 128,
|
||||
OPpOPEN_OUT_RAW => 64,
|
||||
OPpOUR_INTRO => 64,
|
||||
OPpPADHV_ISKEYS => 1,
|
||||
OPpPADRANGE_COUNTMASK => 127,
|
||||
OPpPADRANGE_COUNTSHIFT => 7,
|
||||
OPpPAD_STATE => 64,
|
||||
OPpPV_IS_UTF8 => 128,
|
||||
OPpREFCOUNTED => 64,
|
||||
OPpREPEAT_DOLIST => 64,
|
||||
OPpREVERSE_INPLACE => 8,
|
||||
OPpRV2HV_ISKEYS => 1,
|
||||
OPpSLICE => 64,
|
||||
OPpSLICEWARNING => 4,
|
||||
OPpSORT_DESCEND => 16,
|
||||
OPpSORT_INPLACE => 8,
|
||||
OPpSORT_INTEGER => 2,
|
||||
OPpSORT_NUMERIC => 1,
|
||||
OPpSORT_REVERSE => 4,
|
||||
OPpSPLIT_ASSIGN => 16,
|
||||
OPpSPLIT_IMPLIM => 4,
|
||||
OPpSPLIT_LEX => 8,
|
||||
OPpSUBSTR_REPL_FIRST => 16,
|
||||
OPpTARGET_MY => 16,
|
||||
OPpTRANS_CAN_FORCE_UTF8 => 1,
|
||||
OPpTRANS_COMPLEMENT => 32,
|
||||
OPpTRANS_DELETE => 128,
|
||||
OPpTRANS_GROWS => 64,
|
||||
OPpTRANS_IDENTICAL => 4,
|
||||
OPpTRANS_SQUASH => 8,
|
||||
OPpTRANS_USE_SVOP => 2,
|
||||
OPpTRUEBOOL => 32,
|
||||
OPpUNDEF_KEEP_PV => 32,
|
||||
OPpUSEINT => 4,
|
||||
);
|
||||
|
||||
our %labels = (
|
||||
OPpALLOW_FAKE => 'FAKE',
|
||||
OPpARGELEM_AV => 'AV',
|
||||
OPpARGELEM_HV => 'HV',
|
||||
OPpARGELEM_SV => 'SV',
|
||||
OPpARG_IF_FALSE => 'IF_FALSE',
|
||||
OPpARG_IF_UNDEF => 'IF_UNDEF',
|
||||
OPpASSIGN_BACKWARDS => 'BKWARD',
|
||||
OPpASSIGN_COMMON_AGG => 'COM_AGG',
|
||||
OPpASSIGN_COMMON_RC1 => 'COM_RC1',
|
||||
OPpASSIGN_COMMON_SCALAR => 'COM_SCALAR',
|
||||
OPpASSIGN_CV_TO_GV => 'CV2GV',
|
||||
OPpASSIGN_TRUEBOOL => 'BOOL',
|
||||
OPpCONCAT_NESTED => 'NESTED',
|
||||
OPpCONST_BARE => 'BARE',
|
||||
OPpCONST_ENTERED => 'ENTERED',
|
||||
OPpCONST_NOVER => 'NOVER',
|
||||
OPpCONST_SHORTCIRCUIT => 'SHORT',
|
||||
OPpCONST_STRICT => 'STRICT',
|
||||
OPpCOREARGS_DEREF1 => 'DEREF1',
|
||||
OPpCOREARGS_DEREF2 => 'DEREF2',
|
||||
OPpCOREARGS_PUSHMARK => 'MARK',
|
||||
OPpCOREARGS_SCALARMOD => '$MOD',
|
||||
OPpDEFER_FINALLY => 'FINALLY',
|
||||
OPpDEREF_AV => 'DREFAV',
|
||||
OPpDEREF_HV => 'DREFHV',
|
||||
OPpDEREF_SV => 'DREFSV',
|
||||
OPpDONT_INIT_GV => 'NOINIT',
|
||||
OPpEARLY_CV => 'EARLYCV',
|
||||
OPpEMPTYAVHV_IS_HV => 'ANONHASH',
|
||||
OPpENTERSUB_AMPER => 'AMPER',
|
||||
OPpENTERSUB_DB => 'DBG',
|
||||
OPpENTERSUB_HASTARG => 'TARG',
|
||||
OPpENTERSUB_INARGS => 'INARGS',
|
||||
OPpENTERSUB_NOPAREN => 'NO()',
|
||||
OPpEVAL_BYTES => 'BYTES',
|
||||
OPpEVAL_COPHH => 'COPHH',
|
||||
OPpEVAL_EVALSV => 'EVALSV',
|
||||
OPpEVAL_HAS_HH => 'HAS_HH',
|
||||
OPpEVAL_RE_REPARSING => 'REPARSE',
|
||||
OPpEVAL_UNICODE => 'UNI',
|
||||
OPpEXISTS_SUB => 'SUB',
|
||||
OPpFLIP_LINENUM => 'LINENUM',
|
||||
OPpFT_ACCESS => 'FTACCESS',
|
||||
OPpFT_AFTER_t => 'FTAFTERt',
|
||||
OPpFT_STACKED => 'FTSTACKED',
|
||||
OPpFT_STACKING => 'FTSTACKING',
|
||||
OPpHELEMEXISTSOR_DELETE => 'DELETE',
|
||||
OPpHINT_STRICT_REFS => 'STRICT',
|
||||
OPpHUSH_VMSISH => 'HUSH',
|
||||
OPpINDEX_BOOLNEG => 'NEG',
|
||||
OPpINITFIELDS => 'INITFIELDS',
|
||||
OPpINITFIELD_AV => 'INITFIELD_AV',
|
||||
OPpINITFIELD_HV => 'INITFIELD_HV',
|
||||
OPpITER_DEF => 'DEF',
|
||||
OPpITER_REVERSED => 'REVERSED',
|
||||
OPpKVSLICE => 'KVSLICE',
|
||||
OPpLIST_GUESSED => 'GUESSED',
|
||||
OPpLVALUE => 'LV',
|
||||
OPpLVAL_DEFER => 'LVDEFER',
|
||||
OPpLVAL_INTRO => 'LVINTRO',
|
||||
OPpLVREF_AV => 'AV',
|
||||
OPpLVREF_CV => 'CV',
|
||||
OPpLVREF_ELEM => 'ELEM',
|
||||
OPpLVREF_HV => 'HV',
|
||||
OPpLVREF_ITER => 'ITER',
|
||||
OPpLVREF_SV => 'SV',
|
||||
OPpMAYBE_LVSUB => 'LVSUB',
|
||||
OPpMAYBE_TRUEBOOL => 'BOOL?',
|
||||
OPpMAY_RETURN_CONSTANT => 'CONST',
|
||||
OPpMULTICONCAT_APPEND => 'APPEND',
|
||||
OPpMULTICONCAT_FAKE => 'FAKE',
|
||||
OPpMULTICONCAT_STRINGIFY => 'STRINGIFY',
|
||||
OPpMULTIDEREF_DELETE => 'DELETE',
|
||||
OPpMULTIDEREF_EXISTS => 'EXISTS',
|
||||
OPpOFFBYONE => '+1',
|
||||
OPpOPEN_IN_CRLF => 'INCR',
|
||||
OPpOPEN_IN_RAW => 'INBIN',
|
||||
OPpOPEN_OUT_CRLF => 'OUTCR',
|
||||
OPpOPEN_OUT_RAW => 'OUTBIN',
|
||||
OPpOUR_INTRO => 'OURINTR',
|
||||
OPpPADHV_ISKEYS => 'KEYS',
|
||||
OPpPAD_STATE => 'STATE',
|
||||
OPpPV_IS_UTF8 => 'UTF',
|
||||
OPpREFCOUNTED => 'REFC',
|
||||
OPpREPEAT_DOLIST => 'DOLIST',
|
||||
OPpREVERSE_INPLACE => 'INPLACE',
|
||||
OPpRV2HV_ISKEYS => 'KEYS',
|
||||
OPpSLICE => 'SLICE',
|
||||
OPpSLICEWARNING => 'SLICEWARN',
|
||||
OPpSORT_DESCEND => 'DESC',
|
||||
OPpSORT_INPLACE => 'INPLACE',
|
||||
OPpSORT_INTEGER => 'INT',
|
||||
OPpSORT_NUMERIC => 'NUM',
|
||||
OPpSORT_REVERSE => 'REV',
|
||||
OPpSPLIT_ASSIGN => 'ASSIGN',
|
||||
OPpSPLIT_IMPLIM => 'IMPLIM',
|
||||
OPpSPLIT_LEX => 'LEX',
|
||||
OPpSUBSTR_REPL_FIRST => 'REPL1ST',
|
||||
OPpTARGET_MY => 'TARGMY',
|
||||
OPpTRANS_CAN_FORCE_UTF8 => 'CAN_FORCE_UTF8',
|
||||
OPpTRANS_COMPLEMENT => 'COMPL',
|
||||
OPpTRANS_DELETE => 'DEL',
|
||||
OPpTRANS_GROWS => 'GROWS',
|
||||
OPpTRANS_IDENTICAL => 'IDENT',
|
||||
OPpTRANS_SQUASH => 'SQUASH',
|
||||
OPpTRANS_USE_SVOP => 'USE_SVOP',
|
||||
OPpTRUEBOOL => 'BOOL',
|
||||
OPpUNDEF_KEEP_PV => 'KEEP_PV',
|
||||
OPpUSEINT => 'USEINT',
|
||||
);
|
||||
|
||||
|
||||
our %ops_using = (
|
||||
OPpALLOW_FAKE => [qw(rv2gv)],
|
||||
OPpARG_IF_FALSE => [qw(argdefelem)],
|
||||
OPpASSIGN_BACKWARDS => [qw(sassign)],
|
||||
OPpASSIGN_COMMON_AGG => [qw(aassign)],
|
||||
OPpCONCAT_NESTED => [qw(concat)],
|
||||
OPpCONST_BARE => [qw(const)],
|
||||
OPpCOREARGS_DEREF1 => [qw(coreargs)],
|
||||
OPpDEFER_FINALLY => [qw(pushdefer)],
|
||||
OPpEARLY_CV => [qw(gv)],
|
||||
OPpEMPTYAVHV_IS_HV => [qw(emptyavhv)],
|
||||
OPpENTERSUB_AMPER => [qw(entersub rv2cv)],
|
||||
OPpENTERSUB_INARGS => [qw(entersub)],
|
||||
OPpENTERSUB_NOPAREN => [qw(rv2cv)],
|
||||
OPpEVAL_BYTES => [qw(entereval)],
|
||||
OPpEXISTS_SUB => [qw(exists)],
|
||||
OPpFLIP_LINENUM => [qw(flip flop)],
|
||||
OPpFT_ACCESS => [qw(fteexec fteread ftewrite ftrexec ftrread ftrwrite)],
|
||||
OPpFT_AFTER_t => [qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero)],
|
||||
OPpHELEMEXISTSOR_DELETE => [qw(helemexistsor)],
|
||||
OPpHINT_STRICT_REFS => [qw(entersub multideref rv2av rv2cv rv2gv rv2hv rv2sv)],
|
||||
OPpHUSH_VMSISH => [qw(dbstate nextstate)],
|
||||
OPpINDEX_BOOLNEG => [qw(index rindex)],
|
||||
OPpINITFIELDS => [qw(methstart)],
|
||||
OPpINITFIELD_AV => [qw(initfield)],
|
||||
OPpITER_DEF => [qw(enteriter)],
|
||||
OPpITER_REVERSED => [qw(enteriter iter)],
|
||||
OPpKVSLICE => [qw(delete)],
|
||||
OPpLIST_GUESSED => [qw(list)],
|
||||
OPpLVALUE => [qw(leave leaveloop)],
|
||||
OPpLVAL_DEFER => [qw(aelem helem multideref)],
|
||||
OPpLVAL_INTRO => [qw(aelem aslice cond_expr delete emptyavhv enteriter entersub gvsv helem hslice list lvavref lvref lvrefslice multiconcat multideref padav padhv padrange padsv padsv_store pushmark refassign rv2av rv2gv rv2hv rv2sv split undef)],
|
||||
OPpLVREF_ELEM => [qw(lvref refassign)],
|
||||
OPpMAYBE_LVSUB => [qw(aassign aelem akeys aslice av2arylen avhvswitch helem hslice keys kvaslice kvhslice multideref padav padhv pos rv2av rv2gv rv2hv substr values vec)],
|
||||
OPpMAYBE_TRUEBOOL => [qw(blessed padhv ref rv2hv)],
|
||||
OPpMULTICONCAT_APPEND => [qw(multiconcat)],
|
||||
OPpMULTIDEREF_DELETE => [qw(multideref)],
|
||||
OPpOFFBYONE => [qw(caller runcv wantarray)],
|
||||
OPpOPEN_IN_CRLF => [qw(backtick open)],
|
||||
OPpOUR_INTRO => [qw(enteriter gvsv rv2av rv2hv rv2sv split)],
|
||||
OPpPADHV_ISKEYS => [qw(padhv)],
|
||||
OPpPAD_STATE => [qw(emptyavhv lvavref lvref padav padhv padsv padsv_store pushmark refassign undef)],
|
||||
OPpPV_IS_UTF8 => [qw(dump goto last next redo)],
|
||||
OPpREFCOUNTED => [qw(leave leaveeval leavesub leavesublv leavewrite)],
|
||||
OPpREPEAT_DOLIST => [qw(repeat)],
|
||||
OPpREVERSE_INPLACE => [qw(reverse)],
|
||||
OPpRV2HV_ISKEYS => [qw(rv2hv)],
|
||||
OPpSLICEWARNING => [qw(aslice hslice padav padhv rv2av rv2hv)],
|
||||
OPpSORT_DESCEND => [qw(sort)],
|
||||
OPpSPLIT_ASSIGN => [qw(split)],
|
||||
OPpSUBSTR_REPL_FIRST => [qw(substr)],
|
||||
OPpTARGET_MY => [qw(abs add atan2 ceil chdir chmod chomp chown chr chroot concat cos crypt divide emptyavhv exec exp flock floor getpgrp getppid getpriority hex i_add i_divide i_modulo i_multiply i_subtract index int kill left_shift length link log mkdir modulo multiconcat multiply nbit_and nbit_or nbit_xor ncomplement oct ord pow push rand refaddr reftype rename right_shift rindex rmdir schomp scomplement setpgrp setpriority sin sleep sqrt srand stringify subtract symlink system time undef unlink unshift utime wait waitpid)],
|
||||
OPpTRANS_CAN_FORCE_UTF8 => [qw(trans transr)],
|
||||
OPpTRUEBOOL => [qw(blessed grepwhile index length padav padhv pos ref rindex rv2av rv2hv subst)],
|
||||
OPpUNDEF_KEEP_PV => [qw(undef)],
|
||||
OPpUSEINT => [qw(bit_and bit_or bit_xor complement left_shift nbit_and nbit_or nbit_xor ncomplement right_shift sbit_and sbit_or sbit_xor)],
|
||||
);
|
||||
|
||||
$ops_using{OPpARG_IF_UNDEF} = $ops_using{OPpARG_IF_FALSE};
|
||||
$ops_using{OPpASSIGN_COMMON_RC1} = $ops_using{OPpASSIGN_COMMON_AGG};
|
||||
$ops_using{OPpASSIGN_COMMON_SCALAR} = $ops_using{OPpASSIGN_COMMON_AGG};
|
||||
$ops_using{OPpASSIGN_CV_TO_GV} = $ops_using{OPpASSIGN_BACKWARDS};
|
||||
$ops_using{OPpASSIGN_TRUEBOOL} = $ops_using{OPpASSIGN_COMMON_AGG};
|
||||
$ops_using{OPpCONST_ENTERED} = $ops_using{OPpCONST_BARE};
|
||||
$ops_using{OPpCONST_NOVER} = $ops_using{OPpCONST_BARE};
|
||||
$ops_using{OPpCONST_SHORTCIRCUIT} = $ops_using{OPpCONST_BARE};
|
||||
$ops_using{OPpCONST_STRICT} = $ops_using{OPpCONST_BARE};
|
||||
$ops_using{OPpCOREARGS_DEREF2} = $ops_using{OPpCOREARGS_DEREF1};
|
||||
$ops_using{OPpCOREARGS_PUSHMARK} = $ops_using{OPpCOREARGS_DEREF1};
|
||||
$ops_using{OPpCOREARGS_SCALARMOD} = $ops_using{OPpCOREARGS_DEREF1};
|
||||
$ops_using{OPpDONT_INIT_GV} = $ops_using{OPpALLOW_FAKE};
|
||||
$ops_using{OPpENTERSUB_DB} = $ops_using{OPpENTERSUB_AMPER};
|
||||
$ops_using{OPpENTERSUB_HASTARG} = $ops_using{OPpENTERSUB_AMPER};
|
||||
$ops_using{OPpEVAL_COPHH} = $ops_using{OPpEVAL_BYTES};
|
||||
$ops_using{OPpEVAL_EVALSV} = $ops_using{OPpEVAL_BYTES};
|
||||
$ops_using{OPpEVAL_HAS_HH} = $ops_using{OPpEVAL_BYTES};
|
||||
$ops_using{OPpEVAL_RE_REPARSING} = $ops_using{OPpEVAL_BYTES};
|
||||
$ops_using{OPpEVAL_UNICODE} = $ops_using{OPpEVAL_BYTES};
|
||||
$ops_using{OPpFT_STACKED} = $ops_using{OPpFT_AFTER_t};
|
||||
$ops_using{OPpFT_STACKING} = $ops_using{OPpFT_AFTER_t};
|
||||
$ops_using{OPpINITFIELD_HV} = $ops_using{OPpINITFIELD_AV};
|
||||
$ops_using{OPpLVREF_ITER} = $ops_using{OPpLVREF_ELEM};
|
||||
$ops_using{OPpMAY_RETURN_CONSTANT} = $ops_using{OPpENTERSUB_NOPAREN};
|
||||
$ops_using{OPpMULTICONCAT_FAKE} = $ops_using{OPpMULTICONCAT_APPEND};
|
||||
$ops_using{OPpMULTICONCAT_STRINGIFY} = $ops_using{OPpMULTICONCAT_APPEND};
|
||||
$ops_using{OPpMULTIDEREF_EXISTS} = $ops_using{OPpMULTIDEREF_DELETE};
|
||||
$ops_using{OPpOPEN_IN_RAW} = $ops_using{OPpOPEN_IN_CRLF};
|
||||
$ops_using{OPpOPEN_OUT_CRLF} = $ops_using{OPpOPEN_IN_CRLF};
|
||||
$ops_using{OPpOPEN_OUT_RAW} = $ops_using{OPpOPEN_IN_CRLF};
|
||||
$ops_using{OPpSLICE} = $ops_using{OPpKVSLICE};
|
||||
$ops_using{OPpSORT_INPLACE} = $ops_using{OPpSORT_DESCEND};
|
||||
$ops_using{OPpSORT_INTEGER} = $ops_using{OPpSORT_DESCEND};
|
||||
$ops_using{OPpSORT_NUMERIC} = $ops_using{OPpSORT_DESCEND};
|
||||
$ops_using{OPpSORT_REVERSE} = $ops_using{OPpSORT_DESCEND};
|
||||
$ops_using{OPpSPLIT_IMPLIM} = $ops_using{OPpSPLIT_ASSIGN};
|
||||
$ops_using{OPpSPLIT_LEX} = $ops_using{OPpSPLIT_ASSIGN};
|
||||
$ops_using{OPpTRANS_COMPLEMENT} = $ops_using{OPpTRANS_CAN_FORCE_UTF8};
|
||||
$ops_using{OPpTRANS_DELETE} = $ops_using{OPpTRANS_CAN_FORCE_UTF8};
|
||||
$ops_using{OPpTRANS_GROWS} = $ops_using{OPpTRANS_CAN_FORCE_UTF8};
|
||||
$ops_using{OPpTRANS_IDENTICAL} = $ops_using{OPpTRANS_CAN_FORCE_UTF8};
|
||||
$ops_using{OPpTRANS_SQUASH} = $ops_using{OPpTRANS_CAN_FORCE_UTF8};
|
||||
$ops_using{OPpTRANS_USE_SVOP} = $ops_using{OPpTRANS_CAN_FORCE_UTF8};
|
||||
|
||||
# ex: set ro ft=perl:
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,21 @@
|
||||
package Carp::Heavy;
|
||||
|
||||
use Carp ();
|
||||
|
||||
our $VERSION = '1.54';
|
||||
$VERSION =~ tr/_//d;
|
||||
|
||||
# Carp::Heavy was merged into Carp in version 1.12. Any mismatched versions
|
||||
# after this point are not significant and can be ignored.
|
||||
if(($Carp::VERSION || 0) < 1.12) {
|
||||
my $cv = defined($Carp::VERSION) ? $Carp::VERSION : "undef";
|
||||
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.
|
||||
@@ -0,0 +1,637 @@
|
||||
package Class::Struct;
|
||||
|
||||
## See POD after __END__
|
||||
|
||||
use 5.006_001;
|
||||
|
||||
use strict;
|
||||
use warnings::register;
|
||||
our(@ISA, @EXPORT, $VERSION);
|
||||
|
||||
use Carp;
|
||||
|
||||
require Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(struct);
|
||||
|
||||
$VERSION = '0.68';
|
||||
|
||||
my $print = 0;
|
||||
sub printem {
|
||||
if (@_) { $print = shift }
|
||||
else { $print++ }
|
||||
}
|
||||
|
||||
{
|
||||
package Class::Struct::Tie_ISA;
|
||||
|
||||
sub TIEARRAY {
|
||||
my $class = shift;
|
||||
return bless [], $class;
|
||||
}
|
||||
|
||||
sub STORE {
|
||||
my ($self, $index, $value) = @_;
|
||||
Class::Struct::_subclass_error();
|
||||
}
|
||||
|
||||
sub FETCH {
|
||||
my ($self, $index) = @_;
|
||||
$self->[$index];
|
||||
}
|
||||
|
||||
sub FETCHSIZE {
|
||||
my $self = shift;
|
||||
return scalar(@$self);
|
||||
}
|
||||
|
||||
sub DESTROY { }
|
||||
}
|
||||
|
||||
sub import {
|
||||
my $self = shift;
|
||||
|
||||
if ( @_ == 0 ) {
|
||||
$self->export_to_level( 1, $self, @EXPORT );
|
||||
} elsif ( @_ == 1 ) {
|
||||
# This is admittedly a little bit silly:
|
||||
# do we ever export anything else than 'struct'...?
|
||||
$self->export_to_level( 1, $self, @_ );
|
||||
} else {
|
||||
goto &struct;
|
||||
}
|
||||
}
|
||||
|
||||
sub struct {
|
||||
|
||||
# Determine parameter list structure, one of:
|
||||
# struct( class => [ element-list ])
|
||||
# struct( class => { element-list })
|
||||
# struct( element-list )
|
||||
# Latter form assumes current package name as struct name.
|
||||
|
||||
my ($class, @decls);
|
||||
my $base_type = ref $_[1];
|
||||
if ( $base_type eq 'HASH' ) {
|
||||
$class = shift;
|
||||
@decls = %{shift()};
|
||||
_usage_error() if @_;
|
||||
}
|
||||
elsif ( $base_type eq 'ARRAY' ) {
|
||||
$class = shift;
|
||||
@decls = @{shift()};
|
||||
_usage_error() if @_;
|
||||
}
|
||||
else {
|
||||
$base_type = 'ARRAY';
|
||||
$class = caller();
|
||||
@decls = @_;
|
||||
}
|
||||
|
||||
_usage_error() if @decls % 2 == 1;
|
||||
|
||||
# Ensure we are not, and will not be, a subclass.
|
||||
|
||||
my $isa = do {
|
||||
no strict 'refs';
|
||||
\@{$class . '::ISA'};
|
||||
};
|
||||
_subclass_error() if @$isa;
|
||||
tie @$isa, 'Class::Struct::Tie_ISA';
|
||||
|
||||
# Create constructor.
|
||||
|
||||
croak "function 'new' already defined in package $class"
|
||||
if do { no strict 'refs'; defined &{$class . "::new"} };
|
||||
|
||||
my @methods = ();
|
||||
my %refs = ();
|
||||
my %arrays = ();
|
||||
my %hashes = ();
|
||||
my %classes = ();
|
||||
my $got_class = 0;
|
||||
my $out = '';
|
||||
|
||||
$out = "{\n package $class;\n use Carp;\n sub new {\n";
|
||||
$out .= " my (\$class, \%init) = \@_;\n";
|
||||
$out .= " \$class = __PACKAGE__ unless \@_;\n";
|
||||
|
||||
my $cnt = 0;
|
||||
my $idx = 0;
|
||||
my( $cmt, $name, $type, $elem );
|
||||
|
||||
if( $base_type eq 'HASH' ){
|
||||
$out .= " my(\$r) = {};\n";
|
||||
$cmt = '';
|
||||
}
|
||||
elsif( $base_type eq 'ARRAY' ){
|
||||
$out .= " my(\$r) = [];\n";
|
||||
}
|
||||
|
||||
$out .= " bless \$r, \$class;\n\n";
|
||||
|
||||
while( $idx < @decls ){
|
||||
$name = $decls[$idx];
|
||||
$type = $decls[$idx+1];
|
||||
push( @methods, $name );
|
||||
if( $base_type eq 'HASH' ){
|
||||
$elem = "{'${class}::$name'}";
|
||||
}
|
||||
elsif( $base_type eq 'ARRAY' ){
|
||||
$elem = "[$cnt]";
|
||||
++$cnt;
|
||||
$cmt = " # $name";
|
||||
}
|
||||
if( $type =~ /^\*(.)/ ){
|
||||
$refs{$name}++;
|
||||
$type = $1;
|
||||
}
|
||||
my $init = "defined(\$init{'$name'}) ? \$init{'$name'} :";
|
||||
if( $type eq '@' ){
|
||||
$out .= " croak 'Initializer for $name must be array reference'\n";
|
||||
$out .= " if defined(\$init{'$name'}) && ref(\$init{'$name'}) ne 'ARRAY';\n";
|
||||
$out .= " \$r->$name( $init [] );$cmt\n";
|
||||
$arrays{$name}++;
|
||||
}
|
||||
elsif( $type eq '%' ){
|
||||
$out .= " croak 'Initializer for $name must be hash reference'\n";
|
||||
$out .= " if defined(\$init{'$name'}) && ref(\$init{'$name'}) ne 'HASH';\n";
|
||||
$out .= " \$r->$name( $init {} );$cmt\n";
|
||||
$hashes{$name}++;
|
||||
}
|
||||
elsif ( $type eq '$') {
|
||||
$out .= " \$r->$name( $init undef );$cmt\n";
|
||||
}
|
||||
elsif( $type =~ /^\w+(?:::\w+)*$/ ){
|
||||
$out .= " if (defined(\$init{'$name'})) {\n";
|
||||
$out .= " if (ref \$init{'$name'} eq 'HASH')\n";
|
||||
$out .= " { \$r->$name( $type->new(\%{\$init{'$name'}}) ) } $cmt\n";
|
||||
$out .= " elsif (UNIVERSAL::isa(\$init{'$name'}, '$type'))\n";
|
||||
$out .= " { \$r->$name( \$init{'$name'} ) } $cmt\n";
|
||||
$out .= " else { croak 'Initializer for $name must be hash or $type reference' }\n";
|
||||
$out .= " }\n";
|
||||
$classes{$name} = $type;
|
||||
$got_class = 1;
|
||||
}
|
||||
else{
|
||||
croak "'$type' is not a valid struct element type";
|
||||
}
|
||||
$idx += 2;
|
||||
}
|
||||
|
||||
$out .= "\n \$r;\n}\n";
|
||||
|
||||
# Create accessor methods.
|
||||
|
||||
my( $pre, $pst, $sel );
|
||||
$cnt = 0;
|
||||
foreach $name (@methods){
|
||||
if ( do { no strict 'refs'; defined &{$class . "::$name"} } ) {
|
||||
warnings::warnif("function '$name' already defined, overrides struct accessor method");
|
||||
}
|
||||
else {
|
||||
$pre = $pst = $cmt = $sel = '';
|
||||
if( defined $refs{$name} ){
|
||||
$pre = "\\(";
|
||||
$pst = ")";
|
||||
$cmt = " # returns ref";
|
||||
}
|
||||
$out .= " sub $name {$cmt\n my \$r = shift;\n";
|
||||
if( $base_type eq 'ARRAY' ){
|
||||
$elem = "[$cnt]";
|
||||
++$cnt;
|
||||
}
|
||||
elsif( $base_type eq 'HASH' ){
|
||||
$elem = "{'${class}::$name'}";
|
||||
}
|
||||
if( defined $arrays{$name} ){
|
||||
$out .= " my \$i;\n";
|
||||
$out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n";
|
||||
$out .= " if (ref(\$i) eq 'ARRAY' && !\@_) { \$r->$elem = \$i; return \$r }\n";
|
||||
$sel = "->[\$i]";
|
||||
}
|
||||
elsif( defined $hashes{$name} ){
|
||||
$out .= " my \$i;\n";
|
||||
$out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n";
|
||||
$out .= " if (ref(\$i) eq 'HASH' && !\@_) { \$r->$elem = \$i; return \$r }\n";
|
||||
$sel = "->{\$i}";
|
||||
}
|
||||
elsif( defined $classes{$name} ){
|
||||
$out .= " croak '$name argument is wrong class' if \@_ && ! UNIVERSAL::isa(\$_[0], '$classes{$name}');\n";
|
||||
}
|
||||
$out .= " croak 'Too many args to $name' if \@_ > 1;\n";
|
||||
$out .= " \@_ ? ($pre\$r->$elem$sel = shift$pst) : $pre\$r->$elem$sel$pst;\n";
|
||||
$out .= " }\n";
|
||||
}
|
||||
}
|
||||
$out .= "}\n1;\n";
|
||||
|
||||
print $out if $print;
|
||||
my $result = eval $out;
|
||||
carp $@ if $@;
|
||||
}
|
||||
|
||||
sub _usage_error {
|
||||
confess "struct usage error";
|
||||
}
|
||||
|
||||
sub _subclass_error {
|
||||
croak 'struct class cannot be a subclass (@ISA not allowed)';
|
||||
}
|
||||
|
||||
1; # for require
|
||||
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Class::Struct - declare struct-like datatypes as Perl classes
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Class::Struct;
|
||||
# declare struct, based on array:
|
||||
struct( CLASS_NAME => [ ELEMENT_NAME => ELEMENT_TYPE, ... ]);
|
||||
# declare struct, based on hash:
|
||||
struct( CLASS_NAME => { ELEMENT_NAME => ELEMENT_TYPE, ... });
|
||||
|
||||
package CLASS_NAME;
|
||||
use Class::Struct;
|
||||
# declare struct, based on array, implicit class name:
|
||||
struct( ELEMENT_NAME => ELEMENT_TYPE, ... );
|
||||
|
||||
# Declare struct at compile time
|
||||
use Class::Struct CLASS_NAME => [ELEMENT_NAME => ELEMENT_TYPE, ...];
|
||||
use Class::Struct CLASS_NAME => {ELEMENT_NAME => ELEMENT_TYPE, ...};
|
||||
|
||||
# declare struct at compile time, based on array, implicit
|
||||
# class name:
|
||||
package CLASS_NAME;
|
||||
use Class::Struct ELEMENT_NAME => ELEMENT_TYPE, ... ;
|
||||
|
||||
package Myobj;
|
||||
use Class::Struct;
|
||||
# declare struct with four types of elements:
|
||||
struct( s => '$', a => '@', h => '%', c => 'My_Other_Class' );
|
||||
|
||||
my $obj = Myobj->new; # constructor
|
||||
|
||||
# scalar type accessor:
|
||||
my $element_value = $obj->s; # element value
|
||||
$obj->s('new value'); # assign to element
|
||||
|
||||
# array type accessor:
|
||||
my $ary_ref = $obj->a; # reference to whole array
|
||||
my $ary_element_value = $obj->a(2); # array element value
|
||||
$obj->a(2, 'new value'); # assign to array element
|
||||
|
||||
# hash type accessor:
|
||||
my $hash_ref = $obj->h; # reference to whole hash
|
||||
my $hash_element_value = $obj->h('x'); # hash element value
|
||||
$obj->h('x', 'new value'); # assign to hash element
|
||||
|
||||
# class type accessor:
|
||||
my $element_value = $obj->c; # object reference
|
||||
$obj->c->method(...); # call method of object
|
||||
$obj->c(new My_Other_Class); # assign a new object
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
C<Class::Struct> exports a single function, C<struct>.
|
||||
Given a list of element names and types, and optionally
|
||||
a class name, C<struct> creates a Perl 5 class that implements
|
||||
a "struct-like" data structure.
|
||||
|
||||
The new class is given a constructor method, C<new>, for creating
|
||||
struct objects.
|
||||
|
||||
Each element in the struct data has an accessor method, which is
|
||||
used to assign to the element and to fetch its value. The
|
||||
default accessor can be overridden by declaring a C<sub> of the
|
||||
same name in the package. (See Example 2.)
|
||||
|
||||
Each element's type can be scalar, array, hash, or class.
|
||||
|
||||
=head2 The C<struct()> function
|
||||
|
||||
The C<struct> function has three forms of parameter-list.
|
||||
|
||||
struct( CLASS_NAME => [ ELEMENT_LIST ]);
|
||||
struct( CLASS_NAME => { ELEMENT_LIST });
|
||||
struct( ELEMENT_LIST );
|
||||
|
||||
The first and second forms explicitly identify the name of the
|
||||
class being created. The third form assumes the current package
|
||||
name as the class name.
|
||||
|
||||
An object of a class created by the first and third forms is
|
||||
based on an array, whereas an object of a class created by the
|
||||
second form is based on a hash. The array-based forms will be
|
||||
somewhat faster and smaller; the hash-based forms are more
|
||||
flexible.
|
||||
|
||||
The class created by C<struct> must not be a subclass of another
|
||||
class other than C<UNIVERSAL>.
|
||||
|
||||
It can, however, be used as a superclass for other classes. To facilitate
|
||||
this, the generated constructor method uses a two-argument blessing.
|
||||
Furthermore, if the class is hash-based, the key of each element is
|
||||
prefixed with the class name (see I<Perl Cookbook>, Recipe 13.12).
|
||||
|
||||
A function named C<new> must not be explicitly defined in a class
|
||||
created by C<struct>.
|
||||
|
||||
The I<ELEMENT_LIST> has the form
|
||||
|
||||
NAME => TYPE, ...
|
||||
|
||||
Each name-type pair declares one element of the struct. Each
|
||||
element name will be defined as an accessor method unless a
|
||||
method by that name is explicitly defined; in the latter case, a
|
||||
warning is issued if the warning flag (B<-w>) is set.
|
||||
|
||||
=head2 Class Creation at Compile Time
|
||||
|
||||
C<Class::Struct> can create your class at compile time. The main reason
|
||||
for doing this is obvious, so your class acts like every other class in
|
||||
Perl. Creating your class at compile time will make the order of events
|
||||
similar to using any other class ( or Perl module ).
|
||||
|
||||
There is no significant speed gain between compile time and run time
|
||||
class creation, there is just a new, more standard order of events.
|
||||
|
||||
=head2 Element Types and Accessor Methods
|
||||
|
||||
The four element types -- scalar, array, hash, and class -- are
|
||||
represented by strings -- C<'$'>, C<'@'>, C<'%'>, and a class name --
|
||||
optionally preceded by a C<'*'>.
|
||||
|
||||
The accessor method provided by C<struct> for an element depends
|
||||
on the declared type of the element.
|
||||
|
||||
=over 4
|
||||
|
||||
=item Scalar (C<'$'> or C<'*$'>)
|
||||
|
||||
The element is a scalar, and by default is initialized to C<undef>
|
||||
(but see L</Initializing with new>).
|
||||
|
||||
The accessor's argument, if any, is assigned to the element.
|
||||
|
||||
If the element type is C<'$'>, the value of the element (after
|
||||
assignment) is returned. If the element type is C<'*$'>, a reference
|
||||
to the element is returned.
|
||||
|
||||
=item Array (C<'@'> or C<'*@'>)
|
||||
|
||||
The element is an array, initialized by default to C<()>.
|
||||
|
||||
With no argument, the accessor returns a reference to the
|
||||
element's whole array (whether or not the element was
|
||||
specified as C<'@'> or C<'*@'>).
|
||||
|
||||
With one or two arguments, the first argument is an index
|
||||
specifying one element of the array; the second argument, if
|
||||
present, is assigned to the array element. If the element type
|
||||
is C<'@'>, the accessor returns the array element value. If the
|
||||
element type is C<'*@'>, a reference to the array element is
|
||||
returned.
|
||||
|
||||
As a special case, when the accessor is called with an array reference
|
||||
as the sole argument, this causes an assignment of the whole array element.
|
||||
The object reference is returned.
|
||||
|
||||
=item Hash (C<'%'> or C<'*%'>)
|
||||
|
||||
The element is a hash, initialized by default to C<()>.
|
||||
|
||||
With no argument, the accessor returns a reference to the
|
||||
element's whole hash (whether or not the element was
|
||||
specified as C<'%'> or C<'*%'>).
|
||||
|
||||
With one or two arguments, the first argument is a key specifying
|
||||
one element of the hash; the second argument, if present, is
|
||||
assigned to the hash element. If the element type is C<'%'>, the
|
||||
accessor returns the hash element value. If the element type is
|
||||
C<'*%'>, a reference to the hash element is returned.
|
||||
|
||||
As a special case, when the accessor is called with a hash reference
|
||||
as the sole argument, this causes an assignment of the whole hash element.
|
||||
The object reference is returned.
|
||||
|
||||
=item Class (C<'Class_Name'> or C<'*Class_Name'>)
|
||||
|
||||
The element's value must be a reference blessed to the named
|
||||
class or to one of its subclasses. The element is not initialized
|
||||
by default.
|
||||
|
||||
The accessor's argument, if any, is assigned to the element. The
|
||||
accessor will C<croak> if this is not an appropriate object
|
||||
reference.
|
||||
|
||||
If the element type does not start with a C<'*'>, the accessor
|
||||
returns the element value (after assignment). If the element type
|
||||
starts with a C<'*'>, a reference to the element itself is returned.
|
||||
|
||||
=back
|
||||
|
||||
=head2 Initializing with C<new>
|
||||
|
||||
C<struct> always creates a constructor called C<new>. That constructor
|
||||
may take a list of initializers for the various elements of the new
|
||||
struct.
|
||||
|
||||
Each initializer is a pair of values: I<element name>C< =E<gt> >I<value>.
|
||||
The initializer value for a scalar element is just a scalar value. The
|
||||
initializer for an array element is an array reference. The initializer
|
||||
for a hash is a hash reference.
|
||||
|
||||
The initializer for a class element is an object of the corresponding class,
|
||||
or of one of it's subclasses, or a reference to a hash containing named
|
||||
arguments to be passed to the element's constructor.
|
||||
|
||||
See Example 3 below for an example of initialization.
|
||||
|
||||
=head1 EXAMPLES
|
||||
|
||||
=over 4
|
||||
|
||||
=item Example 1
|
||||
|
||||
Giving a struct element a class type that is also a struct is how
|
||||
structs are nested. Here, C<Timeval> represents a time (seconds and
|
||||
microseconds), and C<Rusage> has two elements, each of which is of
|
||||
type C<Timeval>.
|
||||
|
||||
use Class::Struct;
|
||||
|
||||
struct( Rusage => {
|
||||
ru_utime => 'Timeval', # user time used
|
||||
ru_stime => 'Timeval', # system time used
|
||||
});
|
||||
|
||||
struct( Timeval => [
|
||||
tv_secs => '$', # seconds
|
||||
tv_usecs => '$', # microseconds
|
||||
]);
|
||||
|
||||
# create an object:
|
||||
my $t = Rusage->new(ru_utime=>Timeval->new(),
|
||||
ru_stime=>Timeval->new());
|
||||
|
||||
# $t->ru_utime and $t->ru_stime are objects of type Timeval.
|
||||
# set $t->ru_utime to 100.0 sec and $t->ru_stime to 5.0 sec.
|
||||
$t->ru_utime->tv_secs(100);
|
||||
$t->ru_utime->tv_usecs(0);
|
||||
$t->ru_stime->tv_secs(5);
|
||||
$t->ru_stime->tv_usecs(0);
|
||||
|
||||
=item Example 2
|
||||
|
||||
An accessor function can be redefined in order to provide
|
||||
additional checking of values, etc. Here, we want the C<count>
|
||||
element always to be nonnegative, so we redefine the C<count>
|
||||
accessor accordingly.
|
||||
|
||||
package MyObj;
|
||||
use Class::Struct;
|
||||
|
||||
# declare the struct
|
||||
struct ( 'MyObj', { count => '$', stuff => '%' } );
|
||||
|
||||
# override the default accessor method for 'count'
|
||||
sub count {
|
||||
my $self = shift;
|
||||
if ( @_ ) {
|
||||
die 'count must be nonnegative' if $_[0] < 0;
|
||||
$self->{'MyObj::count'} = shift;
|
||||
warn "Too many args to count" if @_;
|
||||
}
|
||||
return $self->{'MyObj::count'};
|
||||
}
|
||||
|
||||
package main;
|
||||
$x = new MyObj;
|
||||
print "\$x->count(5) = ", $x->count(5), "\n";
|
||||
# prints '$x->count(5) = 5'
|
||||
|
||||
print "\$x->count = ", $x->count, "\n";
|
||||
# prints '$x->count = 5'
|
||||
|
||||
print "\$x->count(-5) = ", $x->count(-5), "\n";
|
||||
# dies due to negative argument!
|
||||
|
||||
=item Example 3
|
||||
|
||||
The constructor of a generated class can be passed a list
|
||||
of I<element>=>I<value> pairs, with which to initialize the struct.
|
||||
If no initializer is specified for a particular element, its default
|
||||
initialization is performed instead. Initializers for non-existent
|
||||
elements are silently ignored.
|
||||
|
||||
Note that the initializer for a nested class may be specified as
|
||||
an object of that class, or as a reference to a hash of initializers
|
||||
that are passed on to the nested struct's constructor.
|
||||
|
||||
use Class::Struct;
|
||||
|
||||
struct Breed =>
|
||||
{
|
||||
name => '$',
|
||||
cross => '$',
|
||||
};
|
||||
|
||||
struct Cat =>
|
||||
[
|
||||
name => '$',
|
||||
kittens => '@',
|
||||
markings => '%',
|
||||
breed => 'Breed',
|
||||
];
|
||||
|
||||
|
||||
my $cat = Cat->new( name => 'Socks',
|
||||
kittens => ['Monica', 'Kenneth'],
|
||||
markings => { socks=>1, blaze=>"white" },
|
||||
breed => Breed->new(name=>'short-hair', cross=>1),
|
||||
or: breed => {name=>'short-hair', cross=>1},
|
||||
);
|
||||
|
||||
print "Once a cat called ", $cat->name, "\n";
|
||||
print "(which was a ", $cat->breed->name, ")\n";
|
||||
print "had 2 kittens: ", join(' and ', @{$cat->kittens}), "\n";
|
||||
|
||||
=back
|
||||
|
||||
=head1 Author and Modification History
|
||||
|
||||
Modified by Damian Conway, 2001-09-10, v0.62.
|
||||
|
||||
Modified implicit construction of nested objects.
|
||||
Now will also take an object ref instead of requiring a hash ref.
|
||||
Also default initializes nested object attributes to undef, rather
|
||||
than calling object constructor without args
|
||||
Original over-helpfulness was fraught with problems:
|
||||
* the class's constructor might not be called 'new'
|
||||
* the class might not have a hash-like-arguments constructor
|
||||
* the class might not have a no-argument constructor
|
||||
* "recursive" data structures didn't work well:
|
||||
package Person;
|
||||
struct { mother => 'Person', father => 'Person'};
|
||||
|
||||
|
||||
Modified by Casey West, 2000-11-08, v0.59.
|
||||
|
||||
Added the ability for compile time class creation.
|
||||
|
||||
Modified by Damian Conway, 1999-03-05, v0.58.
|
||||
|
||||
Added handling of hash-like arg list to class ctor.
|
||||
|
||||
Changed to two-argument blessing in ctor to support
|
||||
derivation from created classes.
|
||||
|
||||
Added classname prefixes to keys in hash-based classes
|
||||
(refer to "Perl Cookbook", Recipe 13.12 for rationale).
|
||||
|
||||
Corrected behaviour of accessors for '*@' and '*%' struct
|
||||
elements. Package now implements documented behaviour when
|
||||
returning a reference to an entire hash or array element.
|
||||
Previously these were returned as a reference to a reference
|
||||
to the element.
|
||||
|
||||
Renamed to C<Class::Struct> and modified by Jim Miner, 1997-04-02.
|
||||
|
||||
members() function removed.
|
||||
Documentation corrected and extended.
|
||||
Use of struct() in a subclass prohibited.
|
||||
User definition of accessor allowed.
|
||||
Treatment of '*' in element types corrected.
|
||||
Treatment of classes as element types corrected.
|
||||
Class name to struct() made optional.
|
||||
Diagnostic checks added.
|
||||
|
||||
Originally C<Class::Template> by Dean Roehrich.
|
||||
|
||||
# Template.pm --- struct/member template builder
|
||||
# 12mar95
|
||||
# Dean Roehrich
|
||||
#
|
||||
# changes/bugs fixed since 28nov94 version:
|
||||
# - podified
|
||||
# changes/bugs fixed since 21nov94 version:
|
||||
# - Fixed examples.
|
||||
# changes/bugs fixed since 02sep94 version:
|
||||
# - Moved to Class::Template.
|
||||
# changes/bugs fixed since 20feb94 version:
|
||||
# - Updated to be a more proper module.
|
||||
# - Added "use strict".
|
||||
# - Bug in build_methods, was using @var when @$var needed.
|
||||
# - Now using my() rather than local().
|
||||
#
|
||||
# Uses perl5 classes to create nested data types.
|
||||
# This is offered as one implementation of Tom Christiansen's
|
||||
# "structs.pl" idea.
|
||||
|
||||
=cut
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,64 @@
|
||||
package Config::Extensions;
|
||||
use strict;
|
||||
our (%Extensions, $VERSION, @ISA, @EXPORT_OK);
|
||||
use Config;
|
||||
require Exporter;
|
||||
|
||||
$VERSION = '0.03';
|
||||
@ISA = 'Exporter';
|
||||
@EXPORT_OK = '%Extensions';
|
||||
|
||||
foreach my $type (qw(static dynamic nonxs)) {
|
||||
foreach (split /\s+/, $Config{$type . '_ext'}) {
|
||||
s!/!::!g;
|
||||
$Extensions{$_} = $type;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Config::Extensions - hash lookup of which core extensions were built.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Config::Extensions '%Extensions';
|
||||
if ($Extensions{PerlIO::via}) {
|
||||
# This perl has PerlIO::via built
|
||||
}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The Config::Extensions module provides a hash C<%Extensions> containing all
|
||||
the core extensions that were enabled for this perl. The hash is keyed by
|
||||
extension name, with each entry having one of 3 possible values:
|
||||
|
||||
=over 4
|
||||
|
||||
=item dynamic
|
||||
|
||||
The extension is dynamically linked
|
||||
|
||||
=item nonxs
|
||||
|
||||
The extension is pure perl, so doesn't need linking to the perl executable
|
||||
|
||||
=item static
|
||||
|
||||
The extension is statically linked to the perl binary
|
||||
|
||||
=back
|
||||
|
||||
As all values evaluate to true, a simple C<if> test is good enough to determine
|
||||
whether an extension is present.
|
||||
|
||||
All the data uses to generate the C<%Extensions> hash is already present in
|
||||
the C<Config> module, but not in such a convenient format to quickly reference.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Nicholas Clark <nick@ccl4.org>
|
||||
|
||||
=cut
|
||||
@@ -0,0 +1,582 @@
|
||||
package Config::Perl::V;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Config;
|
||||
use Exporter;
|
||||
use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS);
|
||||
$VERSION = "0.36";
|
||||
@ISA = qw( Exporter );
|
||||
@EXPORT_OK = qw( plv2hash summary myconfig signature );
|
||||
%EXPORT_TAGS = (
|
||||
'all' => [ @EXPORT_OK ],
|
||||
'sig' => [ "signature" ],
|
||||
);
|
||||
|
||||
# Characteristics of this binary (from libperl):
|
||||
# Compile-time options: DEBUGGING PERL_DONT_CREATE_GVSV PERL_MALLOC_WRAP
|
||||
# USE_64_BIT_INT USE_LARGE_FILES USE_PERLIO
|
||||
|
||||
# The list are as the perl binary has stored it in PL_bincompat_options
|
||||
# search for it in
|
||||
# perl.c line 1643 S_Internals_V ()
|
||||
# perl -ne'(/^S_Internals_V/../^}/)&&s/^\s+"( .*)"/$1/ and print' perl.c
|
||||
# perl.h line 4566 PL_bincompat_options
|
||||
# perl -ne'(/^\w.*PL_bincompat/../^\w}/)&&s/^\s+"( .*)"/$1/ and print' perl.h
|
||||
my %BTD = map {( $_ => 0 )} qw(
|
||||
|
||||
DEBUGGING
|
||||
NO_HASH_SEED
|
||||
NO_MATHOMS
|
||||
NO_PERL_INTERNAL_RAND_SEED
|
||||
NO_PERL_RAND_SEED
|
||||
NO_TAINT_SUPPORT
|
||||
PERL_BOOL_AS_CHAR
|
||||
PERL_COPY_ON_WRITE
|
||||
PERL_DISABLE_PMC
|
||||
PERL_DONT_CREATE_GVSV
|
||||
PERL_EXTERNAL_GLOB
|
||||
PERL_HASH_FUNC_DJB2
|
||||
PERL_HASH_FUNC_MURMUR3
|
||||
PERL_HASH_FUNC_ONE_AT_A_TIME
|
||||
PERL_HASH_FUNC_ONE_AT_A_TIME_HARD
|
||||
PERL_HASH_FUNC_ONE_AT_A_TIME_OLD
|
||||
PERL_HASH_FUNC_SDBM
|
||||
PERL_HASH_FUNC_SIPHASH
|
||||
PERL_HASH_FUNC_SUPERFAST
|
||||
PERL_IS_MINIPERL
|
||||
PERL_MALLOC_WRAP
|
||||
PERL_MEM_LOG
|
||||
PERL_MEM_LOG_ENV
|
||||
PERL_MEM_LOG_ENV_FD
|
||||
PERL_MEM_LOG_NOIMPL
|
||||
PERL_MEM_LOG_STDERR
|
||||
PERL_MEM_LOG_TIMESTAMP
|
||||
PERL_NEW_COPY_ON_WRITE
|
||||
PERL_OP_PARENT
|
||||
PERL_PERTURB_KEYS_DETERMINISTIC
|
||||
PERL_PERTURB_KEYS_DISABLED
|
||||
PERL_PERTURB_KEYS_RANDOM
|
||||
PERL_PRESERVE_IVUV
|
||||
PERL_RC_STACK
|
||||
PERL_RELOCATABLE_INCPUSH
|
||||
PERL_USE_DEVEL
|
||||
PERL_USE_SAFE_PUTENV
|
||||
PERL_USE_UNSHARED_KEYS_IN_LARGE_HASHES
|
||||
SILENT_NO_TAINT_SUPPORT
|
||||
UNLINK_ALL_VERSIONS
|
||||
USE_ATTRIBUTES_FOR_PERLIO
|
||||
USE_FAST_STDIO
|
||||
USE_HASH_SEED_EXPLICIT
|
||||
USE_LOCALE
|
||||
USE_LOCALE_CTYPE
|
||||
USE_NO_REGISTRY
|
||||
USE_PERL_ATOF
|
||||
USE_SITECUSTOMIZE
|
||||
USE_THREAD_SAFE_LOCALE
|
||||
|
||||
DEBUG_LEAKING_SCALARS
|
||||
DEBUG_LEAKING_SCALARS_FORK_DUMP
|
||||
DECCRTL_SOCKETS
|
||||
FAKE_THREADS
|
||||
FCRYPT
|
||||
HAS_TIMES
|
||||
HAVE_INTERP_INTERN
|
||||
MULTIPLICITY
|
||||
MYMALLOC
|
||||
NO_HASH_SEED
|
||||
PERL_DEBUG_READONLY_COW
|
||||
PERL_DEBUG_READONLY_OPS
|
||||
PERL_GLOBAL_STRUCT
|
||||
PERL_GLOBAL_STRUCT_PRIVATE
|
||||
PERL_HASH_NO_SBOX32
|
||||
PERL_HASH_USE_SBOX32
|
||||
PERL_IMPLICIT_CONTEXT
|
||||
PERL_IMPLICIT_SYS
|
||||
PERLIO_LAYERS
|
||||
PERL_MAD
|
||||
PERL_MICRO
|
||||
PERL_NEED_APPCTX
|
||||
PERL_NEED_TIMESBASE
|
||||
PERL_OLD_COPY_ON_WRITE
|
||||
PERL_POISON
|
||||
PERL_SAWAMPERSAND
|
||||
PERL_TRACK_MEMPOOL
|
||||
PERL_USES_PL_PIDSTATUS
|
||||
PL_OP_SLAB_ALLOC
|
||||
THREADS_HAVE_PIDS
|
||||
USE_64_BIT_ALL
|
||||
USE_64_BIT_INT
|
||||
USE_IEEE
|
||||
USE_ITHREADS
|
||||
USE_LARGE_FILES
|
||||
USE_LOCALE_COLLATE
|
||||
USE_LOCALE_NUMERIC
|
||||
USE_LOCALE_TIME
|
||||
USE_LONG_DOUBLE
|
||||
USE_PERLIO
|
||||
USE_QUADMATH
|
||||
USE_REENTRANT_API
|
||||
USE_SFIO
|
||||
USE_SOCKS
|
||||
VMS_DO_SOCKETS
|
||||
VMS_SHORTEN_LONG_SYMBOLS
|
||||
VMS_SYMBOL_CASE_AS_IS
|
||||
);
|
||||
|
||||
# These are all the keys that are
|
||||
# 1. Always present in %Config - lib/Config.pm #87 tie %Config
|
||||
# 2. Reported by 'perl -V' (the rest)
|
||||
my @config_vars = qw(
|
||||
|
||||
api_subversion
|
||||
api_version
|
||||
api_versionstring
|
||||
archlibexp
|
||||
dont_use_nlink
|
||||
d_readlink
|
||||
d_symlink
|
||||
exe_ext
|
||||
inc_version_list
|
||||
ldlibpthname
|
||||
patchlevel
|
||||
path_sep
|
||||
perl_patchlevel
|
||||
privlibexp
|
||||
scriptdir
|
||||
sitearchexp
|
||||
sitelibexp
|
||||
subversion
|
||||
usevendorprefix
|
||||
version
|
||||
|
||||
git_commit_id
|
||||
git_describe
|
||||
git_branch
|
||||
git_uncommitted_changes
|
||||
git_commit_id_title
|
||||
git_snapshot_date
|
||||
|
||||
package revision version_patchlevel_string
|
||||
|
||||
osname osvers archname
|
||||
myuname
|
||||
config_args
|
||||
hint useposix d_sigaction
|
||||
useithreads usemultiplicity
|
||||
useperlio d_sfio uselargefiles usesocks
|
||||
use64bitint use64bitall uselongdouble
|
||||
usemymalloc default_inc_excludes_dot bincompat5005
|
||||
|
||||
cc ccflags
|
||||
optimize
|
||||
cppflags
|
||||
ccversion gccversion gccosandvers
|
||||
intsize longsize ptrsize doublesize byteorder
|
||||
d_longlong longlongsize d_longdbl longdblsize
|
||||
ivtype ivsize nvtype nvsize lseektype lseeksize
|
||||
alignbytes prototype
|
||||
|
||||
ld ldflags
|
||||
libpth
|
||||
libs
|
||||
perllibs
|
||||
libc so useshrplib libperl
|
||||
gnulibc_version
|
||||
|
||||
dlsrc dlext d_dlsymun ccdlflags
|
||||
cccdlflags lddlflags
|
||||
);
|
||||
|
||||
my %empty_build = (
|
||||
'osname' => "",
|
||||
'stamp' => 0,
|
||||
'options' => { %BTD },
|
||||
'patches' => [],
|
||||
);
|
||||
|
||||
sub _make_derived {
|
||||
my $conf = shift;
|
||||
|
||||
for ( [ 'lseektype' => "Off_t" ],
|
||||
[ 'myuname' => "uname" ],
|
||||
[ 'perl_patchlevel' => "patch" ],
|
||||
) {
|
||||
my ($official, $derived) = @{$_};
|
||||
$conf->{'config'}{$derived} ||= $conf->{'config'}{$official};
|
||||
$conf->{'config'}{$official} ||= $conf->{'config'}{$derived};
|
||||
$conf->{'derived'}{$derived} = delete $conf->{'config'}{$derived};
|
||||
}
|
||||
|
||||
if (exists $conf->{'config'}{'version_patchlevel_string'} &&
|
||||
!exists $conf->{'config'}{'api_version'}) {
|
||||
my $vps = $conf->{'config'}{'version_patchlevel_string'};
|
||||
$vps =~ s{\b revision \s+ (\S+) }{}x and
|
||||
$conf->{'config'}{'revision'} ||= $1;
|
||||
|
||||
$vps =~ s{\b version \s+ (\S+) }{}x and
|
||||
$conf->{'config'}{'api_version'} ||= $1;
|
||||
$vps =~ s{\b subversion \s+ (\S+) }{}x and
|
||||
$conf->{'config'}{'subversion'} ||= $1;
|
||||
$vps =~ s{\b patch \s+ (\S+) }{}x and
|
||||
$conf->{'config'}{'perl_patchlevel'} ||= $1;
|
||||
}
|
||||
|
||||
($conf->{'config'}{'version_patchlevel_string'} ||= join " ",
|
||||
map { ($_, $conf->{'config'}{$_} ) }
|
||||
grep { $conf->{'config'}{$_} }
|
||||
qw( api_version subversion perl_patchlevel )) =~ s/\bperl_//;
|
||||
|
||||
$conf->{'config'}{'perl_patchlevel'} ||= ""; # 0 is not a valid patchlevel
|
||||
|
||||
if ($conf->{'config'}{'perl_patchlevel'} =~ m{^git\w*-([^-]+)}i) {
|
||||
$conf->{'config'}{'git_branch'} ||= $1;
|
||||
$conf->{'config'}{'git_describe'} ||= $conf->{'config'}{'perl_patchlevel'};
|
||||
}
|
||||
|
||||
$conf->{'config'}{$_} ||= "undef" for grep m{^(?:use|def)} => @config_vars;
|
||||
|
||||
$conf;
|
||||
} # _make_derived
|
||||
|
||||
sub plv2hash {
|
||||
my %config;
|
||||
|
||||
my $pv = join "\n" => @_;
|
||||
|
||||
if ($pv =~ m{^Summary of my\s+(\S+)\s+\(\s*(.*?)\s*\)}m) {
|
||||
$config{'package'} = $1;
|
||||
my $rev = $2;
|
||||
$rev =~ s/^ revision \s+ (\S+) \s*//x and $config{'revision'} = $1;
|
||||
$rev and $config{'version_patchlevel_string'} = $rev;
|
||||
my ($rel) = $config{'package'} =~ m{perl(\d)};
|
||||
my ($vers, $subvers) = $rev =~ m{version\s+(\d+)\s+subversion\s+(\d+)};
|
||||
defined $vers && defined $subvers && defined $rel and
|
||||
$config{'version'} = "$rel.$vers.$subvers";
|
||||
}
|
||||
|
||||
if ($pv =~ m{^\s+(Snapshot of:)\s+(\S+)}) {
|
||||
$config{'git_commit_id_title'} = $1;
|
||||
$config{'git_commit_id'} = $2;
|
||||
}
|
||||
|
||||
# these are always last on line and can have multiple quotation styles
|
||||
for my $k (qw( ccflags ldflags lddlflags )) {
|
||||
$pv =~ s{, \s* $k \s*=\s* (.*) \s*$}{}mx or next;
|
||||
my $v = $1;
|
||||
$v =~ s/\s*,\s*$//;
|
||||
$v =~ s/^(['"])(.*)\1$/$2/;
|
||||
$config{$k} = $v;
|
||||
}
|
||||
|
||||
my %kv;
|
||||
if ($pv =~ m{\S,? (?:osvers|archname)=}) { # attr is not the first on the line
|
||||
# up to and including 5.24, a line could have multiple kv pairs
|
||||
%kv = ($pv =~ m{\b
|
||||
(\w+) # key
|
||||
\s*= # assign
|
||||
( '\s*[^']*?\s*' # quoted value
|
||||
| \S+[^=]*?\s*\n # unquoted running till end of line
|
||||
| \S+ # unquoted value
|
||||
| \s*\n # empty
|
||||
)
|
||||
(?:,?\s+|\s*\n)? # optional separator (5.8.x reports did
|
||||
}gx); # not have a ',' between every kv pair)
|
||||
}
|
||||
else {
|
||||
# as of 5.25, each kv pair is listed on its own line
|
||||
%kv = ($pv =~ m{^
|
||||
\s+
|
||||
(\w+) # key
|
||||
\s*=\s* # assign
|
||||
(.*?) # value
|
||||
\s*,?\s*$
|
||||
}gmx);
|
||||
}
|
||||
|
||||
while (my ($k, $v) = each %kv) {
|
||||
$k =~ s{\s+$} {};
|
||||
$v =~ s{\s*\n\z} {};
|
||||
$v =~ s{,$} {};
|
||||
$v =~ m{^'(.*)'$} and $v = $1;
|
||||
$v =~ s{\s+$} {};
|
||||
$config{$k} = $v;
|
||||
}
|
||||
|
||||
my $build = { %empty_build };
|
||||
|
||||
$pv =~ m{^\s+Compiled at\s+(.*)}m
|
||||
and $build->{'stamp'} = $1;
|
||||
$pv =~ m{^\s+Locally applied patches:(?:\s+|\n)(.*?)(?:[\s\n]+Buil[td] under)}ms
|
||||
and $build->{'patches'} = [ split m{\n+\s*}, $1 ];
|
||||
$pv =~ m{^\s+Compile-time options:(?:\s+|\n)(.*?)(?:[\s\n]+(?:Locally applied|Buil[td] under))}ms
|
||||
and map { $build->{'options'}{$_} = 1 } split m{\s+|\n} => $1;
|
||||
|
||||
$build->{'osname'} = $config{'osname'};
|
||||
$pv =~ m{^\s+Built under\s+(.*)}m
|
||||
and $build->{'osname'} = $1;
|
||||
$config{'osname'} ||= $build->{'osname'};
|
||||
|
||||
return _make_derived ({
|
||||
'build' => $build,
|
||||
'environment' => {},
|
||||
'config' => \%config,
|
||||
'derived' => {},
|
||||
'inc' => [],
|
||||
});
|
||||
} # plv2hash
|
||||
|
||||
sub summary {
|
||||
my $conf = shift || myconfig ();
|
||||
ref $conf eq "HASH"
|
||||
&& exists $conf->{'config'}
|
||||
&& exists $conf->{'build'}
|
||||
&& ref $conf->{'config'} eq "HASH"
|
||||
&& ref $conf->{'build'} eq "HASH" or return;
|
||||
|
||||
my %info = map {
|
||||
exists $conf->{'config'}{$_} ? ( $_ => $conf->{'config'}{$_} ) : () }
|
||||
qw( archname osname osvers revision patchlevel subversion version
|
||||
cc ccversion gccversion config_args inc_version_list
|
||||
d_longdbl d_longlong use64bitall use64bitint useithreads
|
||||
uselongdouble usemultiplicity usemymalloc useperlio useshrplib
|
||||
doublesize intsize ivsize nvsize longdblsize longlongsize lseeksize
|
||||
default_inc_excludes_dot
|
||||
);
|
||||
$info{$_}++ for grep { $conf->{'build'}{'options'}{$_} } keys %{$conf->{'build'}{'options'}};
|
||||
|
||||
return \%info;
|
||||
} # summary
|
||||
|
||||
sub signature {
|
||||
my $no_md5 = "0" x 32;
|
||||
my $conf = summary (shift) or return $no_md5;
|
||||
|
||||
eval { require Digest::MD5 };
|
||||
$@ and return $no_md5;
|
||||
|
||||
$conf->{'cc'} =~ s{.*\bccache\s+}{};
|
||||
$conf->{'cc'} =~ s{.*[/\\]}{};
|
||||
|
||||
delete $conf->{'config_args'};
|
||||
return Digest::MD5::md5_hex (join "\xFF" => map {
|
||||
"$_=".(defined $conf->{$_} ? $conf->{$_} : "\xFE");
|
||||
} sort keys %{$conf});
|
||||
} # signature
|
||||
|
||||
sub myconfig {
|
||||
my $args = shift;
|
||||
my %args = ref $args eq "HASH" ? %{$args} :
|
||||
ref $args eq "ARRAY" ? @{$args} : ();
|
||||
|
||||
my $build = { %empty_build };
|
||||
|
||||
# 5.14.0 and later provide all the information without shelling out
|
||||
my $stamp = eval { Config::compile_date () };
|
||||
if (defined $stamp) {
|
||||
$stamp =~ s/^Compiled at //;
|
||||
$build->{'osname'} = $^O;
|
||||
$build->{'stamp'} = $stamp;
|
||||
$build->{'patches'} = [ Config::local_patches () ];
|
||||
$build->{'options'}{$_} = 1 for Config::bincompat_options (),
|
||||
Config::non_bincompat_options ();
|
||||
}
|
||||
else {
|
||||
#y $pv = qx[$^X -e"sub Config::myconfig{};" -V];
|
||||
my $cnf = plv2hash (qx[$^X -V]);
|
||||
|
||||
$build->{$_} = $cnf->{'build'}{$_} for qw( osname stamp patches options );
|
||||
}
|
||||
|
||||
my @KEYS = keys %ENV;
|
||||
my %env =
|
||||
map {( $_ => $ENV{$_} )} grep m{^PERL} => @KEYS;
|
||||
if ($args{'env'}) {
|
||||
$env{$_} = $ENV{$_} for grep m{$args{'env'}} => @KEYS;
|
||||
}
|
||||
|
||||
my %config = map { $_ => $Config{$_} } @config_vars;
|
||||
|
||||
return _make_derived ({
|
||||
'build' => $build,
|
||||
'environment' => \%env,
|
||||
'config' => \%config,
|
||||
'derived' => {},
|
||||
'inc' => \@INC,
|
||||
});
|
||||
} # myconfig
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Config::Perl::V - Structured data retrieval of perl -V output
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Config::Perl::V;
|
||||
|
||||
my $local_config = Config::Perl::V::myconfig ();
|
||||
print $local_config->{config}{osname};
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
=head2 $conf = myconfig ()
|
||||
|
||||
This function will collect the data described in L</"The hash structure"> below,
|
||||
and return that as a hash reference. It optionally accepts an option to
|
||||
include more entries from %ENV. See L</environment> below.
|
||||
|
||||
Note that this will not work on uninstalled perls when called with
|
||||
C<-I/path/to/uninstalled/perl/lib>, but it works when that path is in
|
||||
C<$PERL5LIB> or in C<$PERL5OPT>, as paths passed using C<-I> are not
|
||||
known when the C<-V> information is collected.
|
||||
|
||||
=head2 $conf = plv2hash ($text [, ...])
|
||||
|
||||
Convert a sole 'perl -V' text block, or list of lines, to a complete
|
||||
myconfig hash. All unknown entries are defaulted.
|
||||
|
||||
=head2 $info = summary ([$conf])
|
||||
|
||||
Return an arbitrary selection of the information. If no C<$conf> is
|
||||
given, C<myconfig ()> is used instead.
|
||||
|
||||
=head2 $md5 = signature ([$conf])
|
||||
|
||||
Return the MD5 of the info returned by C<summary ()> without the
|
||||
C<config_args> entry.
|
||||
|
||||
If C<Digest::MD5> is not available, it return a string with only C<0>'s.
|
||||
|
||||
=head2 The hash structure
|
||||
|
||||
The returned hash consists of 4 parts:
|
||||
|
||||
=over 4
|
||||
|
||||
=item build
|
||||
|
||||
This information is extracted from the second block that is emitted by
|
||||
C<perl -V>, and usually looks something like
|
||||
|
||||
Characteristics of this binary (from libperl):
|
||||
Compile-time options: DEBUGGING USE_64_BIT_INT USE_LARGE_FILES
|
||||
Locally applied patches:
|
||||
defined-or
|
||||
MAINT24637
|
||||
Built under linux
|
||||
Compiled at Jun 13 2005 10:44:20
|
||||
@INC:
|
||||
/usr/lib/perl5/5.8.7/i686-linux-64int
|
||||
/usr/lib/perl5/5.8.7
|
||||
/usr/lib/perl5/site_perl/5.8.7/i686-linux-64int
|
||||
/usr/lib/perl5/site_perl/5.8.7
|
||||
/usr/lib/perl5/site_perl
|
||||
.
|
||||
|
||||
or
|
||||
|
||||
Characteristics of this binary (from libperl):
|
||||
Compile-time options: DEBUGGING MULTIPLICITY
|
||||
PERL_DONT_CREATE_GVSV PERL_IMPLICIT_CONTEXT
|
||||
PERL_MALLOC_WRAP PERL_TRACK_MEMPOOL
|
||||
PERL_USE_SAFE_PUTENV USE_ITHREADS
|
||||
USE_LARGE_FILES USE_PERLIO
|
||||
USE_REENTRANT_API
|
||||
Built under linux
|
||||
Compiled at Jan 28 2009 15:26:59
|
||||
|
||||
This information is not available anywhere else, including C<%Config>,
|
||||
but it is the information that is only known to the perl binary.
|
||||
|
||||
The extracted information is stored in 5 entries in the C<build> hash:
|
||||
|
||||
=over 4
|
||||
|
||||
=item osname
|
||||
|
||||
This is most likely the same as C<$Config{osname}>, and was the name
|
||||
known when perl was built. It might be different if perl was cross-compiled.
|
||||
|
||||
The default for this field, if it cannot be extracted, is to copy
|
||||
C<$Config{osname}>. The two may be differing in casing (OpenBSD vs openbsd).
|
||||
|
||||
=item stamp
|
||||
|
||||
This is the time string for which the perl binary was compiled. The default
|
||||
value is 0.
|
||||
|
||||
=item options
|
||||
|
||||
This is a hash with all the known defines as keys. The value is either 0,
|
||||
which means unknown or unset, or 1, which means defined.
|
||||
|
||||
=item derived
|
||||
|
||||
As some variables are reported by a different name in the output of C<perl -V>
|
||||
than their actual name in C<%Config>, I decided to leave the C<config> entry
|
||||
as close to reality as possible, and put in the entries that might have been
|
||||
guessed by the printed output in a separate block.
|
||||
|
||||
=item patches
|
||||
|
||||
This is a list of optionally locally applied patches. Default is an empty list.
|
||||
|
||||
=back
|
||||
|
||||
=item environment
|
||||
|
||||
By default this hash is only filled with the environment variables
|
||||
out of %ENV that start with C<PERL>, but you can pass the C<env> option
|
||||
to myconfig to get more
|
||||
|
||||
my $conf = Config::Perl::V::myconfig ({ env => qr/^ORACLE/ });
|
||||
my $conf = Config::Perl::V::myconfig ([ env => qr/^ORACLE/ ]);
|
||||
|
||||
=item config
|
||||
|
||||
This hash is filled with the variables that C<perl -V> fills its report
|
||||
with, and it has the same variables that C<Config::myconfig> returns
|
||||
from C<%Config>.
|
||||
|
||||
=item inc
|
||||
|
||||
This is the list of default @INC.
|
||||
|
||||
=back
|
||||
|
||||
=head1 REASONING
|
||||
|
||||
This module was written to be able to return the configuration for the
|
||||
currently used perl as deeply as needed for the CPANTESTERS framework.
|
||||
Up until now they used the output of myconfig as a single text blob,
|
||||
and so it was missing the vital binary characteristics of the running
|
||||
perl and the optional applied patches.
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
Please feedback what is wrong
|
||||
|
||||
=head1 TODO
|
||||
|
||||
* Implement retrieval functions/methods
|
||||
* Documentation
|
||||
* Error checking
|
||||
* Tests
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
H.Merijn Brand <h.m.brand@xs4all.nl>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright (C) 2009-2023 H.Merijn Brand
|
||||
|
||||
This library is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
@@ -0,0 +1,802 @@
|
||||
#
|
||||
# Documentation is at the __END__
|
||||
#
|
||||
|
||||
package DB;
|
||||
|
||||
# "private" globals
|
||||
|
||||
my ($running, $ready, $deep, $usrctxt, $evalarg,
|
||||
@stack, @saved, @skippkg, @clients);
|
||||
my $preeval = {};
|
||||
my $posteval = {};
|
||||
my $ineval = {};
|
||||
|
||||
####
|
||||
#
|
||||
# Globals - must be defined at startup so that clients can refer to
|
||||
# them right after a C<require DB;>
|
||||
#
|
||||
####
|
||||
|
||||
BEGIN {
|
||||
|
||||
# these are hardcoded in perl source (some are magical)
|
||||
|
||||
$DB::sub = ''; # name of current subroutine
|
||||
%DB::sub = (); # "filename:fromline-toline" for every known sub
|
||||
$DB::single = 0; # single-step flag (set it to 1 to enable stops in BEGIN/use)
|
||||
$DB::signal = 0; # signal flag (will cause a stop at the next line)
|
||||
$DB::trace = 0; # are we tracing through subroutine calls?
|
||||
@DB::args = (); # arguments of current subroutine or @ARGV array
|
||||
@DB::dbline = (); # list of lines in currently loaded file
|
||||
%DB::dbline = (); # actions in current file (keyed by line number)
|
||||
@DB::ret = (); # return value of last sub executed in list context
|
||||
$DB::ret = ''; # return value of last sub executed in scalar context
|
||||
|
||||
# other "public" globals
|
||||
|
||||
$DB::package = ''; # current package space
|
||||
$DB::filename = ''; # current filename
|
||||
$DB::subname = ''; # currently executing sub (fully qualified name)
|
||||
$DB::lineno = ''; # current line number
|
||||
|
||||
$DB::VERSION = $DB::VERSION = '1.08';
|
||||
|
||||
# initialize private globals to avoid warnings
|
||||
|
||||
$running = 1; # are we running, or are we stopped?
|
||||
@stack = (0);
|
||||
@clients = ();
|
||||
$deep = 1000;
|
||||
$ready = 0;
|
||||
@saved = ();
|
||||
@skippkg = ();
|
||||
$usrctxt = '';
|
||||
$evalarg = '';
|
||||
}
|
||||
|
||||
####
|
||||
# entry point for all subroutine calls
|
||||
#
|
||||
sub sub {
|
||||
push(@stack, $DB::single);
|
||||
$DB::single &= 1;
|
||||
$DB::single |= 4 if $#stack == $deep;
|
||||
if ($DB::sub eq 'DESTROY' or substr($DB::sub, -9) eq '::DESTROY' or not defined wantarray) {
|
||||
&$DB::sub;
|
||||
$DB::single |= pop(@stack);
|
||||
$DB::ret = undef;
|
||||
}
|
||||
elsif (wantarray) {
|
||||
@DB::ret = &$DB::sub;
|
||||
$DB::single |= pop(@stack);
|
||||
@DB::ret;
|
||||
}
|
||||
else {
|
||||
$DB::ret = &$DB::sub;
|
||||
$DB::single |= pop(@stack);
|
||||
$DB::ret;
|
||||
}
|
||||
}
|
||||
|
||||
####
|
||||
# this is called by perl for every statement
|
||||
#
|
||||
sub DB {
|
||||
return unless $ready;
|
||||
&save;
|
||||
($DB::package, $DB::filename, $DB::lineno) = caller;
|
||||
|
||||
return if @skippkg and grep { $_ eq $DB::package } @skippkg;
|
||||
|
||||
$usrctxt = "package $DB::package;"; # this won't let them modify, alas
|
||||
local(*DB::dbline) = "::_<$DB::filename";
|
||||
|
||||
my ($stop, $action);
|
||||
if (($stop,$action) = split(/\0/,$DB::dbline{$DB::lineno})) {
|
||||
if ($stop eq '1') {
|
||||
$DB::signal |= 1;
|
||||
}
|
||||
else {
|
||||
$stop = 0 unless $stop; # avoid un_init warning
|
||||
$evalarg = "\$DB::signal |= do { $stop; }"; &eval;
|
||||
$DB::dbline{$DB::lineno} =~ s/;9($|\0)/$1/; # clear any temp breakpt
|
||||
}
|
||||
}
|
||||
if ($DB::single || $DB::trace || $DB::signal) {
|
||||
$DB::subname = ($DB::sub =~ /\'|::/) ? $DB::sub : "${DB::package}::$DB::sub"; #';
|
||||
DB->loadfile($DB::filename, $DB::lineno);
|
||||
}
|
||||
$evalarg = $action, &eval if $action;
|
||||
if ($DB::single || $DB::signal) {
|
||||
_outputall($#stack . " levels deep in subroutine calls.\n") if $DB::single & 4;
|
||||
$DB::single = 0;
|
||||
$DB::signal = 0;
|
||||
$running = 0;
|
||||
|
||||
&eval if ($evalarg = DB->prestop);
|
||||
my $c;
|
||||
for $c (@clients) {
|
||||
# perform any client-specific prestop actions
|
||||
&eval if ($evalarg = $c->cprestop);
|
||||
|
||||
# Now sit in an event loop until something sets $running
|
||||
do {
|
||||
$c->idle; # call client event loop; must not block
|
||||
if ($running == 2) { # client wants something eval-ed
|
||||
&eval if ($evalarg = $c->evalcode);
|
||||
$running = 0;
|
||||
}
|
||||
} until $running;
|
||||
|
||||
# perform any client-specific poststop actions
|
||||
&eval if ($evalarg = $c->cpoststop);
|
||||
}
|
||||
&eval if ($evalarg = DB->poststop);
|
||||
}
|
||||
($@, $!, $,, $/, $\, $^W) = @saved;
|
||||
();
|
||||
}
|
||||
|
||||
####
|
||||
# this takes its argument via $evalarg to preserve current @_
|
||||
#
|
||||
sub eval {
|
||||
($@, $!, $,, $/, $\, $^W) = @saved;
|
||||
eval "$usrctxt $evalarg; &DB::save";
|
||||
_outputall($@) if $@;
|
||||
}
|
||||
|
||||
###############################################################################
|
||||
# no compile-time subroutine call allowed before this point #
|
||||
###############################################################################
|
||||
|
||||
use strict; # this can run only after DB() and sub() are defined
|
||||
|
||||
sub save {
|
||||
@saved = ($@, $!, $,, $/, $\, $^W);
|
||||
$, = ""; $/ = "\n"; $\ = ""; $^W = 0;
|
||||
}
|
||||
|
||||
sub catch {
|
||||
for (@clients) { $_->awaken; }
|
||||
$DB::signal = 1;
|
||||
$ready = 1;
|
||||
}
|
||||
|
||||
####
|
||||
#
|
||||
# Client callable (read inheritable) methods defined after this point
|
||||
#
|
||||
####
|
||||
|
||||
sub register {
|
||||
my $s = shift;
|
||||
$s = _clientname($s) if ref($s);
|
||||
push @clients, $s;
|
||||
}
|
||||
|
||||
sub done {
|
||||
my $s = shift;
|
||||
$s = _clientname($s) if ref($s);
|
||||
@clients = grep {$_ ne $s} @clients;
|
||||
$s->cleanup;
|
||||
# $running = 3 unless @clients;
|
||||
exit(0) unless @clients;
|
||||
}
|
||||
|
||||
sub _clientname {
|
||||
my $name = shift;
|
||||
"$name" =~ /^(.+)=[A-Z]+\(.+\)$/;
|
||||
return $1;
|
||||
}
|
||||
|
||||
sub next {
|
||||
my $s = shift;
|
||||
$DB::single = 2;
|
||||
$running = 1;
|
||||
}
|
||||
|
||||
sub step {
|
||||
my $s = shift;
|
||||
$DB::single = 1;
|
||||
$running = 1;
|
||||
}
|
||||
|
||||
sub cont {
|
||||
my $s = shift;
|
||||
my $i = shift;
|
||||
$s->set_tbreak($i) if $i;
|
||||
for ($i = 0; $i <= $#stack;) {
|
||||
$stack[$i++] &= ~1;
|
||||
}
|
||||
$DB::single = 0;
|
||||
$running = 1;
|
||||
}
|
||||
|
||||
####
|
||||
# XXX caller must experimentally determine $i (since it depends
|
||||
# on how many client call frames are between this call and the DB call).
|
||||
# Such is life.
|
||||
#
|
||||
sub ret {
|
||||
my $s = shift;
|
||||
my $i = shift; # how many levels to get to DB sub
|
||||
$i = 0 unless defined $i;
|
||||
$stack[$#stack-$i] |= 1;
|
||||
$DB::single = 0;
|
||||
$running = 1;
|
||||
}
|
||||
|
||||
####
|
||||
# XXX caller must experimentally determine $start (since it depends
|
||||
# on how many client call frames are between this call and the DB call).
|
||||
# Such is life.
|
||||
#
|
||||
sub backtrace {
|
||||
my $self = shift;
|
||||
my $start = shift;
|
||||
my($p,$f,$l,$s,$h,$w,$e,$r,$a, @a, @ret,$i);
|
||||
$start = 1 unless $start;
|
||||
for ($i = $start; ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i); $i++) {
|
||||
@a = @DB::args;
|
||||
for (@a) {
|
||||
s/'/\\'/g;
|
||||
s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
|
||||
require 'meta_notation.pm';
|
||||
$_ = _meta_notation($_) if /[[:^print:]]/a;
|
||||
}
|
||||
$w = $w ? '@ = ' : '$ = ';
|
||||
$a = $h ? '(' . join(', ', @a) . ')' : '';
|
||||
$e =~ s/\n\s*\;\s*\Z// if $e;
|
||||
$e =~ s/[\\\']/\\$1/g if $e;
|
||||
if ($r) {
|
||||
$s = "require '$e'";
|
||||
} elsif (defined $r) {
|
||||
$s = "eval '$e'";
|
||||
} elsif ($s eq '(eval)') {
|
||||
$s = "eval {...}";
|
||||
}
|
||||
$f = "file '$f'" unless $f eq '-e';
|
||||
push @ret, "$w&$s$a from $f line $l";
|
||||
last if $DB::signal;
|
||||
}
|
||||
return @ret;
|
||||
}
|
||||
|
||||
sub _outputall {
|
||||
my $c;
|
||||
for $c (@clients) {
|
||||
$c->output(@_);
|
||||
}
|
||||
}
|
||||
|
||||
sub trace_toggle {
|
||||
my $s = shift;
|
||||
$DB::trace = !$DB::trace;
|
||||
}
|
||||
|
||||
|
||||
####
|
||||
# without args: returns all defined subroutine names
|
||||
# with subname args: returns a listref [file, start, end]
|
||||
#
|
||||
sub subs {
|
||||
my $s = shift;
|
||||
if (@_) {
|
||||
my(@ret) = ();
|
||||
while (@_) {
|
||||
my $name = shift;
|
||||
push @ret, [$DB::sub{$name} =~ /^(.*)\:(\d+)-(\d+)$/]
|
||||
if exists $DB::sub{$name};
|
||||
}
|
||||
return @ret;
|
||||
}
|
||||
return keys %DB::sub;
|
||||
}
|
||||
|
||||
####
|
||||
# first argument is a filename whose subs will be returned
|
||||
# if a filename is not supplied, all subs in the current
|
||||
# filename are returned.
|
||||
#
|
||||
sub filesubs {
|
||||
my $s = shift;
|
||||
my $fname = shift;
|
||||
$fname = $DB::filename unless $fname;
|
||||
return grep { $DB::sub{$_} =~ /^$fname/ } keys %DB::sub;
|
||||
}
|
||||
|
||||
####
|
||||
# returns a list of all filenames that DB knows about
|
||||
#
|
||||
sub files {
|
||||
my $s = shift;
|
||||
my(@f) = grep(m|^_<|, keys %main::);
|
||||
return map { substr($_,2) } @f;
|
||||
}
|
||||
|
||||
####
|
||||
# returns reference to an array holding the lines in currently
|
||||
# loaded file
|
||||
#
|
||||
sub lines {
|
||||
my $s = shift;
|
||||
return \@DB::dbline;
|
||||
}
|
||||
|
||||
####
|
||||
# loadfile($file, $line)
|
||||
#
|
||||
sub loadfile {
|
||||
my $s = shift;
|
||||
my($file, $line) = @_;
|
||||
if (!defined $main::{'_<' . $file}) {
|
||||
my $try;
|
||||
if (($try) = grep(m|^_<.*$file|, keys %main::)) {
|
||||
$file = substr($try,2);
|
||||
}
|
||||
}
|
||||
if (defined($main::{'_<' . $file})) {
|
||||
my $c;
|
||||
# _outputall("Loading file $file..");
|
||||
*DB::dbline = "::_<$file";
|
||||
$DB::filename = $file;
|
||||
for $c (@clients) {
|
||||
# print "2 ", $file, '|', $line, "\n";
|
||||
$c->showfile($file, $line);
|
||||
}
|
||||
return $file;
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub lineevents {
|
||||
my $s = shift;
|
||||
my $fname = shift;
|
||||
my(%ret) = ();
|
||||
my $i;
|
||||
$fname = $DB::filename unless $fname;
|
||||
local(*DB::dbline) = "::_<$fname";
|
||||
for ($i = 1; $i <= $#DB::dbline; $i++) {
|
||||
$ret{$i} = [$DB::dbline[$i], split(/\0/, $DB::dbline{$i})]
|
||||
if defined $DB::dbline{$i};
|
||||
}
|
||||
return %ret;
|
||||
}
|
||||
|
||||
sub set_break {
|
||||
my $s = shift;
|
||||
my $i = shift;
|
||||
my $cond = shift;
|
||||
$i ||= $DB::lineno;
|
||||
$cond ||= '1';
|
||||
$i = _find_subline($i) if ($i =~ /\D/);
|
||||
$s->output("Subroutine not found.\n") unless $i;
|
||||
if ($i) {
|
||||
if ($DB::dbline[$i] == 0) {
|
||||
$s->output("Line $i not breakable.\n");
|
||||
}
|
||||
else {
|
||||
$DB::dbline{$i} =~ s/^[^\0]*/$cond/;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub set_tbreak {
|
||||
my $s = shift;
|
||||
my $i = shift;
|
||||
$i = _find_subline($i) if ($i =~ /\D/);
|
||||
$s->output("Subroutine not found.\n") unless $i;
|
||||
if ($i) {
|
||||
if ($DB::dbline[$i] == 0) {
|
||||
$s->output("Line $i not breakable.\n");
|
||||
}
|
||||
else {
|
||||
$DB::dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub _find_subline {
|
||||
my $name = shift;
|
||||
$name =~ s/\'/::/;
|
||||
$name = "${DB::package}\:\:" . $name if $name !~ /::/;
|
||||
$name = "main" . $name if substr($name,0,2) eq "::";
|
||||
my($fname, $from, $to) = ($DB::sub{$name} =~ /^(.*):(\d+)-(\d+)$/);
|
||||
if ($from) {
|
||||
local *DB::dbline = "::_<$fname";
|
||||
++$from while $DB::dbline[$from] == 0 && $from < $to;
|
||||
return $from;
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub clr_breaks {
|
||||
my $s = shift;
|
||||
my $i;
|
||||
if (@_) {
|
||||
while (@_) {
|
||||
$i = shift;
|
||||
$i = _find_subline($i) if ($i =~ /\D/);
|
||||
$s->output("Subroutine not found.\n") unless $i;
|
||||
if (defined $DB::dbline{$i}) {
|
||||
$DB::dbline{$i} =~ s/^[^\0]+//;
|
||||
if ($DB::dbline{$i} =~ s/^\0?$//) {
|
||||
delete $DB::dbline{$i};
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
for ($i = 1; $i <= $#DB::dbline ; $i++) {
|
||||
if (defined $DB::dbline{$i}) {
|
||||
$DB::dbline{$i} =~ s/^[^\0]+//;
|
||||
if ($DB::dbline{$i} =~ s/^\0?$//) {
|
||||
delete $DB::dbline{$i};
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub set_action {
|
||||
my $s = shift;
|
||||
my $i = shift;
|
||||
my $act = shift;
|
||||
$i = _find_subline($i) if ($i =~ /\D/);
|
||||
$s->output("Subroutine not found.\n") unless $i;
|
||||
if ($i) {
|
||||
if ($DB::dbline[$i] == 0) {
|
||||
$s->output("Line $i not actionable.\n");
|
||||
}
|
||||
else {
|
||||
$DB::dbline{$i} =~ s/\0[^\0]*//;
|
||||
$DB::dbline{$i} .= "\0" . $act;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub clr_actions {
|
||||
my $s = shift;
|
||||
my $i;
|
||||
if (@_) {
|
||||
while (@_) {
|
||||
my $i = shift;
|
||||
$i = _find_subline($i) if ($i =~ /\D/);
|
||||
$s->output("Subroutine not found.\n") unless $i;
|
||||
if ($i && $DB::dbline[$i] != 0) {
|
||||
$DB::dbline{$i} =~ s/\0[^\0]*//;
|
||||
delete $DB::dbline{$i} if $DB::dbline{$i} =~ s/^\0?$//;
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
for ($i = 1; $i <= $#DB::dbline ; $i++) {
|
||||
if (defined $DB::dbline{$i}) {
|
||||
$DB::dbline{$i} =~ s/\0[^\0]*//;
|
||||
delete $DB::dbline{$i} if $DB::dbline{$i} =~ s/^\0?$//;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub prestop {
|
||||
my ($client, $val) = @_;
|
||||
return defined($val) ? $preeval->{$client} = $val : $preeval->{$client};
|
||||
}
|
||||
|
||||
sub poststop {
|
||||
my ($client, $val) = @_;
|
||||
return defined($val) ? $posteval->{$client} = $val : $posteval->{$client};
|
||||
}
|
||||
|
||||
#
|
||||
# "pure virtual" methods
|
||||
#
|
||||
|
||||
# client-specific pre/post-stop actions.
|
||||
sub cprestop {}
|
||||
sub cpoststop {}
|
||||
|
||||
# client complete startup
|
||||
sub awaken {}
|
||||
|
||||
sub skippkg {
|
||||
my $s = shift;
|
||||
push @skippkg, @_ if @_;
|
||||
}
|
||||
|
||||
sub evalcode {
|
||||
my ($client, $val) = @_;
|
||||
if (defined $val) {
|
||||
$running = 2; # hand over to DB() to evaluate in its context
|
||||
$ineval->{$client} = $val;
|
||||
}
|
||||
return $ineval->{$client};
|
||||
}
|
||||
|
||||
sub ready {
|
||||
my $s = shift;
|
||||
return $ready = 1;
|
||||
}
|
||||
|
||||
# stubs
|
||||
|
||||
sub init {}
|
||||
sub stop {}
|
||||
sub idle {}
|
||||
sub cleanup {}
|
||||
sub output {}
|
||||
|
||||
#
|
||||
# client init
|
||||
#
|
||||
for (@clients) { $_->init }
|
||||
|
||||
$SIG{'INT'} = \&DB::catch;
|
||||
|
||||
# disable this if stepping through END blocks is desired
|
||||
# (looks scary and deconstructivist with Swat)
|
||||
END { $ready = 0 }
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
DB - programmatic interface to the Perl debugging API
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package CLIENT;
|
||||
use DB;
|
||||
@ISA = qw(DB);
|
||||
|
||||
# these (inherited) methods can be called by the client
|
||||
|
||||
CLIENT->register() # register a client package name
|
||||
CLIENT->done() # de-register from the debugging API
|
||||
CLIENT->skippkg('hide::hide') # ask DB not to stop in this package
|
||||
CLIENT->cont([WHERE]) # run some more (until BREAK or
|
||||
# another breakpointt)
|
||||
CLIENT->step() # single step
|
||||
CLIENT->next() # step over
|
||||
CLIENT->ret() # return from current subroutine
|
||||
CLIENT->backtrace() # return the call stack description
|
||||
CLIENT->ready() # call when client setup is done
|
||||
CLIENT->trace_toggle() # toggle subroutine call trace mode
|
||||
CLIENT->subs([SUBS]) # return subroutine information
|
||||
CLIENT->files() # return list of all files known to DB
|
||||
CLIENT->lines() # return lines in currently loaded file
|
||||
CLIENT->loadfile(FILE,LINE) # load a file and let other clients know
|
||||
CLIENT->lineevents() # return info on lines with actions
|
||||
CLIENT->set_break([WHERE],[COND])
|
||||
CLIENT->set_tbreak([WHERE])
|
||||
CLIENT->clr_breaks([LIST])
|
||||
CLIENT->set_action(WHERE,ACTION)
|
||||
CLIENT->clr_actions([LIST])
|
||||
CLIENT->evalcode(STRING) # eval STRING in executing code's context
|
||||
CLIENT->prestop([STRING]) # execute in code context before stopping
|
||||
CLIENT->poststop([STRING])# execute in code context before resuming
|
||||
|
||||
# These methods will be called at the appropriate times.
|
||||
# Stub versions provided do nothing.
|
||||
# None of these can block.
|
||||
|
||||
CLIENT->init() # called when debug API inits itself
|
||||
CLIENT->stop(FILE,LINE) # when execution stops
|
||||
CLIENT->idle() # while stopped (can be a client event loop)
|
||||
CLIENT->cleanup() # just before exit
|
||||
CLIENT->output(LIST) # called to print any output that
|
||||
# the API must show
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Perl debug information is frequently required not just by debuggers,
|
||||
but also by modules that need some "special" information to do their
|
||||
job properly, like profilers.
|
||||
|
||||
This module abstracts and provides all of the hooks into Perl internal
|
||||
debugging functionality, so that various implementations of Perl debuggers
|
||||
(or packages that want to simply get at the "privileged" debugging data)
|
||||
can all benefit from the development of this common code. Currently used
|
||||
by Swat, the perl/Tk GUI debugger.
|
||||
|
||||
Note that multiple "front-ends" can latch into this debugging API
|
||||
simultaneously. This is intended to facilitate things like
|
||||
debugging with a command line and GUI at the same time, debugging
|
||||
debuggers etc. [Sounds nice, but this needs some serious support -- GSAR]
|
||||
|
||||
In particular, this API does B<not> provide the following functions:
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
data display
|
||||
|
||||
=item *
|
||||
|
||||
command processing
|
||||
|
||||
=item *
|
||||
|
||||
command alias management
|
||||
|
||||
=item *
|
||||
|
||||
user interface (tty or graphical)
|
||||
|
||||
=back
|
||||
|
||||
These are intended to be services performed by the clients of this API.
|
||||
|
||||
This module attempts to be squeaky clean w.r.t C<use strict;> and when
|
||||
warnings are enabled.
|
||||
|
||||
|
||||
=head2 Global Variables
|
||||
|
||||
The following "public" global names can be read by clients of this API.
|
||||
Beware that these should be considered "readonly".
|
||||
|
||||
=over 8
|
||||
|
||||
=item $DB::sub
|
||||
|
||||
Name of current executing subroutine.
|
||||
|
||||
=item %DB::sub
|
||||
|
||||
The keys of this hash are the names of all the known subroutines. Each value
|
||||
is an encoded string that has the sprintf(3) format
|
||||
C<("%s:%d-%d", filename, fromline, toline)>.
|
||||
|
||||
=item $DB::single
|
||||
|
||||
Single-step flag. Will be true if the API will stop at the next statement.
|
||||
|
||||
=item $DB::signal
|
||||
|
||||
Signal flag. Will be set to a true value if a signal was caught. Clients may
|
||||
check for this flag to abort time-consuming operations.
|
||||
|
||||
=item $DB::trace
|
||||
|
||||
This flag is set to true if the API is tracing through subroutine calls.
|
||||
|
||||
=item @DB::args
|
||||
|
||||
Contains the arguments of current subroutine, or the C<@ARGV> array if in the
|
||||
toplevel context.
|
||||
|
||||
=item @DB::dbline
|
||||
|
||||
List of lines in currently loaded file.
|
||||
|
||||
=item %DB::dbline
|
||||
|
||||
Actions in current file (keys are line numbers). The values are strings that
|
||||
have the sprintf(3) format C<("%s\000%s", breakcondition, actioncode)>.
|
||||
|
||||
=item $DB::package
|
||||
|
||||
Package namespace of currently executing code.
|
||||
|
||||
=item $DB::filename
|
||||
|
||||
Currently loaded filename.
|
||||
|
||||
=item $DB::subname
|
||||
|
||||
Fully qualified name of currently executing subroutine.
|
||||
|
||||
=item $DB::lineno
|
||||
|
||||
Line number that will be executed next.
|
||||
|
||||
=back
|
||||
|
||||
=head2 API Methods
|
||||
|
||||
The following are methods in the DB base class. A client must
|
||||
access these methods by inheritance (*not* by calling them directly),
|
||||
since the API keeps track of clients through the inheritance
|
||||
mechanism.
|
||||
|
||||
=over 8
|
||||
|
||||
=item CLIENT->register()
|
||||
|
||||
register a client object/package
|
||||
|
||||
=item CLIENT->evalcode(STRING)
|
||||
|
||||
eval STRING in executing code context
|
||||
|
||||
=item CLIENT->skippkg('D::hide')
|
||||
|
||||
ask DB not to stop in these packages
|
||||
|
||||
=item CLIENT->run()
|
||||
|
||||
run some more (until a breakpt is reached)
|
||||
|
||||
=item CLIENT->step()
|
||||
|
||||
single step
|
||||
|
||||
=item CLIENT->next()
|
||||
|
||||
step over
|
||||
|
||||
=item CLIENT->done()
|
||||
|
||||
de-register from the debugging API
|
||||
|
||||
=back
|
||||
|
||||
=head2 Client Callback Methods
|
||||
|
||||
The following "virtual" methods can be defined by the client. They will
|
||||
be called by the API at appropriate points. Note that unless specified
|
||||
otherwise, the debug API only defines empty, non-functional default versions
|
||||
of these methods.
|
||||
|
||||
=over 8
|
||||
|
||||
=item CLIENT->init()
|
||||
|
||||
Called after debug API inits itself.
|
||||
|
||||
=item CLIENT->prestop([STRING])
|
||||
|
||||
Usually inherited from DB package. If no arguments are passed,
|
||||
returns the prestop action string.
|
||||
|
||||
=item CLIENT->stop()
|
||||
|
||||
Called when execution stops (w/ args file, line).
|
||||
|
||||
=item CLIENT->idle()
|
||||
|
||||
Called while stopped (can be a client event loop).
|
||||
|
||||
=item CLIENT->poststop([STRING])
|
||||
|
||||
Usually inherited from DB package. If no arguments are passed,
|
||||
returns the poststop action string.
|
||||
|
||||
=item CLIENT->evalcode(STRING)
|
||||
|
||||
Usually inherited from DB package. Ask for a STRING to be C<eval>-ed
|
||||
in executing code context.
|
||||
|
||||
=item CLIENT->cleanup()
|
||||
|
||||
Called just before exit.
|
||||
|
||||
=item CLIENT->output(LIST)
|
||||
|
||||
Called when API must show a message (warnings, errors etc.).
|
||||
|
||||
|
||||
=back
|
||||
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
The interface defined by this module is missing some of the later additions
|
||||
to perl's debugging functionality. As such, this interface should be considered
|
||||
highly experimental and subject to change.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Gurusamy Sarathy gsar@activestate.com
|
||||
|
||||
This code heavily adapted from an early version of perl5db.pl attributable
|
||||
to Larry Wall and the Perl Porters.
|
||||
|
||||
=cut
|
||||
@@ -0,0 +1,601 @@
|
||||
package DBM_Filter ;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
our $VERSION = '0.06';
|
||||
|
||||
package Tie::Hash ;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Carp;
|
||||
|
||||
|
||||
our %LayerStack = ();
|
||||
our %origDESTROY = ();
|
||||
|
||||
our %Filters = map { $_, undef } qw(
|
||||
Fetch_Key
|
||||
Fetch_Value
|
||||
Store_Key
|
||||
Store_Value
|
||||
);
|
||||
|
||||
our %Options = map { $_, 1 } qw(
|
||||
fetch
|
||||
store
|
||||
);
|
||||
|
||||
#sub Filter_Enable
|
||||
#{
|
||||
#}
|
||||
#
|
||||
#sub Filter_Disable
|
||||
#{
|
||||
#}
|
||||
|
||||
sub Filtered
|
||||
{
|
||||
my $this = shift;
|
||||
return defined $LayerStack{$this} ;
|
||||
}
|
||||
|
||||
sub Filter_Pop
|
||||
{
|
||||
my $this = shift;
|
||||
my $stack = $LayerStack{$this} || return undef ;
|
||||
my $filter = pop @{ $stack };
|
||||
|
||||
# remove the filter hooks if this is the last filter to pop
|
||||
if ( @{ $stack } == 0 ) {
|
||||
$this->filter_store_key ( undef );
|
||||
$this->filter_store_value( undef );
|
||||
$this->filter_fetch_key ( undef );
|
||||
$this->filter_fetch_value( undef );
|
||||
delete $LayerStack{$this};
|
||||
}
|
||||
|
||||
return $filter;
|
||||
}
|
||||
|
||||
sub Filter_Key_Push
|
||||
{
|
||||
&_do_Filter_Push;
|
||||
}
|
||||
|
||||
sub Filter_Value_Push
|
||||
{
|
||||
&_do_Filter_Push;
|
||||
}
|
||||
|
||||
|
||||
sub Filter_Push
|
||||
{
|
||||
&_do_Filter_Push;
|
||||
}
|
||||
|
||||
sub _do_Filter_Push
|
||||
{
|
||||
my $this = shift;
|
||||
my %callbacks = ();
|
||||
my $caller = (caller(1))[3];
|
||||
$caller =~ s/^.*:://;
|
||||
|
||||
croak "$caller: no parameters present" unless @_ ;
|
||||
|
||||
if ( ! $Options{lc $_[0]} ) {
|
||||
my $class = shift;
|
||||
my @params = @_;
|
||||
|
||||
# if $class already contains "::", don't prefix "DBM_Filter::"
|
||||
$class = "DBM_Filter::$class" unless $class =~ /::/;
|
||||
|
||||
no strict 'refs';
|
||||
# does the "DBM_Filter::$class" exist?
|
||||
if ( ! %{ "${class}::"} ) {
|
||||
# Nope, so try to load it.
|
||||
eval " require $class ; " ;
|
||||
croak "$caller: Cannot Load DBM Filter '$class': $@" if $@;
|
||||
}
|
||||
|
||||
my $fetch = *{ "${class}::Fetch" }{CODE};
|
||||
my $store = *{ "${class}::Store" }{CODE};
|
||||
my $filter = *{ "${class}::Filter" }{CODE};
|
||||
use strict 'refs';
|
||||
|
||||
my $count = defined($filter) + defined($store) + defined($fetch) ;
|
||||
|
||||
if ( $count == 0 )
|
||||
{ croak "$caller: No methods (Filter, Fetch or Store) found in class '$class'" }
|
||||
elsif ( $count == 1 && ! defined $filter) {
|
||||
my $need = defined($fetch) ? 'Store' : 'Fetch';
|
||||
croak "$caller: Missing method '$need' in class '$class'" ;
|
||||
}
|
||||
elsif ( $count >= 2 && defined $filter)
|
||||
{ croak "$caller: Can't mix Filter with Store and Fetch in class '$class'" }
|
||||
|
||||
if (defined $filter) {
|
||||
my $callbacks = &{ $filter }(@params);
|
||||
croak "$caller: '${class}::Filter' did not return a hash reference"
|
||||
unless ref $callbacks && ref $callbacks eq 'HASH';
|
||||
%callbacks = %{ $callbacks } ;
|
||||
}
|
||||
else {
|
||||
$callbacks{Fetch} = $fetch;
|
||||
$callbacks{Store} = $store;
|
||||
}
|
||||
}
|
||||
else {
|
||||
croak "$caller: not even params" unless @_ % 2 == 0;
|
||||
%callbacks = @_;
|
||||
}
|
||||
|
||||
my %filters = %Filters ;
|
||||
my @got = ();
|
||||
while (my ($k, $v) = each %callbacks )
|
||||
{
|
||||
my $key = $k;
|
||||
$k = lc $k;
|
||||
if ($k eq 'fetch') {
|
||||
push @got, 'Fetch';
|
||||
if ($caller eq 'Filter_Push')
|
||||
{ $filters{Fetch_Key} = $filters{Fetch_Value} = $v }
|
||||
elsif ($caller eq 'Filter_Key_Push')
|
||||
{ $filters{Fetch_Key} = $v }
|
||||
elsif ($caller eq 'Filter_Value_Push')
|
||||
{ $filters{Fetch_Value} = $v }
|
||||
}
|
||||
elsif ($k eq 'store') {
|
||||
push @got, 'Store';
|
||||
if ($caller eq 'Filter_Push')
|
||||
{ $filters{Store_Key} = $filters{Store_Value} = $v }
|
||||
elsif ($caller eq 'Filter_Key_Push')
|
||||
{ $filters{Store_Key} = $v }
|
||||
elsif ($caller eq 'Filter_Value_Push')
|
||||
{ $filters{Store_Value} = $v }
|
||||
}
|
||||
else
|
||||
{ croak "$caller: Unknown key '$key'" }
|
||||
|
||||
croak "$caller: value associated with key '$key' is not a code reference"
|
||||
unless ref $v && ref $v eq 'CODE';
|
||||
}
|
||||
|
||||
if ( @got != 2 ) {
|
||||
push @got, 'neither' if @got == 0 ;
|
||||
croak "$caller: expected both Store & Fetch - got @got";
|
||||
}
|
||||
|
||||
# remember the class
|
||||
push @{ $LayerStack{$this} }, \%filters ;
|
||||
|
||||
my $str_this = "$this" ; # Avoid a closure with $this in the subs below
|
||||
|
||||
$this->filter_store_key ( sub { store_hook($str_this, 'Store_Key') });
|
||||
$this->filter_store_value( sub { store_hook($str_this, 'Store_Value') });
|
||||
$this->filter_fetch_key ( sub { fetch_hook($str_this, 'Fetch_Key') });
|
||||
$this->filter_fetch_value( sub { fetch_hook($str_this, 'Fetch_Value') });
|
||||
|
||||
# Hijack the callers DESTROY method
|
||||
$this =~ /^(.*)=/;
|
||||
my $type = $1 ;
|
||||
no strict 'refs';
|
||||
if ( *{ "${type}::DESTROY" }{CODE} ne \&MyDESTROY )
|
||||
{
|
||||
$origDESTROY{$type} = *{ "${type}::DESTROY" }{CODE};
|
||||
no warnings 'redefine';
|
||||
*{ "${type}::DESTROY" } = \&MyDESTROY ;
|
||||
}
|
||||
}
|
||||
|
||||
sub store_hook
|
||||
{
|
||||
my $this = shift ;
|
||||
my $type = shift ;
|
||||
foreach my $layer (@{ $LayerStack{$this} })
|
||||
{
|
||||
&{ $layer->{$type} }() if defined $layer->{$type} ;
|
||||
}
|
||||
}
|
||||
|
||||
sub fetch_hook
|
||||
{
|
||||
my $this = shift ;
|
||||
my $type = shift ;
|
||||
foreach my $layer (reverse @{ $LayerStack{$this} })
|
||||
{
|
||||
&{ $layer->{$type} }() if defined $layer->{$type} ;
|
||||
}
|
||||
}
|
||||
|
||||
sub MyDESTROY
|
||||
{
|
||||
my $this = shift ;
|
||||
delete $LayerStack{$this} ;
|
||||
|
||||
# call real DESTROY
|
||||
$this =~ /^(.*)=/;
|
||||
&{ $origDESTROY{$1} }($this);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
DBM_Filter -- Filter DBM keys/values
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use DBM_Filter ;
|
||||
use SDBM_File; # or DB_File, GDBM_File, NDBM_File, or ODBM_File
|
||||
|
||||
$db = tie %hash, ...
|
||||
|
||||
$db->Filter_Push(Fetch => sub {...},
|
||||
Store => sub {...});
|
||||
|
||||
$db->Filter_Push('my_filter1');
|
||||
$db->Filter_Push('my_filter2', params...);
|
||||
|
||||
$db->Filter_Key_Push(...) ;
|
||||
$db->Filter_Value_Push(...) ;
|
||||
|
||||
$db->Filter_Pop();
|
||||
$db->Filtered();
|
||||
|
||||
package DBM_Filter::my_filter1;
|
||||
|
||||
sub Store { ... }
|
||||
sub Fetch { ... }
|
||||
|
||||
1;
|
||||
|
||||
package DBM_Filter::my_filter2;
|
||||
|
||||
sub Filter
|
||||
{
|
||||
my @opts = @_;
|
||||
...
|
||||
return (
|
||||
sub Store { ... },
|
||||
sub Fetch { ... } );
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides an interface that allows filters to be applied
|
||||
to tied Hashes associated with DBM files. It builds on the DBM Filter
|
||||
hooks that are present in all the *DB*_File modules included with the
|
||||
standard Perl source distribution from version 5.6.1 onwards. In addition
|
||||
to the *DB*_File modules distributed with Perl, the BerkeleyDB module,
|
||||
available on CPAN, supports the DBM Filter hooks. See L<perldbmfilter>
|
||||
for more details on the DBM Filter hooks.
|
||||
|
||||
=head1 What is a DBM Filter?
|
||||
|
||||
A DBM Filter allows the keys and/or values in a tied hash to be modified
|
||||
by some user-defined code just before it is written to the DBM file and
|
||||
just after it is read back from the DBM file. For example, this snippet
|
||||
of code
|
||||
|
||||
$some_hash{"abc"} = 42;
|
||||
|
||||
could potentially trigger two filters, one for the writing of the key
|
||||
"abc" and another for writing the value 42. Similarly, this snippet
|
||||
|
||||
my ($key, $value) = each %some_hash
|
||||
|
||||
will trigger two filters, one for the reading of the key and one for
|
||||
the reading of the value.
|
||||
|
||||
Like the existing DBM Filter functionality, this module arranges for the
|
||||
C<$_> variable to be populated with the key or value that a filter will
|
||||
check. This usually means that most DBM filters tend to be very short.
|
||||
|
||||
=head2 So what's new?
|
||||
|
||||
The main enhancements over the standard DBM Filter hooks are:
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
A cleaner interface.
|
||||
|
||||
=item *
|
||||
|
||||
The ability to easily apply multiple filters to a single DBM file.
|
||||
|
||||
=item *
|
||||
|
||||
The ability to create "canned" filters. These allow commonly used filters
|
||||
to be packaged into a stand-alone module.
|
||||
|
||||
=back
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
This module will arrange for the following methods to be available via
|
||||
the object returned from the C<tie> call.
|
||||
|
||||
=head2 $db->Filter_Push() / $db->Filter_Key_Push() / $db->Filter_Value_Push()
|
||||
|
||||
Add a filter to filter stack for the database, C<$db>. The three formats
|
||||
vary only in whether they apply to the DBM key, the DBM value or both.
|
||||
|
||||
=over 5
|
||||
|
||||
=item Filter_Push
|
||||
|
||||
The filter is applied to I<both> keys and values.
|
||||
|
||||
=item Filter_Key_Push
|
||||
|
||||
The filter is applied to the key I<only>.
|
||||
|
||||
=item Filter_Value_Push
|
||||
|
||||
The filter is applied to the value I<only>.
|
||||
|
||||
=back
|
||||
|
||||
|
||||
=head2 $db->Filter_Pop()
|
||||
|
||||
Removes the last filter that was applied to the DBM file associated with
|
||||
C<$db>, if present.
|
||||
|
||||
=head2 $db->Filtered()
|
||||
|
||||
Returns TRUE if there are any filters applied to the DBM associated
|
||||
with C<$db>. Otherwise returns FALSE.
|
||||
|
||||
|
||||
|
||||
=head1 Writing a Filter
|
||||
|
||||
Filters can be created in two main ways
|
||||
|
||||
=head2 Immediate Filters
|
||||
|
||||
An immediate filter allows you to specify the filter code to be used
|
||||
at the point where the filter is applied to a dbm. In this mode the
|
||||
Filter_*_Push methods expects to receive exactly two parameters.
|
||||
|
||||
my $db = tie %hash, 'SDBM_File', ...
|
||||
$db->Filter_Push( Store => sub { },
|
||||
Fetch => sub { });
|
||||
|
||||
The code reference associated with C<Store> will be called before any
|
||||
key/value is written to the database and the code reference associated
|
||||
with C<Fetch> will be called after any key/value is read from the
|
||||
database.
|
||||
|
||||
For example, here is a sample filter that adds a trailing NULL character
|
||||
to all strings before they are written to the DBM file, and removes the
|
||||
trailing NULL when they are read from the DBM file
|
||||
|
||||
my $db = tie %hash, 'SDBM_File', ...
|
||||
$db->Filter_Push( Store => sub { $_ .= "\x00" ; },
|
||||
Fetch => sub { s/\x00$// ; });
|
||||
|
||||
|
||||
Points to note:
|
||||
|
||||
=over 5
|
||||
|
||||
=item 1.
|
||||
|
||||
Both the Store and Fetch filters manipulate C<$_>.
|
||||
|
||||
=back
|
||||
|
||||
=head2 Canned Filters
|
||||
|
||||
Immediate filters are useful for one-off situations. For more generic
|
||||
problems it can be useful to package the filter up in its own module.
|
||||
|
||||
The usage is for a canned filter is:
|
||||
|
||||
$db->Filter_Push("name", params)
|
||||
|
||||
where
|
||||
|
||||
=over 5
|
||||
|
||||
=item "name"
|
||||
|
||||
is the name of the module to load. If the string specified does not
|
||||
contain the package separator characters "::", it is assumed to refer to
|
||||
the full module name "DBM_Filter::name". This means that the full names
|
||||
for canned filters, "null" and "utf8", included with this module are:
|
||||
|
||||
DBM_Filter::null
|
||||
DBM_Filter::utf8
|
||||
|
||||
=item params
|
||||
|
||||
any optional parameters that need to be sent to the filter. See the
|
||||
encode filter for an example of a module that uses parameters.
|
||||
|
||||
=back
|
||||
|
||||
The module that implements the canned filter can take one of two
|
||||
forms. Here is a template for the first
|
||||
|
||||
package DBM_Filter::null ;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
sub Store
|
||||
{
|
||||
# store code here
|
||||
}
|
||||
|
||||
sub Fetch
|
||||
{
|
||||
# fetch code here
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
||||
Notes:
|
||||
|
||||
=over 5
|
||||
|
||||
=item 1.
|
||||
|
||||
The package name uses the C<DBM_Filter::> prefix.
|
||||
|
||||
=item 2.
|
||||
|
||||
The module I<must> have both a Store and a Fetch method. If only one is
|
||||
present, or neither are present, a fatal error will be thrown.
|
||||
|
||||
=back
|
||||
|
||||
The second form allows the filter to hold state information using a
|
||||
closure, thus:
|
||||
|
||||
package DBM_Filter::encoding ;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
sub Filter
|
||||
{
|
||||
my @params = @_ ;
|
||||
|
||||
...
|
||||
return {
|
||||
Store => sub { $_ = $encoding->encode($_) },
|
||||
Fetch => sub { $_ = $encoding->decode($_) }
|
||||
} ;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
||||
In this instance the "Store" and "Fetch" methods are encapsulated inside a
|
||||
"Filter" method.
|
||||
|
||||
|
||||
=head1 Filters Included
|
||||
|
||||
A number of canned filers are provided with this module. They cover a
|
||||
number of the main areas that filters are needed when interfacing with
|
||||
DBM files. They also act as templates for your own filters.
|
||||
|
||||
The filter included are:
|
||||
|
||||
=over 5
|
||||
|
||||
=item * utf8
|
||||
|
||||
This module will ensure that all data written to the DBM will be encoded
|
||||
in UTF-8.
|
||||
|
||||
This module needs the Encode module.
|
||||
|
||||
=item * encode
|
||||
|
||||
Allows you to choose the character encoding will be store in the DBM file.
|
||||
|
||||
=item * compress
|
||||
|
||||
This filter will compress all data before it is written to the database
|
||||
and uncompressed it on reading.
|
||||
|
||||
This module needs Compress::Zlib.
|
||||
|
||||
=item * int32
|
||||
|
||||
This module is used when interoperating with a C/C++ application that
|
||||
uses a C int as either the key and/or value in the DBM file.
|
||||
|
||||
=item * null
|
||||
|
||||
This module ensures that all data written to the DBM file is null
|
||||
terminated. This is useful when you have a perl script that needs
|
||||
to interoperate with a DBM file that a C program also uses. A fairly
|
||||
common issue is for the C application to include the terminating null
|
||||
in a string when it writes to the DBM file. This filter will ensure that
|
||||
all data written to the DBM file can be read by the C application.
|
||||
|
||||
=back
|
||||
|
||||
=head1 NOTES
|
||||
|
||||
=head2 Maintain Round Trip Integrity
|
||||
|
||||
When writing a DBM filter it is I<very> important to ensure that it is
|
||||
possible to retrieve all data that you have written when the DBM filter
|
||||
is in place. In practice, this means that whatever transformation is
|
||||
applied to the data in the Store method, the I<exact> inverse operation
|
||||
should be applied in the Fetch method.
|
||||
|
||||
If you don't provide an exact inverse transformation, you will find that
|
||||
code like this will not behave as you expect.
|
||||
|
||||
while (my ($k, $v) = each %hash)
|
||||
{
|
||||
...
|
||||
}
|
||||
|
||||
Depending on the transformation, you will find that one or more of the
|
||||
following will happen
|
||||
|
||||
=over 5
|
||||
|
||||
=item 1
|
||||
|
||||
The loop will never terminate.
|
||||
|
||||
=item 2
|
||||
|
||||
Too few records will be retrieved.
|
||||
|
||||
=item 3
|
||||
|
||||
Too many will be retrieved.
|
||||
|
||||
=item 4
|
||||
|
||||
The loop will do the right thing for a while, but it will unexpectedly fail.
|
||||
|
||||
=back
|
||||
|
||||
=head2 Don't mix filtered & non-filtered data in the same database file.
|
||||
|
||||
This is just a restatement of the previous section. Unless you are
|
||||
completely certain you know what you are doing, avoid mixing filtered &
|
||||
non-filtered data.
|
||||
|
||||
=head1 EXAMPLE
|
||||
|
||||
Say you need to interoperate with a legacy C application that stores
|
||||
keys as C ints and the values and null terminated UTF-8 strings. Here
|
||||
is how you would set that up
|
||||
|
||||
my $db = tie %hash, 'SDBM_File', ...
|
||||
|
||||
$db->Filter_Key_Push('int32') ;
|
||||
|
||||
$db->Filter_Value_Push('utf8');
|
||||
$db->Filter_Value_Push('null');
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
<DB_File>, L<GDBM_File>, L<NDBM_File>, L<ODBM_File>, L<SDBM_File>, L<perldbmfilter>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Paul Marquess <pmqs@cpan.org>
|
||||
|
||||
@@ -0,0 +1,53 @@
|
||||
package DBM_Filter::compress ;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp;
|
||||
|
||||
our $VERSION = '0.03';
|
||||
|
||||
BEGIN
|
||||
{
|
||||
eval { require Compress::Zlib; Compress::Zlib->import() };
|
||||
|
||||
croak "Compress::Zlib module not found.\n"
|
||||
if $@;
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Store { $_ = compress($_) }
|
||||
sub Fetch { $_ = uncompress($_) }
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
DBM_Filter::compress - filter for DBM_Filter
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use SDBM_File; # or DB_File, GDBM_File, NDBM_File, ODBM_File
|
||||
use DBM_Filter ;
|
||||
|
||||
$db = tie %hash, ...
|
||||
$db->Filter_Push('compress');
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This DBM filter will compress all data before it is written to the database
|
||||
and uncompressed it on reading.
|
||||
|
||||
A fatal error will be thrown if the Compress::Zlib module is not
|
||||
available.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<DBM_Filter>, L<perldbmfilter>, L<Compress::Zlib>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Paul Marquess pmqs@cpan.org
|
||||
|
||||
@@ -0,0 +1,86 @@
|
||||
package DBM_Filter::encode ;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp;
|
||||
|
||||
our $VERSION = '0.03';
|
||||
|
||||
BEGIN
|
||||
{
|
||||
eval { require Encode; };
|
||||
|
||||
croak "Encode module not found.\n"
|
||||
if $@;
|
||||
}
|
||||
|
||||
|
||||
sub Filter
|
||||
{
|
||||
my $encoding_name = shift || "utf8";
|
||||
|
||||
my $encoding = Encode::find_encoding($encoding_name) ;
|
||||
|
||||
croak "Encoding '$encoding_name' is not available"
|
||||
unless $encoding;
|
||||
|
||||
return {
|
||||
Store => sub {
|
||||
$_ = $encoding->encode($_)
|
||||
if defined $_ ;
|
||||
},
|
||||
Fetch => sub {
|
||||
$_ = $encoding->decode($_)
|
||||
if defined $_ ;
|
||||
}
|
||||
} ;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
DBM_Filter::encode - filter for DBM_Filter
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use SDBM_File; # or DB_File, GDBM_File, NDBM_File, ODBM_File
|
||||
use DBM_Filter ;
|
||||
|
||||
$db = tie %hash, ...
|
||||
$db->Filter_Push('encode' => 'iso-8859-16');
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This DBM filter allows you to choose the character encoding will be
|
||||
store in the DBM file. The usage is
|
||||
|
||||
$db->Filter_Push('encode' => ENCODING);
|
||||
|
||||
where "ENCODING" must be a valid encoding name that the Encode module
|
||||
recognises.
|
||||
|
||||
A fatal error will be thrown if:
|
||||
|
||||
=over 5
|
||||
|
||||
=item 1
|
||||
|
||||
The Encode module is not available.
|
||||
|
||||
=item 2
|
||||
|
||||
The encoding requested is not supported by the Encode module.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<DBM_Filter>, L<perldbmfilter>, L<Encode>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Paul Marquess pmqs@cpan.org
|
||||
|
||||
@@ -0,0 +1,50 @@
|
||||
package DBM_Filter::int32 ;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.03';
|
||||
|
||||
# todo get Filter to figure endian.
|
||||
|
||||
sub Store
|
||||
{
|
||||
$_ = 0 if ! defined $_ || $_ eq "" ;
|
||||
$_ = pack("i", $_);
|
||||
}
|
||||
|
||||
sub Fetch
|
||||
{
|
||||
no warnings 'uninitialized';
|
||||
$_ = unpack("i", $_);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
DBM_Filter::int32 - filter for DBM_Filter
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use SDBM_File; # or DB_File, GDBM_File, NDBM_File, or ODBM_File
|
||||
use DBM_Filter ;
|
||||
|
||||
$db = tie %hash, ...
|
||||
$db->Filter_Push('int32');
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This DBM filter is used when interoperating with a C/C++ application
|
||||
that uses a C int as either the key and/or value in the DBM file.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<DBM_Filter>, L<perldbmfilter>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Paul Marquess pmqs@cpan.org
|
||||
|
||||
@@ -0,0 +1,52 @@
|
||||
package DBM_Filter::null ;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.03';
|
||||
|
||||
sub Store
|
||||
{
|
||||
no warnings 'uninitialized';
|
||||
$_ .= "\x00" ;
|
||||
}
|
||||
|
||||
sub Fetch
|
||||
{
|
||||
no warnings 'uninitialized';
|
||||
s/\x00$// ;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
DBM_Filter::null - filter for DBM_Filter
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use SDBM_File; # or DB_File, GDBM_File, NDBM_File, or ODBM_File
|
||||
use DBM_Filter ;
|
||||
|
||||
$db = tie %hash, ...
|
||||
$db->Filter_Push('null');
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This filter ensures that all data written to the DBM file is null
|
||||
terminated. This is useful when you have a perl script that needs
|
||||
to interoperate with a DBM file that a C program also uses. A fairly
|
||||
common issue is for the C application to include the terminating null
|
||||
in a string when it writes to the DBM file. This filter will ensure that
|
||||
all data written to the DBM file can be read by the C application.
|
||||
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<DBM_Filter>, L<perldbmfilter>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Paul Marquess pmqs@cpan.org
|
||||
@@ -0,0 +1,51 @@
|
||||
package DBM_Filter::utf8 ;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp;
|
||||
|
||||
our $VERSION = '0.03';
|
||||
|
||||
BEGIN
|
||||
{
|
||||
eval { require Encode; };
|
||||
|
||||
croak "Encode module not found.\n"
|
||||
if $@;
|
||||
}
|
||||
|
||||
sub Store { $_ = Encode::encode_utf8($_) if defined $_ }
|
||||
|
||||
sub Fetch { $_ = Encode::decode_utf8($_) if defined $_ }
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
DBM_Filter::utf8 - filter for DBM_Filter
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use SDBM_File; # or DB_File, GDBM_File, NDBM_File, or ODBM_File
|
||||
use DBM_Filter;
|
||||
|
||||
$db = tie %hash, ...
|
||||
$db->Filter_Push('utf8');
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This Filter will ensure that all data written to the DBM will be encoded
|
||||
in UTF-8.
|
||||
|
||||
This module uses the Encode module.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<DBM_Filter>, L<perldbmfilter>, L<Encode>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Paul Marquess pmqs@cpan.org
|
||||
|
||||
@@ -0,0 +1,152 @@
|
||||
package Devel::SelfStubber;
|
||||
use File::Spec;
|
||||
require SelfLoader;
|
||||
@ISA = qw(SelfLoader);
|
||||
@EXPORT = 'AUTOLOAD';
|
||||
$JUST_STUBS = 1;
|
||||
$VERSION = 1.06;
|
||||
sub Version {$VERSION}
|
||||
|
||||
# Use as
|
||||
# perl -e 'use Devel::SelfStubber;Devel::SelfStubber->stub(MODULE_NAME,LIB)'
|
||||
# (LIB defaults to '.') e.g.
|
||||
# perl -e 'use Devel::SelfStubber;Devel::SelfStubber->stub('Math::BigInt')'
|
||||
# would print out stubs needed if you added a __DATA__ before the subs.
|
||||
# Setting $Devel::SelfStubber::JUST_STUBS to 0 will print out the whole
|
||||
# module with the stubs entered just before the __DATA__
|
||||
|
||||
sub _add_to_cache {
|
||||
my($self,$fullname,$pack,$lines, $prototype) = @_;
|
||||
push(@DATA,@{$lines});
|
||||
if($fullname){push(@STUBS,"sub $fullname $prototype;\n")}; # stubs
|
||||
'1;';
|
||||
}
|
||||
|
||||
sub _package_defined {
|
||||
my($self,$line) = @_;
|
||||
push(@DATA,$line);
|
||||
}
|
||||
|
||||
sub stub {
|
||||
my($self,$module,$lib) = @_;
|
||||
my($line,$end_data,$fh,$mod_file,$found_selfloader);
|
||||
$lib ||= File::Spec->curdir();
|
||||
($mod_file = $module) =~ s,::,/,g;
|
||||
$mod_file =~ tr|/|:| if $^O eq 'MacOS';
|
||||
|
||||
$mod_file = File::Spec->catfile($lib, "$mod_file.pm");
|
||||
$fh = "${module}::DATA";
|
||||
my (@BEFORE_DATA, @AFTER_DATA, @AFTER_END);
|
||||
@DATA = @STUBS = ();
|
||||
|
||||
open($fh,'<',$mod_file) || die "Unable to open $mod_file";
|
||||
local $/ = "\n";
|
||||
while(defined ($line = <$fh>) and $line !~ m/^__DATA__/) {
|
||||
push(@BEFORE_DATA,$line);
|
||||
$line =~ /use\s+SelfLoader/ && $found_selfloader++;
|
||||
}
|
||||
(defined ($line) && $line =~ m/^__DATA__/)
|
||||
|| die "$mod_file doesn't contain a __DATA__ token";
|
||||
$found_selfloader ||
|
||||
print 'die "\'use SelfLoader;\' statement NOT FOUND!!\n"',"\n";
|
||||
if ($JUST_STUBS) {
|
||||
$self->_load_stubs($module);
|
||||
} else {
|
||||
$self->_load_stubs($module, \@AFTER_END);
|
||||
}
|
||||
if ( fileno($fh) ) {
|
||||
$end_data = 1;
|
||||
while(defined($line = <$fh>)) {
|
||||
push(@AFTER_DATA,$line);
|
||||
}
|
||||
}
|
||||
close($fh);
|
||||
unless ($JUST_STUBS) {
|
||||
print @BEFORE_DATA;
|
||||
}
|
||||
print @STUBS;
|
||||
unless ($JUST_STUBS) {
|
||||
print "1;\n__DATA__\n",@DATA;
|
||||
if($end_data) { print "__END__ DATA\n",@AFTER_DATA; }
|
||||
if(@AFTER_END) { print "__END__\n",@AFTER_END; }
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Devel::SelfStubber - generate stubs for a SelfLoading module
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
To generate just the stubs:
|
||||
|
||||
use Devel::SelfStubber;
|
||||
Devel::SelfStubber->stub('MODULENAME','MY_LIB_DIR');
|
||||
|
||||
or to generate the whole module with stubs inserted correctly
|
||||
|
||||
use Devel::SelfStubber;
|
||||
$Devel::SelfStubber::JUST_STUBS=0;
|
||||
Devel::SelfStubber->stub('MODULENAME','MY_LIB_DIR');
|
||||
|
||||
MODULENAME is the Perl module name, e.g. Devel::SelfStubber,
|
||||
NOT 'Devel/SelfStubber' or 'Devel/SelfStubber.pm'.
|
||||
|
||||
MY_LIB_DIR defaults to '.' if not present.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Devel::SelfStubber prints the stubs you need to put in the module
|
||||
before the __DATA__ token (or you can get it to print the entire
|
||||
module with stubs correctly placed). The stubs ensure that if
|
||||
a method is called, it will get loaded. They are needed specifically
|
||||
for inherited autoloaded methods.
|
||||
|
||||
This is best explained using the following example:
|
||||
|
||||
Assume four classes, A,B,C & D.
|
||||
|
||||
A is the root class, B is a subclass of A, C is a subclass of B,
|
||||
and D is another subclass of A.
|
||||
|
||||
A
|
||||
/ \
|
||||
B D
|
||||
/
|
||||
C
|
||||
|
||||
If D calls an autoloaded method 'foo' which is defined in class A,
|
||||
then the method is loaded into class A, then executed. If C then
|
||||
calls method 'foo', and that method was reimplemented in class
|
||||
B, but set to be autoloaded, then the lookup mechanism never gets to
|
||||
the AUTOLOAD mechanism in B because it first finds the method
|
||||
already loaded in A, and so erroneously uses that. If the method
|
||||
foo had been stubbed in B, then the lookup mechanism would have
|
||||
found the stub, and correctly loaded and used the sub from B.
|
||||
|
||||
So, for classes and subclasses to have inheritance correctly
|
||||
work with autoloading, you need to ensure stubs are loaded.
|
||||
|
||||
The SelfLoader can load stubs automatically at module initialization
|
||||
with the statement 'SelfLoader-E<gt>load_stubs()';, but you may wish to
|
||||
avoid having the stub loading overhead associated with your
|
||||
initialization (though note that the SelfLoader::load_stubs method
|
||||
will be called sooner or later - at latest when the first sub
|
||||
is being autoloaded). In this case, you can put the sub stubs
|
||||
before the __DATA__ token. This can be done manually, but this
|
||||
module allows automatic generation of the stubs.
|
||||
|
||||
By default it just prints the stubs, but you can set the
|
||||
global $Devel::SelfStubber::JUST_STUBS to 0 and it will
|
||||
print out the entire module with the stubs positioned correctly.
|
||||
|
||||
At the very least, this is useful to see what the SelfLoader
|
||||
thinks are stubs - in order to ensure future versions of the
|
||||
SelfStubber remain in step with the SelfLoader, the
|
||||
SelfStubber actually uses the SelfLoader to determine which
|
||||
stubs are needed.
|
||||
|
||||
=cut
|
||||
@@ -0,0 +1,334 @@
|
||||
package Digest;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = "1.20";
|
||||
|
||||
our %MMAP = (
|
||||
"SHA-1" => [ [ "Digest::SHA", 1 ], "Digest::SHA1", [ "Digest::SHA2", 1 ] ],
|
||||
"SHA-224" => [ [ "Digest::SHA", 224 ] ],
|
||||
"SHA-256" => [ [ "Digest::SHA", 256 ], [ "Digest::SHA2", 256 ] ],
|
||||
"SHA-384" => [ [ "Digest::SHA", 384 ], [ "Digest::SHA2", 384 ] ],
|
||||
"SHA-512" => [ [ "Digest::SHA", 512 ], [ "Digest::SHA2", 512 ] ],
|
||||
"SHA3-224" => [ [ "Digest::SHA3", 224 ] ],
|
||||
"SHA3-256" => [ [ "Digest::SHA3", 256 ] ],
|
||||
"SHA3-384" => [ [ "Digest::SHA3", 384 ] ],
|
||||
"SHA3-512" => [ [ "Digest::SHA3", 512 ] ],
|
||||
"HMAC-MD5" => "Digest::HMAC_MD5",
|
||||
"HMAC-SHA-1" => "Digest::HMAC_SHA1",
|
||||
"CRC-16" => [ [ "Digest::CRC", type => "crc16" ] ],
|
||||
"CRC-32" => [ [ "Digest::CRC", type => "crc32" ] ],
|
||||
"CRC-CCITT" => [ [ "Digest::CRC", type => "crcccitt" ] ],
|
||||
"RIPEMD-160" => "Crypt::RIPEMD160",
|
||||
);
|
||||
|
||||
sub new {
|
||||
shift; # class ignored
|
||||
my $algorithm = shift;
|
||||
my $impl = $MMAP{$algorithm} || do {
|
||||
$algorithm =~ s/\W+//g;
|
||||
"Digest::$algorithm";
|
||||
};
|
||||
$impl = [$impl] unless ref($impl);
|
||||
local $@; # don't clobber it for our caller
|
||||
my $err;
|
||||
for (@$impl) {
|
||||
my $class = $_;
|
||||
my @args;
|
||||
( $class, @args ) = @$class if ref($class);
|
||||
no strict 'refs';
|
||||
unless ( exists ${"$class\::"}{"VERSION"} ) {
|
||||
my $pm_file = $class . ".pm";
|
||||
$pm_file =~ s{::}{/}g;
|
||||
eval {
|
||||
local @INC = @INC;
|
||||
pop @INC if $INC[-1] eq '.';
|
||||
require $pm_file
|
||||
};
|
||||
if ($@) {
|
||||
$err ||= $@;
|
||||
next;
|
||||
}
|
||||
}
|
||||
return $class->new( @args, @_ );
|
||||
}
|
||||
die $err;
|
||||
}
|
||||
|
||||
our $AUTOLOAD;
|
||||
|
||||
sub AUTOLOAD {
|
||||
my $class = shift;
|
||||
my $algorithm = substr( $AUTOLOAD, rindex( $AUTOLOAD, '::' ) + 2 );
|
||||
$class->new( $algorithm, @_ );
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Digest - Modules that calculate message digests
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
$md5 = Digest->new("MD5");
|
||||
$sha1 = Digest->new("SHA-1");
|
||||
$sha256 = Digest->new("SHA-256");
|
||||
$sha384 = Digest->new("SHA-384");
|
||||
$sha512 = Digest->new("SHA-512");
|
||||
|
||||
$hmac = Digest->HMAC_MD5($key);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The C<Digest::> modules calculate digests, also called "fingerprints"
|
||||
or "hashes", of some data, called a message. The digest is (usually)
|
||||
some small/fixed size string. The actual size of the digest depend of
|
||||
the algorithm used. The message is simply a sequence of arbitrary
|
||||
bytes or bits.
|
||||
|
||||
An important property of the digest algorithms is that the digest is
|
||||
I<likely> to change if the message change in some way. Another
|
||||
property is that digest functions are one-way functions, that is it
|
||||
should be I<hard> to find a message that correspond to some given
|
||||
digest. Algorithms differ in how "likely" and how "hard", as well as
|
||||
how efficient they are to compute.
|
||||
|
||||
Note that the properties of the algorithms change over time, as the
|
||||
algorithms are analyzed and machines grow faster. If your application
|
||||
for instance depends on it being "impossible" to generate the same
|
||||
digest for a different message it is wise to make it easy to plug in
|
||||
stronger algorithms as the one used grow weaker. Using the interface
|
||||
documented here should make it easy to change algorithms later.
|
||||
|
||||
All C<Digest::> modules provide the same programming interface. A
|
||||
functional interface for simple use, as well as an object oriented
|
||||
interface that can handle messages of arbitrary length and which can
|
||||
read files directly.
|
||||
|
||||
The digest can be delivered in three formats:
|
||||
|
||||
=over 8
|
||||
|
||||
=item I<binary>
|
||||
|
||||
This is the most compact form, but it is not well suited for printing
|
||||
or embedding in places that can't handle arbitrary data.
|
||||
|
||||
=item I<hex>
|
||||
|
||||
A twice as long string of lowercase hexadecimal digits.
|
||||
|
||||
=item I<base64>
|
||||
|
||||
A string of portable printable characters. This is the base64 encoded
|
||||
representation of the digest with any trailing padding removed. The
|
||||
string will be about 30% longer than the binary version.
|
||||
L<MIME::Base64> tells you more about this encoding.
|
||||
|
||||
=back
|
||||
|
||||
|
||||
The functional interface is simply importable functions with the same
|
||||
name as the algorithm. The functions take the message as argument and
|
||||
return the digest. Example:
|
||||
|
||||
use Digest::MD5 qw(md5);
|
||||
$digest = md5($message);
|
||||
|
||||
There are also versions of the functions with "_hex" or "_base64"
|
||||
appended to the name, which returns the digest in the indicated form.
|
||||
|
||||
=head1 OO INTERFACE
|
||||
|
||||
The following methods are available for all C<Digest::> modules:
|
||||
|
||||
=over 4
|
||||
|
||||
=item $ctx = Digest->XXX($arg,...)
|
||||
|
||||
=item $ctx = Digest->new(XXX => $arg,...)
|
||||
|
||||
=item $ctx = Digest::XXX->new($arg,...)
|
||||
|
||||
The constructor returns some object that encapsulate the state of the
|
||||
message-digest algorithm. You can add data to the object and finally
|
||||
ask for the digest. The "XXX" should of course be replaced by the proper
|
||||
name of the digest algorithm you want to use.
|
||||
|
||||
The two first forms are simply syntactic sugar which automatically
|
||||
load the right module on first use. The second form allow you to use
|
||||
algorithm names which contains letters which are not legal perl
|
||||
identifiers, e.g. "SHA-1". If no implementation for the given algorithm
|
||||
can be found, then an exception is raised.
|
||||
|
||||
To know what arguments (if any) the constructor takes (the C<$args,...> above)
|
||||
consult the docs for the specific digest implementation.
|
||||
|
||||
If new() is called as an instance method (i.e. $ctx->new) it will just
|
||||
reset the state the object to the state of a newly created object. No
|
||||
new object is created in this case, and the return value is the
|
||||
reference to the object (i.e. $ctx).
|
||||
|
||||
=item $other_ctx = $ctx->clone
|
||||
|
||||
The clone method creates a copy of the digest state object and returns
|
||||
a reference to the copy.
|
||||
|
||||
=item $ctx->reset
|
||||
|
||||
This is just an alias for $ctx->new.
|
||||
|
||||
=item $ctx->add( $data )
|
||||
|
||||
=item $ctx->add( $chunk1, $chunk2, ... )
|
||||
|
||||
The string value of the $data provided as argument is appended to the
|
||||
message we calculate the digest for. The return value is the $ctx
|
||||
object itself.
|
||||
|
||||
If more arguments are provided then they are all appended to the
|
||||
message, thus all these lines will have the same effect on the state
|
||||
of the $ctx object:
|
||||
|
||||
$ctx->add("a"); $ctx->add("b"); $ctx->add("c");
|
||||
$ctx->add("a")->add("b")->add("c");
|
||||
$ctx->add("a", "b", "c");
|
||||
$ctx->add("abc");
|
||||
|
||||
Most algorithms are only defined for strings of bytes and this method
|
||||
might therefore croak if the provided arguments contain chars with
|
||||
ordinal number above 255.
|
||||
|
||||
=item $ctx->addfile( $io_handle )
|
||||
|
||||
The $io_handle is read until EOF and the content is appended to the
|
||||
message we calculate the digest for. The return value is the $ctx
|
||||
object itself.
|
||||
|
||||
The addfile() method will croak() if it fails reading data for some
|
||||
reason. If it croaks it is unpredictable what the state of the $ctx
|
||||
object will be in. The addfile() method might have been able to read
|
||||
the file partially before it failed. It is probably wise to discard
|
||||
or reset the $ctx object if this occurs.
|
||||
|
||||
In most cases you want to make sure that the $io_handle is in
|
||||
"binmode" before you pass it as argument to the addfile() method.
|
||||
|
||||
=item $ctx->add_bits( $data, $nbits )
|
||||
|
||||
=item $ctx->add_bits( $bitstring )
|
||||
|
||||
The add_bits() method is an alternative to add() that allow partial
|
||||
bytes to be appended to the message. Most users can just ignore
|
||||
this method since typical applications involve only whole-byte data.
|
||||
|
||||
The two argument form of add_bits() will add the first $nbits bits
|
||||
from $data. For the last potentially partial byte only the high order
|
||||
C<< $nbits % 8 >> bits are used. If $nbits is greater than C<<
|
||||
length($data) * 8 >>, then this method would do the same as C<<
|
||||
$ctx->add($data) >>.
|
||||
|
||||
The one argument form of add_bits() takes a $bitstring of "1" and "0"
|
||||
chars as argument. It's a shorthand for C<< $ctx->add_bits(pack("B*",
|
||||
$bitstring), length($bitstring)) >>.
|
||||
|
||||
The return value is the $ctx object itself.
|
||||
|
||||
This example shows two calls that should have the same effect:
|
||||
|
||||
$ctx->add_bits("111100001010");
|
||||
$ctx->add_bits("\xF0\xA0", 12);
|
||||
|
||||
Most digest algorithms are byte based and for these it is not possible
|
||||
to add bits that are not a multiple of 8, and the add_bits() method
|
||||
will croak if you try.
|
||||
|
||||
=item $ctx->digest
|
||||
|
||||
Return the binary digest for the message.
|
||||
|
||||
Note that the C<digest> operation is effectively a destructive,
|
||||
read-once operation. Once it has been performed, the $ctx object is
|
||||
automatically C<reset> and can be used to calculate another digest
|
||||
value. Call $ctx->clone->digest if you want to calculate the digest
|
||||
without resetting the digest state.
|
||||
|
||||
=item $ctx->hexdigest
|
||||
|
||||
Same as $ctx->digest, but will return the digest in hexadecimal form.
|
||||
|
||||
=item $ctx->b64digest
|
||||
|
||||
Same as $ctx->digest, but will return the digest as a base64 encoded
|
||||
string without padding.
|
||||
|
||||
=item $ctx->base64_padded_digest
|
||||
|
||||
Same as $ctx->digest, but will return the digest as a base64 encoded
|
||||
string.
|
||||
|
||||
=back
|
||||
|
||||
=head1 Digest speed
|
||||
|
||||
This table should give some indication on the relative speed of
|
||||
different algorithms. It is sorted by throughput based on a benchmark
|
||||
done with of some implementations of this API:
|
||||
|
||||
Algorithm Size Implementation MB/s
|
||||
|
||||
MD4 128 Digest::MD4 v1.3 165.0
|
||||
MD5 128 Digest::MD5 v2.33 98.8
|
||||
SHA-256 256 Digest::SHA2 v1.1.0 66.7
|
||||
SHA-1 160 Digest::SHA v4.3.1 58.9
|
||||
SHA-1 160 Digest::SHA1 v2.10 48.8
|
||||
SHA-256 256 Digest::SHA v4.3.1 41.3
|
||||
Haval-256 256 Digest::Haval256 v1.0.4 39.8
|
||||
SHA-384 384 Digest::SHA2 v1.1.0 19.6
|
||||
SHA-512 512 Digest::SHA2 v1.1.0 19.3
|
||||
SHA-384 384 Digest::SHA v4.3.1 19.2
|
||||
SHA-512 512 Digest::SHA v4.3.1 19.2
|
||||
Whirlpool 512 Digest::Whirlpool v1.0.2 13.0
|
||||
MD2 128 Digest::MD2 v2.03 9.5
|
||||
|
||||
Adler-32 32 Digest::Adler32 v0.03 1.3
|
||||
CRC-16 16 Digest::CRC v0.05 1.1
|
||||
CRC-32 32 Digest::CRC v0.05 1.1
|
||||
MD5 128 Digest::Perl::MD5 v1.5 1.0
|
||||
CRC-CCITT 16 Digest::CRC v0.05 0.8
|
||||
|
||||
These numbers was achieved Apr 2004 with ActivePerl-5.8.3 running
|
||||
under Linux on a P4 2.8 GHz CPU. The last 5 entries differ by being
|
||||
pure perl implementations of the algorithms, which explains why they
|
||||
are so slow.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Digest::Adler32>, L<Digest::CRC>, L<Digest::Haval256>,
|
||||
L<Digest::HMAC>, L<Digest::MD2>, L<Digest::MD4>, L<Digest::MD5>,
|
||||
L<Digest::SHA>, L<Digest::SHA1>, L<Digest::SHA2>, L<Digest::Whirlpool>
|
||||
|
||||
New digest implementations should consider subclassing from L<Digest::base>.
|
||||
|
||||
L<MIME::Base64>
|
||||
|
||||
http://en.wikipedia.org/wiki/Cryptographic_hash_function
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Gisle Aas <gisle@aas.no>
|
||||
|
||||
The C<Digest::> interface is based on the interface originally
|
||||
developed by Neil Winton for his C<MD5> module.
|
||||
|
||||
This library is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
||||
Copyright 1998-2006 Gisle Aas.
|
||||
Copyright 1995,1996 Neil Winton.
|
||||
|
||||
=cut
|
||||
@@ -0,0 +1,106 @@
|
||||
package Digest::base;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = "1.20";
|
||||
|
||||
# subclass is supposed to implement at least these
|
||||
sub new;
|
||||
sub clone;
|
||||
sub add;
|
||||
sub digest;
|
||||
|
||||
sub reset {
|
||||
my $self = shift;
|
||||
$self->new(@_); # ugly
|
||||
}
|
||||
|
||||
sub addfile {
|
||||
my ( $self, $handle ) = @_;
|
||||
|
||||
my $n;
|
||||
my $buf = "";
|
||||
|
||||
while ( ( $n = read( $handle, $buf, 4 * 1024 ) ) ) {
|
||||
$self->add($buf);
|
||||
}
|
||||
unless ( defined $n ) {
|
||||
require Carp;
|
||||
Carp::croak("Read failed: $!");
|
||||
}
|
||||
|
||||
$self;
|
||||
}
|
||||
|
||||
sub add_bits {
|
||||
my $self = shift;
|
||||
my $bits;
|
||||
my $nbits;
|
||||
if ( @_ == 1 ) {
|
||||
my $arg = shift;
|
||||
$bits = pack( "B*", $arg );
|
||||
$nbits = length($arg);
|
||||
}
|
||||
else {
|
||||
( $bits, $nbits ) = @_;
|
||||
}
|
||||
if ( ( $nbits % 8 ) != 0 ) {
|
||||
require Carp;
|
||||
Carp::croak("Number of bits must be multiple of 8 for this algorithm");
|
||||
}
|
||||
return $self->add( substr( $bits, 0, $nbits / 8 ) );
|
||||
}
|
||||
|
||||
sub hexdigest {
|
||||
my $self = shift;
|
||||
return unpack( "H*", $self->digest(@_) );
|
||||
}
|
||||
|
||||
sub b64digest {
|
||||
my $self = shift;
|
||||
my $b64 = $self->base64_padded_digest;
|
||||
$b64 =~ s/=+$//;
|
||||
return $b64;
|
||||
}
|
||||
|
||||
sub base64_padded_digest {
|
||||
my $self = shift;
|
||||
require MIME::Base64;
|
||||
return MIME::Base64::encode( $self->digest(@_), "" );
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Digest::base - Digest base class
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package Digest::Foo;
|
||||
use base 'Digest::base';
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The C<Digest::base> class provide implementations of the methods
|
||||
C<addfile> and C<add_bits> in terms of C<add>, and of the methods
|
||||
C<hexdigest> and C<b64digest> in terms of C<digest>.
|
||||
|
||||
Digest implementations might want to inherit from this class to get
|
||||
this implementations of the alternative I<add> and I<digest> methods.
|
||||
A minimal subclass needs to implement the following methods by itself:
|
||||
|
||||
new
|
||||
clone
|
||||
add
|
||||
digest
|
||||
|
||||
The arguments and expected behaviour of these methods are described in
|
||||
L<Digest>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Digest>
|
||||
@@ -0,0 +1,83 @@
|
||||
package Digest::file;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Exporter ();
|
||||
use Carp qw(croak);
|
||||
use Digest ();
|
||||
|
||||
our $VERSION = "1.20";
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(digest_file_ctx digest_file digest_file_hex digest_file_base64);
|
||||
|
||||
sub digest_file_ctx {
|
||||
my $file = shift;
|
||||
croak("No digest algorithm specified") unless @_;
|
||||
open( my $fh, "<", $file ) || croak("Can't open '$file': $!");
|
||||
binmode($fh);
|
||||
my $ctx = Digest->new(@_);
|
||||
$ctx->addfile($fh);
|
||||
close($fh);
|
||||
return $ctx;
|
||||
}
|
||||
|
||||
sub digest_file {
|
||||
digest_file_ctx(@_)->digest;
|
||||
}
|
||||
|
||||
sub digest_file_hex {
|
||||
digest_file_ctx(@_)->hexdigest;
|
||||
}
|
||||
|
||||
sub digest_file_base64 {
|
||||
digest_file_ctx(@_)->b64digest;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Digest::file - Calculate digests of files
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# Poor mans "md5sum" command
|
||||
use Digest::file qw(digest_file_hex);
|
||||
for (@ARGV) {
|
||||
print digest_file_hex($_, "MD5"), " $_\n";
|
||||
}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provide 3 convenience functions to calculate the digest
|
||||
of files. The following functions are provided:
|
||||
|
||||
=over
|
||||
|
||||
=item digest_file( $file, $algorithm, [$arg,...] )
|
||||
|
||||
This function will calculate and return the binary digest of the bytes
|
||||
of the given file. The function will croak if it fails to open or
|
||||
read the file.
|
||||
|
||||
The $algorithm is a string like "MD2", "MD5", "SHA-1", "SHA-512".
|
||||
Additional arguments are passed to the constructor for the
|
||||
implementation of the given algorithm.
|
||||
|
||||
=item digest_file_hex( $file, $algorithm, [$arg,...] )
|
||||
|
||||
Same as digest_file(), but return the digest in hex form.
|
||||
|
||||
=item digest_file_base64( $file, $algorithm, [$arg,...] )
|
||||
|
||||
Same as digest_file(), but return the digest as a base64 encoded
|
||||
string.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Digest>
|
||||
@@ -0,0 +1,89 @@
|
||||
package DirHandle;
|
||||
|
||||
our $VERSION = '1.05';
|
||||
|
||||
=head1 NAME
|
||||
|
||||
DirHandle - (obsolete) supply object methods for directory handles
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# recommended approach since Perl 5.6: do not use DirHandle
|
||||
if (opendir my $d, '.') {
|
||||
while (readdir $d) { something($_); }
|
||||
rewind $d;
|
||||
while (readdir $d) { something_else($_); }
|
||||
}
|
||||
|
||||
# how you would use this module if you were going to
|
||||
use DirHandle;
|
||||
if (my $d = DirHandle->new(".")) {
|
||||
while (defined($_ = $d->read)) { something($_); }
|
||||
$d->rewind;
|
||||
while (defined($_ = $d->read)) { something_else($_); }
|
||||
}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
B<There is no reason to use this module nowadays.>
|
||||
|
||||
The C<DirHandle> method provide an alternative interface to the
|
||||
opendir(), closedir(), readdir(), and rewinddir() functions.
|
||||
|
||||
Up to Perl 5.5, opendir() could not autovivify a directory handle from
|
||||
C<undef>, so using a lexical handle required using a function from L<Symbol>
|
||||
to create an anonymous glob, which took a separate step.
|
||||
C<DirHandle> encapsulates this, which allowed cleaner code than opendir().
|
||||
Since Perl 5.6, opendir() alone has been all you need for lexical handles.
|
||||
|
||||
=cut
|
||||
|
||||
require 5.000;
|
||||
use Carp;
|
||||
use Symbol;
|
||||
|
||||
sub new {
|
||||
@_ >= 1 && @_ <= 2 or croak 'usage: DirHandle->new( [DIRNAME] )';
|
||||
my $class = shift;
|
||||
my $dh = gensym;
|
||||
if (@_) {
|
||||
DirHandle::open($dh, $_[0])
|
||||
or return undef;
|
||||
}
|
||||
bless $dh, $class;
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
my ($dh) = @_;
|
||||
# Don't warn about already being closed as it may have been closed
|
||||
# correctly, or maybe never opened at all.
|
||||
local($., $@, $!, $^E, $?);
|
||||
no warnings 'io';
|
||||
closedir($dh);
|
||||
}
|
||||
|
||||
sub open {
|
||||
@_ == 2 or croak 'usage: $dh->open(DIRNAME)';
|
||||
my ($dh, $dirname) = @_;
|
||||
opendir($dh, $dirname);
|
||||
}
|
||||
|
||||
sub close {
|
||||
@_ == 1 or croak 'usage: $dh->close()';
|
||||
my ($dh) = @_;
|
||||
closedir($dh);
|
||||
}
|
||||
|
||||
sub read {
|
||||
@_ == 1 or croak 'usage: $dh->read()';
|
||||
my ($dh) = @_;
|
||||
readdir($dh);
|
||||
}
|
||||
|
||||
sub rewind {
|
||||
@_ == 1 or croak 'usage: $dh->rewind()';
|
||||
my ($dh) = @_;
|
||||
rewinddir($dh);
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,675 @@
|
||||
use 5.006_001; # for (defined ref) and $#$v and our
|
||||
package Dumpvalue;
|
||||
use strict;
|
||||
use warnings;
|
||||
our $VERSION = '1.21';
|
||||
our(%address, $stab, @stab, %stab, %subs);
|
||||
|
||||
sub ASCII { return ord('A') == 65; }
|
||||
|
||||
# This module will give incorrect results for some inputs on EBCDIC platforms
|
||||
# before v5.8
|
||||
*to_native = ($] lt "5.008")
|
||||
? sub { return shift }
|
||||
: sub { return utf8::unicode_to_native(shift) };
|
||||
|
||||
my $APC = chr to_native(0x9F);
|
||||
my $backslash_c_question = (ASCII) ? '\177' : $APC;
|
||||
|
||||
# documentation nits, handle complex data structures better by chromatic
|
||||
# translate control chars to ^X - Randal Schwartz
|
||||
# Modifications to print types by Peter Gordon v1.0
|
||||
|
||||
# Ilya Zakharevich -- patches after 5.001 (and some before ;-)
|
||||
|
||||
# Won't dump symbol tables and contents of debugged files by default
|
||||
|
||||
# (IZ) changes for objectification:
|
||||
# c) quote() renamed to method set_quote();
|
||||
# d) unctrlSet() renamed to method set_unctrl();
|
||||
# f) Compiles with 'use strict', but in two places no strict refs is needed:
|
||||
# maybe more problems are waiting...
|
||||
|
||||
my %defaults = (
|
||||
globPrint => 0,
|
||||
printUndef => 1,
|
||||
tick => "auto",
|
||||
unctrl => 'quote',
|
||||
subdump => 1,
|
||||
dumpReused => 0,
|
||||
bareStringify => 1,
|
||||
hashDepth => '',
|
||||
arrayDepth => '',
|
||||
dumpDBFiles => '',
|
||||
dumpPackages => '',
|
||||
quoteHighBit => '',
|
||||
usageOnly => '',
|
||||
compactDump => '',
|
||||
veryCompact => '',
|
||||
stopDbSignal => '',
|
||||
);
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my %opt = (%defaults, @_);
|
||||
bless \%opt, $class;
|
||||
}
|
||||
|
||||
sub set {
|
||||
my $self = shift;
|
||||
my %opt = @_;
|
||||
@$self{keys %opt} = values %opt;
|
||||
}
|
||||
|
||||
sub get {
|
||||
my $self = shift;
|
||||
wantarray ? @$self{@_} : $$self{pop @_};
|
||||
}
|
||||
|
||||
sub dumpValue {
|
||||
my $self = shift;
|
||||
die "usage: \$dumper->dumpValue(value)" unless @_ == 1;
|
||||
local %address;
|
||||
local $^W=0;
|
||||
(print "undef\n"), return unless defined $_[0];
|
||||
(print $self->stringify($_[0]), "\n"), return unless ref $_[0];
|
||||
$self->unwrap($_[0],0);
|
||||
}
|
||||
|
||||
sub dumpValues {
|
||||
my $self = shift;
|
||||
local %address;
|
||||
local $^W=0;
|
||||
(print "undef\n"), return if (@_ == 1 and not defined $_[0]);
|
||||
$self->unwrap(\@_,0);
|
||||
}
|
||||
|
||||
# This one is good for variable names:
|
||||
|
||||
sub unctrl {
|
||||
local($_) = @_;
|
||||
|
||||
return \$_ if ref \$_ eq "GLOB";
|
||||
s/([\000-\037])/'^' . chr(to_native(ord($1)^64))/eg;
|
||||
s/ $backslash_c_question /^?/xg;
|
||||
$_;
|
||||
}
|
||||
|
||||
sub stringify {
|
||||
my $self = shift;
|
||||
local $_ = shift;
|
||||
my $noticks = shift;
|
||||
my $tick = $self->{tick};
|
||||
|
||||
return 'undef' unless defined $_ or not $self->{printUndef};
|
||||
$_ = '' if not defined $_;
|
||||
return $_ . "" if ref \$_ eq 'GLOB';
|
||||
{ no strict 'refs';
|
||||
$_ = &{'overload::StrVal'}($_)
|
||||
if $self->{bareStringify} and ref $_
|
||||
and %overload:: and defined &{'overload::StrVal'};
|
||||
}
|
||||
if ($tick eq 'auto') {
|
||||
if (/[^[:^cntrl:]\n]/) { # All ASCII controls but \n get '"'
|
||||
$tick = '"';
|
||||
} else {
|
||||
$tick = "'";
|
||||
}
|
||||
}
|
||||
if ($tick eq "'") {
|
||||
s/([\'\\])/\\$1/g;
|
||||
} elsif ($self->{unctrl} eq 'unctrl') {
|
||||
s/([\"\\])/\\$1/g ;
|
||||
$_ = &unctrl($_);
|
||||
s/([[:^ascii:]])/'\\0x'.sprintf('%2X',ord($1))/eg
|
||||
if $self->{quoteHighBit};
|
||||
} elsif ($self->{unctrl} eq 'quote') {
|
||||
s/([\"\\\$\@])/\\$1/g if $tick eq '"';
|
||||
s/\e/\\e/g;
|
||||
s/([\000-\037$backslash_c_question])/'\\c'._escaped_ord($1)/eg;
|
||||
}
|
||||
s/([[:^ascii:]])/'\\'.sprintf('%3o',ord($1))/eg if $self->{quoteHighBit};
|
||||
($noticks || /^\d+(\.\d*)?\Z/)
|
||||
? $_
|
||||
: $tick . $_ . $tick;
|
||||
}
|
||||
|
||||
# Ensure a resulting \ is escaped to be \\
|
||||
sub _escaped_ord {
|
||||
my $chr = shift;
|
||||
if ($chr eq $backslash_c_question) {
|
||||
$chr = '?';
|
||||
}
|
||||
else {
|
||||
$chr = chr(to_native(ord($chr)^64));
|
||||
$chr =~ s{\\}{\\\\}g;
|
||||
}
|
||||
return $chr;
|
||||
}
|
||||
|
||||
sub DumpElem {
|
||||
my ($self, $v) = (shift, shift);
|
||||
my $short = $self->stringify($v, ref $v);
|
||||
my $shortmore = '';
|
||||
if ($self->{veryCompact} && ref $v
|
||||
&& (ref $v eq 'ARRAY' and !grep(ref $_, @$v) )) {
|
||||
my $depth = $#$v;
|
||||
($shortmore, $depth) = (' ...', $self->{arrayDepth} - 1)
|
||||
if $self->{arrayDepth} and $depth >= $self->{arrayDepth};
|
||||
my @a = map $self->stringify($_), @$v[0..$depth];
|
||||
print "0..$#{$v} @a$shortmore\n";
|
||||
} elsif ($self->{veryCompact} && ref $v
|
||||
&& (ref $v eq 'HASH') and !grep(ref $_, values %$v)) {
|
||||
my @a = sort keys %$v;
|
||||
my $depth = $#a;
|
||||
($shortmore, $depth) = (' ...', $self->{hashDepth} - 1)
|
||||
if $self->{hashDepth} and $depth >= $self->{hashDepth};
|
||||
my @b = map {$self->stringify($_) . " => " . $self->stringify($$v{$_})}
|
||||
@a[0..$depth];
|
||||
local $" = ', ';
|
||||
print "@b$shortmore\n";
|
||||
} else {
|
||||
print "$short\n";
|
||||
$self->unwrap($v,shift);
|
||||
}
|
||||
}
|
||||
|
||||
sub unwrap {
|
||||
my $self = shift;
|
||||
return if $DB::signal and $self->{stopDbSignal};
|
||||
my ($v) = shift ;
|
||||
my ($s) = shift || 0; # extra no of spaces
|
||||
my $sp;
|
||||
my (%v,@v,$address,$short,$fileno);
|
||||
|
||||
$sp = " " x $s ;
|
||||
$s += 3 ;
|
||||
|
||||
# Check for reused addresses
|
||||
if (ref $v) {
|
||||
my $val = $v;
|
||||
{ no strict 'refs';
|
||||
$val = &{'overload::StrVal'}($v)
|
||||
if %overload:: and defined &{'overload::StrVal'};
|
||||
}
|
||||
($address) = $val =~ /(0x[0-9a-f]+)\)$/ ;
|
||||
if (!$self->{dumpReused} && defined $address) {
|
||||
$address{$address}++ ;
|
||||
if ( $address{$address} > 1 ) {
|
||||
print "${sp}-> REUSED_ADDRESS\n" ;
|
||||
return ;
|
||||
}
|
||||
}
|
||||
} elsif (ref \$v eq 'GLOB') {
|
||||
$address = "$v" . ""; # To avoid a bug with globs
|
||||
$address{$address}++ ;
|
||||
if ( $address{$address} > 1 ) {
|
||||
print "${sp}*DUMPED_GLOB*\n" ;
|
||||
return ;
|
||||
}
|
||||
}
|
||||
|
||||
if (ref $v eq 'Regexp') {
|
||||
my $re = "$v";
|
||||
$re =~ s,/,\\/,g;
|
||||
print "$sp-> qr/$re/\n";
|
||||
return;
|
||||
}
|
||||
|
||||
if ( UNIVERSAL::isa($v, 'HASH') ) {
|
||||
my @sortKeys = sort keys(%$v) ;
|
||||
my $more;
|
||||
my $tHashDepth = $#sortKeys ;
|
||||
$tHashDepth = $#sortKeys < $self->{hashDepth}-1 ? $#sortKeys : $self->{hashDepth}-1
|
||||
unless $self->{hashDepth} eq '' ;
|
||||
$more = "....\n" if $tHashDepth < $#sortKeys ;
|
||||
my $shortmore = "";
|
||||
$shortmore = ", ..." if $tHashDepth < $#sortKeys ;
|
||||
$#sortKeys = $tHashDepth ;
|
||||
if ($self->{compactDump} && !grep(ref $_, values %{$v})) {
|
||||
$short = $sp;
|
||||
my @keys;
|
||||
for (@sortKeys) {
|
||||
push @keys, $self->stringify($_) . " => " . $self->stringify($v->{$_});
|
||||
}
|
||||
$short .= join ', ', @keys;
|
||||
$short .= $shortmore;
|
||||
(print "$short\n"), return if length $short <= $self->{compactDump};
|
||||
}
|
||||
for my $key (@sortKeys) {
|
||||
return if $DB::signal and $self->{stopDbSignal};
|
||||
my $value = $ {$v}{$key} ;
|
||||
print $sp, $self->stringify($key), " => ";
|
||||
$self->DumpElem($value, $s);
|
||||
}
|
||||
print "$sp empty hash\n" unless @sortKeys;
|
||||
print "$sp$more" if defined $more ;
|
||||
} elsif ( UNIVERSAL::isa($v, 'ARRAY') ) {
|
||||
my $tArrayDepth = $#{$v} ;
|
||||
my $more ;
|
||||
$tArrayDepth = $#$v < $self->{arrayDepth}-1 ? $#$v : $self->{arrayDepth}-1
|
||||
unless $self->{arrayDepth} eq '' ;
|
||||
$more = "....\n" if $tArrayDepth < $#{$v} ;
|
||||
my $shortmore = "";
|
||||
$shortmore = " ..." if $tArrayDepth < $#{$v} ;
|
||||
if ($self->{compactDump} && !grep(ref $_, @{$v})) {
|
||||
if ($#$v >= 0) {
|
||||
$short = $sp . "0..$#{$v} " .
|
||||
join(" ",
|
||||
map {defined $v->[$_] ? $self->stringify($v->[$_]) : "empty"} (0..$tArrayDepth)
|
||||
) . "$shortmore";
|
||||
} else {
|
||||
$short = $sp . "empty array";
|
||||
}
|
||||
(print "$short\n"), return if length $short <= $self->{compactDump};
|
||||
}
|
||||
for my $num (0 .. $tArrayDepth) {
|
||||
return if $DB::signal and $self->{stopDbSignal};
|
||||
print "$sp$num ";
|
||||
if (defined $v->[$num]) {
|
||||
$self->DumpElem($v->[$num], $s);
|
||||
} else {
|
||||
print "empty slot\n";
|
||||
}
|
||||
}
|
||||
print "$sp empty array\n" unless @$v;
|
||||
print "$sp$more" if defined $more ;
|
||||
} elsif ( UNIVERSAL::isa($v, 'SCALAR') or ref $v eq 'REF' ) {
|
||||
print "$sp-> ";
|
||||
$self->DumpElem($$v, $s);
|
||||
} elsif ( UNIVERSAL::isa($v, 'CODE') ) {
|
||||
print "$sp-> ";
|
||||
$self->dumpsub(0, $v);
|
||||
} elsif ( UNIVERSAL::isa($v, 'GLOB') ) {
|
||||
print "$sp-> ",$self->stringify($$v,1),"\n";
|
||||
if ($self->{globPrint}) {
|
||||
$s += 3;
|
||||
$self->dumpglob('', $s, "{$$v}", $$v, 1);
|
||||
} elsif (defined ($fileno = fileno($v))) {
|
||||
print( (' ' x ($s+3)) . "FileHandle({$$v}) => fileno($fileno)\n" );
|
||||
}
|
||||
} elsif (ref \$v eq 'GLOB') {
|
||||
if ($self->{globPrint}) {
|
||||
$self->dumpglob('', $s, "{$v}", $v, 1);
|
||||
} elsif (defined ($fileno = fileno(\$v))) {
|
||||
print( (' ' x $s) . "FileHandle({$v}) => fileno($fileno)\n" );
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub matchvar {
|
||||
$_[0] eq $_[1] or
|
||||
($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and
|
||||
($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/});
|
||||
}
|
||||
|
||||
sub compactDump {
|
||||
my $self = shift;
|
||||
$self->{compactDump} = shift if @_;
|
||||
$self->{compactDump} = 6*80-1
|
||||
if $self->{compactDump} and $self->{compactDump} < 2;
|
||||
$self->{compactDump};
|
||||
}
|
||||
|
||||
sub veryCompact {
|
||||
my $self = shift;
|
||||
$self->{veryCompact} = shift if @_;
|
||||
$self->compactDump(1) if !$self->{compactDump} and $self->{veryCompact};
|
||||
$self->{veryCompact};
|
||||
}
|
||||
|
||||
sub set_unctrl {
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
my $in = shift;
|
||||
if ($in eq 'unctrl' or $in eq 'quote') {
|
||||
$self->{unctrl} = $in;
|
||||
} else {
|
||||
print "Unknown value for 'unctrl'.\n";
|
||||
}
|
||||
}
|
||||
$self->{unctrl};
|
||||
}
|
||||
|
||||
sub set_quote {
|
||||
my $self = shift;
|
||||
if (@_ and $_[0] eq '"') {
|
||||
$self->{tick} = '"';
|
||||
$self->{unctrl} = 'quote';
|
||||
} elsif (@_ and $_[0] eq 'auto') {
|
||||
$self->{tick} = 'auto';
|
||||
$self->{unctrl} = 'quote';
|
||||
} elsif (@_) { # Need to set
|
||||
$self->{tick} = "'";
|
||||
$self->{unctrl} = 'unctrl';
|
||||
}
|
||||
$self->{tick};
|
||||
}
|
||||
|
||||
sub dumpglob {
|
||||
my $self = shift;
|
||||
return if $DB::signal and $self->{stopDbSignal};
|
||||
my ($package, $off, $key, $val, $all) = @_;
|
||||
local(*stab) = $val;
|
||||
my $fileno;
|
||||
if (($key !~ /^_</ or $self->{dumpDBFiles}) and defined $stab) {
|
||||
print( (' ' x $off) . "\$", &unctrl($key), " = " );
|
||||
$self->DumpElem($stab, 3+$off);
|
||||
}
|
||||
if (($key !~ /^_</ or $self->{dumpDBFiles}) and @stab) {
|
||||
print( (' ' x $off) . "\@$key = (\n" );
|
||||
$self->unwrap(\@stab,3+$off) ;
|
||||
print( (' ' x $off) . ")\n" );
|
||||
}
|
||||
if ($key ne "main::" && $key ne "DB::" && %stab
|
||||
&& ($self->{dumpPackages} or $key !~ /::$/)
|
||||
&& ($key !~ /^_</ or $self->{dumpDBFiles})
|
||||
&& !($package eq "Dumpvalue" and $key eq "stab")) {
|
||||
print( (' ' x $off) . "\%$key = (\n" );
|
||||
$self->unwrap(\%stab,3+$off) ;
|
||||
print( (' ' x $off) . ")\n" );
|
||||
}
|
||||
if (defined ($fileno = fileno(*stab))) {
|
||||
print( (' ' x $off) . "FileHandle($key) => fileno($fileno)\n" );
|
||||
}
|
||||
if ($all) {
|
||||
if (defined &stab) {
|
||||
$self->dumpsub($off, $key);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub CvGV_name {
|
||||
my $self = shift;
|
||||
my $in = shift;
|
||||
return if $self->{skipCvGV}; # Backdoor to avoid problems if XS broken...
|
||||
$in = \&$in; # Hard reference...
|
||||
eval {require Devel::Peek; 1} or return;
|
||||
my $gv = Devel::Peek::CvGV($in) or return;
|
||||
*$gv{PACKAGE} . '::' . *$gv{NAME};
|
||||
}
|
||||
|
||||
sub dumpsub {
|
||||
my $self = shift;
|
||||
my ($off,$sub) = @_;
|
||||
$off ||= 0;
|
||||
my $ini = $sub;
|
||||
my $s;
|
||||
$sub = $1 if $sub =~ /^\{\*(.*)\}$/;
|
||||
my $subref = defined $1 ? \&$sub : \&$ini;
|
||||
my $place = $DB::sub{$sub} || (($s = $subs{"$subref"}) && $DB::sub{$s})
|
||||
|| (($s = $self->CvGV_name($subref)) && $DB::sub{$s})
|
||||
|| ($self->{subdump} && ($s = $self->findsubs("$subref"))
|
||||
&& $DB::sub{$s});
|
||||
$s = $sub unless defined $s;
|
||||
$place = '???' unless defined $place;
|
||||
print( (' ' x $off) . "&$s in $place\n" );
|
||||
}
|
||||
|
||||
sub findsubs {
|
||||
my $self = shift;
|
||||
return undef unless %DB::sub;
|
||||
my ($addr, $name, $loc);
|
||||
while (($name, $loc) = each %DB::sub) {
|
||||
$addr = \&$name;
|
||||
$subs{"$addr"} = $name;
|
||||
}
|
||||
$self->{subdump} = 0;
|
||||
$subs{ shift() };
|
||||
}
|
||||
|
||||
sub dumpvars {
|
||||
my $self = shift;
|
||||
my ($package,@vars) = @_;
|
||||
local(%address,$^W);
|
||||
$package .= "::" unless $package =~ /::$/;
|
||||
*stab = *main::;
|
||||
|
||||
while ($package =~ /(\w+?::)/g) {
|
||||
*stab = defined ${stab}{$1} ? ${stab}{$1} : '';
|
||||
}
|
||||
$self->{TotalStrings} = 0;
|
||||
$self->{Strings} = 0;
|
||||
$self->{CompleteTotal} = 0;
|
||||
for my $k (keys %stab) {
|
||||
my ($key,$val) = ($k, $stab{$k});
|
||||
return if $DB::signal and $self->{stopDbSignal};
|
||||
next if @vars && !grep( matchvar($key, $_), @vars );
|
||||
if ($self->{usageOnly}) {
|
||||
$self->globUsage(\$val, $key)
|
||||
if ($package ne 'Dumpvalue' or $key ne 'stab')
|
||||
and ref(\$val) eq 'GLOB';
|
||||
} else {
|
||||
$self->dumpglob($package, 0,$key, $val);
|
||||
}
|
||||
}
|
||||
if ($self->{usageOnly}) {
|
||||
print <<EOP;
|
||||
String space: $self->{TotalStrings} bytes in $self->{Strings} strings.
|
||||
EOP
|
||||
$self->{CompleteTotal} += $self->{TotalStrings};
|
||||
print <<EOP;
|
||||
Grand total = $self->{CompleteTotal} bytes (1 level deep) + overhead.
|
||||
EOP
|
||||
}
|
||||
}
|
||||
|
||||
sub scalarUsage {
|
||||
my $self = shift;
|
||||
my $size;
|
||||
if (UNIVERSAL::isa($_[0], 'ARRAY')) {
|
||||
$size = $self->arrayUsage($_[0]);
|
||||
} elsif (UNIVERSAL::isa($_[0], 'HASH')) {
|
||||
$size = $self->hashUsage($_[0]);
|
||||
} elsif (!ref($_[0])) {
|
||||
$size = length($_[0]);
|
||||
}
|
||||
$self->{TotalStrings} += $size;
|
||||
$self->{Strings}++;
|
||||
$size;
|
||||
}
|
||||
|
||||
sub arrayUsage { # array ref, name
|
||||
my $self = shift;
|
||||
my $size = 0;
|
||||
map {$size += $self->scalarUsage($_)} @{$_[0]};
|
||||
my $len = @{$_[0]};
|
||||
print "\@$_[1] = $len item", ($len > 1 ? "s" : ""), " (data: $size bytes)\n"
|
||||
if defined $_[1];
|
||||
$self->{CompleteTotal} += $size;
|
||||
$size;
|
||||
}
|
||||
|
||||
sub hashUsage { # hash ref, name
|
||||
my $self = shift;
|
||||
my @keys = keys %{$_[0]};
|
||||
my @values = values %{$_[0]};
|
||||
my $keys = $self->arrayUsage(\@keys);
|
||||
my $values = $self->arrayUsage(\@values);
|
||||
my $len = @keys;
|
||||
my $total = $keys + $values;
|
||||
print "\%$_[1] = $len item", ($len > 1 ? "s" : ""),
|
||||
" (keys: $keys; values: $values; total: $total bytes)\n"
|
||||
if defined $_[1];
|
||||
$total;
|
||||
}
|
||||
|
||||
sub globUsage { # glob ref, name
|
||||
my $self = shift;
|
||||
local *stab = *{$_[0]};
|
||||
my $total = 0;
|
||||
$total += $self->scalarUsage($stab) if defined $stab;
|
||||
$total += $self->arrayUsage(\@stab, $_[1]) if @stab;
|
||||
$total += $self->hashUsage(\%stab, $_[1])
|
||||
if %stab and $_[1] ne "main::" and $_[1] ne "DB::";
|
||||
#and !($package eq "Dumpvalue" and $key eq "stab"));
|
||||
$total;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Dumpvalue - provides screen dump of Perl data.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Dumpvalue;
|
||||
my $dumper = Dumpvalue->new;
|
||||
$dumper->set(globPrint => 1);
|
||||
$dumper->dumpValue(\*::);
|
||||
$dumper->dumpvars('main');
|
||||
my $dump = $dumper->stringify($some_value);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
=head2 Creation
|
||||
|
||||
A new dumper is created by a call
|
||||
|
||||
$d = Dumpvalue->new(option1 => value1, option2 => value2)
|
||||
|
||||
Recognized options:
|
||||
|
||||
=over 4
|
||||
|
||||
=item C<arrayDepth>, C<hashDepth>
|
||||
|
||||
Print only first N elements of arrays and hashes. If false, prints all the
|
||||
elements.
|
||||
|
||||
=item C<compactDump>, C<veryCompact>
|
||||
|
||||
Change style of array and hash dump. If true, short array
|
||||
may be printed on one line.
|
||||
|
||||
=item C<globPrint>
|
||||
|
||||
Whether to print contents of globs.
|
||||
|
||||
=item C<dumpDBFiles>
|
||||
|
||||
Dump arrays holding contents of debugged files.
|
||||
|
||||
=item C<dumpPackages>
|
||||
|
||||
Dump symbol tables of packages.
|
||||
|
||||
=item C<dumpReused>
|
||||
|
||||
Dump contents of "reused" addresses.
|
||||
|
||||
=item C<tick>, C<quoteHighBit>, C<printUndef>
|
||||
|
||||
Change style of string dump. Default value of C<tick> is C<auto>, one
|
||||
can enable either double-quotish dump, or single-quotish by setting it
|
||||
to C<"> or C<'>. By default, characters with high bit set are printed
|
||||
I<as is>. If C<quoteHighBit> is set, they will be quoted.
|
||||
|
||||
=item C<usageOnly>
|
||||
|
||||
rudimentary per-package memory usage dump. If set,
|
||||
C<dumpvars> calculates total size of strings in variables in the package.
|
||||
|
||||
=item unctrl
|
||||
|
||||
Changes the style of printout of strings. Possible values are
|
||||
C<unctrl> and C<quote>.
|
||||
|
||||
=item subdump
|
||||
|
||||
Whether to try to find the subroutine name given the reference.
|
||||
|
||||
=item bareStringify
|
||||
|
||||
Whether to write the non-overloaded form of the stringify-overloaded objects.
|
||||
|
||||
=item quoteHighBit
|
||||
|
||||
Whether to print chars with high bit set in binary or "as is".
|
||||
|
||||
=item stopDbSignal
|
||||
|
||||
Whether to abort printing if debugger signal flag is raised.
|
||||
|
||||
=back
|
||||
|
||||
Later in the life of the object the methods may be queries with get()
|
||||
method and set() method (which accept multiple arguments).
|
||||
|
||||
=head2 Methods
|
||||
|
||||
=over 4
|
||||
|
||||
=item dumpValue
|
||||
|
||||
$dumper->dumpValue($value);
|
||||
$dumper->dumpValue([$value1, $value2]);
|
||||
|
||||
Prints a dump to the currently selected filehandle.
|
||||
|
||||
=item dumpValues
|
||||
|
||||
$dumper->dumpValues($value1, $value2);
|
||||
|
||||
Same as C<< $dumper->dumpValue([$value1, $value2]); >>.
|
||||
|
||||
=item stringify
|
||||
|
||||
my $dump = $dumper->stringify($value [,$noticks] );
|
||||
|
||||
Returns the dump of a single scalar without printing. If the second
|
||||
argument is true, the return value does not contain enclosing ticks.
|
||||
Does not handle data structures.
|
||||
|
||||
=item dumpvars
|
||||
|
||||
$dumper->dumpvars('my_package');
|
||||
$dumper->dumpvars('my_package', 'foo', '~bar$', '!......');
|
||||
|
||||
The optional arguments are considered as literal strings unless they
|
||||
start with C<~> or C<!>, in which case they are interpreted as regular
|
||||
expressions (possibly negated).
|
||||
|
||||
The second example prints entries with names C<foo>, and also entries
|
||||
with names which ends on C<bar>, or are shorter than 5 chars.
|
||||
|
||||
=item set_quote
|
||||
|
||||
$d->set_quote('"');
|
||||
|
||||
Sets C<tick> and C<unctrl> options to suitable values for printout with the
|
||||
given quote char. Possible values are C<auto>, C<'> and C<">.
|
||||
|
||||
=item set_unctrl
|
||||
|
||||
$d->set_unctrl('unctrl');
|
||||
|
||||
Sets C<unctrl> option with checking for an invalid argument.
|
||||
Possible values are C<unctrl> and C<quote>.
|
||||
|
||||
=item compactDump
|
||||
|
||||
$d->compactDump(1);
|
||||
|
||||
Sets C<compactDump> option. If the value is 1, sets to a reasonable
|
||||
big number.
|
||||
|
||||
=item veryCompact
|
||||
|
||||
$d->veryCompact(1);
|
||||
|
||||
Sets C<compactDump> and C<veryCompact> options simultaneously.
|
||||
|
||||
=item set
|
||||
|
||||
$d->set(option1 => value1, option2 => value2);
|
||||
|
||||
=item get
|
||||
|
||||
@values = $d->get('option1', 'option2');
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
@@ -0,0 +1,7 @@
|
||||
#
|
||||
# $Id: Changes.e2x,v 2.0 2004/05/16 20:55:15 dankogai Exp $
|
||||
# Revision history for Perl extension Encode::$_Name_.
|
||||
#
|
||||
|
||||
0.01 $_Now_
|
||||
Autogenerated by enc2xs version $_Version_.
|
||||
@@ -0,0 +1,13 @@
|
||||
#
|
||||
# Local demand-load module list
|
||||
#
|
||||
# You should not edit this file by hand! use "enc2xs -C"
|
||||
#
|
||||
package Encode::ConfigLocal;
|
||||
our $VERSION = $_LocalVer_;
|
||||
|
||||
use strict;
|
||||
|
||||
$_ModLines_
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,190 @@
|
||||
#
|
||||
# This file is auto-generated by:
|
||||
# enc2xs version $_Version_
|
||||
# $_Now_
|
||||
#
|
||||
use 5.7.2;
|
||||
use strict;
|
||||
use ExtUtils::MakeMaker;
|
||||
use Config;
|
||||
|
||||
# Please edit the following to the taste!
|
||||
my $name = '$_Name_';
|
||||
my %tables = (
|
||||
$_Name__t => [ $_TableFiles_ ],
|
||||
);
|
||||
|
||||
#### DO NOT EDIT BEYOND THIS POINT!
|
||||
require File::Spec;
|
||||
my ($enc2xs, $encode_h) = ();
|
||||
my @path_ext = ('');
|
||||
@path_ext = split(';', $ENV{PATHEXT}) if $^O eq 'MSWin32';
|
||||
PATHLOOP:
|
||||
for my $d (@Config{qw/bin sitebin vendorbin/},
|
||||
(split /$Config{path_sep}/o, $ENV{PATH})){
|
||||
for my $f (qw/enc2xs enc2xs5.7.3/){
|
||||
my $path = File::Spec->catfile($d, $f);
|
||||
for my $ext (@path_ext) {
|
||||
my $bin = "$path$ext";
|
||||
-r "$bin" and $enc2xs = $bin and last PATHLOOP;
|
||||
}
|
||||
}
|
||||
}
|
||||
$enc2xs or die "enc2xs not found!";
|
||||
print "enc2xs is $enc2xs\n";
|
||||
my %encode_h = ();
|
||||
for my $d (@INC){
|
||||
my $dir = File::Spec->catfile($d, "Encode");
|
||||
my $file = File::Spec->catfile($dir, "encode.h");
|
||||
-f $file and $encode_h{$dir} = -M $file;
|
||||
}
|
||||
%encode_h or die "encode.h not found!";
|
||||
# find the latest one
|
||||
($encode_h) = sort {$encode_h{$b} <=> $encode_h{$a}} keys %encode_h;
|
||||
print "encode.h is at $encode_h\n";
|
||||
|
||||
WriteMakefile(
|
||||
INC => "-I$encode_h",
|
||||
#### END_OF_HEADER -- DO NOT EDIT THIS LINE BY HAND! ####
|
||||
NAME => 'Encode::'.$name,
|
||||
VERSION_FROM => "$name.pm",
|
||||
OBJECT => '$(O_FILES)',
|
||||
'dist' => {
|
||||
COMPRESS => 'gzip -9f',
|
||||
SUFFIX => 'gz',
|
||||
DIST_DEFAULT => 'all tardist',
|
||||
},
|
||||
MAN3PODS => {},
|
||||
PREREQ_PM => {
|
||||
'Encode' => "1.41",
|
||||
},
|
||||
# OS 390 winges about line numbers > 64K ???
|
||||
XSOPT => '-nolinenumbers',
|
||||
);
|
||||
|
||||
package MY;
|
||||
|
||||
sub post_initialize
|
||||
{
|
||||
my ($self) = @_;
|
||||
my %o;
|
||||
my $x = $self->{'OBJ_EXT'};
|
||||
# Add the table O_FILES
|
||||
foreach my $e (keys %tables)
|
||||
{
|
||||
$o{$e.$x} = 1;
|
||||
}
|
||||
$o{"$name$x"} = 1;
|
||||
$self->{'O_FILES'} = [sort keys %o];
|
||||
my @files = ("$name.xs");
|
||||
$self->{'C'} = ["$name.c"];
|
||||
# The next two lines to make MacPerl Happy -- dankogai via pudge
|
||||
$self->{SOURCE} .= " $name.c"
|
||||
if $^O eq 'MacOS' && $self->{SOURCE} !~ /\b$name\.c\b/;
|
||||
# $self->{'H'} = [$self->catfile($self->updir,'encode.h')];
|
||||
my %xs;
|
||||
foreach my $table (sort keys %tables) {
|
||||
push (@{$self->{'C'}},"$table.c");
|
||||
# Do NOT add $table.h etc. to H_FILES unless we own up as to how they
|
||||
# get built.
|
||||
foreach my $ext (qw($(OBJ_EXT) .c .h .exh .fnm)) {
|
||||
push (@files,$table.$ext);
|
||||
}
|
||||
}
|
||||
$self->{'XS'} = { "$name.xs" => "$name.c" };
|
||||
$self->{'clean'}{'FILES'} .= join(' ',@files);
|
||||
open(XS,">$name.xs") || die "Cannot open $name.xs:$!";
|
||||
print XS <<'END';
|
||||
#include <EXTERN.h>
|
||||
#include <perl.h>
|
||||
#include <XSUB.h>
|
||||
#include "encode.h"
|
||||
END
|
||||
foreach my $table (sort keys %tables) {
|
||||
print XS qq[#include "${table}.h"\n];
|
||||
}
|
||||
print XS <<"END";
|
||||
|
||||
static void
|
||||
Encode_XSEncoding(pTHX_ encode_t *enc)
|
||||
{
|
||||
dSP;
|
||||
HV *stash = gv_stashpv("Encode::XS", TRUE);
|
||||
SV *iv = newSViv(PTR2IV(enc));
|
||||
SV *sv = sv_bless(newRV_noinc(iv),stash);
|
||||
int i = 0;
|
||||
/* with the SvLEN() == 0 hack, PVX won't be freed. We cast away name's
|
||||
constness, in the hope that perl won't mess with it. */
|
||||
assert(SvTYPE(iv) >= SVt_PV); assert(SvLEN(iv) == 0);
|
||||
SvFLAGS(iv) |= SVp_POK;
|
||||
SvPVX(iv) = (char*) enc->name[0];
|
||||
PUSHMARK(sp);
|
||||
XPUSHs(sv);
|
||||
while (enc->name[i])
|
||||
{
|
||||
const char *name = enc->name[i++];
|
||||
XPUSHs(sv_2mortal(newSVpvn(name,strlen(name))));
|
||||
}
|
||||
PUTBACK;
|
||||
call_pv("Encode::define_encoding",G_DISCARD);
|
||||
SvREFCNT_dec(sv);
|
||||
}
|
||||
|
||||
MODULE = Encode::$name PACKAGE = Encode::$name
|
||||
PROTOTYPES: DISABLE
|
||||
BOOT:
|
||||
{
|
||||
END
|
||||
foreach my $table (sort keys %tables) {
|
||||
print XS qq[#include "${table}.exh"\n];
|
||||
}
|
||||
print XS "}\n";
|
||||
close(XS);
|
||||
return "# Built $name.xs\n\n";
|
||||
}
|
||||
|
||||
sub postamble
|
||||
{
|
||||
my $self = shift;
|
||||
my $dir = "."; # $self->catdir('Encode');
|
||||
my $str = "# $name\$(OBJ_EXT) depends on .h and .exh files not .c files - but all written by enc2xs\n";
|
||||
$str .= "$name.c : $name.xs ";
|
||||
foreach my $table (sort keys %tables)
|
||||
{
|
||||
$str .= " $table.c";
|
||||
}
|
||||
$str .= "\n\n";
|
||||
$str .= "$name\$(OBJ_EXT) : $name.c\n\n";
|
||||
|
||||
foreach my $table (sort keys %tables)
|
||||
{
|
||||
my $numlines = 1;
|
||||
my $lengthsofar = length($str);
|
||||
my $continuator = '';
|
||||
$str .= "$table.c : Makefile.PL";
|
||||
foreach my $file (@{$tables{$table}})
|
||||
{
|
||||
$str .= $continuator.' '.$self->catfile($dir,$file);
|
||||
if ( length($str)-$lengthsofar > 128*$numlines )
|
||||
{
|
||||
$continuator .= " \\\n\t";
|
||||
$numlines++;
|
||||
} else {
|
||||
$continuator = '';
|
||||
}
|
||||
}
|
||||
my $plib = $self->{PERL_CORE} ? '"-I$(PERL_LIB)"' : '';
|
||||
my $ucopts = '-"Q"';
|
||||
$str .=
|
||||
qq{\n\t\$(PERL) $plib $enc2xs $ucopts -o \$\@ -f $table.fnm\n\n};
|
||||
open (FILELIST, ">$table.fnm")
|
||||
|| die "Could not open $table.fnm: $!";
|
||||
foreach my $file (@{$tables{$table}})
|
||||
{
|
||||
print FILELIST $self->catfile($dir,$file) . "\n";
|
||||
}
|
||||
close(FILELIST);
|
||||
}
|
||||
return $str;
|
||||
}
|
||||
|
||||
@@ -0,0 +1,31 @@
|
||||
Encode::$_Name_ version 0.1
|
||||
========
|
||||
|
||||
NAME
|
||||
Encode::$_Name_ - <describe encoding>
|
||||
|
||||
SYNOPSIS
|
||||
use Encode::$_Name_;
|
||||
#<put more words here>
|
||||
ABSTRACT
|
||||
<fill this in>
|
||||
INSTALLATION
|
||||
|
||||
To install this module type the following:
|
||||
|
||||
perl Makefile.PL
|
||||
make
|
||||
make test
|
||||
make install
|
||||
|
||||
DEPENDENCIES
|
||||
|
||||
This module requires perl version 5.7.3 or later.
|
||||
|
||||
COPYRIGHT AND LICENCE
|
||||
|
||||
Copyright (C) 2002 Your Name <your@address.domain>
|
||||
|
||||
This library is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
@@ -0,0 +1,23 @@
|
||||
package Encode::$_Name_;
|
||||
our $VERSION = "0.01";
|
||||
|
||||
use Encode;
|
||||
use XSLoader;
|
||||
XSLoader::load(__PACKAGE__,$VERSION);
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Encode::$_Name_ - New Encoding
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
You got to fill this in!
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Encode>
|
||||
|
||||
=cut
|
||||
@@ -0,0 +1,9 @@
|
||||
use strict;
|
||||
# Adjust the number here!
|
||||
use Test::More tests => 2;
|
||||
|
||||
BEGIN {
|
||||
use_ok('Encode');
|
||||
use_ok('Encode::$_Name_');
|
||||
}
|
||||
# Add more test here!
|
||||
@@ -0,0 +1,237 @@
|
||||
package English;
|
||||
|
||||
our $VERSION = '1.11';
|
||||
|
||||
require Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
English - use nice English (or awk) names for ugly punctuation variables
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use English;
|
||||
use English qw( -no_match_vars ) ; # Avoids regex performance
|
||||
# penalty in perl 5.18 and
|
||||
# earlier
|
||||
...
|
||||
if ($ERRNO =~ /denied/) { ... }
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides aliases for the built-in variables whose
|
||||
names no one seems to like to read. Variables with side-effects
|
||||
which get triggered just by accessing them (like $0) will still
|
||||
be affected.
|
||||
|
||||
For those variables that have an B<awk> version, both long
|
||||
and short English alternatives are provided. For example,
|
||||
the C<$/> variable can be referred to either $RS or
|
||||
$INPUT_RECORD_SEPARATOR if you are using the English module.
|
||||
|
||||
See L<perlvar> for a complete list of these.
|
||||
|
||||
=head1 PERFORMANCE
|
||||
|
||||
NOTE: This was fixed in perl 5.20. Mentioning these three variables no
|
||||
longer makes a speed difference. This section still applies if your code
|
||||
is to run on perl 5.18 or earlier.
|
||||
|
||||
This module can provoke sizeable inefficiencies for regular expressions,
|
||||
due to unfortunate implementation details. If performance matters in
|
||||
your application and you don't need $PREMATCH, $MATCH, or $POSTMATCH,
|
||||
try doing
|
||||
|
||||
use English qw( -no_match_vars ) ;
|
||||
|
||||
. B<It is especially important to do this in modules to avoid penalizing
|
||||
all applications which use them.>
|
||||
|
||||
=cut
|
||||
|
||||
no warnings;
|
||||
|
||||
my $globbed_match ;
|
||||
|
||||
# Grandfather $NAME import
|
||||
sub import {
|
||||
my $this = shift;
|
||||
my @list = grep { ! /^-no_match_vars$/ } @_ ;
|
||||
local $Exporter::ExportLevel = 1;
|
||||
if ( @_ == @list ) {
|
||||
*EXPORT = \@COMPLETE_EXPORT ;
|
||||
$globbed_match ||= (
|
||||
eval q{
|
||||
*MATCH = *& ;
|
||||
*PREMATCH = *` ;
|
||||
*POSTMATCH = *' ;
|
||||
1 ;
|
||||
}
|
||||
|| do {
|
||||
require Carp ;
|
||||
Carp::croak("Can't create English for match leftovers: $@") ;
|
||||
}
|
||||
) ;
|
||||
}
|
||||
else {
|
||||
*EXPORT = \@MINIMAL_EXPORT ;
|
||||
}
|
||||
Exporter::import($this,grep {s/^\$/*/} @list);
|
||||
}
|
||||
|
||||
@MINIMAL_EXPORT = qw(
|
||||
*ARG
|
||||
*LAST_PAREN_MATCH
|
||||
*INPUT_LINE_NUMBER
|
||||
*NR
|
||||
*INPUT_RECORD_SEPARATOR
|
||||
*RS
|
||||
*OUTPUT_AUTOFLUSH
|
||||
*OUTPUT_FIELD_SEPARATOR
|
||||
*OFS
|
||||
*OUTPUT_RECORD_SEPARATOR
|
||||
*ORS
|
||||
*LIST_SEPARATOR
|
||||
*SUBSCRIPT_SEPARATOR
|
||||
*SUBSEP
|
||||
*FORMAT_PAGE_NUMBER
|
||||
*FORMAT_LINES_PER_PAGE
|
||||
*FORMAT_LINES_LEFT
|
||||
*FORMAT_NAME
|
||||
*FORMAT_TOP_NAME
|
||||
*FORMAT_LINE_BREAK_CHARACTERS
|
||||
*FORMAT_FORMFEED
|
||||
*CHILD_ERROR
|
||||
*OS_ERROR
|
||||
*ERRNO
|
||||
*EXTENDED_OS_ERROR
|
||||
*EVAL_ERROR
|
||||
*PROCESS_ID
|
||||
*PID
|
||||
*REAL_USER_ID
|
||||
*UID
|
||||
*EFFECTIVE_USER_ID
|
||||
*EUID
|
||||
*REAL_GROUP_ID
|
||||
*GID
|
||||
*EFFECTIVE_GROUP_ID
|
||||
*EGID
|
||||
*PROGRAM_NAME
|
||||
*PERL_VERSION
|
||||
*OLD_PERL_VERSION
|
||||
*ACCUMULATOR
|
||||
*COMPILING
|
||||
*DEBUGGING
|
||||
*SYSTEM_FD_MAX
|
||||
*INPLACE_EDIT
|
||||
*PERLDB
|
||||
*BASETIME
|
||||
*WARNING
|
||||
*EXECUTABLE_NAME
|
||||
*OSNAME
|
||||
*LAST_REGEXP_CODE_RESULT
|
||||
*EXCEPTIONS_BEING_CAUGHT
|
||||
*LAST_SUBMATCH_RESULT
|
||||
@LAST_MATCH_START
|
||||
@LAST_MATCH_END
|
||||
);
|
||||
|
||||
|
||||
@MATCH_EXPORT = qw(
|
||||
*MATCH
|
||||
*PREMATCH
|
||||
*POSTMATCH
|
||||
);
|
||||
|
||||
@COMPLETE_EXPORT = ( @MINIMAL_EXPORT, @MATCH_EXPORT ) ;
|
||||
|
||||
# The ground of all being.
|
||||
|
||||
*ARG = *_ ;
|
||||
|
||||
# Matching.
|
||||
|
||||
*LAST_PAREN_MATCH = *+ ;
|
||||
*LAST_SUBMATCH_RESULT = *^N ;
|
||||
*LAST_MATCH_START = *-{ARRAY} ;
|
||||
*LAST_MATCH_END = *+{ARRAY} ;
|
||||
|
||||
# Input.
|
||||
|
||||
*INPUT_LINE_NUMBER = *. ;
|
||||
*NR = *. ;
|
||||
*INPUT_RECORD_SEPARATOR = */ ;
|
||||
*RS = */ ;
|
||||
|
||||
# Output.
|
||||
|
||||
*OUTPUT_AUTOFLUSH = *| ;
|
||||
*OUTPUT_FIELD_SEPARATOR = *, ;
|
||||
*OFS = *, ;
|
||||
*OUTPUT_RECORD_SEPARATOR = *\ ;
|
||||
*ORS = *\ ;
|
||||
|
||||
# Interpolation "constants".
|
||||
|
||||
*LIST_SEPARATOR = *" ;
|
||||
*SUBSCRIPT_SEPARATOR = *; ;
|
||||
*SUBSEP = *; ;
|
||||
|
||||
# Formats
|
||||
|
||||
*FORMAT_PAGE_NUMBER = *% ;
|
||||
*FORMAT_LINES_PER_PAGE = *= ;
|
||||
*FORMAT_LINES_LEFT = *-{SCALAR} ;
|
||||
*FORMAT_NAME = *~ ;
|
||||
*FORMAT_TOP_NAME = *^ ;
|
||||
*FORMAT_LINE_BREAK_CHARACTERS = *: ;
|
||||
*FORMAT_FORMFEED = *^L ;
|
||||
|
||||
# Error status.
|
||||
|
||||
*CHILD_ERROR = *? ;
|
||||
*OS_ERROR = *! ;
|
||||
*ERRNO = *! ;
|
||||
*OS_ERROR = *! ;
|
||||
*ERRNO = *! ;
|
||||
*EXTENDED_OS_ERROR = *^E ;
|
||||
*EVAL_ERROR = *@ ;
|
||||
|
||||
# Process info.
|
||||
|
||||
*PROCESS_ID = *$ ;
|
||||
*PID = *$ ;
|
||||
*REAL_USER_ID = *< ;
|
||||
*UID = *< ;
|
||||
*EFFECTIVE_USER_ID = *> ;
|
||||
*EUID = *> ;
|
||||
*REAL_GROUP_ID = *( ;
|
||||
*GID = *( ;
|
||||
*EFFECTIVE_GROUP_ID = *) ;
|
||||
*EGID = *) ;
|
||||
*PROGRAM_NAME = *0 ;
|
||||
|
||||
# Internals.
|
||||
|
||||
*PERL_VERSION = *^V ;
|
||||
*OLD_PERL_VERSION = *] ;
|
||||
*ACCUMULATOR = *^A ;
|
||||
*COMPILING = *^C ;
|
||||
*DEBUGGING = *^D ;
|
||||
*SYSTEM_FD_MAX = *^F ;
|
||||
*INPLACE_EDIT = *^I ;
|
||||
*PERLDB = *^P ;
|
||||
*LAST_REGEXP_CODE_RESULT = *^R ;
|
||||
*EXCEPTIONS_BEING_CAUGHT = *^S ;
|
||||
*BASETIME = *^T ;
|
||||
*WARNING = *^W ;
|
||||
*EXECUTABLE_NAME = *^X ;
|
||||
*OSNAME = *^O ;
|
||||
|
||||
# Deprecated.
|
||||
|
||||
# *ARRAY_BASE = *[ ;
|
||||
# *OFMT = *# ;
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,255 @@
|
||||
package Env;
|
||||
|
||||
our $VERSION = '1.06';
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Env - perl module that imports environment variables as scalars or arrays
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Env;
|
||||
use Env qw(PATH HOME TERM);
|
||||
use Env qw($SHELL @LD_LIBRARY_PATH);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Perl maintains environment variables in a special hash named C<%ENV>. For
|
||||
when this access method is inconvenient, the Perl module C<Env> allows
|
||||
environment variables to be treated as scalar or array variables.
|
||||
|
||||
The C<Env::import()> function ties environment variables with suitable
|
||||
names to global Perl variables with the same names. By default it
|
||||
ties all existing environment variables (C<keys %ENV>) to scalars. If
|
||||
the C<import> function receives arguments, it takes them to be a list of
|
||||
variables to tie; it's okay if they don't yet exist. The scalar type
|
||||
prefix '$' is inferred for any element of this list not prefixed by '$'
|
||||
or '@'. Arrays are implemented in terms of C<split> and C<join>, using
|
||||
C<$Config::Config{path_sep}> as the delimiter.
|
||||
|
||||
After an environment variable is tied, merely use it like a normal variable.
|
||||
You may access its value
|
||||
|
||||
@path = split(/:/, $PATH);
|
||||
print join("\n", @LD_LIBRARY_PATH), "\n";
|
||||
|
||||
or modify it
|
||||
|
||||
$PATH .= ":/any/path";
|
||||
push @LD_LIBRARY_PATH, $dir;
|
||||
|
||||
however you'd like. Bear in mind, however, that each access to a tied array
|
||||
variable requires splitting the environment variable's string anew.
|
||||
|
||||
The code:
|
||||
|
||||
use Env qw(@PATH);
|
||||
push @PATH, '/any/path';
|
||||
|
||||
is almost equivalent to:
|
||||
|
||||
use Env qw(PATH);
|
||||
$PATH .= ":/any/path";
|
||||
|
||||
except that if C<$ENV{PATH}> started out empty, the second approach leaves
|
||||
it with the (odd) value "C<:/any/path>", but the first approach leaves it with
|
||||
"C</any/path>".
|
||||
|
||||
To remove a tied environment variable from
|
||||
the environment, assign it the undefined value
|
||||
|
||||
undef $PATH;
|
||||
undef @LD_LIBRARY_PATH;
|
||||
|
||||
=head1 LIMITATIONS
|
||||
|
||||
On VMS systems, arrays tied to environment variables are read-only. Attempting
|
||||
to change anything will cause a warning.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Chip Salzenberg E<lt>F<chip@fin.uucp>E<gt>
|
||||
and
|
||||
Gregor N. Purdy E<lt>F<gregor@focusresearch.com>E<gt>
|
||||
|
||||
=cut
|
||||
|
||||
sub import {
|
||||
my $callpack = caller(0);
|
||||
my $pack = shift;
|
||||
my @vars = grep /^[\$\@]?[A-Za-z_]\w*$/, (@_ ? @_ : keys(%ENV));
|
||||
return unless @vars;
|
||||
|
||||
@vars = map { m/^[\$\@]/ ? $_ : '$'.$_ } @vars;
|
||||
|
||||
eval "package $callpack; use vars qw(" . join(' ', @vars) . ")";
|
||||
die $@ if $@;
|
||||
foreach (@vars) {
|
||||
my ($type, $name) = m/^([\$\@])(.*)$/;
|
||||
if ($type eq '$') {
|
||||
tie ${"${callpack}::$name"}, Env, $name;
|
||||
} else {
|
||||
if ($^O eq 'VMS') {
|
||||
tie @{"${callpack}::$name"}, Env::Array::VMS, $name;
|
||||
} else {
|
||||
tie @{"${callpack}::$name"}, Env::Array, $name;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub TIESCALAR {
|
||||
bless \($_[1]);
|
||||
}
|
||||
|
||||
sub FETCH {
|
||||
my ($self) = @_;
|
||||
$ENV{$$self};
|
||||
}
|
||||
|
||||
sub STORE {
|
||||
my ($self, $value) = @_;
|
||||
if (defined($value)) {
|
||||
$ENV{$$self} = $value;
|
||||
} else {
|
||||
delete $ENV{$$self};
|
||||
}
|
||||
}
|
||||
|
||||
######################################################################
|
||||
|
||||
package Env::Array;
|
||||
|
||||
use Config;
|
||||
use Tie::Array;
|
||||
|
||||
@ISA = qw(Tie::Array);
|
||||
|
||||
my $sep = $Config::Config{path_sep};
|
||||
|
||||
sub TIEARRAY {
|
||||
bless \($_[1]);
|
||||
}
|
||||
|
||||
sub FETCHSIZE {
|
||||
my ($self) = @_;
|
||||
return 1 + scalar(() = $ENV{$$self} =~ /\Q$sep\E/g);
|
||||
}
|
||||
|
||||
sub STORESIZE {
|
||||
my ($self, $size) = @_;
|
||||
my @temp = split($sep, $ENV{$$self});
|
||||
$#temp = $size - 1;
|
||||
$ENV{$$self} = join($sep, @temp);
|
||||
}
|
||||
|
||||
sub CLEAR {
|
||||
my ($self) = @_;
|
||||
$ENV{$$self} = '';
|
||||
}
|
||||
|
||||
sub FETCH {
|
||||
my ($self, $index) = @_;
|
||||
return (split($sep, $ENV{$$self}))[$index];
|
||||
}
|
||||
|
||||
sub STORE {
|
||||
my ($self, $index, $value) = @_;
|
||||
my @temp = split($sep, $ENV{$$self});
|
||||
$temp[$index] = $value;
|
||||
$ENV{$$self} = join($sep, @temp);
|
||||
return $value;
|
||||
}
|
||||
|
||||
sub EXISTS {
|
||||
my ($self, $index) = @_;
|
||||
return $index < $self->FETCHSIZE;
|
||||
}
|
||||
|
||||
sub DELETE {
|
||||
my ($self, $index) = @_;
|
||||
my @temp = split($sep, $ENV{$$self});
|
||||
my $value = splice(@temp, $index, 1, ());
|
||||
$ENV{$$self} = join($sep, @temp);
|
||||
return $value;
|
||||
}
|
||||
|
||||
sub PUSH {
|
||||
my $self = shift;
|
||||
my @temp = split($sep, $ENV{$$self});
|
||||
push @temp, @_;
|
||||
$ENV{$$self} = join($sep, @temp);
|
||||
return scalar(@temp);
|
||||
}
|
||||
|
||||
sub POP {
|
||||
my ($self) = @_;
|
||||
my @temp = split($sep, $ENV{$$self});
|
||||
my $result = pop @temp;
|
||||
$ENV{$$self} = join($sep, @temp);
|
||||
return $result;
|
||||
}
|
||||
|
||||
sub UNSHIFT {
|
||||
my $self = shift;
|
||||
my @temp = split($sep, $ENV{$$self});
|
||||
my $result = unshift @temp, @_;
|
||||
$ENV{$$self} = join($sep, @temp);
|
||||
return $result;
|
||||
}
|
||||
|
||||
sub SHIFT {
|
||||
my ($self) = @_;
|
||||
my @temp = split($sep, $ENV{$$self});
|
||||
my $result = shift @temp;
|
||||
$ENV{$$self} = join($sep, @temp);
|
||||
return $result;
|
||||
}
|
||||
|
||||
sub SPLICE {
|
||||
my $self = shift;
|
||||
my $offset = shift;
|
||||
my $length = shift;
|
||||
my @temp = split($sep, $ENV{$$self});
|
||||
if (wantarray) {
|
||||
my @result = splice @temp, $offset, $length, @_;
|
||||
$ENV{$$self} = join($sep, @temp);
|
||||
return @result;
|
||||
} else {
|
||||
my $result = scalar splice @temp, $offset, $length, @_;
|
||||
$ENV{$$self} = join($sep, @temp);
|
||||
return $result;
|
||||
}
|
||||
}
|
||||
|
||||
######################################################################
|
||||
|
||||
package Env::Array::VMS;
|
||||
use Tie::Array;
|
||||
|
||||
@ISA = qw(Tie::Array);
|
||||
|
||||
sub TIEARRAY {
|
||||
bless \($_[1]);
|
||||
}
|
||||
|
||||
sub FETCHSIZE {
|
||||
my ($self) = @_;
|
||||
my $i = 0;
|
||||
while ($i < 127 and defined $ENV{$$self . ';' . $i}) { $i++; };
|
||||
return $i;
|
||||
}
|
||||
|
||||
sub FETCH {
|
||||
my ($self, $index) = @_;
|
||||
return $ENV{$$self . ';' . $index};
|
||||
}
|
||||
|
||||
sub EXISTS {
|
||||
my ($self, $index) = @_;
|
||||
return $index < $self->FETCHSIZE;
|
||||
}
|
||||
|
||||
sub DELETE { }
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,605 @@
|
||||
package Exporter;
|
||||
|
||||
use strict;
|
||||
no strict 'refs';
|
||||
|
||||
our $Debug = 0;
|
||||
our $ExportLevel = 0;
|
||||
our $Verbose ||= 0;
|
||||
our $VERSION = '5.77';
|
||||
our %Cache;
|
||||
|
||||
sub as_heavy {
|
||||
require Exporter::Heavy;
|
||||
# Unfortunately, this does not work if the caller is aliased as *name = \&foo
|
||||
# Thus the need to create a lot of identical subroutines
|
||||
my $c = (caller(1))[3];
|
||||
$c =~ s/.*:://;
|
||||
\&{"Exporter::Heavy::heavy_$c"};
|
||||
}
|
||||
|
||||
sub export {
|
||||
goto &{as_heavy()};
|
||||
}
|
||||
|
||||
sub import {
|
||||
my $pkg = shift;
|
||||
my $callpkg = caller($ExportLevel);
|
||||
|
||||
if ($pkg eq "Exporter" and @_ and $_[0] eq "import") {
|
||||
*{$callpkg."::import"} = \&import;
|
||||
return;
|
||||
}
|
||||
|
||||
# We *need* to treat @{"$pkg\::EXPORT_FAIL"} since Carp uses it :-(
|
||||
my $exports = \@{"$pkg\::EXPORT"};
|
||||
# But, avoid creating things if they don't exist, which saves a couple of
|
||||
# hundred bytes per package processed.
|
||||
my $fail = ${$pkg . '::'}{EXPORT_FAIL} && \@{"$pkg\::EXPORT_FAIL"};
|
||||
return export $pkg, $callpkg, @_
|
||||
if $Verbose or $Debug or $fail && @$fail > 1;
|
||||
my $export_cache = ($Cache{$pkg} ||= {});
|
||||
my $args = @_ or @_ = @$exports;
|
||||
|
||||
if ($args and not %$export_cache) {
|
||||
s/^&//, $export_cache->{$_} = 1
|
||||
foreach (@$exports, @{"$pkg\::EXPORT_OK"});
|
||||
}
|
||||
my $heavy;
|
||||
# Try very hard not to use {} and hence have to enter scope on the foreach
|
||||
# We bomb out of the loop with last as soon as heavy is set.
|
||||
if ($args or $fail) {
|
||||
($heavy = (/\W/ or $args and not exists $export_cache->{$_}
|
||||
or $fail and @$fail and $_ eq $fail->[0])) and last
|
||||
foreach (@_);
|
||||
} else {
|
||||
($heavy = /\W/) and last
|
||||
foreach (@_);
|
||||
}
|
||||
return export $pkg, $callpkg, ($args ? @_ : ()) if $heavy;
|
||||
local $SIG{__WARN__} =
|
||||
sub {require Carp; &Carp::carp} if not $SIG{__WARN__};
|
||||
# shortcut for the common case of no type character
|
||||
*{"$callpkg\::$_"} = \&{"$pkg\::$_"} foreach @_;
|
||||
}
|
||||
|
||||
# Default methods
|
||||
|
||||
sub export_fail {
|
||||
my $self = shift;
|
||||
@_;
|
||||
}
|
||||
|
||||
# Unfortunately, caller(1)[3] "does not work" if the caller is aliased as
|
||||
# *name = \&foo. Thus the need to create a lot of identical subroutines
|
||||
# Otherwise we could have aliased them to export().
|
||||
|
||||
sub export_to_level {
|
||||
goto &{as_heavy()};
|
||||
}
|
||||
|
||||
sub export_tags {
|
||||
goto &{as_heavy()};
|
||||
}
|
||||
|
||||
sub export_ok_tags {
|
||||
goto &{as_heavy()};
|
||||
}
|
||||
|
||||
sub require_version {
|
||||
goto &{as_heavy()};
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Exporter - Implements default import method for modules
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
In module F<YourModule.pm>:
|
||||
|
||||
package YourModule;
|
||||
use Exporter 'import';
|
||||
our @EXPORT_OK = qw(munge frobnicate); # symbols to export on request
|
||||
|
||||
or
|
||||
|
||||
package YourModule;
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter); # inherit all of Exporter's methods
|
||||
our @EXPORT_OK = qw(munge frobnicate); # symbols to export on request
|
||||
|
||||
or
|
||||
|
||||
package YourModule;
|
||||
use parent 'Exporter'; # inherit all of Exporter's methods
|
||||
our @EXPORT_OK = qw(munge frobnicate); # symbols to export on request
|
||||
|
||||
In other files which wish to use C<YourModule>:
|
||||
|
||||
use YourModule qw(frobnicate); # import listed symbols
|
||||
frobnicate ($left, $right) # calls YourModule::frobnicate
|
||||
|
||||
Take a look at L</Good Practices> for some variants
|
||||
you will like to use in modern Perl code.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The Exporter module implements an C<import> method which allows a module
|
||||
to export functions and variables to its users' namespaces. Many modules
|
||||
use Exporter rather than implementing their own C<import> method because
|
||||
Exporter provides a highly flexible interface, with an implementation optimised
|
||||
for the common case.
|
||||
|
||||
Perl automatically calls the C<import> method when processing a
|
||||
C<use> statement for a module. Modules and C<use> are documented
|
||||
in L<perlfunc> and L<perlmod>. Understanding the concept of
|
||||
modules and how the C<use> statement operates is important to
|
||||
understanding the Exporter.
|
||||
|
||||
=head2 How to Export
|
||||
|
||||
The arrays C<@EXPORT> and C<@EXPORT_OK> in a module hold lists of
|
||||
symbols that are going to be exported into the users name space by
|
||||
default, or which they can request to be exported, respectively. The
|
||||
symbols can represent functions, scalars, arrays, hashes, or typeglobs.
|
||||
The symbols must be given by full name with the exception that the
|
||||
ampersand in front of a function is optional, e.g.
|
||||
|
||||
our @EXPORT = qw(afunc $scalar @array); # afunc is a function
|
||||
our @EXPORT_OK = qw(&bfunc %hash *typeglob); # explicit prefix on &bfunc
|
||||
|
||||
If you are only exporting function names it is recommended to omit the
|
||||
ampersand, as the implementation is faster this way.
|
||||
|
||||
=head2 Selecting What to Export
|
||||
|
||||
Do B<not> export method names!
|
||||
|
||||
Do B<not> export anything else by default without a good reason!
|
||||
|
||||
Exports pollute the namespace of the module user. If you must export
|
||||
try to use C<@EXPORT_OK> in preference to C<@EXPORT> and avoid short or
|
||||
common symbol names to reduce the risk of name clashes.
|
||||
|
||||
Generally anything not exported is still accessible from outside the
|
||||
module using the C<YourModule::item_name> (or C<< $blessed_ref->method >>)
|
||||
syntax. By convention you can use a leading underscore on names to
|
||||
informally indicate that they are 'internal' and not for public use.
|
||||
|
||||
(It is actually possible to get private functions by saying:
|
||||
|
||||
my $subref = sub { ... };
|
||||
$subref->(@args); # Call it as a function
|
||||
$obj->$subref(@args); # Use it as a method
|
||||
|
||||
However if you use them for methods it is up to you to figure out
|
||||
how to make inheritance work.)
|
||||
|
||||
As a general rule, if the module is trying to be object oriented
|
||||
then export nothing. If it's just a collection of functions then
|
||||
C<@EXPORT_OK> anything but use C<@EXPORT> with caution. For function and
|
||||
method names use barewords in preference to names prefixed with
|
||||
ampersands for the export lists.
|
||||
|
||||
Other module design guidelines can be found in L<perlmod>.
|
||||
|
||||
=head2 How to Import
|
||||
|
||||
In other files which wish to use your module there are three basic ways for
|
||||
them to load your module and import its symbols:
|
||||
|
||||
=over 4
|
||||
|
||||
=item C<use YourModule;>
|
||||
|
||||
This imports all the symbols from YourModule's C<@EXPORT> into the namespace
|
||||
of the C<use> statement.
|
||||
|
||||
=item C<use YourModule ();>
|
||||
|
||||
This causes perl to load your module but does not import any symbols.
|
||||
|
||||
=item C<use YourModule qw(...);>
|
||||
|
||||
This imports only the symbols listed by the caller into their namespace.
|
||||
All listed symbols must be in your C<@EXPORT> or C<@EXPORT_OK>, else an error
|
||||
occurs. The advanced export features of Exporter are accessed like this,
|
||||
but with list entries that are syntactically distinct from symbol names.
|
||||
|
||||
=back
|
||||
|
||||
Unless you want to use its advanced features, this is probably all you
|
||||
need to know to use Exporter.
|
||||
|
||||
=head1 Advanced Features
|
||||
|
||||
=head2 Specialised Import Lists
|
||||
|
||||
If any of the entries in an import list begins with !, : or / then
|
||||
the list is treated as a series of specifications which either add to
|
||||
or delete from the list of names to import. They are processed left to
|
||||
right. Specifications are in the form:
|
||||
|
||||
[!]name This name only
|
||||
[!]:DEFAULT All names in @EXPORT
|
||||
[!]:tag All names in $EXPORT_TAGS{tag} anonymous array
|
||||
[!]/pattern/ All names in @EXPORT and @EXPORT_OK which match
|
||||
|
||||
A leading ! indicates that matching names should be deleted from the
|
||||
list of names to import. If the first specification is a deletion it
|
||||
is treated as though preceded by :DEFAULT. If you just want to import
|
||||
extra names in addition to the default set you will still need to
|
||||
include :DEFAULT explicitly.
|
||||
|
||||
e.g., F<Module.pm> defines:
|
||||
|
||||
our @EXPORT = qw(A1 A2 A3 A4 A5);
|
||||
our @EXPORT_OK = qw(B1 B2 B3 B4 B5);
|
||||
our %EXPORT_TAGS = (T1 => [qw(A1 A2 B1 B2)], T2 => [qw(A1 A2 B3 B4)]);
|
||||
|
||||
Note that you cannot use tags in @EXPORT or @EXPORT_OK.
|
||||
|
||||
Names in EXPORT_TAGS must also appear in @EXPORT or @EXPORT_OK.
|
||||
|
||||
An application using Module can say something like:
|
||||
|
||||
use Module qw(:DEFAULT :T2 !B3 A3);
|
||||
|
||||
Other examples include:
|
||||
|
||||
use Socket qw(!/^[AP]F_/ !SOMAXCONN !SOL_SOCKET);
|
||||
use POSIX qw(:errno_h :termios_h !TCSADRAIN !/^EXIT/);
|
||||
|
||||
Remember that most patterns (using //) will need to be anchored
|
||||
with a leading ^, e.g., C</^EXIT/> rather than C</EXIT/>.
|
||||
|
||||
You can say C<BEGIN { $Exporter::Verbose=1 }> to see how the
|
||||
specifications are being processed and what is actually being imported
|
||||
into modules.
|
||||
|
||||
=head2 Exporting Without Using Exporter's import Method
|
||||
|
||||
Exporter has a special method, 'export_to_level' which is used in situations
|
||||
where you can't directly call Exporter's
|
||||
import method. The export_to_level
|
||||
method looks like:
|
||||
|
||||
MyPackage->export_to_level(
|
||||
$where_to_export, $package, @what_to_export
|
||||
);
|
||||
|
||||
where C<$where_to_export> is an integer telling how far up the calling stack
|
||||
to export your symbols, and C<@what_to_export> is an array telling what
|
||||
symbols *to* export (usually this is C<@_>). The C<$package> argument is
|
||||
currently unused.
|
||||
|
||||
For example, suppose that you have a module, A, which already has an
|
||||
import function:
|
||||
|
||||
package A;
|
||||
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw($b);
|
||||
|
||||
sub import
|
||||
{
|
||||
$A::b = 1; # not a very useful import method
|
||||
}
|
||||
|
||||
and you want to Export symbol C<$A::b> back to the module that called
|
||||
package A. Since Exporter relies on the import method to work, via
|
||||
inheritance, as it stands Exporter::import() will never get called.
|
||||
Instead, say the following:
|
||||
|
||||
package A;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw($b);
|
||||
|
||||
sub import
|
||||
{
|
||||
$A::b = 1;
|
||||
A->export_to_level(1, @_);
|
||||
}
|
||||
|
||||
This will export the symbols one level 'above' the current package - ie: to
|
||||
the program or module that used package A.
|
||||
|
||||
Note: Be careful not to modify C<@_> at all before you call export_to_level
|
||||
- or people using your package will get very unexplained results!
|
||||
|
||||
=head2 Exporting Without Inheriting from Exporter
|
||||
|
||||
By including Exporter in your C<@ISA> you inherit an Exporter's import() method
|
||||
but you also inherit several other helper methods which you probably don't
|
||||
want and complicate the inheritance tree. To avoid this you can do:
|
||||
|
||||
package YourModule;
|
||||
use Exporter qw(import);
|
||||
|
||||
which will export Exporter's own import() method into YourModule.
|
||||
Everything will work as before but you won't need to include Exporter in
|
||||
C<@YourModule::ISA>.
|
||||
|
||||
Note: This feature was introduced in version 5.57
|
||||
of Exporter, released with perl 5.8.3.
|
||||
|
||||
=head2 Module Version Checking
|
||||
|
||||
The Exporter module will convert an attempt to import a number from a
|
||||
module into a call to C<< $module_name->VERSION($value) >>. This can
|
||||
be used to validate that the version of the module being used is
|
||||
greater than or equal to the required version.
|
||||
|
||||
For historical reasons, Exporter supplies a C<require_version> method that
|
||||
simply delegates to C<VERSION>. Originally, before C<UNIVERSAL::VERSION>
|
||||
existed, Exporter would call C<require_version>.
|
||||
|
||||
Since the C<UNIVERSAL::VERSION> method treats the C<$VERSION> number as
|
||||
a simple numeric value it will regard version 1.10 as lower than
|
||||
1.9. For this reason it is strongly recommended that you use numbers
|
||||
with at least two decimal places, e.g., 1.09.
|
||||
|
||||
=head2 Managing Unknown Symbols
|
||||
|
||||
In some situations you may want to prevent certain symbols from being
|
||||
exported. Typically this applies to extensions which have functions
|
||||
or constants that may not exist on some systems.
|
||||
|
||||
The names of any symbols that cannot be exported should be listed
|
||||
in the C<@EXPORT_FAIL> array.
|
||||
|
||||
If a module attempts to import any of these symbols the Exporter
|
||||
will give the module an opportunity to handle the situation before
|
||||
generating an error. The Exporter will call an export_fail method
|
||||
with a list of the failed symbols:
|
||||
|
||||
@failed_symbols = $module_name->export_fail(@failed_symbols);
|
||||
|
||||
If the C<export_fail> method returns an empty list then no error is
|
||||
recorded and all the requested symbols are exported. If the returned
|
||||
list is not empty then an error is generated for each symbol and the
|
||||
export fails. The Exporter provides a default C<export_fail> method which
|
||||
simply returns the list unchanged.
|
||||
|
||||
Uses for the C<export_fail> method include giving better error messages
|
||||
for some symbols and performing lazy architectural checks (put more
|
||||
symbols into C<@EXPORT_FAIL> by default and then take them out if someone
|
||||
actually tries to use them and an expensive check shows that they are
|
||||
usable on that platform).
|
||||
|
||||
=head2 Tag Handling Utility Functions
|
||||
|
||||
Since the symbols listed within C<%EXPORT_TAGS> must also appear in either
|
||||
C<@EXPORT> or C<@EXPORT_OK>, two utility functions are provided which allow
|
||||
you to easily add tagged sets of symbols to C<@EXPORT> or C<@EXPORT_OK>:
|
||||
|
||||
our %EXPORT_TAGS = (foo => [qw(aa bb cc)], bar => [qw(aa cc dd)]);
|
||||
|
||||
Exporter::export_tags('foo'); # add aa, bb and cc to @EXPORT
|
||||
Exporter::export_ok_tags('bar'); # add aa, cc and dd to @EXPORT_OK
|
||||
|
||||
Any names which are not tags are added to C<@EXPORT> or C<@EXPORT_OK>
|
||||
unchanged but will trigger a warning (with C<-w>) to avoid misspelt tags
|
||||
names being silently added to C<@EXPORT> or C<@EXPORT_OK>. Future versions
|
||||
may make this a fatal error.
|
||||
|
||||
=head2 Generating Combined Tags
|
||||
|
||||
If several symbol categories exist in C<%EXPORT_TAGS>, it's usually
|
||||
useful to create the utility ":all" to simplify "use" statements.
|
||||
|
||||
The simplest way to do this is:
|
||||
|
||||
our %EXPORT_TAGS = (foo => [qw(aa bb cc)], bar => [qw(aa cc dd)]);
|
||||
|
||||
# add all the other ":class" tags to the ":all" class,
|
||||
# deleting duplicates
|
||||
{
|
||||
my %seen;
|
||||
|
||||
push @{$EXPORT_TAGS{all}},
|
||||
grep {!$seen{$_}++} @{$EXPORT_TAGS{$_}} foreach keys %EXPORT_TAGS;
|
||||
}
|
||||
|
||||
F<CGI.pm> creates an ":all" tag which contains some (but not really
|
||||
all) of its categories. That could be done with one small
|
||||
change:
|
||||
|
||||
# add some of the other ":class" tags to the ":all" class,
|
||||
# deleting duplicates
|
||||
{
|
||||
my %seen;
|
||||
|
||||
push @{$EXPORT_TAGS{all}},
|
||||
grep {!$seen{$_}++} @{$EXPORT_TAGS{$_}}
|
||||
foreach qw/html2 html3 netscape form cgi internal/;
|
||||
}
|
||||
|
||||
Note that the tag names in C<%EXPORT_TAGS> don't have the leading ':'.
|
||||
|
||||
=head2 C<AUTOLOAD>ed Constants
|
||||
|
||||
Many modules make use of C<AUTOLOAD>ing for constant subroutines to
|
||||
avoid having to compile and waste memory on rarely used values (see
|
||||
L<perlsub> for details on constant subroutines). Calls to such
|
||||
constant subroutines are not optimized away at compile time because
|
||||
they can't be checked at compile time for constancy.
|
||||
|
||||
Even if a prototype is available at compile time, the body of the
|
||||
subroutine is not (it hasn't been C<AUTOLOAD>ed yet). perl needs to
|
||||
examine both the C<()> prototype and the body of a subroutine at
|
||||
compile time to detect that it can safely replace calls to that
|
||||
subroutine with the constant value.
|
||||
|
||||
A workaround for this is to call the constants once in a C<BEGIN> block:
|
||||
|
||||
package My ;
|
||||
|
||||
use Socket ;
|
||||
|
||||
foo( SO_LINGER ); ## SO_LINGER NOT optimized away; called at runtime
|
||||
BEGIN { SO_LINGER }
|
||||
foo( SO_LINGER ); ## SO_LINGER optimized away at compile time.
|
||||
|
||||
This forces the C<AUTOLOAD> for C<SO_LINGER> to take place before
|
||||
SO_LINGER is encountered later in C<My> package.
|
||||
|
||||
If you are writing a package that C<AUTOLOAD>s, consider forcing
|
||||
an C<AUTOLOAD> for any constants explicitly imported by other packages
|
||||
or which are usually used when your package is C<use>d.
|
||||
|
||||
=head1 Good Practices
|
||||
|
||||
=head2 Declaring C<@EXPORT_OK> and Friends
|
||||
|
||||
When using C<Exporter> with the standard C<strict> and C<warnings>
|
||||
pragmas, the C<our> keyword is needed to declare the package
|
||||
variables C<@EXPORT_OK>, C<@EXPORT>, C<@ISA>, etc.
|
||||
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(munge frobnicate);
|
||||
|
||||
If backward compatibility for Perls B<under> 5.6 is important,
|
||||
one must write instead a C<use vars> statement.
|
||||
|
||||
use vars qw(@ISA @EXPORT_OK);
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT_OK = qw(munge frobnicate);
|
||||
|
||||
=head2 Playing Safe
|
||||
|
||||
There are some caveats with the use of runtime statements
|
||||
like C<require Exporter> and the assignment to package
|
||||
variables, which can be very subtle for the unaware programmer.
|
||||
This may happen for instance with mutually recursive
|
||||
modules, which are affected by the time the relevant
|
||||
constructions are executed.
|
||||
|
||||
The ideal way to never have to think about that is to use
|
||||
C<BEGIN> blocks and the simple import method. So the first part
|
||||
of the L</SYNOPSIS> code could be rewritten as:
|
||||
|
||||
package YourModule;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Exporter 'import';
|
||||
BEGIN {
|
||||
our @EXPORT_OK = qw(munge frobnicate); # symbols to export on request
|
||||
}
|
||||
|
||||
Or if you need to inherit from Exporter:
|
||||
|
||||
package YourModule;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
BEGIN {
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter); # inherit all of Exporter's methods
|
||||
our @EXPORT_OK = qw(munge frobnicate); # symbols to export on request
|
||||
}
|
||||
|
||||
The C<BEGIN> will assure that the loading of F<Exporter.pm>
|
||||
and the assignments to C<@ISA> and C<@EXPORT_OK> happen
|
||||
immediately like C<use>, leaving no room for something to get awry
|
||||
or just plain wrong.
|
||||
|
||||
With respect to loading C<Exporter> and inheriting, there
|
||||
are alternatives with the use of modules like C<base> and C<parent>.
|
||||
|
||||
use base qw(Exporter);
|
||||
# or
|
||||
use parent qw(Exporter);
|
||||
|
||||
Any of these statements are nice replacements for
|
||||
C<BEGIN { require Exporter; our @ISA = qw(Exporter); }>
|
||||
with the same compile-time effect. The basic difference
|
||||
is that C<base> code interacts with declared C<fields>
|
||||
while C<parent> is a streamlined version of the older
|
||||
C<base> code to just establish the IS-A relationship.
|
||||
|
||||
For more details, see the documentation and code of
|
||||
L<base> and L<parent>.
|
||||
|
||||
Another thorough remedy to that runtime
|
||||
vs. compile-time trap is to use L<Exporter::Easy>,
|
||||
which is a wrapper of Exporter that allows all
|
||||
boilerplate code at a single gulp in the
|
||||
use statement.
|
||||
|
||||
use Exporter::Easy (
|
||||
OK => [ qw(munge frobnicate) ],
|
||||
);
|
||||
# @ISA setup is automatic
|
||||
# all assignments happen at compile time
|
||||
|
||||
=head2 What Not to Export
|
||||
|
||||
You have been warned already in L</Selecting What to Export>
|
||||
to not export:
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
method names (because you don't need to
|
||||
and that's likely to not do what you want),
|
||||
|
||||
=item *
|
||||
|
||||
anything by default (because you don't want to surprise your users...
|
||||
badly)
|
||||
|
||||
=item *
|
||||
|
||||
anything you don't need to (because less is more)
|
||||
|
||||
=back
|
||||
|
||||
There's one more item to add to this list. Do B<not>
|
||||
export variable names. Just because C<Exporter> lets you
|
||||
do that, it does not mean you should.
|
||||
|
||||
@EXPORT_OK = qw($svar @avar %hvar); # DON'T!
|
||||
|
||||
Exporting variables is not a good idea. They can
|
||||
change under the hood, provoking horrible
|
||||
effects at-a-distance that are too hard to track
|
||||
and to fix. Trust me: they are not worth it.
|
||||
|
||||
To provide the capability to set/get class-wide
|
||||
settings, it is best instead to provide accessors
|
||||
as subroutines or class methods instead.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
C<Exporter> is definitely not the only module with
|
||||
symbol exporter capabilities. At CPAN, you may find
|
||||
a bunch of them. Some are lighter. Some
|
||||
provide improved APIs and features. Pick the one
|
||||
that fits your needs. The following is
|
||||
a sample list of such modules.
|
||||
|
||||
Exporter::Easy
|
||||
Exporter::Lite
|
||||
Exporter::Renaming
|
||||
Exporter::Tidy
|
||||
Sub::Exporter / Sub::Installer
|
||||
Perl6::Export / Perl6::Export::Attrs
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
This library is free software. You can redistribute it
|
||||
and/or modify it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
|
||||
@@ -0,0 +1,253 @@
|
||||
package Exporter::Heavy;
|
||||
|
||||
use strict;
|
||||
no strict 'refs';
|
||||
|
||||
# On one line so MakeMaker will see it.
|
||||
our $VERSION = '5.77';
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Exporter::Heavy - Exporter guts
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
(internal use only)
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
No user-serviceable parts inside.
|
||||
|
||||
=cut
|
||||
|
||||
#
|
||||
# We go to a lot of trouble not to 'require Carp' at file scope,
|
||||
# because Carp requires Exporter, and something has to give.
|
||||
#
|
||||
|
||||
sub _rebuild_cache {
|
||||
my ($pkg, $exports, $cache) = @_;
|
||||
s/^&// foreach @$exports;
|
||||
@{$cache}{@$exports} = (1) x @$exports;
|
||||
my $ok = \@{"${pkg}::EXPORT_OK"};
|
||||
if (@$ok) {
|
||||
s/^&// foreach @$ok;
|
||||
@{$cache}{@$ok} = (1) x @$ok;
|
||||
}
|
||||
}
|
||||
|
||||
sub heavy_export {
|
||||
|
||||
# Save the old __WARN__ handler in case it was defined
|
||||
my $oldwarn = $SIG{__WARN__};
|
||||
|
||||
# First make import warnings look like they're coming from the "use".
|
||||
local $SIG{__WARN__} = sub {
|
||||
# restore it back so proper stacking occurs
|
||||
local $SIG{__WARN__} = $oldwarn;
|
||||
my $text = shift;
|
||||
if ($text =~ s/ at \S*Exporter\S*.pm line \d+.*\n//) {
|
||||
require Carp;
|
||||
local $Carp::CarpLevel = 1; # ignore package calling us too.
|
||||
Carp::carp($text);
|
||||
}
|
||||
else {
|
||||
warn $text;
|
||||
}
|
||||
};
|
||||
local $SIG{__DIE__} = sub {
|
||||
require Carp;
|
||||
local $Carp::CarpLevel = 1; # ignore package calling us too.
|
||||
Carp::croak("$_[0]Illegal null symbol in \@${1}::EXPORT")
|
||||
if $_[0] =~ /^Unable to create sub named "(.*?)::"/;
|
||||
};
|
||||
|
||||
my($pkg, $callpkg, @imports) = @_;
|
||||
my($type, $sym, $cache_is_current, $oops);
|
||||
my($exports, $export_cache) = (\@{"${pkg}::EXPORT"},
|
||||
$Exporter::Cache{$pkg} ||= {});
|
||||
|
||||
if (@imports) {
|
||||
if (!%$export_cache) {
|
||||
_rebuild_cache ($pkg, $exports, $export_cache);
|
||||
$cache_is_current = 1;
|
||||
}
|
||||
|
||||
if (grep m{^[/!:]}, @imports) {
|
||||
my $tagsref = \%{"${pkg}::EXPORT_TAGS"};
|
||||
my $tagdata;
|
||||
my %imports;
|
||||
my($remove, $spec, @names, @allexports);
|
||||
# negated first item implies starting with default set:
|
||||
unshift @imports, ':DEFAULT' if $imports[0] =~ m/^!/;
|
||||
foreach $spec (@imports){
|
||||
$remove = $spec =~ s/^!//;
|
||||
|
||||
if ($spec =~ s/^://){
|
||||
if ($spec eq 'DEFAULT'){
|
||||
@names = @$exports;
|
||||
}
|
||||
elsif ($tagdata = $tagsref->{$spec}) {
|
||||
@names = @$tagdata;
|
||||
}
|
||||
else {
|
||||
warn qq["$spec" is not defined in %${pkg}::EXPORT_TAGS];
|
||||
++$oops;
|
||||
next;
|
||||
}
|
||||
}
|
||||
elsif ($spec =~ m:^/(.*)/$:){
|
||||
my $patn = $1;
|
||||
@allexports = keys %$export_cache unless @allexports; # only do keys once
|
||||
@names = grep(/$patn/, @allexports); # not anchored by default
|
||||
}
|
||||
else {
|
||||
@names = ($spec); # is a normal symbol name
|
||||
}
|
||||
|
||||
warn "Import ".($remove ? "del":"add").": @names "
|
||||
if $Exporter::Verbose;
|
||||
|
||||
if ($remove) {
|
||||
foreach $sym (@names) { delete $imports{$sym} }
|
||||
}
|
||||
else {
|
||||
@imports{@names} = (1) x @names;
|
||||
}
|
||||
}
|
||||
@imports = keys %imports;
|
||||
}
|
||||
|
||||
my @carp;
|
||||
foreach $sym (@imports) {
|
||||
if (!$export_cache->{$sym}) {
|
||||
if ($sym =~ m/^\d/) {
|
||||
$pkg->VERSION($sym); # inherit from UNIVERSAL
|
||||
# If the version number was the only thing specified
|
||||
# then we should act as if nothing was specified:
|
||||
if (@imports == 1) {
|
||||
@imports = @$exports;
|
||||
last;
|
||||
}
|
||||
# We need a way to emulate 'use Foo ()' but still
|
||||
# allow an easy version check: "use Foo 1.23, ''";
|
||||
if (@imports == 2 and !$imports[1]) {
|
||||
@imports = ();
|
||||
last;
|
||||
}
|
||||
} elsif ($sym !~ s/^&// || !$export_cache->{$sym}) {
|
||||
# Last chance - see if they've updated EXPORT_OK since we
|
||||
# cached it.
|
||||
|
||||
unless ($cache_is_current) {
|
||||
%$export_cache = ();
|
||||
_rebuild_cache ($pkg, $exports, $export_cache);
|
||||
$cache_is_current = 1;
|
||||
}
|
||||
|
||||
if (!$export_cache->{$sym}) {
|
||||
# accumulate the non-exports
|
||||
push @carp,
|
||||
qq["$sym" is not exported by the $pkg module];
|
||||
$oops++;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
if ($oops) {
|
||||
require Carp;
|
||||
Carp::croak(join("\n", @carp, "Can't continue after import errors"));
|
||||
}
|
||||
}
|
||||
else {
|
||||
@imports = @$exports;
|
||||
}
|
||||
|
||||
my($fail, $fail_cache) = (\@{"${pkg}::EXPORT_FAIL"},
|
||||
$Exporter::FailCache{$pkg} ||= {});
|
||||
|
||||
if (@$fail) {
|
||||
if (!%$fail_cache) {
|
||||
# Build cache of symbols. Optimise the lookup by adding
|
||||
# barewords twice... both with and without a leading &.
|
||||
# (Technique could be applied to $export_cache at cost of memory)
|
||||
my @expanded = map { /^\w/ ? ($_, '&'.$_) : $_ } @$fail;
|
||||
warn "${pkg}::EXPORT_FAIL cached: @expanded" if $Exporter::Verbose;
|
||||
@{$fail_cache}{@expanded} = (1) x @expanded;
|
||||
}
|
||||
my @failed;
|
||||
foreach $sym (@imports) { push(@failed, $sym) if $fail_cache->{$sym} }
|
||||
if (@failed) {
|
||||
@failed = $pkg->export_fail(@failed);
|
||||
foreach $sym (@failed) {
|
||||
require Carp;
|
||||
Carp::carp(qq["$sym" is not implemented by the $pkg module ],
|
||||
"on this architecture");
|
||||
}
|
||||
if (@failed) {
|
||||
require Carp;
|
||||
Carp::croak("Can't continue after import errors");
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
warn "Importing into $callpkg from $pkg: ",
|
||||
join(", ",sort @imports) if $Exporter::Verbose;
|
||||
|
||||
foreach $sym (@imports) {
|
||||
# shortcut for the common case of no type character
|
||||
(*{"${callpkg}::$sym"} = \&{"${pkg}::$sym"}, next)
|
||||
unless $sym =~ s/^(\W)//;
|
||||
$type = $1;
|
||||
no warnings 'once';
|
||||
*{"${callpkg}::$sym"} =
|
||||
$type eq '&' ? \&{"${pkg}::$sym"} :
|
||||
$type eq '$' ? \${"${pkg}::$sym"} :
|
||||
$type eq '@' ? \@{"${pkg}::$sym"} :
|
||||
$type eq '%' ? \%{"${pkg}::$sym"} :
|
||||
$type eq '*' ? *{"${pkg}::$sym"} :
|
||||
do { require Carp; Carp::croak("Can't export symbol: $type$sym") };
|
||||
}
|
||||
}
|
||||
|
||||
sub heavy_export_to_level
|
||||
{
|
||||
my $pkg = shift;
|
||||
my $level = shift;
|
||||
(undef) = shift; # XXX redundant arg
|
||||
my $callpkg = caller($level);
|
||||
$pkg->export($callpkg, @_);
|
||||
}
|
||||
|
||||
# Utility functions
|
||||
|
||||
sub _push_tags {
|
||||
my($pkg, $var, $syms) = @_;
|
||||
my @nontag = ();
|
||||
my $export_tags = \%{"${pkg}::EXPORT_TAGS"};
|
||||
push(@{"${pkg}::$var"},
|
||||
map { $export_tags->{$_} ? @{$export_tags->{$_}}
|
||||
: scalar(push(@nontag,$_),$_) }
|
||||
(@$syms) ? @$syms : keys %$export_tags);
|
||||
if (@nontag and $^W) {
|
||||
# This may change to a die one day
|
||||
require Carp;
|
||||
Carp::carp(join(", ", @nontag)." are not tags of $pkg");
|
||||
}
|
||||
}
|
||||
|
||||
sub heavy_require_version {
|
||||
my($self, $wanted) = @_;
|
||||
my $pkg = ref $self || $self;
|
||||
return ${pkg}->VERSION($wanted);
|
||||
}
|
||||
|
||||
sub heavy_export_tags {
|
||||
_push_tags((caller)[0], "EXPORT", \@_);
|
||||
}
|
||||
|
||||
sub heavy_export_ok_tags {
|
||||
_push_tags((caller)[0], "EXPORT_OK", \@_);
|
||||
}
|
||||
|
||||
1;
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,402 @@
|
||||
=head1 NAME
|
||||
|
||||
File::Basename - Parse file paths into directory, filename and suffix.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::Basename;
|
||||
|
||||
my ($name, $path, $suffix) = fileparse($fullname, @suffixlist);
|
||||
my $name = fileparse($fullname, @suffixlist);
|
||||
|
||||
my $basename = basename($fullname, @suffixlist);
|
||||
my $dirname = dirname($fullname);
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
These routines allow you to parse file paths into their directory, filename
|
||||
and suffix.
|
||||
|
||||
B<NOTE>: C<dirname()> and C<basename()> emulate the behaviours, and
|
||||
quirks, of the shell and C functions of the same name. See each
|
||||
function's documentation for details. If your concern is just parsing
|
||||
paths it is safer to use L<File::Spec>'s C<splitpath()> and
|
||||
C<splitdir()> methods.
|
||||
|
||||
It is guaranteed that
|
||||
|
||||
# Where $path_separator is / for Unix, \ for Windows, etc...
|
||||
dirname($path) . $path_separator . basename($path);
|
||||
|
||||
is equivalent to the original path for all systems but VMS.
|
||||
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
package File::Basename;
|
||||
|
||||
# File::Basename is used during the Perl build, when the re extension may
|
||||
# not be available, but we only actually need it if running under tainting.
|
||||
BEGIN {
|
||||
if (${^TAINT}) {
|
||||
require re;
|
||||
re->import('taint');
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
use strict;
|
||||
use 5.006;
|
||||
use warnings;
|
||||
our(@ISA, @EXPORT, $VERSION, $Fileparse_fstype, $Fileparse_igncase);
|
||||
require Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(fileparse fileparse_set_fstype basename dirname);
|
||||
$VERSION = "2.86";
|
||||
|
||||
fileparse_set_fstype($^O);
|
||||
|
||||
|
||||
=over 4
|
||||
|
||||
=item C<fileparse>
|
||||
X<fileparse>
|
||||
|
||||
my($filename, $dirs, $suffix) = fileparse($path);
|
||||
my($filename, $dirs, $suffix) = fileparse($path, @suffixes);
|
||||
my $filename = fileparse($path, @suffixes);
|
||||
|
||||
The C<fileparse()> routine divides a file path into its $dirs, $filename
|
||||
and (optionally) the filename $suffix.
|
||||
|
||||
$dirs contains everything up to and including the last
|
||||
directory separator in the $path including the volume (if applicable).
|
||||
The remainder of the $path is the $filename.
|
||||
|
||||
# On Unix returns ("baz", "/foo/bar/", "")
|
||||
fileparse("/foo/bar/baz");
|
||||
|
||||
# On Windows returns ("baz", 'C:\foo\bar\', "")
|
||||
fileparse('C:\foo\bar\baz');
|
||||
|
||||
# On Unix returns ("", "/foo/bar/baz/", "")
|
||||
fileparse("/foo/bar/baz/");
|
||||
|
||||
If @suffixes are given each element is a pattern (either a string or a
|
||||
C<qr//>) matched against the end of the $filename. The matching
|
||||
portion is removed and becomes the $suffix.
|
||||
|
||||
# On Unix returns ("baz", "/foo/bar/", ".txt")
|
||||
fileparse("/foo/bar/baz.txt", qr/\.[^.]*/);
|
||||
|
||||
If type is non-Unix (see L</fileparse_set_fstype>) then the pattern
|
||||
matching for suffix removal is performed case-insensitively, since
|
||||
those systems are not case-sensitive when opening existing files.
|
||||
|
||||
You are guaranteed that C<$dirs . $filename . $suffix> will
|
||||
denote the same location as the original $path.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub fileparse {
|
||||
my($fullname,@suffices) = @_;
|
||||
|
||||
unless (defined $fullname) {
|
||||
require Carp;
|
||||
Carp::croak("fileparse(): need a valid pathname");
|
||||
}
|
||||
|
||||
my $orig_type = '';
|
||||
my($type,$igncase) = ($Fileparse_fstype, $Fileparse_igncase);
|
||||
|
||||
my($taint) = substr($fullname,0,0); # Is $fullname tainted?
|
||||
|
||||
if ($type eq "VMS" and $fullname =~ m{/} ) {
|
||||
# We're doing Unix emulation
|
||||
$orig_type = $type;
|
||||
$type = 'Unix';
|
||||
}
|
||||
|
||||
my($dirpath, $basename);
|
||||
|
||||
if (grep { $type eq $_ } qw(MSDOS DOS MSWin32 Epoc)) {
|
||||
($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/s);
|
||||
$dirpath .= '.\\' unless $dirpath =~ /[\\\/]\z/;
|
||||
}
|
||||
elsif ($type eq "OS2") {
|
||||
($dirpath,$basename) = ($fullname =~ m#^((?:.*[:\\/])?)(.*)#s);
|
||||
$dirpath = './' unless $dirpath; # Can't be 0
|
||||
$dirpath .= '/' unless $dirpath =~ m#[\\/]\z#;
|
||||
}
|
||||
elsif ($type eq "MacOS") {
|
||||
($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/s);
|
||||
$dirpath = ':' unless $dirpath;
|
||||
}
|
||||
elsif ($type eq "AmigaOS") {
|
||||
($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/s);
|
||||
$dirpath = './' unless $dirpath;
|
||||
}
|
||||
elsif ($type eq 'VMS' ) {
|
||||
($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/s);
|
||||
$dirpath ||= ''; # should always be defined
|
||||
}
|
||||
else { # Default to Unix semantics.
|
||||
($dirpath,$basename) = ($fullname =~ m{^(.*/)?(.*)}s);
|
||||
if ($orig_type eq 'VMS' and $fullname =~ m{^(/[^/]+/000000(/|$))(.*)}) {
|
||||
# dev:[000000] is top of VMS tree, similar to Unix '/'
|
||||
# so strip it off and treat the rest as "normal"
|
||||
my $devspec = $1;
|
||||
my $remainder = $3;
|
||||
($dirpath,$basename) = ($remainder =~ m{^(.*/)?(.*)}s);
|
||||
$dirpath ||= ''; # should always be defined
|
||||
$dirpath = $devspec.$dirpath;
|
||||
}
|
||||
$dirpath = './' unless $dirpath;
|
||||
}
|
||||
|
||||
|
||||
my $tail = '';
|
||||
my $suffix = '';
|
||||
if (@suffices) {
|
||||
foreach $suffix (@suffices) {
|
||||
my $pat = ($igncase ? '(?i)' : '') . "($suffix)\$";
|
||||
if ($basename =~ s/$pat//s) {
|
||||
$taint .= substr($suffix,0,0);
|
||||
$tail = $1 . $tail;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Ensure taint is propagated from the path to its pieces.
|
||||
$tail .= $taint;
|
||||
wantarray ? ($basename .= $taint, $dirpath .= $taint, $tail)
|
||||
: ($basename .= $taint);
|
||||
}
|
||||
|
||||
|
||||
|
||||
=item C<basename>
|
||||
X<basename> X<filename>
|
||||
|
||||
my $filename = basename($path);
|
||||
my $filename = basename($path, @suffixes);
|
||||
|
||||
This function is provided for compatibility with the Unix shell command
|
||||
C<basename(1)>. It does B<NOT> always return the file name portion of a
|
||||
path as you might expect. To be safe, if you want the file name portion of
|
||||
a path use C<fileparse()>.
|
||||
|
||||
C<basename()> returns the last level of a filepath even if the last
|
||||
level is clearly directory. In effect, it is acting like C<pop()> for
|
||||
paths. This differs from C<fileparse()>'s behaviour.
|
||||
|
||||
# Both return "bar"
|
||||
basename("/foo/bar");
|
||||
basename("/foo/bar/");
|
||||
|
||||
@suffixes work as in C<fileparse()> except all regex metacharacters are
|
||||
quoted.
|
||||
|
||||
# These two function calls are equivalent.
|
||||
my $filename = basename("/foo/bar/baz.txt", ".txt");
|
||||
my $filename = fileparse("/foo/bar/baz.txt", qr/\Q.txt\E/);
|
||||
|
||||
Also note that in order to be compatible with the shell command,
|
||||
C<basename()> does not strip off a suffix if it is identical to the
|
||||
remaining characters in the filename.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub basename {
|
||||
my($path) = shift;
|
||||
|
||||
# From BSD basename(1)
|
||||
# The basename utility deletes any prefix ending with the last slash '/'
|
||||
# character present in string (after first stripping trailing slashes)
|
||||
_strip_trailing_sep($path);
|
||||
|
||||
my($basename, $dirname, $suffix) = fileparse( $path, map("\Q$_\E",@_) );
|
||||
|
||||
# From BSD basename(1)
|
||||
# The suffix is not stripped if it is identical to the remaining
|
||||
# characters in string.
|
||||
if( length $suffix and !length $basename ) {
|
||||
$basename = $suffix;
|
||||
}
|
||||
|
||||
# Ensure that basename '/' == '/'
|
||||
if( !length $basename ) {
|
||||
$basename = $dirname;
|
||||
}
|
||||
|
||||
return $basename;
|
||||
}
|
||||
|
||||
|
||||
|
||||
=item C<dirname>
|
||||
X<dirname>
|
||||
|
||||
This function is provided for compatibility with the Unix shell
|
||||
command C<dirname(1)> and has inherited some of its quirks. In spite of
|
||||
its name it does B<NOT> always return the directory name as you might
|
||||
expect. To be safe, if you want the directory name of a path use
|
||||
C<fileparse()>.
|
||||
|
||||
Only on VMS (where there is no ambiguity between the file and directory
|
||||
portions of a path) and AmigaOS (possibly due to an implementation quirk in
|
||||
this module) does C<dirname()> work like C<fileparse($path)>, returning just the
|
||||
$dirs.
|
||||
|
||||
# On VMS and AmigaOS
|
||||
my $dirs = dirname($path);
|
||||
|
||||
When using Unix or MSDOS syntax this emulates the C<dirname(1)> shell function
|
||||
which is subtly different from how C<fileparse()> works. It returns all but
|
||||
the last level of a file path even if the last level is clearly a directory.
|
||||
In effect, it is not returning the directory portion but simply the path one
|
||||
level up acting like C<chop()> for file paths.
|
||||
|
||||
Also unlike C<fileparse()>, C<dirname()> does not include a trailing slash on
|
||||
its returned path.
|
||||
|
||||
# returns /foo/bar. fileparse() would return /foo/bar/
|
||||
dirname("/foo/bar/baz");
|
||||
|
||||
# also returns /foo/bar despite the fact that baz is clearly a
|
||||
# directory. fileparse() would return /foo/bar/baz/
|
||||
dirname("/foo/bar/baz/");
|
||||
|
||||
# returns '.'. fileparse() would return 'foo/'
|
||||
dirname("foo/");
|
||||
|
||||
Under VMS, if there is no directory information in the $path, then the
|
||||
current default device and directory is used.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub dirname {
|
||||
my $path = shift;
|
||||
|
||||
my($type) = $Fileparse_fstype;
|
||||
|
||||
if( $type eq 'VMS' and $path =~ m{/} ) {
|
||||
# Parse as Unix
|
||||
local($File::Basename::Fileparse_fstype) = '';
|
||||
return dirname($path);
|
||||
}
|
||||
|
||||
my($basename, $dirname) = fileparse($path);
|
||||
|
||||
if ($type eq 'VMS') {
|
||||
$dirname ||= $ENV{DEFAULT};
|
||||
}
|
||||
elsif ($type eq 'MacOS') {
|
||||
if( !length($basename) && $dirname !~ /^[^:]+:\z/) {
|
||||
_strip_trailing_sep($dirname);
|
||||
($basename,$dirname) = fileparse $dirname;
|
||||
}
|
||||
$dirname .= ":" unless $dirname =~ /:\z/;
|
||||
}
|
||||
elsif (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) {
|
||||
_strip_trailing_sep($dirname);
|
||||
unless( length($basename) ) {
|
||||
($basename,$dirname) = fileparse $dirname;
|
||||
_strip_trailing_sep($dirname);
|
||||
}
|
||||
}
|
||||
elsif ($type eq 'AmigaOS') {
|
||||
if ( $dirname =~ /:\z/) { return $dirname }
|
||||
chop $dirname;
|
||||
$dirname =~ s{[^:/]+\z}{} unless length($basename);
|
||||
}
|
||||
else {
|
||||
_strip_trailing_sep($dirname);
|
||||
unless( length($basename) ) {
|
||||
($basename,$dirname) = fileparse $dirname;
|
||||
_strip_trailing_sep($dirname);
|
||||
}
|
||||
}
|
||||
|
||||
$dirname;
|
||||
}
|
||||
|
||||
|
||||
# Strip the trailing path separator.
|
||||
sub _strip_trailing_sep {
|
||||
my $type = $Fileparse_fstype;
|
||||
|
||||
if ($type eq 'MacOS') {
|
||||
$_[0] =~ s/([^:]):\z/$1/s;
|
||||
}
|
||||
elsif (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) {
|
||||
$_[0] =~ s/([^:])[\\\/]*\z/$1/;
|
||||
}
|
||||
else {
|
||||
$_[0] =~ s{(.)/*\z}{$1}s;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
=item C<fileparse_set_fstype>
|
||||
X<filesystem>
|
||||
|
||||
my $type = fileparse_set_fstype();
|
||||
my $previous_type = fileparse_set_fstype($type);
|
||||
|
||||
Normally File::Basename will assume a file path type native to your current
|
||||
operating system (ie. /foo/bar style on Unix, \foo\bar on Windows, etc...).
|
||||
With this function you can override that assumption.
|
||||
|
||||
Valid $types are "MacOS", "VMS", "AmigaOS", "OS2", "RISCOS",
|
||||
"MSWin32", "DOS" (also "MSDOS" for backwards bug compatibility),
|
||||
"Epoc" and "Unix" (all case-insensitive). If an unrecognized $type is
|
||||
given "Unix" will be assumed.
|
||||
|
||||
If you've selected VMS syntax, and the file specification you pass to
|
||||
one of these routines contains a "/", they assume you are using Unix
|
||||
emulation and apply the Unix syntax rules instead, for that function
|
||||
call only.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
BEGIN {
|
||||
|
||||
my @Ignore_Case = qw(MacOS VMS AmigaOS OS2 RISCOS MSWin32 MSDOS DOS Epoc);
|
||||
my @Types = (@Ignore_Case, qw(Unix));
|
||||
|
||||
sub fileparse_set_fstype {
|
||||
my $old = $Fileparse_fstype;
|
||||
|
||||
if (@_) {
|
||||
my $new_type = shift;
|
||||
|
||||
$Fileparse_fstype = 'Unix'; # default
|
||||
foreach my $type (@Types) {
|
||||
$Fileparse_fstype = $type if $new_type =~ /^$type/i;
|
||||
}
|
||||
|
||||
$Fileparse_igncase =
|
||||
(grep $Fileparse_fstype eq $_, @Ignore_Case) ? 1 : 0;
|
||||
}
|
||||
|
||||
return $old;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<dirname(1)>, L<basename(1)>, L<File::Spec>
|
||||
@@ -0,0 +1,174 @@
|
||||
package File::Compare 1.1007;
|
||||
|
||||
use v5.12;
|
||||
use warnings;
|
||||
|
||||
use Exporter 'import';
|
||||
|
||||
our @EXPORT = qw(compare);
|
||||
our @EXPORT_OK = qw(cmp compare_text);
|
||||
|
||||
our $Too_Big = 1024 * 1024 * 2;
|
||||
|
||||
sub croak {
|
||||
require Carp;
|
||||
goto &Carp::croak;
|
||||
}
|
||||
|
||||
sub compare {
|
||||
croak("Usage: compare( file1, file2 [, buffersize]) ")
|
||||
unless(@_ == 2 || @_ == 3);
|
||||
|
||||
my ($from,$to,$size) = @_;
|
||||
my $text_mode = defined($size) && (ref($size) eq 'CODE' || $size < 0);
|
||||
|
||||
my ($fromsize,$closefrom,$closeto);
|
||||
local (*FROM, *TO);
|
||||
|
||||
croak("from undefined") unless (defined $from);
|
||||
croak("to undefined") unless (defined $to);
|
||||
|
||||
if (ref($from) &&
|
||||
(UNIVERSAL::isa($from,'GLOB') || UNIVERSAL::isa($from,'IO::Handle'))) {
|
||||
*FROM = *$from;
|
||||
} elsif (ref(\$from) eq 'GLOB') {
|
||||
*FROM = $from;
|
||||
} else {
|
||||
open(FROM,"<",$from) or goto fail_open1;
|
||||
unless ($text_mode) {
|
||||
binmode FROM;
|
||||
$fromsize = -s FROM;
|
||||
}
|
||||
$closefrom = 1;
|
||||
}
|
||||
|
||||
if (ref($to) &&
|
||||
(UNIVERSAL::isa($to,'GLOB') || UNIVERSAL::isa($to,'IO::Handle'))) {
|
||||
*TO = *$to;
|
||||
} elsif (ref(\$to) eq 'GLOB') {
|
||||
*TO = $to;
|
||||
} else {
|
||||
open(TO,"<",$to) or goto fail_open2;
|
||||
binmode TO unless $text_mode;
|
||||
$closeto = 1;
|
||||
}
|
||||
|
||||
if (!$text_mode && $closefrom && $closeto) {
|
||||
# If both are opened files we know they differ if their size differ
|
||||
goto fail_inner if $fromsize != -s TO;
|
||||
}
|
||||
|
||||
if ($text_mode) {
|
||||
local $/ = "\n";
|
||||
my ($fline,$tline);
|
||||
while (defined($fline = <FROM>)) {
|
||||
goto fail_inner unless defined($tline = <TO>);
|
||||
if (ref $size) {
|
||||
# $size contains ref to comparison function
|
||||
goto fail_inner if &$size($fline, $tline);
|
||||
} else {
|
||||
goto fail_inner if $fline ne $tline;
|
||||
}
|
||||
}
|
||||
goto fail_inner if defined($tline = <TO>);
|
||||
}
|
||||
else {
|
||||
unless (defined($size) && $size > 0) {
|
||||
$size = $fromsize || -s TO || 0;
|
||||
$size = 1024 if $size < 512;
|
||||
$size = $Too_Big if $size > $Too_Big;
|
||||
}
|
||||
|
||||
my ($fr,$tr,$fbuf,$tbuf);
|
||||
$fbuf = $tbuf = '';
|
||||
while(defined($fr = read(FROM,$fbuf,$size)) && $fr > 0) {
|
||||
unless (defined($tr = read(TO,$tbuf,$fr)) && $tbuf eq $fbuf) {
|
||||
goto fail_inner;
|
||||
}
|
||||
}
|
||||
goto fail_inner if defined($tr = read(TO,$tbuf,$size)) && $tr > 0;
|
||||
}
|
||||
|
||||
close(TO) || goto fail_open2 if $closeto;
|
||||
close(FROM) || goto fail_open1 if $closefrom;
|
||||
|
||||
return 0;
|
||||
|
||||
# All of these contortions try to preserve error messages...
|
||||
fail_inner:
|
||||
close(TO) || goto fail_open2 if $closeto;
|
||||
close(FROM) || goto fail_open1 if $closefrom;
|
||||
|
||||
return 1;
|
||||
|
||||
fail_open2:
|
||||
if ($closefrom) {
|
||||
my $status = $!;
|
||||
$! = 0;
|
||||
close FROM;
|
||||
$! = $status unless $!;
|
||||
}
|
||||
fail_open1:
|
||||
return -1;
|
||||
}
|
||||
|
||||
sub cmp;
|
||||
*cmp = \&compare;
|
||||
|
||||
sub compare_text {
|
||||
my ($from,$to,$cmp) = @_;
|
||||
croak("Usage: compare_text( file1, file2 [, cmp-function])")
|
||||
unless @_ == 2 || @_ == 3;
|
||||
croak("Third arg to compare_text() function must be a code reference")
|
||||
if @_ == 3 && ref($cmp) ne 'CODE';
|
||||
|
||||
# Using a negative buffer size puts compare into text_mode too
|
||||
compare($from, $to, $cmp // -1);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::Compare - Compare files or filehandles
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::Compare;
|
||||
|
||||
if (compare("file1","file2") == 0) {
|
||||
print "They're equal\n";
|
||||
}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The File::Compare::compare function compares the contents of two
|
||||
sources, each of which can be a file or a file handle. It is exported
|
||||
from File::Compare by default.
|
||||
|
||||
File::Compare::cmp is a synonym for File::Compare::compare. It is
|
||||
exported from File::Compare only by request.
|
||||
|
||||
File::Compare::compare_text does a line by line comparison of the two
|
||||
files. It stops as soon as a difference is detected. compare_text()
|
||||
accepts an optional third argument: This must be a CODE reference to
|
||||
a line comparison function, which returns 0 when both lines are considered
|
||||
equal. For example:
|
||||
|
||||
compare_text($file1, $file2)
|
||||
|
||||
is basically equivalent to
|
||||
|
||||
compare_text($file1, $file2, sub {$_[0] ne $_[1]} )
|
||||
|
||||
=head1 RETURN
|
||||
|
||||
File::Compare::compare and its sibling functions return 0 if the files
|
||||
are equal, 1 if the files are unequal, or -1 if an error was encountered.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
File::Compare was written by Nick Ing-Simmons.
|
||||
Its original documentation was written by Chip Salzenberg.
|
||||
@@ -0,0 +1,513 @@
|
||||
# File/Copy.pm. Written in 1994 by Aaron Sherman <ajs@ajs.com>. This
|
||||
# source code has been placed in the public domain by the author.
|
||||
# Please be kind and preserve the documentation.
|
||||
#
|
||||
# Additions copyright 1996 by Charles Bailey. Permission is granted
|
||||
# to distribute the revised code under the same terms as Perl itself.
|
||||
|
||||
package File::Copy;
|
||||
|
||||
use 5.035007;
|
||||
use strict;
|
||||
use warnings; no warnings 'newline';
|
||||
no warnings 'experimental::builtin';
|
||||
use builtin 'blessed';
|
||||
use overload;
|
||||
use File::Spec;
|
||||
use Config;
|
||||
# We want HiRes stat and utime if available
|
||||
BEGIN { eval q{ use Time::HiRes qw( stat utime ) } };
|
||||
our(@ISA, @EXPORT, @EXPORT_OK, $VERSION, $Too_Big, $Syscopy_is_copy);
|
||||
sub copy;
|
||||
sub syscopy;
|
||||
sub cp;
|
||||
sub mv;
|
||||
|
||||
$VERSION = '2.41';
|
||||
|
||||
require Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(copy move);
|
||||
@EXPORT_OK = qw(cp mv);
|
||||
|
||||
$Too_Big = 1024 * 1024 * 2;
|
||||
|
||||
sub croak {
|
||||
require Carp;
|
||||
goto &Carp::croak;
|
||||
}
|
||||
|
||||
sub carp {
|
||||
require Carp;
|
||||
goto &Carp::carp;
|
||||
}
|
||||
|
||||
sub _catname {
|
||||
my($from, $to) = @_;
|
||||
if (not defined &basename) {
|
||||
require File::Basename;
|
||||
File::Basename->import( 'basename' );
|
||||
}
|
||||
|
||||
return File::Spec->catfile($to, basename($from));
|
||||
}
|
||||
|
||||
# _eq($from, $to) tells whether $from and $to are identical
|
||||
sub _eq {
|
||||
my ($from, $to) = map {
|
||||
blessed($_) && overload::Method($_, q{""})
|
||||
? "$_"
|
||||
: $_
|
||||
} (@_);
|
||||
return '' if ( (ref $from) xor (ref $to) );
|
||||
return $from == $to if ref $from;
|
||||
return $from eq $to;
|
||||
}
|
||||
|
||||
sub copy {
|
||||
croak("Usage: copy(FROM, TO [, BUFFERSIZE]) ")
|
||||
unless(@_ == 2 || @_ == 3);
|
||||
|
||||
my $from = shift;
|
||||
my $to = shift;
|
||||
|
||||
my $size;
|
||||
if (@_) {
|
||||
$size = shift(@_) + 0;
|
||||
croak("Bad buffer size for copy: $size\n") unless ($size > 0);
|
||||
}
|
||||
|
||||
my $from_a_handle = (ref($from)
|
||||
? (ref($from) eq 'GLOB'
|
||||
|| UNIVERSAL::isa($from, 'GLOB')
|
||||
|| UNIVERSAL::isa($from, 'IO::Handle'))
|
||||
: (ref(\$from) eq 'GLOB'));
|
||||
my $to_a_handle = (ref($to)
|
||||
? (ref($to) eq 'GLOB'
|
||||
|| UNIVERSAL::isa($to, 'GLOB')
|
||||
|| UNIVERSAL::isa($to, 'IO::Handle'))
|
||||
: (ref(\$to) eq 'GLOB'));
|
||||
|
||||
if (_eq($from, $to)) { # works for references, too
|
||||
carp("'$from' and '$to' are identical (not copied)");
|
||||
return 0;
|
||||
}
|
||||
|
||||
if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) {
|
||||
$to = _catname($from, $to);
|
||||
}
|
||||
|
||||
if ((($Config{d_symlink} && $Config{d_readlink}) || $Config{d_link}) &&
|
||||
!($^O eq 'os2')) {
|
||||
my @fs = stat($from);
|
||||
if (@fs) {
|
||||
my @ts = stat($to);
|
||||
if (@ts && $fs[0] == $ts[0] && $fs[1] eq $ts[1] && !-p $from) {
|
||||
carp("'$from' and '$to' are identical (not copied)");
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif (_eq($from, $to)) {
|
||||
carp("'$from' and '$to' are identical (not copied)");
|
||||
return 0;
|
||||
}
|
||||
|
||||
if (defined &syscopy && !$Syscopy_is_copy
|
||||
&& !$to_a_handle
|
||||
&& !($from_a_handle && $^O eq 'os2' ) # OS/2 cannot handle handles
|
||||
&& !($from_a_handle && $^O eq 'MSWin32')
|
||||
)
|
||||
{
|
||||
if ($^O eq 'VMS' && -e $from
|
||||
&& ! -d $to && ! -d $from) {
|
||||
|
||||
# VMS natively inherits path components from the source of a
|
||||
# copy, but we want the Unixy behavior of inheriting from
|
||||
# the current working directory. Also, default in a trailing
|
||||
# dot for null file types.
|
||||
|
||||
$to = VMS::Filespec::rmsexpand(VMS::Filespec::vmsify($to), '.');
|
||||
|
||||
# Get rid of the old versions to be like UNIX
|
||||
1 while unlink $to;
|
||||
}
|
||||
|
||||
return syscopy($from, $to) || 0;
|
||||
}
|
||||
|
||||
my $closefrom = 0;
|
||||
my $closeto = 0;
|
||||
my ($status, $r, $buf);
|
||||
local($\) = '';
|
||||
|
||||
my $from_h;
|
||||
if ($from_a_handle) {
|
||||
$from_h = $from;
|
||||
} else {
|
||||
open $from_h, "<", $from or goto fail_open1;
|
||||
binmode $from_h or die "($!,$^E)";
|
||||
$closefrom = 1;
|
||||
}
|
||||
|
||||
# Seems most logical to do this here, in case future changes would want to
|
||||
# make this croak for some reason.
|
||||
unless (defined $size) {
|
||||
$size = tied(*$from_h) ? 0 : -s $from_h || 0;
|
||||
$size = 1024 if ($size < 512);
|
||||
$size = $Too_Big if ($size > $Too_Big);
|
||||
}
|
||||
|
||||
my $to_h;
|
||||
if ($to_a_handle) {
|
||||
$to_h = $to;
|
||||
} else {
|
||||
$to_h = \do { local *FH }; # XXX is this line obsolete?
|
||||
open $to_h, ">", $to or goto fail_open2;
|
||||
binmode $to_h or die "($!,$^E)";
|
||||
$closeto = 1;
|
||||
}
|
||||
|
||||
$! = 0;
|
||||
for (;;) {
|
||||
my ($r, $w, $t);
|
||||
defined($r = sysread($from_h, $buf, $size))
|
||||
or goto fail_inner;
|
||||
last unless $r;
|
||||
for ($w = 0; $w < $r; $w += $t) {
|
||||
$t = syswrite($to_h, $buf, $r - $w, $w)
|
||||
or goto fail_inner;
|
||||
}
|
||||
}
|
||||
|
||||
close($to_h) || goto fail_open2 if $closeto;
|
||||
close($from_h) || goto fail_open1 if $closefrom;
|
||||
|
||||
# Use this idiom to avoid uninitialized value warning.
|
||||
return 1;
|
||||
|
||||
# All of these contortions try to preserve error messages...
|
||||
fail_inner:
|
||||
if ($closeto) {
|
||||
$status = $!;
|
||||
$! = 0;
|
||||
close $to_h;
|
||||
$! = $status unless $!;
|
||||
}
|
||||
fail_open2:
|
||||
if ($closefrom) {
|
||||
$status = $!;
|
||||
$! = 0;
|
||||
close $from_h;
|
||||
$! = $status unless $!;
|
||||
}
|
||||
fail_open1:
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub cp {
|
||||
my($from,$to) = @_;
|
||||
my(@fromstat) = stat $from;
|
||||
my(@tostat) = stat $to;
|
||||
my $perm;
|
||||
|
||||
return 0 unless copy(@_) and @fromstat;
|
||||
|
||||
if (@tostat) {
|
||||
$perm = $tostat[2];
|
||||
} else {
|
||||
$perm = $fromstat[2] & ~(umask || 0);
|
||||
@tostat = stat $to;
|
||||
}
|
||||
# Might be more robust to look for S_I* in Fcntl, but we're
|
||||
# trying to avoid dependence on any XS-containing modules,
|
||||
# since File::Copy is used during the Perl build.
|
||||
$perm &= 07777;
|
||||
if ($perm & 06000) {
|
||||
croak("Unable to check setuid/setgid permissions for $to: $!")
|
||||
unless @tostat;
|
||||
|
||||
if ($perm & 04000 and # setuid
|
||||
$fromstat[4] != $tostat[4]) { # owner must match
|
||||
$perm &= ~06000;
|
||||
}
|
||||
|
||||
if ($perm & 02000 && $> != 0) { # if not root, setgid
|
||||
my $ok = $fromstat[5] == $tostat[5]; # group must match
|
||||
if ($ok) { # and we must be in group
|
||||
$ok = grep { $_ == $fromstat[5] } split /\s+/, $)
|
||||
}
|
||||
$perm &= ~06000 unless $ok;
|
||||
}
|
||||
}
|
||||
return 0 unless @tostat;
|
||||
return 1 if $perm == ($tostat[2] & 07777);
|
||||
return eval { chmod $perm, $to; } ? 1 : 0;
|
||||
}
|
||||
|
||||
sub _move {
|
||||
croak("Usage: move(FROM, TO) ") unless @_ == 3;
|
||||
|
||||
my($from,$to,$fallback) = @_;
|
||||
|
||||
my($fromsz,$tosz1,$tomt1,$tosz2,$tomt2,$sts,$ossts);
|
||||
|
||||
if (-d $to && ! -d $from) {
|
||||
$to = _catname($from, $to);
|
||||
}
|
||||
|
||||
($tosz1,$tomt1) = (stat($to))[7,9];
|
||||
$fromsz = -s $from;
|
||||
if ($^O eq 'os2' and defined $tosz1 and defined $fromsz) {
|
||||
# will not rename with overwrite
|
||||
unlink $to;
|
||||
}
|
||||
|
||||
if ($^O eq 'VMS' && -e $from
|
||||
&& ! -d $to && ! -d $from) {
|
||||
|
||||
# VMS natively inherits path components from the source of a
|
||||
# copy, but we want the Unixy behavior of inheriting from
|
||||
# the current working directory. Also, default in a trailing
|
||||
# dot for null file types.
|
||||
|
||||
$to = VMS::Filespec::rmsexpand(VMS::Filespec::vmsify($to), '.');
|
||||
|
||||
# Get rid of the old versions to be like UNIX
|
||||
1 while unlink $to;
|
||||
}
|
||||
|
||||
return 1 if rename $from, $to;
|
||||
|
||||
# Did rename return an error even though it succeeded, because $to
|
||||
# is on a remote NFS file system, and NFS lost the server's ack?
|
||||
return 1 if defined($fromsz) && !-e $from && # $from disappeared
|
||||
(($tosz2,$tomt2) = (stat($to))[7,9]) && # $to's there
|
||||
((!defined $tosz1) || # not before or
|
||||
($tosz1 != $tosz2 or $tomt1 != $tomt2)) && # was changed
|
||||
$tosz2 == $fromsz; # it's all there
|
||||
|
||||
($tosz1,$tomt1) = (stat($to))[7,9]; # just in case rename did something
|
||||
|
||||
{
|
||||
local $@;
|
||||
eval {
|
||||
local $SIG{__DIE__};
|
||||
$fallback->($from,$to) or die;
|
||||
my($atime, $mtime) = (stat($from))[8,9];
|
||||
utime($atime, $mtime, $to);
|
||||
unlink($from) or die;
|
||||
};
|
||||
return 1 unless $@;
|
||||
}
|
||||
($sts,$ossts) = ($! + 0, $^E + 0);
|
||||
|
||||
($tosz2,$tomt2) = ((stat($to))[7,9],0,0) if defined $tomt1;
|
||||
unlink($to) if !defined($tomt1) or $tomt1 != $tomt2 or $tosz1 != $tosz2;
|
||||
($!,$^E) = ($sts,$ossts);
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub move { _move(@_,\©); }
|
||||
sub mv { _move(@_,\&cp); }
|
||||
|
||||
# &syscopy is an XSUB under OS/2
|
||||
unless (defined &syscopy) {
|
||||
if ($^O eq 'VMS') {
|
||||
*syscopy = \&rmscopy;
|
||||
} elsif ($^O eq 'MSWin32' && defined &DynaLoader::boot_DynaLoader) {
|
||||
# Win32::CopyFile() fill only work if we can load Win32.xs
|
||||
*syscopy = sub {
|
||||
return 0 unless @_ == 2;
|
||||
return Win32::CopyFile(@_, 1);
|
||||
};
|
||||
} else {
|
||||
$Syscopy_is_copy = 1;
|
||||
*syscopy = \©
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::Copy - Copy files or filehandles
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::Copy;
|
||||
|
||||
copy("sourcefile", "destinationfile") or die "Copy failed: $!";
|
||||
copy("Copy.pm", \*STDOUT);
|
||||
move("/dev1/sourcefile", "/dev2/destinationfile");
|
||||
|
||||
use File::Copy "cp";
|
||||
|
||||
my $n = FileHandle->new("/a/file", "r");
|
||||
cp($n, "x");
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The File::Copy module provides two basic functions, C<copy> and
|
||||
C<move>, which are useful for getting the contents of a file from
|
||||
one place to another.
|
||||
|
||||
=over 4
|
||||
|
||||
=item copy
|
||||
X<copy> X<cp>
|
||||
|
||||
The C<copy> function takes two
|
||||
parameters: a file to copy from and a file to copy to. Either
|
||||
argument may be a string, a FileHandle reference or a FileHandle
|
||||
glob. Obviously, if the first argument is a filehandle of some
|
||||
sort, it will be read from, and if it is a file I<name> it will
|
||||
be opened for reading. Likewise, the second argument will be
|
||||
written to. If the second argument does not exist but the parent
|
||||
directory does exist, then it will be created. Trying to copy
|
||||
a file into a non-existent directory is an error.
|
||||
Trying to copy a file on top of itself is also an error.
|
||||
C<copy> will not overwrite read-only files.
|
||||
|
||||
If the destination (second argument) already exists and is a directory,
|
||||
and the source (first argument) is not a filehandle, then the source
|
||||
file will be copied into the directory specified by the destination,
|
||||
using the same base name as the source file. It's a failure to have a
|
||||
filehandle as the source when the destination is a directory.
|
||||
|
||||
B<Note that passing in
|
||||
files as handles instead of names may lead to loss of information
|
||||
on some operating systems; it is recommended that you use file
|
||||
names whenever possible.> Files are opened in binary mode where
|
||||
applicable. To get a consistent behaviour when copying from a
|
||||
filehandle to a file, use C<binmode> on the filehandle.
|
||||
|
||||
An optional third parameter can be used to specify the buffer
|
||||
size used for copying. This is the number of bytes from the
|
||||
first file, that will be held in memory at any given time, before
|
||||
being written to the second file. The default buffer size depends
|
||||
upon the file, but will generally be the whole file (up to 2MB), or
|
||||
1k for filehandles that do not reference files (eg. sockets).
|
||||
|
||||
You may use the syntax C<use File::Copy "cp"> to get at the C<cp>
|
||||
alias for this function. The syntax is I<exactly> the same. The
|
||||
behavior is nearly the same as well: as of version 2.15, C<cp> will
|
||||
preserve the source file's permission bits like the shell utility
|
||||
C<cp(1)> would do with default options, while C<copy> uses the default
|
||||
permissions for the target file (which may depend on the process'
|
||||
C<umask>, file ownership, inherited ACLs, etc.). That is, if the
|
||||
destination file already exists, C<cp> will leave its permissions
|
||||
unchanged; otherwise the permissions are taken from the source file
|
||||
and modified by the C<umask>. If an error occurs in setting
|
||||
permissions, C<cp> will return 0, regardless of whether the file was
|
||||
successfully copied.
|
||||
|
||||
=item move
|
||||
X<move> X<mv> X<rename>
|
||||
|
||||
The C<move> function also takes two parameters: the current name
|
||||
and the intended name of the file to be moved. If the destination
|
||||
already exists and is a directory, and the source is not a
|
||||
directory, then the source file will be renamed into the directory
|
||||
specified by the destination.
|
||||
|
||||
If possible, move() will simply rename the file. Otherwise, it copies
|
||||
the file to the new location and deletes the original. If an error occurs
|
||||
during this copy-and-delete process, you may be left with a (possibly partial)
|
||||
copy of the file under the destination name.
|
||||
|
||||
You may use the C<mv> alias for this function in the same way that
|
||||
you may use the C<cp> alias for C<copy>.
|
||||
|
||||
=item syscopy
|
||||
X<syscopy>
|
||||
|
||||
File::Copy also provides the C<syscopy> routine, which copies the
|
||||
file specified in the first parameter to the file specified in the
|
||||
second parameter, preserving OS-specific attributes and file
|
||||
structure. For Unix systems, this is equivalent to the simple
|
||||
C<copy> routine, which doesn't preserve OS-specific attributes. For
|
||||
VMS systems, this calls the C<rmscopy> routine (see below). For OS/2
|
||||
systems, this calls the C<syscopy> XSUB directly. For Win32 systems,
|
||||
this calls C<Win32::CopyFile>.
|
||||
|
||||
B<Special behaviour if C<syscopy> is defined (OS/2, VMS and Win32)>:
|
||||
|
||||
If both arguments to C<copy> are not file handles,
|
||||
then C<copy> will perform a "system copy" of
|
||||
the input file to a new output file, in order to preserve file
|
||||
attributes, indexed file structure, I<etc.> The buffer size
|
||||
parameter is ignored. If either argument to C<copy> is a
|
||||
handle to an opened file, then data is copied using Perl
|
||||
operators, and no effort is made to preserve file attributes
|
||||
or record structure.
|
||||
|
||||
The system copy routine may also be called directly under VMS and OS/2
|
||||
as C<File::Copy::syscopy> (or under VMS as C<File::Copy::rmscopy>, which
|
||||
is the routine that does the actual work for syscopy).
|
||||
|
||||
=item rmscopy($from,$to[,$date_flag])
|
||||
X<rmscopy>
|
||||
|
||||
The first and second arguments may be strings, typeglobs, typeglob
|
||||
references, or objects inheriting from IO::Handle;
|
||||
they are used in all cases to obtain the
|
||||
I<filespec> of the input and output files, respectively. The
|
||||
name and type of the input file are used as defaults for the
|
||||
output file, if necessary.
|
||||
|
||||
A new version of the output file is always created, which
|
||||
inherits the structure and RMS attributes of the input file,
|
||||
except for owner and protections (and possibly timestamps;
|
||||
see below). All data from the input file is copied to the
|
||||
output file; if either of the first two parameters to C<rmscopy>
|
||||
is a file handle, its position is unchanged. (Note that this
|
||||
means a file handle pointing to the output file will be
|
||||
associated with an old version of that file after C<rmscopy>
|
||||
returns, not the newly created version.)
|
||||
|
||||
The third parameter is an integer flag, which tells C<rmscopy>
|
||||
how to handle timestamps. If it is E<lt> 0, none of the input file's
|
||||
timestamps are propagated to the output file. If it is E<gt> 0, then
|
||||
it is interpreted as a bitmask: if bit 0 (the LSB) is set, then
|
||||
timestamps other than the revision date are propagated; if bit 1
|
||||
is set, the revision date is propagated. If the third parameter
|
||||
to C<rmscopy> is 0, then it behaves much like the DCL COPY command:
|
||||
if the name or type of the output file was explicitly specified,
|
||||
then no timestamps are propagated, but if they were taken implicitly
|
||||
from the input filespec, then all timestamps other than the
|
||||
revision date are propagated. If this parameter is not supplied,
|
||||
it defaults to 0.
|
||||
|
||||
C<rmscopy> is VMS specific and cannot be exported; it must be
|
||||
referenced by its full name, e.g.:
|
||||
|
||||
File::Copy::rmscopy($from, $to) or die $!;
|
||||
|
||||
Like C<copy>, C<rmscopy> returns 1 on success. If an error occurs,
|
||||
it sets C<$!>, deletes the output file, and returns 0.
|
||||
|
||||
=back
|
||||
|
||||
=head1 RETURN
|
||||
|
||||
All functions return 1 on success, 0 on failure.
|
||||
$! will be set if an error was encountered.
|
||||
|
||||
=head1 NOTES
|
||||
|
||||
Before calling copy() or move() on a filehandle, the caller should
|
||||
close or flush() the file to avoid writes being lost. Note that this
|
||||
is the case even for move(), because it may actually copy the file,
|
||||
depending on the OS-specific implementation, and the underlying
|
||||
filesystem(s).
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
File::Copy was written by Aaron Sherman I<E<lt>ajs@ajs.comE<gt>> in 1995,
|
||||
and updated by Charles Bailey I<E<lt>bailey@newman.upenn.eduE<gt>> in 1996.
|
||||
|
||||
=cut
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,679 @@
|
||||
package File::GlobMapper;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp;
|
||||
|
||||
our ($CSH_GLOB);
|
||||
|
||||
BEGIN
|
||||
{
|
||||
if ($] < 5.006)
|
||||
{
|
||||
require File::BSDGlob; import File::BSDGlob qw(:glob) ;
|
||||
$CSH_GLOB = File::BSDGlob::GLOB_CSH() ;
|
||||
*globber = \&File::BSDGlob::csh_glob;
|
||||
}
|
||||
else
|
||||
{
|
||||
require File::Glob; import File::Glob qw(:glob) ;
|
||||
$CSH_GLOB = File::Glob::GLOB_CSH() ;
|
||||
#*globber = \&File::Glob::bsd_glob;
|
||||
*globber = \&File::Glob::csh_glob;
|
||||
}
|
||||
}
|
||||
|
||||
our ($Error);
|
||||
|
||||
our ($VERSION, @EXPORT_OK);
|
||||
$VERSION = '1.001';
|
||||
@EXPORT_OK = qw( globmap );
|
||||
|
||||
|
||||
our ($noPreBS, $metachars, $matchMetaRE, %mapping, %wildCount);
|
||||
$noPreBS = '(?<!\\\)' ; # no preceding backslash
|
||||
$metachars = '.*?[](){}';
|
||||
$matchMetaRE = '[' . quotemeta($metachars) . ']';
|
||||
|
||||
%mapping = (
|
||||
'*' => '([^/]*)',
|
||||
'?' => '([^/])',
|
||||
'.' => '\.',
|
||||
'[' => '([',
|
||||
'(' => '(',
|
||||
')' => ')',
|
||||
);
|
||||
|
||||
%wildCount = map { $_ => 1 } qw/ * ? . { ( [ /;
|
||||
|
||||
sub globmap ($$;)
|
||||
{
|
||||
my $inputGlob = shift ;
|
||||
my $outputGlob = shift ;
|
||||
|
||||
my $obj = File::GlobMapper->new($inputGlob, $outputGlob, @_)
|
||||
or croak "globmap: $Error" ;
|
||||
return $obj->getFileMap();
|
||||
}
|
||||
|
||||
sub new
|
||||
{
|
||||
my $class = shift ;
|
||||
my $inputGlob = shift ;
|
||||
my $outputGlob = shift ;
|
||||
# TODO -- flags needs to default to whatever File::Glob does
|
||||
my $flags = shift || $CSH_GLOB ;
|
||||
#my $flags = shift ;
|
||||
|
||||
$inputGlob =~ s/^\s*\<\s*//;
|
||||
$inputGlob =~ s/\s*\>\s*$//;
|
||||
|
||||
$outputGlob =~ s/^\s*\<\s*//;
|
||||
$outputGlob =~ s/\s*\>\s*$//;
|
||||
|
||||
my %object =
|
||||
( InputGlob => $inputGlob,
|
||||
OutputGlob => $outputGlob,
|
||||
GlobFlags => $flags,
|
||||
Braces => 0,
|
||||
WildCount => 0,
|
||||
Pairs => [],
|
||||
Sigil => '#',
|
||||
);
|
||||
|
||||
my $self = bless \%object, ref($class) || $class ;
|
||||
|
||||
$self->_parseInputGlob()
|
||||
or return undef ;
|
||||
|
||||
$self->_parseOutputGlob()
|
||||
or return undef ;
|
||||
|
||||
my @inputFiles = globber($self->{InputGlob}, $flags) ;
|
||||
|
||||
if (GLOB_ERROR)
|
||||
{
|
||||
$Error = $!;
|
||||
return undef ;
|
||||
}
|
||||
|
||||
#if (whatever)
|
||||
{
|
||||
my $missing = grep { ! -e $_ } @inputFiles ;
|
||||
|
||||
if ($missing)
|
||||
{
|
||||
$Error = "$missing input files do not exist";
|
||||
return undef ;
|
||||
}
|
||||
}
|
||||
|
||||
$self->{InputFiles} = \@inputFiles ;
|
||||
|
||||
$self->_getFiles()
|
||||
or return undef ;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub _retError
|
||||
{
|
||||
my $string = shift ;
|
||||
$Error = "$string in input fileglob" ;
|
||||
return undef ;
|
||||
}
|
||||
|
||||
sub _unmatched
|
||||
{
|
||||
my $delimeter = shift ;
|
||||
|
||||
_retError("Unmatched $delimeter");
|
||||
return undef ;
|
||||
}
|
||||
|
||||
sub _parseBit
|
||||
{
|
||||
my $self = shift ;
|
||||
|
||||
my $string = shift ;
|
||||
|
||||
my $out = '';
|
||||
my $depth = 0 ;
|
||||
|
||||
while ($string =~ s/(.*?)$noPreBS(,|$matchMetaRE)//)
|
||||
{
|
||||
$out .= quotemeta($1) ;
|
||||
$out .= $mapping{$2} if defined $mapping{$2};
|
||||
|
||||
++ $self->{WildCount} if $wildCount{$2} ;
|
||||
|
||||
if ($2 eq ',')
|
||||
{
|
||||
return _unmatched("(")
|
||||
if $depth ;
|
||||
|
||||
$out .= '|';
|
||||
}
|
||||
elsif ($2 eq '(')
|
||||
{
|
||||
++ $depth ;
|
||||
}
|
||||
elsif ($2 eq ')')
|
||||
{
|
||||
return _unmatched(")")
|
||||
if ! $depth ;
|
||||
|
||||
-- $depth ;
|
||||
}
|
||||
elsif ($2 eq '[')
|
||||
{
|
||||
# TODO -- quotemeta & check no '/'
|
||||
# TODO -- check for \] & other \ within the []
|
||||
$string =~ s#(.*?\])##
|
||||
or return _unmatched("[");
|
||||
$out .= "$1)" ;
|
||||
}
|
||||
elsif ($2 eq ']')
|
||||
{
|
||||
return _unmatched("]");
|
||||
}
|
||||
elsif ($2 eq '{' || $2 eq '}')
|
||||
{
|
||||
return _retError("Nested {} not allowed");
|
||||
}
|
||||
}
|
||||
|
||||
$out .= quotemeta $string;
|
||||
|
||||
return _unmatched("(")
|
||||
if $depth ;
|
||||
|
||||
return $out ;
|
||||
}
|
||||
|
||||
sub _parseInputGlob
|
||||
{
|
||||
my $self = shift ;
|
||||
|
||||
my $string = $self->{InputGlob} ;
|
||||
my $inGlob = '';
|
||||
|
||||
# Multiple concatenated *'s don't make sense
|
||||
#$string =~ s#\*\*+#*# ;
|
||||
|
||||
# TODO -- Allow space to delimit patterns?
|
||||
#my @strings = split /\s+/, $string ;
|
||||
#for my $str (@strings)
|
||||
my $out = '';
|
||||
my $depth = 0 ;
|
||||
|
||||
while ($string =~ s/(.*?)$noPreBS($matchMetaRE)//)
|
||||
{
|
||||
$out .= quotemeta($1) ;
|
||||
$out .= $mapping{$2} if defined $mapping{$2};
|
||||
++ $self->{WildCount} if $wildCount{$2} ;
|
||||
|
||||
if ($2 eq '(')
|
||||
{
|
||||
++ $depth ;
|
||||
}
|
||||
elsif ($2 eq ')')
|
||||
{
|
||||
return _unmatched(")")
|
||||
if ! $depth ;
|
||||
|
||||
-- $depth ;
|
||||
}
|
||||
elsif ($2 eq '[')
|
||||
{
|
||||
# TODO -- quotemeta & check no '/' or '(' or ')'
|
||||
# TODO -- check for \] & other \ within the []
|
||||
$string =~ s#(.*?\])##
|
||||
or return _unmatched("[");
|
||||
$out .= "$1)" ;
|
||||
}
|
||||
elsif ($2 eq ']')
|
||||
{
|
||||
return _unmatched("]");
|
||||
}
|
||||
elsif ($2 eq '}')
|
||||
{
|
||||
return _unmatched("}");
|
||||
}
|
||||
elsif ($2 eq '{')
|
||||
{
|
||||
# TODO -- check no '/' within the {}
|
||||
# TODO -- check for \} & other \ within the {}
|
||||
|
||||
my $tmp ;
|
||||
unless ( $string =~ s/(.*?)$noPreBS\}//)
|
||||
{
|
||||
return _unmatched("{");
|
||||
}
|
||||
#$string =~ s#(.*?)\}##;
|
||||
|
||||
#my $alt = join '|',
|
||||
# map { quotemeta $_ }
|
||||
# split "$noPreBS,", $1 ;
|
||||
my $alt = $self->_parseBit($1);
|
||||
defined $alt or return 0 ;
|
||||
$out .= "($alt)" ;
|
||||
|
||||
++ $self->{Braces} ;
|
||||
}
|
||||
}
|
||||
|
||||
return _unmatched("(")
|
||||
if $depth ;
|
||||
|
||||
$out .= quotemeta $string ;
|
||||
|
||||
|
||||
$self->{InputGlob} =~ s/$noPreBS[\(\)]//g;
|
||||
$self->{InputPattern} = $out ;
|
||||
|
||||
#print "# INPUT '$self->{InputGlob}' => '$out'\n";
|
||||
|
||||
return 1 ;
|
||||
|
||||
}
|
||||
|
||||
sub _parseOutputGlob
|
||||
{
|
||||
my $self = shift ;
|
||||
|
||||
my $string = $self->{OutputGlob} ;
|
||||
my $maxwild = $self->{WildCount};
|
||||
|
||||
if ($self->{GlobFlags} & GLOB_TILDE)
|
||||
#if (1)
|
||||
{
|
||||
$string =~ s{
|
||||
^ ~ # find a leading tilde
|
||||
( # save this in $1
|
||||
[^/] # a non-slash character
|
||||
* # repeated 0 or more times (0 means me)
|
||||
)
|
||||
}{
|
||||
$1
|
||||
? (getpwnam($1))[7]
|
||||
: ( $ENV{HOME} || $ENV{LOGDIR} )
|
||||
}ex;
|
||||
|
||||
}
|
||||
|
||||
# max #1 must be == to max no of '*' in input
|
||||
while ( $string =~ m/#(\d)/g )
|
||||
{
|
||||
croak "Max wild is #$maxwild, you tried #$1"
|
||||
if $1 > $maxwild ;
|
||||
}
|
||||
|
||||
my $noPreBS = '(?<!\\\)' ; # no preceding backslash
|
||||
#warn "noPreBS = '$noPreBS'\n";
|
||||
|
||||
#$string =~ s/${noPreBS}\$(\d)/\${$1}/g;
|
||||
$string =~ s/${noPreBS}#(\d)/\${$1}/g;
|
||||
$string =~ s#${noPreBS}\*#\${inFile}#g;
|
||||
$string = '"' . $string . '"';
|
||||
|
||||
#print "OUTPUT '$self->{OutputGlob}' => '$string'\n";
|
||||
$self->{OutputPattern} = $string ;
|
||||
|
||||
return 1 ;
|
||||
}
|
||||
|
||||
sub _getFiles
|
||||
{
|
||||
my $self = shift ;
|
||||
|
||||
my %outInMapping = ();
|
||||
my %inFiles = () ;
|
||||
|
||||
foreach my $inFile (@{ $self->{InputFiles} })
|
||||
{
|
||||
next if $inFiles{$inFile} ++ ;
|
||||
|
||||
my $outFile = $inFile ;
|
||||
|
||||
if ( $inFile =~ m/$self->{InputPattern}/ )
|
||||
{
|
||||
no warnings 'uninitialized';
|
||||
eval "\$outFile = $self->{OutputPattern};" ;
|
||||
|
||||
if (defined $outInMapping{$outFile})
|
||||
{
|
||||
$Error = "multiple input files map to one output file";
|
||||
return undef ;
|
||||
}
|
||||
$outInMapping{$outFile} = $inFile;
|
||||
push @{ $self->{Pairs} }, [$inFile, $outFile];
|
||||
}
|
||||
}
|
||||
|
||||
return 1 ;
|
||||
}
|
||||
|
||||
sub getFileMap
|
||||
{
|
||||
my $self = shift ;
|
||||
|
||||
return $self->{Pairs} ;
|
||||
}
|
||||
|
||||
sub getHash
|
||||
{
|
||||
my $self = shift ;
|
||||
|
||||
return { map { $_->[0] => $_->[1] } @{ $self->{Pairs} } } ;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::GlobMapper - Extend File Glob to Allow Input and Output Files
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::GlobMapper qw( globmap );
|
||||
|
||||
my $aref = globmap $input => $output
|
||||
or die $File::GlobMapper::Error ;
|
||||
|
||||
my $gm = File::GlobMapper->new( $input => $output )
|
||||
or die $File::GlobMapper::Error ;
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module needs Perl5.005 or better.
|
||||
|
||||
This module takes the existing C<File::Glob> module as a starting point and
|
||||
extends it to allow new filenames to be derived from the files matched by
|
||||
C<File::Glob>.
|
||||
|
||||
This can be useful when carrying out batch operations on multiple files that
|
||||
have both an input filename and output filename and the output file can be
|
||||
derived from the input filename. Examples of operations where this can be
|
||||
useful include, file renaming, file copying and file compression.
|
||||
|
||||
|
||||
=head2 Behind The Scenes
|
||||
|
||||
To help explain what C<File::GlobMapper> does, consider what code you
|
||||
would write if you wanted to rename all files in the current directory
|
||||
that ended in C<.tar.gz> to C<.tgz>. So say these files are in the
|
||||
current directory
|
||||
|
||||
alpha.tar.gz
|
||||
beta.tar.gz
|
||||
gamma.tar.gz
|
||||
|
||||
and they need renamed to this
|
||||
|
||||
alpha.tgz
|
||||
beta.tgz
|
||||
gamma.tgz
|
||||
|
||||
Below is a possible implementation of a script to carry out the rename
|
||||
(error cases have been omitted)
|
||||
|
||||
foreach my $old ( glob "*.tar.gz" )
|
||||
{
|
||||
my $new = $old;
|
||||
$new =~ s#(.*)\.tar\.gz$#$1.tgz# ;
|
||||
|
||||
rename $old => $new
|
||||
or die "Cannot rename '$old' to '$new': $!\n;
|
||||
}
|
||||
|
||||
Notice that a file glob pattern C<*.tar.gz> was used to match the
|
||||
C<.tar.gz> files, then a fairly similar regular expression was used in
|
||||
the substitute to allow the new filename to be created.
|
||||
|
||||
Given that the file glob is just a cut-down regular expression and that it
|
||||
has already done a lot of the hard work in pattern matching the filenames,
|
||||
wouldn't it be handy to be able to use the patterns in the fileglob to
|
||||
drive the new filename?
|
||||
|
||||
Well, that's I<exactly> what C<File::GlobMapper> does.
|
||||
|
||||
Here is same snippet of code rewritten using C<globmap>
|
||||
|
||||
for my $pair (globmap '<*.tar.gz>' => '<#1.tgz>' )
|
||||
{
|
||||
my ($from, $to) = @$pair;
|
||||
rename $from => $to
|
||||
or die "Cannot rename '$old' to '$new': $!\n;
|
||||
}
|
||||
|
||||
So how does it work?
|
||||
|
||||
Behind the scenes the C<globmap> function does a combination of a
|
||||
file glob to match existing filenames followed by a substitute
|
||||
to create the new filenames.
|
||||
|
||||
Notice how both parameters to C<globmap> are strings that are delimited by <>.
|
||||
This is done to make them look more like file globs - it is just syntactic
|
||||
sugar, but it can be handy when you want the strings to be visually
|
||||
distinctive. The enclosing <> are optional, so you don't have to use them - in
|
||||
fact the first thing globmap will do is remove these delimiters if they are
|
||||
present.
|
||||
|
||||
The first parameter to C<globmap>, C<*.tar.gz>, is an I<Input File Glob>.
|
||||
Once the enclosing "< ... >" is removed, this is passed (more or
|
||||
less) unchanged to C<File::Glob> to carry out a file match.
|
||||
|
||||
Next the fileglob C<*.tar.gz> is transformed behind the scenes into a
|
||||
full Perl regular expression, with the additional step of wrapping each
|
||||
transformed wildcard metacharacter sequence in parenthesis.
|
||||
|
||||
In this case the input fileglob C<*.tar.gz> will be transformed into
|
||||
this Perl regular expression
|
||||
|
||||
([^/]*)\.tar\.gz
|
||||
|
||||
Wrapping with parenthesis allows the wildcard parts of the Input File
|
||||
Glob to be referenced by the second parameter to C<globmap>, C<#1.tgz>,
|
||||
the I<Output File Glob>. This parameter operates just like the replacement
|
||||
part of a substitute command. The difference is that the C<#1> syntax
|
||||
is used to reference sub-patterns matched in the input fileglob, rather
|
||||
than the C<$1> syntax that is used with perl regular expressions. In
|
||||
this case C<#1> is used to refer to the text matched by the C<*> in the
|
||||
Input File Glob. This makes it easier to use this module where the
|
||||
parameters to C<globmap> are typed at the command line.
|
||||
|
||||
The final step involves passing each filename matched by the C<*.tar.gz>
|
||||
file glob through the derived Perl regular expression in turn and
|
||||
expanding the output fileglob using it.
|
||||
|
||||
The end result of all this is a list of pairs of filenames. By default
|
||||
that is what is returned by C<globmap>. In this example the data structure
|
||||
returned will look like this
|
||||
|
||||
( ['alpha.tar.gz' => 'alpha.tgz'],
|
||||
['beta.tar.gz' => 'beta.tgz' ],
|
||||
['gamma.tar.gz' => 'gamma.tgz']
|
||||
)
|
||||
|
||||
|
||||
Each pair is an array reference with two elements - namely the I<from>
|
||||
filename, that C<File::Glob> has matched, and a I<to> filename that is
|
||||
derived from the I<from> filename.
|
||||
|
||||
|
||||
|
||||
=head2 Limitations
|
||||
|
||||
C<File::GlobMapper> has been kept simple deliberately, so it isn't intended to
|
||||
solve all filename mapping operations. Under the hood C<File::Glob> (or for
|
||||
older versions of Perl, C<File::BSDGlob>) is used to match the files, so you
|
||||
will never have the flexibility of full Perl regular expression.
|
||||
|
||||
=head2 Input File Glob
|
||||
|
||||
The syntax for an Input FileGlob is identical to C<File::Glob>, except
|
||||
for the following
|
||||
|
||||
=over 5
|
||||
|
||||
=item 1.
|
||||
|
||||
No nested {}
|
||||
|
||||
=item 2.
|
||||
|
||||
Whitespace does not delimit fileglobs.
|
||||
|
||||
=item 3.
|
||||
|
||||
The use of parenthesis can be used to capture parts of the input filename.
|
||||
|
||||
=item 4.
|
||||
|
||||
If an Input glob matches the same file more than once, only the first
|
||||
will be used.
|
||||
|
||||
=back
|
||||
|
||||
The syntax
|
||||
|
||||
=over 5
|
||||
|
||||
=item B<~>
|
||||
|
||||
=item B<~user>
|
||||
|
||||
|
||||
=item B<.>
|
||||
|
||||
Matches a literal '.'.
|
||||
Equivalent to the Perl regular expression
|
||||
|
||||
\.
|
||||
|
||||
=item B<*>
|
||||
|
||||
Matches zero or more characters, except '/'. Equivalent to the Perl
|
||||
regular expression
|
||||
|
||||
[^/]*
|
||||
|
||||
=item B<?>
|
||||
|
||||
Matches zero or one character, except '/'. Equivalent to the Perl
|
||||
regular expression
|
||||
|
||||
[^/]?
|
||||
|
||||
=item B<\>
|
||||
|
||||
Backslash is used, as usual, to escape the next character.
|
||||
|
||||
=item B<[]>
|
||||
|
||||
Character class.
|
||||
|
||||
=item B<{,}>
|
||||
|
||||
Alternation
|
||||
|
||||
=item B<()>
|
||||
|
||||
Capturing parenthesis that work just like perl
|
||||
|
||||
=back
|
||||
|
||||
Any other character it taken literally.
|
||||
|
||||
=head2 Output File Glob
|
||||
|
||||
The Output File Glob is a normal string, with 2 glob-like features.
|
||||
|
||||
The first is the '*' metacharacter. This will be replaced by the complete
|
||||
filename matched by the input file glob. So
|
||||
|
||||
*.c *.Z
|
||||
|
||||
The second is
|
||||
|
||||
Output FileGlobs take the
|
||||
|
||||
=over 5
|
||||
|
||||
=item "*"
|
||||
|
||||
The "*" character will be replaced with the complete input filename.
|
||||
|
||||
=item #1
|
||||
|
||||
Patterns of the form /#\d/ will be replaced with the
|
||||
|
||||
=back
|
||||
|
||||
=head2 Returned Data
|
||||
|
||||
|
||||
=head1 EXAMPLES
|
||||
|
||||
=head2 A Rename script
|
||||
|
||||
Below is a simple "rename" script that uses C<globmap> to determine the
|
||||
source and destination filenames.
|
||||
|
||||
use File::GlobMapper qw(globmap) ;
|
||||
use File::Copy;
|
||||
|
||||
die "rename: Usage rename 'from' 'to'\n"
|
||||
unless @ARGV == 2 ;
|
||||
|
||||
my $fromGlob = shift @ARGV;
|
||||
my $toGlob = shift @ARGV;
|
||||
|
||||
my $pairs = globmap($fromGlob, $toGlob)
|
||||
or die $File::GlobMapper::Error;
|
||||
|
||||
for my $pair (@$pairs)
|
||||
{
|
||||
my ($from, $to) = @$pair;
|
||||
move $from => $to ;
|
||||
}
|
||||
|
||||
|
||||
|
||||
Here is an example that renames all c files to cpp.
|
||||
|
||||
$ rename '*.c' '#1.cpp'
|
||||
|
||||
=head2 A few example globmaps
|
||||
|
||||
Below are a few examples of globmaps
|
||||
|
||||
To copy all your .c file to a backup directory
|
||||
|
||||
'</my/home/*.c>' '</my/backup/#1.c>'
|
||||
|
||||
If you want to compress all
|
||||
|
||||
'</my/home/*.[ch]>' '<*.gz>'
|
||||
|
||||
To uncompress
|
||||
|
||||
'</my/home/*.[ch].gz>' '</my/home/#1.#2>'
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<File::Glob|File::Glob>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
The I<File::GlobMapper> module was written by Paul Marquess, F<pmqs@cpan.org>.
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright (c) 2005 Paul Marquess. All rights reserved.
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,363 @@
|
||||
package File::stat;
|
||||
use 5.006;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use warnings::register;
|
||||
use Carp;
|
||||
use constant _IS_CYGWIN => $^O eq "cygwin";
|
||||
|
||||
BEGIN { *warnif = \&warnings::warnif }
|
||||
|
||||
our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
|
||||
|
||||
our $VERSION = '1.13';
|
||||
|
||||
our @fields;
|
||||
our ( $st_dev, $st_ino, $st_mode,
|
||||
$st_nlink, $st_uid, $st_gid,
|
||||
$st_rdev, $st_size,
|
||||
$st_atime, $st_mtime, $st_ctime,
|
||||
$st_blksize, $st_blocks
|
||||
);
|
||||
|
||||
BEGIN {
|
||||
use Exporter ();
|
||||
@EXPORT = qw(stat lstat);
|
||||
@fields = qw( $st_dev $st_ino $st_mode
|
||||
$st_nlink $st_uid $st_gid
|
||||
$st_rdev $st_size
|
||||
$st_atime $st_mtime $st_ctime
|
||||
$st_blksize $st_blocks
|
||||
);
|
||||
@EXPORT_OK = ( @fields, "stat_cando" );
|
||||
%EXPORT_TAGS = ( FIELDS => [ @fields, @EXPORT ] );
|
||||
}
|
||||
|
||||
use Fcntl qw(S_IRUSR S_IWUSR S_IXUSR);
|
||||
|
||||
BEGIN {
|
||||
# These constants will croak on use if the platform doesn't define
|
||||
# them. It's important to avoid inflicting that on the user.
|
||||
no strict 'refs';
|
||||
for (qw(suid sgid svtx)) {
|
||||
my $val = eval { &{"Fcntl::S_I\U$_"} };
|
||||
*{"_$_"} = defined $val ? sub { $_[0] & $val ? 1 : "" } : sub { "" };
|
||||
}
|
||||
for (qw(SOCK CHR BLK REG DIR LNK)) {
|
||||
*{"S_IS$_"} = defined eval { &{"Fcntl::S_IF$_"} }
|
||||
? \&{"Fcntl::S_IS$_"} : sub { "" };
|
||||
}
|
||||
# FIFO flag and macro don't quite follow the S_IF/S_IS pattern above
|
||||
# RT #111638
|
||||
*{"S_ISFIFO"} = defined &Fcntl::S_IFIFO
|
||||
? \&Fcntl::S_ISFIFO : sub { "" };
|
||||
}
|
||||
|
||||
# from doio.c
|
||||
sub _ingroup {
|
||||
my ($gid, $eff) = @_;
|
||||
|
||||
# I am assuming that since VMS doesn't have getgroups(2), $) will
|
||||
# always only contain a single entry.
|
||||
$^O eq "VMS" and return $_[0] == $);
|
||||
|
||||
my ($egid, @supp) = split " ", $);
|
||||
my ($rgid) = split " ", $(;
|
||||
|
||||
$gid == ($eff ? $egid : $rgid) and return 1;
|
||||
grep $gid == $_, @supp and return 1;
|
||||
|
||||
return "";
|
||||
}
|
||||
|
||||
# VMS uses the Unix version of the routine, even though this is very
|
||||
# suboptimal. VMS has a permissions structure that doesn't really fit
|
||||
# into struct stat, and unlike on Win32 the normal -X operators respect
|
||||
# that, but unfortunately by the time we get here we've already lost the
|
||||
# information we need. It looks to me as though if we were to preserve
|
||||
# the st_devnam entry of vmsish.h's fake struct stat (which actually
|
||||
# holds the filename) it might be possible to do this right, but both
|
||||
# getting that value out of the struct (perl's stat doesn't return it)
|
||||
# and interpreting it later would require this module to have an XS
|
||||
# component (at which point we might as well just call Perl_cando and
|
||||
# have done with it).
|
||||
|
||||
if (grep $^O eq $_, qw/os2 MSWin32/) {
|
||||
|
||||
# from doio.c
|
||||
*cando = sub { ($_[0][2] & $_[1]) ? 1 : "" };
|
||||
}
|
||||
else {
|
||||
|
||||
# from doio.c
|
||||
*cando = sub {
|
||||
my ($s, $mode, $eff) = @_;
|
||||
my $uid = $eff ? $> : $<;
|
||||
my ($stmode, $stuid, $stgid) = @$s[2,4,5];
|
||||
|
||||
# This code basically assumes that the rwx bits of the mode are
|
||||
# the 0777 bits, but so does Perl_cando.
|
||||
|
||||
if (_IS_CYGWIN ? _ingroup(544, $eff) : ($uid == 0 && $^O ne "VMS")) {
|
||||
# If we're root on unix
|
||||
# not testing for executable status => all file tests are true
|
||||
return 1 if !($mode & 0111);
|
||||
# testing for executable status =>
|
||||
# for a file, any x bit will do
|
||||
# for a directory, always true
|
||||
return 1 if $stmode & 0111 || S_ISDIR($stmode);
|
||||
return "";
|
||||
}
|
||||
|
||||
if ($stuid == $uid) {
|
||||
$stmode & $mode and return 1;
|
||||
}
|
||||
elsif (_ingroup($stgid, $eff)) {
|
||||
$stmode & ($mode >> 3) and return 1;
|
||||
}
|
||||
else {
|
||||
$stmode & ($mode >> 6) and return 1;
|
||||
}
|
||||
return "";
|
||||
};
|
||||
}
|
||||
|
||||
# alias for those who don't like objects
|
||||
*stat_cando = \&cando;
|
||||
|
||||
my %op = (
|
||||
r => sub { cando($_[0], S_IRUSR, 1) },
|
||||
w => sub { cando($_[0], S_IWUSR, 1) },
|
||||
x => sub { cando($_[0], S_IXUSR, 1) },
|
||||
o => sub { $_[0][4] == $> },
|
||||
|
||||
R => sub { cando($_[0], S_IRUSR, 0) },
|
||||
W => sub { cando($_[0], S_IWUSR, 0) },
|
||||
X => sub { cando($_[0], S_IXUSR, 0) },
|
||||
O => sub { $_[0][4] == $< },
|
||||
|
||||
e => sub { 1 },
|
||||
z => sub { $_[0][7] == 0 },
|
||||
s => sub { $_[0][7] },
|
||||
|
||||
f => sub { S_ISREG ($_[0][2]) },
|
||||
d => sub { S_ISDIR ($_[0][2]) },
|
||||
l => sub { S_ISLNK ($_[0][2]) },
|
||||
p => sub { S_ISFIFO($_[0][2]) },
|
||||
S => sub { S_ISSOCK($_[0][2]) },
|
||||
b => sub { S_ISBLK ($_[0][2]) },
|
||||
c => sub { S_ISCHR ($_[0][2]) },
|
||||
|
||||
u => sub { _suid($_[0][2]) },
|
||||
g => sub { _sgid($_[0][2]) },
|
||||
k => sub { _svtx($_[0][2]) },
|
||||
|
||||
M => sub { ($^T - $_[0][9] ) / 86400 },
|
||||
C => sub { ($^T - $_[0][10]) / 86400 },
|
||||
A => sub { ($^T - $_[0][8] ) / 86400 },
|
||||
);
|
||||
|
||||
use constant HINT_FILETEST_ACCESS => 0x00400000;
|
||||
|
||||
# we need fallback=>1 or stringifying breaks
|
||||
use overload
|
||||
fallback => 1,
|
||||
-X => sub {
|
||||
my ($s, $op) = @_;
|
||||
|
||||
if (index("rwxRWX", $op) >= 0) {
|
||||
(caller 0)[8] & HINT_FILETEST_ACCESS
|
||||
and warnif("File::stat ignores use filetest 'access'");
|
||||
|
||||
$^O eq "VMS" and warnif("File::stat ignores VMS ACLs");
|
||||
|
||||
# It would be nice to have a warning about using -l on a
|
||||
# non-lstat, but that would require an extra member in the
|
||||
# object.
|
||||
}
|
||||
|
||||
if ($op{$op}) {
|
||||
return $op{$op}->($_[0]);
|
||||
}
|
||||
else {
|
||||
croak "-$op is not implemented on a File::stat object";
|
||||
}
|
||||
};
|
||||
|
||||
# Class::Struct forbids use of @ISA
|
||||
sub import { goto &Exporter::import }
|
||||
|
||||
use Class::Struct qw(struct);
|
||||
struct 'File::stat' => [
|
||||
map { $_ => '$' } qw{
|
||||
dev ino mode nlink uid gid rdev size
|
||||
atime mtime ctime blksize blocks
|
||||
}
|
||||
];
|
||||
|
||||
sub populate (@) {
|
||||
return unless @_;
|
||||
my $stob = new();
|
||||
@$stob = (
|
||||
$st_dev, $st_ino, $st_mode, $st_nlink, $st_uid, $st_gid, $st_rdev,
|
||||
$st_size, $st_atime, $st_mtime, $st_ctime, $st_blksize, $st_blocks )
|
||||
= @_;
|
||||
return $stob;
|
||||
}
|
||||
|
||||
sub lstat ($) { populate(CORE::lstat(shift)) }
|
||||
|
||||
sub stat ($) {
|
||||
my $arg = shift;
|
||||
my $st = populate(CORE::stat $arg);
|
||||
return $st if defined $st;
|
||||
my $fh;
|
||||
{
|
||||
local $!;
|
||||
no strict 'refs';
|
||||
require Symbol;
|
||||
$fh = \*{ Symbol::qualify( $arg, caller() )};
|
||||
return unless defined fileno $fh;
|
||||
}
|
||||
return populate(CORE::stat $fh);
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::stat - by-name interface to Perl's built-in stat() functions
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::stat;
|
||||
my $st = stat($file) or die "No $file: $!";
|
||||
if ( ($st->mode & 0111) && ($st->nlink > 1) ) {
|
||||
print "$file is executable with lotsa links\n";
|
||||
}
|
||||
|
||||
if ( -x $st ) {
|
||||
print "$file is executable\n";
|
||||
}
|
||||
|
||||
use Fcntl "S_IRUSR";
|
||||
if ( $st->cando(S_IRUSR, 1) ) {
|
||||
print "My effective uid can read $file\n";
|
||||
}
|
||||
|
||||
use File::stat qw(:FIELDS);
|
||||
stat($file) or die "No $file: $!";
|
||||
if ( ($st_mode & 0111) && ($st_nlink > 1) ) {
|
||||
print "$file is executable with lotsa links\n";
|
||||
}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module's default exports override the core stat()
|
||||
and lstat() functions, replacing them with versions that return
|
||||
"File::stat" objects. This object has methods that
|
||||
return the similarly named structure field name from the
|
||||
stat(2) function; namely,
|
||||
dev,
|
||||
ino,
|
||||
mode,
|
||||
nlink,
|
||||
uid,
|
||||
gid,
|
||||
rdev,
|
||||
size,
|
||||
atime,
|
||||
mtime,
|
||||
ctime,
|
||||
blksize,
|
||||
and
|
||||
blocks.
|
||||
|
||||
As of version 1.02 (provided with perl 5.12) the object provides C<"-X">
|
||||
overloading, so you can call filetest operators (C<-f>, C<-x>, and so
|
||||
on) on it. It also provides a C<< ->cando >> method, called like
|
||||
|
||||
$st->cando( ACCESS, EFFECTIVE )
|
||||
|
||||
where I<ACCESS> is one of C<S_IRUSR>, C<S_IWUSR> or C<S_IXUSR> from the
|
||||
L<Fcntl|Fcntl> module, and I<EFFECTIVE> indicates whether to use
|
||||
effective (true) or real (false) ids. The method interprets the C<mode>,
|
||||
C<uid> and C<gid> fields, and returns whether or not the current process
|
||||
would be allowed the specified access.
|
||||
|
||||
If you don't want to use the objects, you may import the C<< ->cando >>
|
||||
method into your namespace as a regular function called C<stat_cando>.
|
||||
This takes an arrayref containing the return values of C<stat> or
|
||||
C<lstat> as its first argument, and interprets it for you.
|
||||
|
||||
You may also import all the structure fields directly into your namespace
|
||||
as regular variables using the :FIELDS import tag. (Note that this still
|
||||
overrides your stat() and lstat() functions.) Access these fields as
|
||||
variables named with a preceding C<st_> in front their method names.
|
||||
Thus, C<$stat_obj-E<gt>dev()> corresponds to $st_dev if you import
|
||||
the fields.
|
||||
|
||||
To access this functionality without the core overrides,
|
||||
pass the C<use> an empty import list, and then access
|
||||
function functions with their full qualified names.
|
||||
On the other hand, the built-ins are still available
|
||||
via the C<CORE::> pseudo-package.
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
As of Perl 5.8.0 after using this module you cannot use the implicit
|
||||
C<$_> or the special filehandle C<_> with stat() or lstat(), trying
|
||||
to do so leads into strange errors. The workaround is for C<$_> to
|
||||
be explicit
|
||||
|
||||
my $stat_obj = stat $_;
|
||||
|
||||
and for C<_> to explicitly populate the object using the unexported
|
||||
and undocumented populate() function with CORE::stat():
|
||||
|
||||
my $stat_obj = File::stat::populate(CORE::stat(_));
|
||||
|
||||
=head1 ERRORS
|
||||
|
||||
=over 4
|
||||
|
||||
=item -%s is not implemented on a File::stat object
|
||||
|
||||
The filetest operators C<-t>, C<-T> and C<-B> are not implemented, as
|
||||
they require more information than just a stat buffer.
|
||||
|
||||
=back
|
||||
|
||||
=head1 WARNINGS
|
||||
|
||||
These can all be disabled with
|
||||
|
||||
no warnings "File::stat";
|
||||
|
||||
=over 4
|
||||
|
||||
=item File::stat ignores use filetest 'access'
|
||||
|
||||
You have tried to use one of the C<-rwxRWX> filetests with C<use
|
||||
filetest 'access'> in effect. C<File::stat> will ignore the pragma, and
|
||||
just use the information in the C<mode> member as usual.
|
||||
|
||||
=item File::stat ignores VMS ACLs
|
||||
|
||||
VMS systems have a permissions structure that cannot be completely
|
||||
represented in a stat buffer, and unlike on other systems the builtin
|
||||
filetest operators respect this. The C<File::stat> overloads, however,
|
||||
do not, since the information required is not available.
|
||||
|
||||
=back
|
||||
|
||||
=head1 NOTE
|
||||
|
||||
While this class is currently implemented using the Class::Struct
|
||||
module to build a struct-like class, you shouldn't rely upon this.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Tom Christiansen
|
||||
@@ -0,0 +1,188 @@
|
||||
package FileCache;
|
||||
|
||||
our $VERSION = '1.10';
|
||||
|
||||
=head1 NAME
|
||||
|
||||
FileCache - keep more files open than the system permits
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
no strict 'refs';
|
||||
|
||||
use FileCache;
|
||||
# or
|
||||
use FileCache maxopen => 16;
|
||||
|
||||
cacheout $mode, $path;
|
||||
# or
|
||||
cacheout $path;
|
||||
print $path @data;
|
||||
|
||||
$fh = cacheout $mode, $path;
|
||||
# or
|
||||
$fh = cacheout $path;
|
||||
print $fh @data;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The C<cacheout> function will make sure that there's a filehandle open
|
||||
for reading or writing available as the pathname you give it. It
|
||||
automatically closes and re-opens files if you exceed your system's
|
||||
maximum number of file descriptors, or the suggested maximum I<maxopen>.
|
||||
|
||||
=over
|
||||
|
||||
=item cacheout EXPR
|
||||
|
||||
The 1-argument form of cacheout will open a file for writing (C<< '>' >>)
|
||||
on it's first use, and appending (C<<< '>>' >>>) thereafter.
|
||||
|
||||
Returns EXPR on success for convenience. You may neglect the
|
||||
return value and manipulate EXPR as the filehandle directly if you prefer.
|
||||
|
||||
=item cacheout MODE, EXPR
|
||||
|
||||
The 2-argument form of cacheout will use the supplied mode for the initial
|
||||
and subsequent openings. Most valid modes for 3-argument C<open> are supported
|
||||
namely; C<< '>' >>, C<< '+>' >>, C<< '<' >>, C<< '<+' >>, C<<< '>>' >>>,
|
||||
C< '|-' > and C< '-|' >
|
||||
|
||||
To pass supplemental arguments to a program opened with C< '|-' > or C< '-|' >
|
||||
append them to the command string as you would system EXPR.
|
||||
|
||||
Returns EXPR on success for convenience. You may neglect the
|
||||
return value and manipulate EXPR as the filehandle directly if you prefer.
|
||||
|
||||
=back
|
||||
|
||||
=head1 CAVEATS
|
||||
|
||||
While it is permissible to C<close> a FileCache managed file,
|
||||
do not do so if you are calling C<FileCache::cacheout> from a package other
|
||||
than which it was imported, or with another module which overrides C<close>.
|
||||
If you must, use C<FileCache::cacheout_close>.
|
||||
|
||||
Although FileCache can be used with piped opens ('-|' or '|-') doing so is
|
||||
strongly discouraged. If FileCache finds it necessary to close and then reopen
|
||||
a pipe, the command at the far end of the pipe will be reexecuted - the results
|
||||
of performing IO on FileCache'd pipes is unlikely to be what you expect. The
|
||||
ability to use FileCache on pipes may be removed in a future release.
|
||||
|
||||
FileCache does not store the current file offset if it finds it necessary to
|
||||
close a file. When the file is reopened, the offset will be as specified by the
|
||||
original C<open> file mode. This could be construed to be a bug.
|
||||
|
||||
The module functionality relies on symbolic references, so things will break
|
||||
under 'use strict' unless 'no strict "refs"' is also specified.
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
F<sys/param.h> lies with its C<NOFILE> define on some systems,
|
||||
so you may have to set I<maxopen> yourself.
|
||||
|
||||
=cut
|
||||
|
||||
require 5.006;
|
||||
use Carp;
|
||||
use strict;
|
||||
no strict 'refs';
|
||||
|
||||
# These are not C<my> for legacy reasons.
|
||||
# Previous versions requested the user set $cacheout_maxopen by hand.
|
||||
# Some authors fiddled with %saw to overcome the clobber on initial open.
|
||||
our %saw;
|
||||
our $cacheout_maxopen = 16;
|
||||
|
||||
use parent 'Exporter';
|
||||
our @EXPORT = qw[cacheout cacheout_close];
|
||||
|
||||
|
||||
my %isopen;
|
||||
my $cacheout_seq = 0;
|
||||
|
||||
sub import {
|
||||
my ($pkg,%args) = @_;
|
||||
|
||||
# Use Exporter. %args are for us, not Exporter.
|
||||
# Make sure to up export_to_level, or we will import into ourselves,
|
||||
# rather than our calling package;
|
||||
|
||||
__PACKAGE__->export_to_level(1);
|
||||
Exporter::import( $pkg );
|
||||
|
||||
# Truth is okay here because setting maxopen to 0 would be bad
|
||||
return $cacheout_maxopen = $args{maxopen} if $args{maxopen};
|
||||
|
||||
# XXX This code is crazy. Why is it a one element foreach loop?
|
||||
# Why is it using $param both as a filename and filehandle?
|
||||
foreach my $param ( '/usr/include/sys/param.h' ){
|
||||
if (open($param, '<', $param)) {
|
||||
local ($_, $.);
|
||||
while (<$param>) {
|
||||
if( /^\s*#\s*define\s+NOFILE\s+(\d+)/ ){
|
||||
$cacheout_maxopen = $1 - 4;
|
||||
close($param);
|
||||
last;
|
||||
}
|
||||
}
|
||||
close $param;
|
||||
}
|
||||
}
|
||||
$cacheout_maxopen ||= 16;
|
||||
}
|
||||
|
||||
# Open in their package.
|
||||
sub cacheout_open {
|
||||
return open(*{caller(1) . '::' . $_[1]}, $_[0], $_[1]) && $_[1];
|
||||
}
|
||||
|
||||
# Close in their package.
|
||||
sub cacheout_close {
|
||||
# Short-circuit in case the filehandle disappeared
|
||||
my $pkg = caller($_[1]||0);
|
||||
defined fileno(*{$pkg . '::' . $_[0]}) &&
|
||||
CORE::close(*{$pkg . '::' . $_[0]});
|
||||
delete $isopen{$_[0]};
|
||||
}
|
||||
|
||||
# But only this sub name is visible to them.
|
||||
sub cacheout {
|
||||
my($mode, $file, $class, $ret, $ref, $narg);
|
||||
croak "Not enough arguments for cacheout" unless $narg = scalar @_;
|
||||
croak "Too many arguments for cacheout" if $narg > 2;
|
||||
|
||||
($mode, $file) = @_;
|
||||
($file, $mode) = ($mode, $file) if $narg == 1;
|
||||
croak "Invalid mode for cacheout" if $mode &&
|
||||
( $mode !~ /^\s*(?:>>|\+?>|\+?<|\|\-|)|\-\|\s*$/ );
|
||||
|
||||
# Mode changed?
|
||||
if( $isopen{$file} && ($mode||'>') ne $isopen{$file}->[1] ){
|
||||
&cacheout_close($file, 1);
|
||||
}
|
||||
|
||||
if( $isopen{$file}) {
|
||||
$ret = $file;
|
||||
$isopen{$file}->[0]++;
|
||||
}
|
||||
else{
|
||||
if( scalar keys(%isopen) > $cacheout_maxopen -1 ) {
|
||||
my @lru = sort{ $isopen{$a}->[0] <=> $isopen{$b}->[0] } keys(%isopen);
|
||||
$cacheout_seq = 0;
|
||||
$isopen{$_}->[0] = $cacheout_seq++ for
|
||||
splice(@lru, int($cacheout_maxopen / 3)||$cacheout_maxopen);
|
||||
&cacheout_close($_, 1) for @lru;
|
||||
}
|
||||
|
||||
unless( $ref ){
|
||||
$mode ||= $saw{$file} ? '>>' : ($saw{$file}=1, '>');
|
||||
}
|
||||
#XXX should we just return the value from cacheout_open, no croak?
|
||||
$ret = cacheout_open($mode, $file) or croak("Can't create $file: $!");
|
||||
|
||||
$isopen{$file} = [++$cacheout_seq, $mode];
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
1;
|
||||
@@ -0,0 +1,262 @@
|
||||
package FileHandle;
|
||||
|
||||
use 5.006;
|
||||
use strict;
|
||||
our($VERSION, @ISA, @EXPORT, @EXPORT_OK);
|
||||
|
||||
$VERSION = "2.05";
|
||||
|
||||
require IO::File;
|
||||
@ISA = qw(IO::File);
|
||||
|
||||
@EXPORT = qw(_IOFBF _IOLBF _IONBF);
|
||||
|
||||
@EXPORT_OK = qw(
|
||||
pipe
|
||||
|
||||
autoflush
|
||||
output_field_separator
|
||||
output_record_separator
|
||||
input_record_separator
|
||||
input_line_number
|
||||
format_page_number
|
||||
format_lines_per_page
|
||||
format_lines_left
|
||||
format_name
|
||||
format_top_name
|
||||
format_line_break_characters
|
||||
format_formfeed
|
||||
|
||||
print
|
||||
printf
|
||||
getline
|
||||
getlines
|
||||
);
|
||||
|
||||
#
|
||||
# Everything we're willing to export, we must first import.
|
||||
#
|
||||
IO::Handle->import( grep { !defined(&$_) } @EXPORT, @EXPORT_OK );
|
||||
|
||||
#
|
||||
# Some people call "FileHandle::function", so all the functions
|
||||
# that were in the old FileHandle class must be imported, too.
|
||||
#
|
||||
{
|
||||
no strict 'refs';
|
||||
|
||||
my %import = (
|
||||
'IO::Handle' =>
|
||||
[qw(DESTROY new_from_fd fdopen close fileno getc ungetc gets
|
||||
eof flush error clearerr setbuf setvbuf _open_mode_string)],
|
||||
'IO::Seekable' =>
|
||||
[qw(seek tell getpos setpos)],
|
||||
'IO::File' =>
|
||||
[qw(new new_tmpfile open)]
|
||||
);
|
||||
for my $pkg (keys %import) {
|
||||
for my $func (@{$import{$pkg}}) {
|
||||
my $c = *{"${pkg}::$func"}{CODE}
|
||||
or die "${pkg}::$func missing";
|
||||
*$func = $c;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
#
|
||||
# Specialized importer for Fcntl magic.
|
||||
#
|
||||
sub import {
|
||||
my $pkg = shift;
|
||||
my $callpkg = caller;
|
||||
require Exporter;
|
||||
Exporter::export($pkg, $callpkg, @_);
|
||||
|
||||
#
|
||||
# If the Fcntl extension is available,
|
||||
# export its constants.
|
||||
#
|
||||
eval {
|
||||
require Fcntl;
|
||||
Exporter::export('Fcntl', $callpkg);
|
||||
};
|
||||
}
|
||||
|
||||
################################################
|
||||
# This is the only exported function we define;
|
||||
# the rest come from other classes.
|
||||
#
|
||||
|
||||
sub pipe {
|
||||
my $r = IO::Handle->new;
|
||||
my $w = IO::Handle->new;
|
||||
CORE::pipe($r, $w) or return undef;
|
||||
($r, $w);
|
||||
}
|
||||
|
||||
# Rebless standard file handles
|
||||
bless *STDIN{IO}, "FileHandle" if ref *STDIN{IO} eq "IO::Handle";
|
||||
bless *STDOUT{IO}, "FileHandle" if ref *STDOUT{IO} eq "IO::Handle";
|
||||
bless *STDERR{IO}, "FileHandle" if ref *STDERR{IO} eq "IO::Handle";
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
FileHandle - supply object methods for filehandles
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use FileHandle;
|
||||
|
||||
my $fh = FileHandle->new;
|
||||
if ($fh->open("< file")) {
|
||||
print <$fh>;
|
||||
$fh->close;
|
||||
}
|
||||
|
||||
my $fh = FileHandle->new("> FOO");
|
||||
if (defined $fh) {
|
||||
print $fh "bar\n";
|
||||
$fh->close;
|
||||
}
|
||||
|
||||
my $fh = FileHandle->new("file", "r");
|
||||
if (defined $fh) {
|
||||
print <$fh>;
|
||||
undef $fh; # automatically closes the file
|
||||
}
|
||||
|
||||
my $fh = FileHandle->new("file", O_WRONLY|O_APPEND);
|
||||
if (defined $fh) {
|
||||
print $fh "corge\n";
|
||||
undef $fh; # automatically closes the file
|
||||
}
|
||||
|
||||
my $pos = $fh->getpos;
|
||||
$fh->setpos($pos);
|
||||
|
||||
$fh->setvbuf(my $buffer_var, _IOLBF, 1024);
|
||||
|
||||
my ($readfh, $writefh) = FileHandle::pipe;
|
||||
|
||||
autoflush STDOUT 1;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
NOTE: This class is now a front-end to the IO::* classes.
|
||||
|
||||
C<FileHandle::new> creates a C<FileHandle>, which is a reference to a
|
||||
newly created symbol (see the L<Symbol> package). If it receives any
|
||||
parameters, they are passed to C<FileHandle::open>; if the open fails,
|
||||
the C<FileHandle> object is destroyed. Otherwise, it is returned to
|
||||
the caller.
|
||||
|
||||
C<FileHandle::new_from_fd> creates a C<FileHandle> like C<new> does.
|
||||
It requires two parameters, which are passed to C<FileHandle::fdopen>;
|
||||
if the fdopen fails, the C<FileHandle> object is destroyed.
|
||||
Otherwise, it is returned to the caller.
|
||||
|
||||
C<FileHandle::open> accepts one parameter or two. With one parameter,
|
||||
it is just a front end for the built-in C<open> function. With two
|
||||
parameters, the first parameter is a filename that may include
|
||||
whitespace or other special characters, and the second parameter is
|
||||
the open mode, optionally followed by a file permission value.
|
||||
|
||||
If C<FileHandle::open> receives a Perl mode string (">", "+<", etc.)
|
||||
or a POSIX fopen() mode string ("w", "r+", etc.), it uses the basic
|
||||
Perl C<open> operator.
|
||||
|
||||
If C<FileHandle::open> is given a numeric mode, it passes that mode
|
||||
and the optional permissions value to the Perl C<sysopen> operator.
|
||||
For convenience, C<FileHandle::import> tries to import the O_XXX
|
||||
constants from the Fcntl module. If dynamic loading is not available,
|
||||
this may fail, but the rest of FileHandle will still work.
|
||||
|
||||
C<FileHandle::fdopen> is like C<open> except that its first parameter
|
||||
is not a filename but rather a file handle name, a FileHandle object,
|
||||
or a file descriptor number.
|
||||
|
||||
If the C functions fgetpos() and fsetpos() are available, then
|
||||
C<FileHandle::getpos> returns an opaque value that represents the
|
||||
current position of the FileHandle, and C<FileHandle::setpos> uses
|
||||
that value to return to a previously visited position.
|
||||
|
||||
If the C function setvbuf() is available, then C<FileHandle::setvbuf>
|
||||
sets the buffering policy for the FileHandle. The calling sequence
|
||||
for the Perl function is the same as its C counterpart, including the
|
||||
macros C<_IOFBF>, C<_IOLBF>, and C<_IONBF>, except that the buffer
|
||||
parameter specifies a scalar variable to use as a buffer. WARNING: A
|
||||
variable used as a buffer by C<FileHandle::setvbuf> must not be
|
||||
modified in any way until the FileHandle is closed or until
|
||||
C<FileHandle::setvbuf> is called again, or memory corruption may
|
||||
result!
|
||||
|
||||
See L<perlfunc> for complete descriptions of each of the following
|
||||
supported C<FileHandle> methods, which are just front ends for the
|
||||
corresponding built-in functions:
|
||||
|
||||
close
|
||||
fileno
|
||||
getc
|
||||
gets
|
||||
eof
|
||||
clearerr
|
||||
seek
|
||||
tell
|
||||
|
||||
See L<perlvar> for complete descriptions of each of the following
|
||||
supported C<FileHandle> methods:
|
||||
|
||||
autoflush
|
||||
output_field_separator
|
||||
output_record_separator
|
||||
input_record_separator
|
||||
input_line_number
|
||||
format_page_number
|
||||
format_lines_per_page
|
||||
format_lines_left
|
||||
format_name
|
||||
format_top_name
|
||||
format_line_break_characters
|
||||
format_formfeed
|
||||
|
||||
Furthermore, for doing normal I/O you might need these:
|
||||
|
||||
=over 4
|
||||
|
||||
=item $fh->print
|
||||
|
||||
See L<perlfunc/print>.
|
||||
|
||||
=item $fh->printf
|
||||
|
||||
See L<perlfunc/printf>.
|
||||
|
||||
=item $fh->getline
|
||||
|
||||
This works like <$fh> described in L<perlop/"I/O Operators">
|
||||
except that it's more readable and can be safely called in a
|
||||
list context but still returns just one line.
|
||||
|
||||
=item $fh->getlines
|
||||
|
||||
This works like <$fh> when called in a list context to
|
||||
read all the remaining lines in a file, except that it's more readable.
|
||||
It will also croak() if accidentally called in a scalar context.
|
||||
|
||||
=back
|
||||
|
||||
There are many other functions available since FileHandle is descended
|
||||
from IO::File, IO::Seekable, and IO::Handle. Please see those
|
||||
respective pages for documentation on more functions.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
The B<IO> extension,
|
||||
L<perlfunc>,
|
||||
L<perlop/"I/O Operators">.
|
||||
|
||||
=cut
|
||||
@@ -0,0 +1,805 @@
|
||||
package Filter::Simple;
|
||||
|
||||
use Text::Balanced ':ALL';
|
||||
|
||||
our $VERSION = '0.96';
|
||||
|
||||
use Filter::Util::Call;
|
||||
use Carp;
|
||||
|
||||
our @EXPORT = qw( FILTER FILTER_ONLY );
|
||||
|
||||
|
||||
sub import {
|
||||
if (@_>1) { shift; goto &FILTER }
|
||||
else { *{caller()."::$_"} = \&$_ foreach @EXPORT }
|
||||
}
|
||||
|
||||
sub fail {
|
||||
croak "FILTER_ONLY: ", @_;
|
||||
}
|
||||
|
||||
my $exql = sub {
|
||||
my @bits = extract_quotelike $_[0], qr//;
|
||||
return unless $bits[0];
|
||||
return \@bits;
|
||||
};
|
||||
|
||||
my $ncws = qr/\s+/;
|
||||
my $comment = qr/(?<![\$\@%])#.*/;
|
||||
my $ws = qr/(?:$ncws|$comment)+/;
|
||||
my $id = qr/\b(?!([ysm]|q[rqxw]?|tr)\b)\w+/;
|
||||
my $EOP = qr/\n\n|\Z/;
|
||||
my $CUT = qr/\n=cut.*$EOP/;
|
||||
my $pod_or_DATA = qr/
|
||||
^=(?:head[1-4]|item) .*? $CUT
|
||||
| ^=pod .*? $CUT
|
||||
| ^=for .*? $CUT
|
||||
| ^=begin .*? $CUT
|
||||
| ^__(DATA|END)__\r?\n.*
|
||||
/smx;
|
||||
my $variable = qr{
|
||||
[\$*\@%]\s*
|
||||
\{\s*(?!::)(?:\d+|[][&`'#+*./|,";%=~:?!\@<>()-]|\^[A-Z]?)\}
|
||||
| (?:\$#?|[*\@\%]|\\&)\$*\s*
|
||||
(?: \{\s*(?:\^(?=[A-Z_]))?(?:\w|::|'\w)*\s*\}
|
||||
| (?:\^(?=[A-Z_]))?(?:\w|::|'\w)*
|
||||
| (?=\{) # ${ block }
|
||||
)
|
||||
)
|
||||
| \$\s*(?!::)(?:\d+|[][&`'#+*./|,";%=~:?!\@<>()-]|\^[A-Z]?)
|
||||
}x;
|
||||
|
||||
my %extractor_for = (
|
||||
quotelike => [ $ws, $variable, $id, { MATCH => \&extract_quotelike } ],
|
||||
regex => [ $ws, $pod_or_DATA, $id, $exql ],
|
||||
string => [ $ws, $pod_or_DATA, $id, $exql ],
|
||||
code => [ $ws, { DONT_MATCH => $pod_or_DATA }, $variable,
|
||||
$id, { DONT_MATCH => \&extract_quotelike } ],
|
||||
code_no_comments
|
||||
=> [ { DONT_MATCH => $comment },
|
||||
$ncws, { DONT_MATCH => $pod_or_DATA }, $variable,
|
||||
$id, { DONT_MATCH => \&extract_quotelike } ],
|
||||
executable => [ $ws, { DONT_MATCH => $pod_or_DATA } ],
|
||||
executable_no_comments
|
||||
=> [ { DONT_MATCH => $comment },
|
||||
$ncws, { DONT_MATCH => $pod_or_DATA } ],
|
||||
all => [ { MATCH => qr/(?s:.*)/ } ],
|
||||
);
|
||||
|
||||
my %selector_for = (
|
||||
all => sub { my ($t)=@_; sub{ $_=$$_; $t->(@_); $_} },
|
||||
executable=> sub { my ($t)=@_; sub{ref() ? $_=$$_ : $t->(@_); $_} },
|
||||
executable_no_comments=> sub { my ($t)=@_; sub{ref() ? $_=$$_ : $t->(@_); $_} },
|
||||
quotelike => sub { my ($t)=@_; sub{ref() && do{$_=$$_; $t->(@_)}; $_} },
|
||||
regex => sub { my ($t)=@_;
|
||||
sub{ref() or return $_;
|
||||
my ($ql,undef,$pre,$op,$ld,$pat) = @$_;
|
||||
return $_->[0] unless $op =~ /^(qr|m|s)/
|
||||
|| !$op && ($ld eq '/' || $ld eq '?');
|
||||
$_ = $pat;
|
||||
$t->(@_);
|
||||
$ql =~ s/^(\s*\Q$op\E\s*\Q$ld\E)\Q$pat\E/$1$_/;
|
||||
return "$pre$ql";
|
||||
};
|
||||
},
|
||||
string => sub { my ($t)=@_;
|
||||
sub{ref() or return $_;
|
||||
local *args = \@_;
|
||||
my ($pre,$op,$ld1,$str1,$rd1,$ld2,$str2,$rd2,$flg) = @{$_}[2..10];
|
||||
return $_->[0] if $op =~ /^(qr|m)/
|
||||
|| !$op && ($ld1 eq '/' || $ld1 eq '?');
|
||||
if (!$op || $op eq 'tr' || $op eq 'y') {
|
||||
local *_ = \$str1;
|
||||
$t->(@args);
|
||||
}
|
||||
if ($op =~ /^(tr|y|s)/) {
|
||||
local *_ = \$str2;
|
||||
$t->(@args);
|
||||
}
|
||||
my $result = "$pre$op$ld1$str1$rd1";
|
||||
$result .= $ld2 if $ld1 =~ m/[[({<]/; #])}>
|
||||
$result .= "$str2$rd2$flg";
|
||||
return $result;
|
||||
};
|
||||
},
|
||||
);
|
||||
|
||||
|
||||
sub gen_std_filter_for {
|
||||
my ($type, $transform) = @_;
|
||||
return sub {
|
||||
my $instr;
|
||||
local @components;
|
||||
for (extract_multiple($_,$extractor_for{$type})) {
|
||||
if (ref()) { push @components, $_; $instr=0 }
|
||||
elsif ($instr) { $components[-1] .= $_ }
|
||||
else { push @components, $_; $instr=1 }
|
||||
}
|
||||
if ($type =~ /^code/) {
|
||||
my $count = 0;
|
||||
local $placeholder = qr/\Q$;\E(.{4})\Q$;\E/s;
|
||||
my $extractor = qr/\Q$;\E(.{4})\Q$;\E/s;
|
||||
$_ = join "",
|
||||
map { ref $_ ? $;.pack('N',$count++).$; : $_ }
|
||||
@components;
|
||||
@components = grep { ref $_ } @components;
|
||||
$transform->(@_);
|
||||
s/$extractor/${$components[unpack('N',$1)]}/g;
|
||||
}
|
||||
else {
|
||||
my $selector = $selector_for{$type}->($transform);
|
||||
$_ = join "", map $selector->(@_), @components;
|
||||
}
|
||||
}
|
||||
};
|
||||
|
||||
sub FILTER (&;$) {
|
||||
my $caller = caller;
|
||||
my ($filter, $terminator) = @_;
|
||||
no warnings 'redefine';
|
||||
*{"${caller}::import"} = gen_filter_import($caller,$filter,$terminator);
|
||||
*{"${caller}::unimport"} = gen_filter_unimport($caller);
|
||||
}
|
||||
|
||||
sub FILTER_ONLY {
|
||||
my $caller = caller;
|
||||
while (@_ > 1) {
|
||||
my ($what, $how) = splice(@_, 0, 2);
|
||||
fail "Unknown selector: $what"
|
||||
unless exists $extractor_for{$what};
|
||||
fail "Filter for $what is not a subroutine reference"
|
||||
unless ref $how eq 'CODE';
|
||||
push @transforms, gen_std_filter_for($what,$how);
|
||||
}
|
||||
my $terminator = shift;
|
||||
|
||||
my $multitransform = sub {
|
||||
foreach my $transform ( @transforms ) {
|
||||
$transform->(@_);
|
||||
}
|
||||
};
|
||||
no warnings 'redefine';
|
||||
*{"${caller}::import"} =
|
||||
gen_filter_import($caller,$multitransform,$terminator);
|
||||
*{"${caller}::unimport"} = gen_filter_unimport($caller);
|
||||
}
|
||||
|
||||
my $ows = qr/(?:[ \t]+|#[^\n]*)*/;
|
||||
|
||||
sub gen_filter_import {
|
||||
my ($class, $filter, $terminator) = @_;
|
||||
my %terminator;
|
||||
my $prev_import = *{$class."::import"}{CODE};
|
||||
return sub {
|
||||
my ($imported_class, @args) = @_;
|
||||
my $def_terminator =
|
||||
qr/^(?:\s*no\s+$imported_class\s*;$ows|__(?:END|DATA)__)\r?$/;
|
||||
if (!defined $terminator) {
|
||||
$terminator{terminator} = $def_terminator;
|
||||
}
|
||||
elsif (!ref $terminator || ref $terminator eq 'Regexp') {
|
||||
$terminator{terminator} = $terminator;
|
||||
}
|
||||
elsif (ref $terminator ne 'HASH') {
|
||||
croak "Terminator must be specified as scalar or hash ref"
|
||||
}
|
||||
elsif (!exists $terminator->{terminator}) {
|
||||
$terminator{terminator} = $def_terminator;
|
||||
}
|
||||
filter_add(
|
||||
sub {
|
||||
my ($status, $lastline);
|
||||
my $count = 0;
|
||||
my $data = "";
|
||||
while ($status = filter_read()) {
|
||||
return $status if $status < 0;
|
||||
if ($terminator{terminator} &&
|
||||
m/$terminator{terminator}/) {
|
||||
$lastline = $_;
|
||||
$count++;
|
||||
last;
|
||||
}
|
||||
$data .= $_;
|
||||
$count++;
|
||||
$_ = "";
|
||||
}
|
||||
return $count if not $count;
|
||||
$_ = $data;
|
||||
$filter->($imported_class, @args) unless $status < 0;
|
||||
if (defined $lastline) {
|
||||
if (defined $terminator{becomes}) {
|
||||
$_ .= $terminator{becomes};
|
||||
}
|
||||
elsif ($lastline =~ $def_terminator) {
|
||||
$_ .= $lastline;
|
||||
}
|
||||
}
|
||||
return $count;
|
||||
}
|
||||
);
|
||||
if ($prev_import) {
|
||||
goto &$prev_import;
|
||||
}
|
||||
elsif ($class->isa('Exporter')) {
|
||||
$class->export_to_level(1,@_);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub gen_filter_unimport {
|
||||
my ($class) = @_;
|
||||
return sub {
|
||||
filter_del();
|
||||
goto &$prev_unimport if $prev_unimport;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Filter::Simple - Simplified source filtering
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# in MyFilter.pm:
|
||||
|
||||
package MyFilter;
|
||||
|
||||
use Filter::Simple;
|
||||
|
||||
FILTER { ... };
|
||||
|
||||
# or just:
|
||||
#
|
||||
# use Filter::Simple sub { ... };
|
||||
|
||||
# in user's code:
|
||||
|
||||
use MyFilter;
|
||||
|
||||
# this code is filtered
|
||||
|
||||
no MyFilter;
|
||||
|
||||
# this code is not
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
=head2 The Problem
|
||||
|
||||
Source filtering is an immensely powerful feature of recent versions of Perl.
|
||||
It allows one to extend the language itself (e.g. the Switch module), to
|
||||
simplify the language (e.g. Language::Pythonesque), or to completely recast the
|
||||
language (e.g. Lingua::Romana::Perligata). Effectively, it allows one to use
|
||||
the full power of Perl as its own, recursively applied, macro language.
|
||||
|
||||
The excellent Filter::Util::Call module (by Paul Marquess) provides a
|
||||
usable Perl interface to source filtering, but it is often too powerful
|
||||
and not nearly as simple as it could be.
|
||||
|
||||
To use the module it is necessary to do the following:
|
||||
|
||||
=over 4
|
||||
|
||||
=item 1.
|
||||
|
||||
Download, build, and install the Filter::Util::Call module.
|
||||
(If you have Perl 5.7.1 or later, this is already done for you.)
|
||||
|
||||
=item 2.
|
||||
|
||||
Set up a module that does a C<use Filter::Util::Call>.
|
||||
|
||||
=item 3.
|
||||
|
||||
Within that module, create an C<import> subroutine.
|
||||
|
||||
=item 4.
|
||||
|
||||
Within the C<import> subroutine do a call to C<filter_add>, passing
|
||||
it either a subroutine reference.
|
||||
|
||||
=item 5.
|
||||
|
||||
Within the subroutine reference, call C<filter_read> or C<filter_read_exact>
|
||||
to "prime" $_ with source code data from the source file that will
|
||||
C<use> your module. Check the status value returned to see if any
|
||||
source code was actually read in.
|
||||
|
||||
=item 6.
|
||||
|
||||
Process the contents of $_ to change the source code in the desired manner.
|
||||
|
||||
=item 7.
|
||||
|
||||
Return the status value.
|
||||
|
||||
=item 8.
|
||||
|
||||
If the act of unimporting your module (via a C<no>) should cause source
|
||||
code filtering to cease, create an C<unimport> subroutine, and have it call
|
||||
C<filter_del>. Make sure that the call to C<filter_read> or
|
||||
C<filter_read_exact> in step 5 will not accidentally read past the
|
||||
C<no>. Effectively this limits source code filters to line-by-line
|
||||
operation, unless the C<import> subroutine does some fancy
|
||||
pre-pre-parsing of the source code it's filtering.
|
||||
|
||||
=back
|
||||
|
||||
For example, here is a minimal source code filter in a module named
|
||||
BANG.pm. It simply converts every occurrence of the sequence C<BANG\s+BANG>
|
||||
to the sequence C<die 'BANG' if $BANG> in any piece of code following a
|
||||
C<use BANG;> statement (until the next C<no BANG;> statement, if any):
|
||||
|
||||
package BANG;
|
||||
|
||||
use Filter::Util::Call ;
|
||||
|
||||
sub import {
|
||||
filter_add( sub {
|
||||
my $caller = caller;
|
||||
my ($status, $no_seen, $data);
|
||||
while ($status = filter_read()) {
|
||||
if (/^\s*no\s+$caller\s*;\s*?$/) {
|
||||
$no_seen=1;
|
||||
last;
|
||||
}
|
||||
$data .= $_;
|
||||
$_ = "";
|
||||
}
|
||||
$_ = $data;
|
||||
s/BANG\s+BANG/die 'BANG' if \$BANG/g
|
||||
unless $status < 0;
|
||||
$_ .= "no $class;\n" if $no_seen;
|
||||
return 1;
|
||||
})
|
||||
}
|
||||
|
||||
sub unimport {
|
||||
filter_del();
|
||||
}
|
||||
|
||||
1 ;
|
||||
|
||||
This level of sophistication puts filtering out of the reach of
|
||||
many programmers.
|
||||
|
||||
|
||||
=head2 A Solution
|
||||
|
||||
The Filter::Simple module provides a simplified interface to
|
||||
Filter::Util::Call; one that is sufficient for most common cases.
|
||||
|
||||
Instead of the above process, with Filter::Simple the task of setting up
|
||||
a source code filter is reduced to:
|
||||
|
||||
=over 4
|
||||
|
||||
=item 1.
|
||||
|
||||
Download and install the Filter::Simple module.
|
||||
(If you have Perl 5.7.1 or later, this is already done for you.)
|
||||
|
||||
=item 2.
|
||||
|
||||
Set up a module that does a C<use Filter::Simple> and then
|
||||
calls C<FILTER { ... }>.
|
||||
|
||||
=item 3.
|
||||
|
||||
Within the anonymous subroutine or block that is passed to
|
||||
C<FILTER>, process the contents of $_ to change the source code in
|
||||
the desired manner.
|
||||
|
||||
=back
|
||||
|
||||
In other words, the previous example, would become:
|
||||
|
||||
package BANG;
|
||||
use Filter::Simple;
|
||||
|
||||
FILTER {
|
||||
s/BANG\s+BANG/die 'BANG' if \$BANG/g;
|
||||
};
|
||||
|
||||
1 ;
|
||||
|
||||
Note that the source code is passed as a single string, so any regex that
|
||||
uses C<^> or C<$> to detect line boundaries will need the C</m> flag.
|
||||
|
||||
=head2 Disabling or changing <no> behaviour
|
||||
|
||||
By default, the installed filter only filters up to a line consisting of one of
|
||||
the three standard source "terminators":
|
||||
|
||||
no ModuleName; # optional comment
|
||||
|
||||
or:
|
||||
|
||||
__END__
|
||||
|
||||
or:
|
||||
|
||||
__DATA__
|
||||
|
||||
but this can be altered by passing a second argument to C<use Filter::Simple>
|
||||
or C<FILTER> (just remember: there's I<no> comma after the initial block when
|
||||
you use C<FILTER>).
|
||||
|
||||
That second argument may be either a C<qr>'d regular expression (which is then
|
||||
used to match the terminator line), or a defined false value (which indicates
|
||||
that no terminator line should be looked for), or a reference to a hash
|
||||
(in which case the terminator is the value associated with the key
|
||||
C<'terminator'>.
|
||||
|
||||
For example, to cause the previous filter to filter only up to a line of the
|
||||
form:
|
||||
|
||||
GNAB esu;
|
||||
|
||||
you would write:
|
||||
|
||||
package BANG;
|
||||
use Filter::Simple;
|
||||
|
||||
FILTER {
|
||||
s/BANG\s+BANG/die 'BANG' if \$BANG/g;
|
||||
}
|
||||
qr/^\s*GNAB\s+esu\s*;\s*?$/;
|
||||
|
||||
or:
|
||||
|
||||
FILTER {
|
||||
s/BANG\s+BANG/die 'BANG' if \$BANG/g;
|
||||
}
|
||||
{ terminator => qr/^\s*GNAB\s+esu\s*;\s*?$/ };
|
||||
|
||||
and to prevent the filter's being turned off in any way:
|
||||
|
||||
package BANG;
|
||||
use Filter::Simple;
|
||||
|
||||
FILTER {
|
||||
s/BANG\s+BANG/die 'BANG' if \$BANG/g;
|
||||
}
|
||||
""; # or: 0
|
||||
|
||||
or:
|
||||
|
||||
FILTER {
|
||||
s/BANG\s+BANG/die 'BANG' if \$BANG/g;
|
||||
}
|
||||
{ terminator => "" };
|
||||
|
||||
B<Note that, no matter what you set the terminator pattern to,
|
||||
the actual terminator itself I<must> be contained on a single source line.>
|
||||
|
||||
|
||||
=head2 All-in-one interface
|
||||
|
||||
Separating the loading of Filter::Simple:
|
||||
|
||||
use Filter::Simple;
|
||||
|
||||
from the setting up of the filtering:
|
||||
|
||||
FILTER { ... };
|
||||
|
||||
is useful because it allows other code (typically parser support code
|
||||
or caching variables) to be defined before the filter is invoked.
|
||||
However, there is often no need for such a separation.
|
||||
|
||||
In those cases, it is easier to just append the filtering subroutine and
|
||||
any terminator specification directly to the C<use> statement that loads
|
||||
Filter::Simple, like so:
|
||||
|
||||
use Filter::Simple sub {
|
||||
s/BANG\s+BANG/die 'BANG' if \$BANG/g;
|
||||
};
|
||||
|
||||
This is exactly the same as:
|
||||
|
||||
use Filter::Simple;
|
||||
BEGIN {
|
||||
Filter::Simple::FILTER {
|
||||
s/BANG\s+BANG/die 'BANG' if \$BANG/g;
|
||||
};
|
||||
}
|
||||
|
||||
except that the C<FILTER> subroutine is not exported by Filter::Simple.
|
||||
|
||||
|
||||
=head2 Filtering only specific components of source code
|
||||
|
||||
One of the problems with a filter like:
|
||||
|
||||
use Filter::Simple;
|
||||
|
||||
FILTER { s/BANG\s+BANG/die 'BANG' if \$BANG/g };
|
||||
|
||||
is that it indiscriminately applies the specified transformation to
|
||||
the entire text of your source program. So something like:
|
||||
|
||||
warn 'BANG BANG, YOU'RE DEAD';
|
||||
BANG BANG;
|
||||
|
||||
will become:
|
||||
|
||||
warn 'die 'BANG' if $BANG, YOU'RE DEAD';
|
||||
die 'BANG' if $BANG;
|
||||
|
||||
It is very common when filtering source to only want to apply the filter
|
||||
to the non-character-string parts of the code, or alternatively to I<only>
|
||||
the character strings.
|
||||
|
||||
Filter::Simple supports this type of filtering by automatically
|
||||
exporting the C<FILTER_ONLY> subroutine.
|
||||
|
||||
C<FILTER_ONLY> takes a sequence of specifiers that install separate
|
||||
(and possibly multiple) filters that act on only parts of the source code.
|
||||
For example:
|
||||
|
||||
use Filter::Simple;
|
||||
|
||||
FILTER_ONLY
|
||||
code => sub { s/BANG\s+BANG/die 'BANG' if \$BANG/g },
|
||||
quotelike => sub { s/BANG\s+BANG/CHITTY CHITTY/g };
|
||||
|
||||
The C<"code"> subroutine will only be used to filter parts of the source
|
||||
code that are not quotelikes, POD, or C<__DATA__>. The C<quotelike>
|
||||
subroutine only filters Perl quotelikes (including here documents).
|
||||
|
||||
The full list of alternatives is:
|
||||
|
||||
=over
|
||||
|
||||
=item C<"code">
|
||||
|
||||
Filters only those sections of the source code that are not quotelikes, POD, or
|
||||
C<__DATA__>.
|
||||
|
||||
=item C<"code_no_comments">
|
||||
|
||||
Filters only those sections of the source code that are not quotelikes, POD,
|
||||
comments, or C<__DATA__>.
|
||||
|
||||
=item C<"executable">
|
||||
|
||||
Filters only those sections of the source code that are not POD or C<__DATA__>.
|
||||
|
||||
=item C<"executable_no_comments">
|
||||
|
||||
Filters only those sections of the source code that are not POD, comments, or C<__DATA__>.
|
||||
|
||||
=item C<"quotelike">
|
||||
|
||||
Filters only Perl quotelikes (as interpreted by
|
||||
C<&Text::Balanced::extract_quotelike>).
|
||||
|
||||
=item C<"string">
|
||||
|
||||
Filters only the string literal parts of a Perl quotelike (i.e. the
|
||||
contents of a string literal, either half of a C<tr///>, the second
|
||||
half of an C<s///>).
|
||||
|
||||
=item C<"regex">
|
||||
|
||||
Filters only the pattern literal parts of a Perl quotelike (i.e. the
|
||||
contents of a C<qr//> or an C<m//>, the first half of an C<s///>).
|
||||
|
||||
=item C<"all">
|
||||
|
||||
Filters everything. Identical in effect to C<FILTER>.
|
||||
|
||||
=back
|
||||
|
||||
Except for C<< FILTER_ONLY code => sub {...} >>, each of
|
||||
the component filters is called repeatedly, once for each component
|
||||
found in the source code.
|
||||
|
||||
Note that you can also apply two or more of the same type of filter in
|
||||
a single C<FILTER_ONLY>. For example, here's a simple
|
||||
macro-preprocessor that is only applied within regexes,
|
||||
with a final debugging pass that prints the resulting source code:
|
||||
|
||||
use Regexp::Common;
|
||||
FILTER_ONLY
|
||||
regex => sub { s/!\[/[^/g },
|
||||
regex => sub { s/%d/$RE{num}{int}/g },
|
||||
regex => sub { s/%f/$RE{num}{real}/g },
|
||||
all => sub { print if $::DEBUG };
|
||||
|
||||
|
||||
|
||||
=head2 Filtering only the code parts of source code
|
||||
|
||||
Most source code ceases to be grammatically correct when it is broken up
|
||||
into the pieces between string literals and regexes. So the C<'code'>
|
||||
and C<'code_no_comments'> component filter behave slightly differently
|
||||
from the other partial filters described in the previous section.
|
||||
|
||||
Rather than calling the specified processor on each individual piece of
|
||||
code (i.e. on the bits between quotelikes), the C<'code...'> partial
|
||||
filters operate on the entire source code, but with the quotelike bits
|
||||
(and, in the case of C<'code_no_comments'>, the comments) "blanked out".
|
||||
|
||||
That is, a C<'code...'> filter I<replaces> each quoted string, quotelike,
|
||||
regex, POD, and __DATA__ section with a placeholder. The
|
||||
delimiters of this placeholder are the contents of the C<$;> variable
|
||||
at the time the filter is applied (normally C<"\034">). The remaining
|
||||
four bytes are a unique identifier for the component being replaced.
|
||||
|
||||
This approach makes it comparatively easy to write code preprocessors
|
||||
without worrying about the form or contents of strings, regexes, etc.
|
||||
|
||||
For convenience, during a C<'code...'> filtering operation, Filter::Simple
|
||||
provides a package variable (C<$Filter::Simple::placeholder>) that
|
||||
contains a pre-compiled regex that matches any placeholder...and
|
||||
captures the identifier within the placeholder. Placeholders can be
|
||||
moved and re-ordered within the source code as needed.
|
||||
|
||||
In addition, a second package variable (C<@Filter::Simple::components>)
|
||||
contains a list of the various pieces of C<$_>, as they were originally split
|
||||
up to allow placeholders to be inserted.
|
||||
|
||||
Once the filtering has been applied, the original strings, regexes, POD,
|
||||
etc. are re-inserted into the code, by replacing each placeholder with
|
||||
the corresponding original component (from C<@components>). Note that
|
||||
this means that the C<@components> variable must be treated with extreme
|
||||
care within the filter. The C<@components> array stores the "back-
|
||||
translations" of each placeholder inserted into C<$_>, as well as the
|
||||
interstitial source code between placeholders. If the placeholder
|
||||
backtranslations are altered in C<@components>, they will be similarly
|
||||
changed when the placeholders are removed from C<$_> after the filter
|
||||
is complete.
|
||||
|
||||
For example, the following filter detects concatenated pairs of
|
||||
strings/quotelikes and reverses the order in which they are
|
||||
concatenated:
|
||||
|
||||
package DemoRevCat;
|
||||
use Filter::Simple;
|
||||
|
||||
FILTER_ONLY code => sub {
|
||||
my $ph = $Filter::Simple::placeholder;
|
||||
s{ ($ph) \s* [.] \s* ($ph) }{ $2.$1 }gx
|
||||
};
|
||||
|
||||
Thus, the following code:
|
||||
|
||||
use DemoRevCat;
|
||||
|
||||
my $str = "abc" . q(def);
|
||||
|
||||
print "$str\n";
|
||||
|
||||
would become:
|
||||
|
||||
my $str = q(def)."abc";
|
||||
|
||||
print "$str\n";
|
||||
|
||||
and hence print:
|
||||
|
||||
defabc
|
||||
|
||||
|
||||
=head2 Using Filter::Simple with an explicit C<import> subroutine
|
||||
|
||||
Filter::Simple generates a special C<import> subroutine for
|
||||
your module (see L<"How it works">) which would normally replace any
|
||||
C<import> subroutine you might have explicitly declared.
|
||||
|
||||
However, Filter::Simple is smart enough to notice your existing
|
||||
C<import> and Do The Right Thing with it.
|
||||
That is, if you explicitly define an C<import> subroutine in a package
|
||||
that's using Filter::Simple, that C<import> subroutine will still
|
||||
be invoked immediately after any filter you install.
|
||||
|
||||
The only thing you have to remember is that the C<import> subroutine
|
||||
I<must> be declared I<before> the filter is installed. If you use C<FILTER>
|
||||
to install the filter:
|
||||
|
||||
package Filter::TurnItUpTo11;
|
||||
|
||||
use Filter::Simple;
|
||||
|
||||
FILTER { s/(\w+)/\U$1/ };
|
||||
|
||||
that will almost never be a problem, but if you install a filtering
|
||||
subroutine by passing it directly to the C<use Filter::Simple>
|
||||
statement:
|
||||
|
||||
package Filter::TurnItUpTo11;
|
||||
|
||||
use Filter::Simple sub{ s/(\w+)/\U$1/ };
|
||||
|
||||
then you must make sure that your C<import> subroutine appears before
|
||||
that C<use> statement.
|
||||
|
||||
|
||||
=head2 Using Filter::Simple and Exporter together
|
||||
|
||||
Likewise, Filter::Simple is also smart enough
|
||||
to Do The Right Thing if you use Exporter:
|
||||
|
||||
package Switch;
|
||||
use base Exporter;
|
||||
use Filter::Simple;
|
||||
|
||||
@EXPORT = qw(switch case);
|
||||
@EXPORT_OK = qw(given when);
|
||||
|
||||
FILTER { $_ = magic_Perl_filter($_) }
|
||||
|
||||
Immediately after the filter has been applied to the source,
|
||||
Filter::Simple will pass control to Exporter, so it can do its magic too.
|
||||
|
||||
Of course, here too, Filter::Simple has to know you're using Exporter
|
||||
before it applies the filter. That's almost never a problem, but if you're
|
||||
nervous about it, you can guarantee that things will work correctly by
|
||||
ensuring that your C<use base Exporter> always precedes your
|
||||
C<use Filter::Simple>.
|
||||
|
||||
|
||||
=head2 How it works
|
||||
|
||||
The Filter::Simple module exports into the package that calls C<FILTER>
|
||||
(or C<use>s it directly) -- such as package "BANG" in the above example --
|
||||
two automagically constructed
|
||||
subroutines -- C<import> and C<unimport> -- which take care of all the
|
||||
nasty details.
|
||||
|
||||
In addition, the generated C<import> subroutine passes its own argument
|
||||
list to the filtering subroutine, so the BANG.pm filter could easily
|
||||
be made parametric:
|
||||
|
||||
package BANG;
|
||||
|
||||
use Filter::Simple;
|
||||
|
||||
FILTER {
|
||||
my ($die_msg, $var_name) = @_;
|
||||
s/BANG\s+BANG/die '$die_msg' if \${$var_name}/g;
|
||||
};
|
||||
|
||||
# and in some user code:
|
||||
|
||||
use BANG "BOOM", "BAM"; # "BANG BANG" becomes: die 'BOOM' if $BAM
|
||||
|
||||
|
||||
The specified filtering subroutine is called every time a C<use BANG> is
|
||||
encountered, and passed all the source code following that call, up to
|
||||
either the next C<no BANG;> (or whatever terminator you've set) or the
|
||||
end of the source file, whichever occurs first. By default, any C<no
|
||||
BANG;> call must appear by itself on a separate line, or it is ignored.
|
||||
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Damian Conway
|
||||
|
||||
=head1 CONTACT
|
||||
|
||||
Filter::Simple is now maintained by the Perl5-Porters.
|
||||
Please submit bug via the C<perlbug> tool that comes with your perl.
|
||||
For usage instructions, read C<perldoc perlbug> or possibly C<man perlbug>.
|
||||
For mostly anything else, please contact E<lt>perl5-porters@perl.orgE<gt>.
|
||||
|
||||
Maintainer of the CPAN release is Steffen Mueller E<lt>smueller@cpan.orgE<gt>.
|
||||
Contact him with technical difficulties with respect to the packaging of the
|
||||
CPAN module.
|
||||
|
||||
Praise of the module, flowers, and presents still go to the author,
|
||||
Damian Conway E<lt>damian@conway.orgE<gt>.
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright (c) 2000-2014, Damian Conway. All Rights Reserved.
|
||||
This module is free software. It may be used, redistributed
|
||||
and/or modified under the same terms as Perl itself.
|
||||
@@ -0,0 +1,171 @@
|
||||
# FindBin.pm
|
||||
#
|
||||
# Copyright (c) 1995 Graham Barr & Nick Ing-Simmons. All rights reserved.
|
||||
# This program is free software; you can redistribute it and/or modify it
|
||||
# under the same terms as Perl itself.
|
||||
|
||||
=head1 NAME
|
||||
|
||||
FindBin - Locate directory of original perl script
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use FindBin;
|
||||
use lib "$FindBin::Bin/../lib";
|
||||
|
||||
or
|
||||
|
||||
use FindBin qw($Bin);
|
||||
use lib "$Bin/../lib";
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Locates the full path to the script bin directory to allow the use
|
||||
of paths relative to the bin directory.
|
||||
|
||||
This allows a user to setup a directory tree for some software with
|
||||
directories C<< <root>/bin >> and C<< <root>/lib >>, and then the above
|
||||
example will allow the use of modules in the lib directory without knowing
|
||||
where the software tree is installed.
|
||||
|
||||
If perl is invoked using the B<-e> option or the perl script is read from
|
||||
C<STDIN> then FindBin sets both C<$Bin> and C<$RealBin> to the current
|
||||
directory.
|
||||
|
||||
=head1 EXPORTABLE VARIABLES
|
||||
|
||||
$Bin - path to bin directory from where script was invoked
|
||||
$Script - basename of script from which perl was invoked
|
||||
$RealBin - $Bin with all links resolved
|
||||
$RealScript - $Script with all links resolved
|
||||
|
||||
=head1 KNOWN ISSUES
|
||||
|
||||
If there are two modules using C<FindBin> from different directories
|
||||
under the same interpreter, this won't work. Since C<FindBin> uses a
|
||||
C<BEGIN> block, it'll be executed only once, and only the first caller
|
||||
will get it right. This is a problem under mod_perl and other persistent
|
||||
Perl environments, where you shouldn't use this module. Which also means
|
||||
that you should avoid using C<FindBin> in modules that you plan to put
|
||||
on CPAN. To make sure that C<FindBin> will work is to call the C<again>
|
||||
function:
|
||||
|
||||
use FindBin;
|
||||
FindBin::again(); # or FindBin->again;
|
||||
|
||||
In former versions of FindBin there was no C<again> function. The
|
||||
workaround was to force the C<BEGIN> block to be executed again:
|
||||
|
||||
delete $INC{'FindBin.pm'};
|
||||
require FindBin;
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
FindBin is supported as part of the core perl distribution. Please submit bug
|
||||
reports at L<https://github.com/Perl/perl5/issues>.
|
||||
|
||||
Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
|
||||
Nick Ing-Simmons E<lt>F<nik@tiuk.ti.com>E<gt>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 1995 Graham Barr & Nick Ing-Simmons. All rights reserved.
|
||||
This program is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
package FindBin;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Carp;
|
||||
require Exporter;
|
||||
use Cwd qw(getcwd cwd abs_path);
|
||||
use File::Basename;
|
||||
use File::Spec;
|
||||
|
||||
our ($Bin, $Script, $RealBin, $RealScript, $Dir, $RealDir);
|
||||
our @EXPORT_OK = qw($Bin $Script $RealBin $RealScript $Dir $RealDir);
|
||||
our %EXPORT_TAGS = (ALL => [qw($Bin $Script $RealBin $RealScript $Dir $RealDir)]);
|
||||
our @ISA = qw(Exporter);
|
||||
|
||||
our $VERSION = "1.53";
|
||||
|
||||
# needed for VMS-specific filename translation
|
||||
if( $^O eq 'VMS' ) {
|
||||
require VMS::Filespec;
|
||||
VMS::Filespec->import;
|
||||
}
|
||||
|
||||
sub cwd2 {
|
||||
my $cwd = getcwd();
|
||||
# getcwd might fail if it hasn't access to the current directory.
|
||||
# try harder.
|
||||
defined $cwd or $cwd = cwd();
|
||||
$cwd;
|
||||
}
|
||||
|
||||
sub init
|
||||
{
|
||||
*Dir = \$Bin;
|
||||
*RealDir = \$RealBin;
|
||||
|
||||
if($0 eq '-e' || $0 eq '-')
|
||||
{
|
||||
# perl invoked with -e or script is on C<STDIN>
|
||||
$Script = $RealScript = $0;
|
||||
$Bin = $RealBin = cwd2();
|
||||
$Bin = VMS::Filespec::unixify($Bin) if $^O eq 'VMS';
|
||||
}
|
||||
else
|
||||
{
|
||||
my $script = $0;
|
||||
|
||||
if ($^O eq 'VMS')
|
||||
{
|
||||
($Bin,$Script) = VMS::Filespec::rmsexpand($0) =~ /(.*[\]>\/]+)(.*)/s;
|
||||
# C<use disk:[dev]/lib> isn't going to work, so unixify first
|
||||
($Bin = VMS::Filespec::unixify($Bin)) =~ s/\/\z//;
|
||||
($RealBin,$RealScript) = ($Bin,$Script);
|
||||
}
|
||||
else
|
||||
{
|
||||
croak("Cannot find current script '$0'") unless(-f $script);
|
||||
|
||||
# Ensure $script contains the complete path in case we C<chdir>
|
||||
|
||||
$script = File::Spec->catfile(cwd2(), $script)
|
||||
unless File::Spec->file_name_is_absolute($script);
|
||||
|
||||
($Script,$Bin) = fileparse($script);
|
||||
|
||||
# Resolve $script if it is a link
|
||||
while(1)
|
||||
{
|
||||
my $linktext = readlink($script);
|
||||
|
||||
($RealScript,$RealBin) = fileparse($script);
|
||||
last unless defined $linktext;
|
||||
|
||||
$script = (File::Spec->file_name_is_absolute($linktext))
|
||||
? $linktext
|
||||
: File::Spec->catfile($RealBin, $linktext);
|
||||
}
|
||||
|
||||
# Get absolute paths to directories
|
||||
if ($Bin) {
|
||||
my $BinOld = $Bin;
|
||||
$Bin = abs_path($Bin);
|
||||
defined $Bin or $Bin = File::Spec->canonpath($BinOld);
|
||||
}
|
||||
$RealBin = abs_path($RealBin) if($RealBin);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
BEGIN { init }
|
||||
|
||||
*again = \&init;
|
||||
|
||||
1; # Keep require happy
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,312 @@
|
||||
package Getopt::Std;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
require Exporter;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Getopt::Std - Process single-character switches with switch clustering
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Getopt::Std;
|
||||
|
||||
getopts('oif:'); # -o & -i are boolean flags, -f takes an argument
|
||||
# Sets $opt_* as a side effect.
|
||||
getopts('oif:', \%opts); # options as above. Values in %opts
|
||||
getopt('oDI'); # -o, -D & -I take arg.
|
||||
# Sets $opt_* as a side effect.
|
||||
getopt('oDI', \%opts); # -o, -D & -I take arg. Values in %opts
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The C<getopts()> function processes single-character switches with switch
|
||||
clustering. Pass one argument which is a string containing all switches to be
|
||||
recognized. For each switch found, if an argument is expected and provided,
|
||||
C<getopts()> sets C<$opt_x> (where C<x> is the switch name) to the value of
|
||||
the argument. If an argument is expected but none is provided, C<$opt_x> is
|
||||
set to an undefined value. If a switch does not take an argument, C<$opt_x>
|
||||
is set to C<1>.
|
||||
|
||||
Switches which take an argument don't care whether there is a space between
|
||||
the switch and the argument. If unspecified switches are found on the
|
||||
command-line, the user will be warned that an unknown option was given.
|
||||
|
||||
The C<getopts()> function returns true unless an invalid option was found.
|
||||
|
||||
The C<getopt()> function is similar, but its argument is a string containing
|
||||
all switches that take an argument. If no argument is provided for a switch,
|
||||
say, C<y>, the corresponding C<$opt_y> will be set to an undefined value.
|
||||
Unspecified switches are silently accepted. Use of C<getopt()> is not
|
||||
recommended.
|
||||
|
||||
Note that, if your code is running under the recommended C<use strict
|
||||
vars> pragma, you will need to declare these package variables
|
||||
with C<our>:
|
||||
|
||||
our($opt_x, $opt_y);
|
||||
|
||||
For those of you who don't like additional global variables being created,
|
||||
C<getopt()> and C<getopts()> will also accept a hash reference as an optional
|
||||
second argument. Hash keys will be C<x> (where C<x> is the switch name) with
|
||||
key values the value of the argument or C<1> if no argument is specified.
|
||||
|
||||
To allow programs to process arguments that look like switches, but aren't,
|
||||
both functions will stop processing switches when they see the argument
|
||||
C<-->. The C<--> will be removed from @ARGV.
|
||||
|
||||
=head1 C<--help> and C<--version>
|
||||
|
||||
If C<-> is not a recognized switch letter, getopts() supports arguments
|
||||
C<--help> and C<--version>. If C<main::HELP_MESSAGE()> and/or
|
||||
C<main::VERSION_MESSAGE()> are defined, they are called; the arguments are
|
||||
the output file handle, the name of option-processing package, its version,
|
||||
and the switches string. If the subroutines are not defined, an attempt is
|
||||
made to generate intelligent messages; for best results, define $main::VERSION.
|
||||
|
||||
If embedded documentation (in pod format, see L<perlpod>) is detected
|
||||
in the script, C<--help> will also show how to access the documentation.
|
||||
|
||||
Note that due to excessive paranoia, if $Getopt::Std::STANDARD_HELP_VERSION
|
||||
isn't true (the default is false), then the messages are printed on STDERR,
|
||||
and the processing continues after the messages are printed. This being
|
||||
the opposite of the standard-conforming behaviour, it is strongly recommended
|
||||
to set $Getopt::Std::STANDARD_HELP_VERSION to true.
|
||||
|
||||
One can change the output file handle of the messages by setting
|
||||
$Getopt::Std::OUTPUT_HELP_VERSION. One can print the messages of C<--help>
|
||||
(without the C<Usage:> line) and C<--version> by calling functions help_mess()
|
||||
and version_mess() with the switches string as an argument.
|
||||
|
||||
=cut
|
||||
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT = qw(getopt getopts);
|
||||
our $VERSION = '1.13';
|
||||
# uncomment the next line to disable 1.03-backward compatibility paranoia
|
||||
# $STANDARD_HELP_VERSION = 1;
|
||||
|
||||
# Process single-character switches with switch clustering. Pass one argument
|
||||
# which is a string containing all switches that take an argument. For each
|
||||
# switch found, sets $opt_x (where x is the switch name) to the value of the
|
||||
# argument, or 1 if no argument. Switches which take an argument don't care
|
||||
# whether there is a space between the switch and the argument.
|
||||
|
||||
# Usage:
|
||||
# getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect.
|
||||
|
||||
sub getopt (;$$) {
|
||||
my ($argumentative, $hash) = @_;
|
||||
$argumentative = '' if !defined $argumentative;
|
||||
my ($first,$rest);
|
||||
local $_;
|
||||
local @EXPORT;
|
||||
|
||||
while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
|
||||
($first,$rest) = ($1,$2);
|
||||
if (/^--$/) { # early exit if --
|
||||
shift @ARGV;
|
||||
last;
|
||||
}
|
||||
if (index($argumentative,$first) >= 0) {
|
||||
if ($rest ne '') {
|
||||
shift(@ARGV);
|
||||
}
|
||||
else {
|
||||
shift(@ARGV);
|
||||
$rest = shift(@ARGV);
|
||||
}
|
||||
if (ref $hash) {
|
||||
$$hash{$first} = $rest;
|
||||
}
|
||||
else {
|
||||
no strict 'refs';
|
||||
${"opt_$first"} = $rest;
|
||||
push( @EXPORT, "\$opt_$first" );
|
||||
}
|
||||
}
|
||||
else {
|
||||
if (ref $hash) {
|
||||
$$hash{$first} = 1;
|
||||
}
|
||||
else {
|
||||
no strict 'refs';
|
||||
${"opt_$first"} = 1;
|
||||
push( @EXPORT, "\$opt_$first" );
|
||||
}
|
||||
if ($rest ne '') {
|
||||
$ARGV[0] = "-$rest";
|
||||
}
|
||||
else {
|
||||
shift(@ARGV);
|
||||
}
|
||||
}
|
||||
}
|
||||
unless (ref $hash) {
|
||||
local $Exporter::ExportLevel = 1;
|
||||
import Getopt::Std;
|
||||
}
|
||||
}
|
||||
|
||||
our ($OUTPUT_HELP_VERSION, $STANDARD_HELP_VERSION);
|
||||
sub output_h () {
|
||||
return $OUTPUT_HELP_VERSION if defined $OUTPUT_HELP_VERSION;
|
||||
return \*STDOUT if $STANDARD_HELP_VERSION;
|
||||
return \*STDERR;
|
||||
}
|
||||
|
||||
sub try_exit () {
|
||||
exit 0 if $STANDARD_HELP_VERSION;
|
||||
my $p = __PACKAGE__;
|
||||
print {output_h()} <<EOM;
|
||||
[Now continuing due to backward compatibility and excessive paranoia.
|
||||
See 'perldoc $p' about \$$p\::STANDARD_HELP_VERSION.]
|
||||
EOM
|
||||
}
|
||||
|
||||
sub version_mess ($;$) {
|
||||
my $args = shift;
|
||||
my $h = output_h;
|
||||
if (@_ and defined &main::VERSION_MESSAGE) {
|
||||
main::VERSION_MESSAGE($h, __PACKAGE__, $VERSION, $args);
|
||||
} else {
|
||||
my $v = $main::VERSION;
|
||||
$v = '[unknown]' unless defined $v;
|
||||
my $myv = $VERSION;
|
||||
$myv .= ' [paranoid]' unless $STANDARD_HELP_VERSION;
|
||||
my $perlv = $];
|
||||
$perlv = sprintf "%vd", $^V if $] >= 5.006;
|
||||
print $h <<EOH;
|
||||
$0 version $v calling Getopt::Std::getopts (version $myv),
|
||||
running under Perl version $perlv.
|
||||
EOH
|
||||
}
|
||||
}
|
||||
|
||||
sub help_mess ($;$) {
|
||||
my $args = shift;
|
||||
my $h = output_h;
|
||||
if (@_ and defined &main::HELP_MESSAGE) {
|
||||
main::HELP_MESSAGE($h, __PACKAGE__, $VERSION, $args);
|
||||
} else {
|
||||
my (@witharg) = ($args =~ /(\S)\s*:/g);
|
||||
my (@rest) = ($args =~ /([^\s:])(?!\s*:)/g);
|
||||
my ($help, $arg) = ('', '');
|
||||
if (@witharg) {
|
||||
$help .= "\n\tWith arguments: -" . join " -", @witharg;
|
||||
$arg = "\nSpace is not required between options and their arguments.";
|
||||
}
|
||||
if (@rest) {
|
||||
$help .= "\n\tBoolean (without arguments): -" . join " -", @rest;
|
||||
}
|
||||
my ($scr) = ($0 =~ m,([^/\\]+)$,);
|
||||
print $h <<EOH if @_; # Let the script override this
|
||||
|
||||
Usage: $scr [-OPTIONS [-MORE_OPTIONS]] [--] [PROGRAM_ARG1 ...]
|
||||
EOH
|
||||
print $h <<EOH;
|
||||
|
||||
The following single-character options are accepted:$help
|
||||
|
||||
Options may be merged together. -- stops processing of options.$arg
|
||||
EOH
|
||||
my $has_pod;
|
||||
if ( defined $0 and $0 ne '-e' and -f $0 and -r $0
|
||||
and open my $script, '<', $0 ) {
|
||||
while (<$script>) {
|
||||
$has_pod = 1, last if /^=(pod|head1)/;
|
||||
}
|
||||
}
|
||||
print $h <<EOH if $has_pod;
|
||||
|
||||
For more details run
|
||||
perldoc -F $0
|
||||
EOH
|
||||
}
|
||||
}
|
||||
|
||||
# Usage:
|
||||
# getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a
|
||||
# # side effect.
|
||||
|
||||
sub getopts ($;$) {
|
||||
my ($argumentative, $hash) = @_;
|
||||
my (@args,$first,$rest,$exit);
|
||||
my $errs = 0;
|
||||
local $_;
|
||||
local @EXPORT;
|
||||
|
||||
@args = split( / */, $argumentative );
|
||||
while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/s) {
|
||||
($first,$rest) = ($1,$2);
|
||||
if (/^--$/) { # early exit if --
|
||||
shift @ARGV;
|
||||
last;
|
||||
}
|
||||
my $pos = index($argumentative,$first);
|
||||
if ($pos >= 0) {
|
||||
if (defined($args[$pos+1]) and ($args[$pos+1] eq ':')) {
|
||||
shift(@ARGV);
|
||||
if ($rest eq '') {
|
||||
++$errs unless @ARGV;
|
||||
$rest = shift(@ARGV);
|
||||
}
|
||||
if (ref $hash) {
|
||||
$$hash{$first} = $rest;
|
||||
}
|
||||
else {
|
||||
no strict 'refs';
|
||||
${"opt_$first"} = $rest;
|
||||
push( @EXPORT, "\$opt_$first" );
|
||||
}
|
||||
}
|
||||
else {
|
||||
if (ref $hash) {
|
||||
$$hash{$first} = 1;
|
||||
}
|
||||
else {
|
||||
no strict 'refs';
|
||||
${"opt_$first"} = 1;
|
||||
push( @EXPORT, "\$opt_$first" );
|
||||
}
|
||||
if ($rest eq '') {
|
||||
shift(@ARGV);
|
||||
}
|
||||
else {
|
||||
$ARGV[0] = "-$rest";
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
if ($first eq '-' and $rest eq 'help') {
|
||||
version_mess($argumentative, 'main');
|
||||
help_mess($argumentative, 'main');
|
||||
try_exit();
|
||||
shift(@ARGV);
|
||||
next;
|
||||
} elsif ($first eq '-' and $rest eq 'version') {
|
||||
version_mess($argumentative, 'main');
|
||||
try_exit();
|
||||
shift(@ARGV);
|
||||
next;
|
||||
}
|
||||
warn "Unknown option: $first\n";
|
||||
++$errs;
|
||||
if ($rest ne '') {
|
||||
$ARGV[0] = "-$rest";
|
||||
}
|
||||
else {
|
||||
shift(@ARGV);
|
||||
}
|
||||
}
|
||||
}
|
||||
unless (ref $hash) {
|
||||
local $Exporter::ExportLevel = 1;
|
||||
import Getopt::Std;
|
||||
}
|
||||
$errs == 0;
|
||||
}
|
||||
|
||||
1;
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,196 @@
|
||||
package I18N::Collate;
|
||||
|
||||
use strict;
|
||||
our $VERSION = '1.02';
|
||||
|
||||
=head1 NAME
|
||||
|
||||
I18N::Collate - compare 8-bit scalar data according to the current locale
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use I18N::Collate;
|
||||
setlocale(LC_COLLATE, 'locale-of-your-choice');
|
||||
$s1 = I18N::Collate->new("scalar_data_1");
|
||||
$s2 = I18N::Collate->new("scalar_data_2");
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
***
|
||||
|
||||
WARNING: starting from the Perl version 5.003_06
|
||||
the I18N::Collate interface for comparing 8-bit scalar data
|
||||
according to the current locale
|
||||
|
||||
HAS BEEN DEPRECATED
|
||||
|
||||
That is, please do not use it anymore for any new applications
|
||||
and please migrate the old applications away from it because its
|
||||
functionality was integrated into the Perl core language in the
|
||||
release 5.003_06.
|
||||
|
||||
See the perllocale manual page for further information.
|
||||
|
||||
***
|
||||
|
||||
This module provides you with objects that will collate
|
||||
according to your national character set, provided that the
|
||||
POSIX setlocale() function is supported on your system.
|
||||
|
||||
You can compare $s1 and $s2 above with
|
||||
|
||||
$s1 le $s2
|
||||
|
||||
to extract the data itself, you'll need a dereference: $$s1
|
||||
|
||||
This module uses POSIX::setlocale(). The basic collation conversion is
|
||||
done by strxfrm() which terminates at NUL characters being a decent C
|
||||
routine. collate_xfrm() handles embedded NUL characters gracefully.
|
||||
|
||||
The available locales depend on your operating system; try whether
|
||||
C<locale -a> shows them or man pages for "locale" or "nlsinfo" or the
|
||||
direct approach C<ls /usr/lib/nls/loc> or C<ls /usr/lib/nls> or
|
||||
C<ls /usr/lib/locale>. Not all the locales that your vendor supports
|
||||
are necessarily installed: please consult your operating system's
|
||||
documentation and possibly your local system administration. The
|
||||
locale names are probably something like C<xx_XX.(ISO)?8859-N> or
|
||||
C<xx_XX.(ISO)?8859N>, for example C<fr_CH.ISO8859-1> is the Swiss (CH)
|
||||
variant of French (fr), ISO Latin (8859) 1 (-1) which is the Western
|
||||
European character set.
|
||||
|
||||
=cut
|
||||
|
||||
# I18N::Collate.pm
|
||||
#
|
||||
# Author: Jarkko Hietaniemi <F<jhi@iki.fi>>
|
||||
# Helsinki University of Technology, Finland
|
||||
#
|
||||
# Acks: Guy Decoux <F<decoux@moulon.inra.fr>> understood
|
||||
# overloading magic much deeper than I and told
|
||||
# how to cut the size of this code by more than half.
|
||||
# (my first version did overload all of lt gt eq le ge cmp)
|
||||
#
|
||||
# Purpose: compare 8-bit scalar data according to the current locale
|
||||
#
|
||||
# Requirements: Perl5 POSIX::setlocale() and POSIX::strxfrm()
|
||||
#
|
||||
# Exports: setlocale 1)
|
||||
# collate_xfrm 2)
|
||||
#
|
||||
# Overloads: cmp # 3)
|
||||
#
|
||||
# Usage: use I18N::Collate;
|
||||
# setlocale(LC_COLLATE, 'locale-of-your-choice'); # 4)
|
||||
# $s1 = I18N::Collate->("scalar_data_1");
|
||||
# $s2 = I18N::Collate->("scalar_data_2");
|
||||
#
|
||||
# now you can compare $s1 and $s2: $s1 le $s2
|
||||
# to extract the data itself, you need to deref: $$s1
|
||||
#
|
||||
# Notes:
|
||||
# 1) this uses POSIX::setlocale
|
||||
# 2) the basic collation conversion is done by strxfrm() which
|
||||
# terminates at NUL characters being a decent C routine.
|
||||
# collate_xfrm handles embedded NUL characters gracefully.
|
||||
# 3) due to cmp and overload magic, lt le eq ge gt work also
|
||||
# 4) the available locales depend on your operating system;
|
||||
# try whether "locale -a" shows them or man pages for
|
||||
# "locale" or "nlsinfo" work or the more direct
|
||||
# approach "ls /usr/lib/nls/loc" or "ls /usr/lib/nls".
|
||||
# Not all the locales that your vendor supports
|
||||
# are necessarily installed: please consult your
|
||||
# operating system's documentation.
|
||||
# The locale names are probably something like
|
||||
# 'xx_XX.(ISO)?8859-N' or 'xx_XX.(ISO)?8859N',
|
||||
# for example 'fr_CH.ISO8859-1' is the Swiss (CH)
|
||||
# variant of French (fr), ISO Latin (8859) 1 (-1)
|
||||
# which is the Western European character set.
|
||||
#
|
||||
# Updated: 19961005
|
||||
#
|
||||
# ---
|
||||
|
||||
use POSIX qw(strxfrm LC_COLLATE);
|
||||
use warnings::register;
|
||||
|
||||
require Exporter;
|
||||
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT = qw(collate_xfrm setlocale LC_COLLATE);
|
||||
our @EXPORT_OK = qw();
|
||||
|
||||
use overload qw(
|
||||
fallback 1
|
||||
cmp collate_cmp
|
||||
);
|
||||
|
||||
our($LOCALE, $C);
|
||||
|
||||
our $please_use_I18N_Collate_even_if_deprecated = 0;
|
||||
sub new {
|
||||
my $new = $_[1];
|
||||
|
||||
if (warnings::enabled() && $] >= 5.003_06) {
|
||||
unless ($please_use_I18N_Collate_even_if_deprecated) {
|
||||
warnings::warn <<___EOD___;
|
||||
***
|
||||
|
||||
WARNING: starting from the Perl version 5.003_06
|
||||
the I18N::Collate interface for comparing 8-bit scalar data
|
||||
according to the current locale
|
||||
|
||||
HAS BEEN DEPRECATED
|
||||
|
||||
That is, please do not use it anymore for any new applications
|
||||
and please migrate the old applications away from it because its
|
||||
functionality was integrated into the Perl core language in the
|
||||
release 5.003_06.
|
||||
|
||||
See the perllocale manual page for further information.
|
||||
|
||||
***
|
||||
___EOD___
|
||||
$please_use_I18N_Collate_even_if_deprecated++;
|
||||
}
|
||||
}
|
||||
|
||||
bless \$new;
|
||||
}
|
||||
|
||||
sub setlocale {
|
||||
my ($category, $locale) = @_[0,1];
|
||||
|
||||
POSIX::setlocale($category, $locale) if (defined $category);
|
||||
# the current $LOCALE
|
||||
$LOCALE = $locale || $ENV{'LC_COLLATE'} || $ENV{'LC_ALL'} || '';
|
||||
}
|
||||
|
||||
sub C {
|
||||
my $s = ${$_[0]};
|
||||
|
||||
$C->{$LOCALE}->{$s} = collate_xfrm($s)
|
||||
unless (defined $C->{$LOCALE}->{$s}); # cache when met
|
||||
|
||||
$C->{$LOCALE}->{$s};
|
||||
}
|
||||
|
||||
sub collate_xfrm {
|
||||
my $s = $_[0];
|
||||
my $x = '';
|
||||
|
||||
for (split(/(\000+)/, $s)) {
|
||||
$x .= (/^\000/) ? $_ : strxfrm("$_\000");
|
||||
}
|
||||
|
||||
$x;
|
||||
}
|
||||
|
||||
sub collate_cmp {
|
||||
&C($_[0]) cmp &C($_[1]);
|
||||
}
|
||||
|
||||
# init $LOCALE
|
||||
|
||||
&I18N::Collate::setlocale();
|
||||
|
||||
1; # keep require happy
|
||||
@@ -0,0 +1,887 @@
|
||||
|
||||
# Time-stamp: "2004-10-06 23:26:33 ADT"
|
||||
# Sean M. Burke <sburke@cpan.org>
|
||||
|
||||
require 5.000;
|
||||
package I18N::LangTags;
|
||||
use strict;
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT = qw();
|
||||
our @EXPORT_OK = qw(is_language_tag same_language_tag
|
||||
extract_language_tags super_languages
|
||||
similarity_language_tag is_dialect_of
|
||||
locale2language_tag alternate_language_tags
|
||||
encode_language_tag panic_languages
|
||||
implicate_supers
|
||||
implicate_supers_strictly
|
||||
);
|
||||
our %EXPORT_TAGS = ('ALL' => \@EXPORT_OK);
|
||||
|
||||
our $VERSION = "0.45";
|
||||
our %Panic;
|
||||
|
||||
sub uniq { my %seen; return grep(!($seen{$_}++), @_); } # a util function
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
I18N::LangTags - functions for dealing with RFC3066-style language tags
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use I18N::LangTags();
|
||||
|
||||
...or specify whichever of those functions you want to import, like so:
|
||||
|
||||
use I18N::LangTags qw(implicate_supers similarity_language_tag);
|
||||
|
||||
All the exportable functions are listed below -- you're free to import
|
||||
only some, or none at all. By default, none are imported. If you
|
||||
say:
|
||||
|
||||
use I18N::LangTags qw(:ALL)
|
||||
|
||||
...then all are exported. (This saves you from having to use
|
||||
something less obvious like C<use I18N::LangTags qw(/./)>.)
|
||||
|
||||
If you don't import any of these functions, assume a C<&I18N::LangTags::>
|
||||
in front of all the function names in the following examples.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Language tags are a formalism, described in RFC 3066 (obsoleting
|
||||
1766), for declaring what language form (language and possibly
|
||||
dialect) a given chunk of information is in.
|
||||
|
||||
This library provides functions for common tasks involving language
|
||||
tags as they are needed in a variety of protocols and applications.
|
||||
|
||||
Please see the "See Also" references for a thorough explanation
|
||||
of how to correctly use language tags.
|
||||
|
||||
=over
|
||||
|
||||
=cut
|
||||
|
||||
###########################################################################
|
||||
|
||||
=item * the function is_language_tag($lang1)
|
||||
|
||||
Returns true iff $lang1 is a formally valid language tag.
|
||||
|
||||
is_language_tag("fr") is TRUE
|
||||
is_language_tag("x-jicarilla") is FALSE
|
||||
(Subtags can be 8 chars long at most -- 'jicarilla' is 9)
|
||||
|
||||
is_language_tag("sgn-US") is TRUE
|
||||
(That's American Sign Language)
|
||||
|
||||
is_language_tag("i-Klikitat") is TRUE
|
||||
(True without regard to the fact noone has actually
|
||||
registered Klikitat -- it's a formally valid tag)
|
||||
|
||||
is_language_tag("fr-patois") is TRUE
|
||||
(Formally valid -- altho descriptively weak!)
|
||||
|
||||
is_language_tag("Spanish") is FALSE
|
||||
is_language_tag("french-patois") is FALSE
|
||||
(No good -- first subtag has to match
|
||||
/^([xXiI]|[a-zA-Z]{2,3})$/ -- see RFC3066)
|
||||
|
||||
is_language_tag("x-borg-prot2532") is TRUE
|
||||
(Yes, subtags can contain digits, as of RFC3066)
|
||||
|
||||
=cut
|
||||
|
||||
sub is_language_tag {
|
||||
|
||||
## Changes in the language tagging standards may have to be reflected here.
|
||||
|
||||
my($tag) = lc($_[0]);
|
||||
|
||||
return 0 if $tag eq "i" or $tag eq "x";
|
||||
# Bad degenerate cases that the following
|
||||
# regexp would erroneously let pass
|
||||
|
||||
return $tag =~
|
||||
/^(?: # First subtag
|
||||
[xi] | [a-z]{2,3}
|
||||
)
|
||||
(?: # Subtags thereafter
|
||||
- # separator
|
||||
[a-z0-9]{1,8} # subtag
|
||||
)*
|
||||
$/xs ? 1 : 0;
|
||||
}
|
||||
|
||||
###########################################################################
|
||||
|
||||
=item * the function extract_language_tags($whatever)
|
||||
|
||||
Returns a list of whatever looks like formally valid language tags
|
||||
in $whatever. Not very smart, so don't get too creative with
|
||||
what you want to feed it.
|
||||
|
||||
extract_language_tags("fr, fr-ca, i-mingo")
|
||||
returns: ('fr', 'fr-ca', 'i-mingo')
|
||||
|
||||
extract_language_tags("It's like this: I'm in fr -- French!")
|
||||
returns: ('It', 'in', 'fr')
|
||||
(So don't just feed it any old thing.)
|
||||
|
||||
The output is untainted. If you don't know what tainting is,
|
||||
don't worry about it.
|
||||
|
||||
=cut
|
||||
|
||||
sub extract_language_tags {
|
||||
|
||||
## Changes in the language tagging standards may have to be reflected here.
|
||||
|
||||
my($text) =
|
||||
$_[0] =~ m/(.+)/ # to make for an untainted result
|
||||
? $1 : ''
|
||||
;
|
||||
|
||||
return grep(!m/^[ixIX]$/s, # 'i' and 'x' aren't good tags
|
||||
$text =~
|
||||
m/
|
||||
\b
|
||||
(?: # First subtag
|
||||
[iIxX] | [a-zA-Z]{2,3}
|
||||
)
|
||||
(?: # Subtags thereafter
|
||||
- # separator
|
||||
[a-zA-Z0-9]{1,8} # subtag
|
||||
)*
|
||||
\b
|
||||
/xsg
|
||||
);
|
||||
}
|
||||
|
||||
###########################################################################
|
||||
|
||||
=item * the function same_language_tag($lang1, $lang2)
|
||||
|
||||
Returns true iff $lang1 and $lang2 are acceptable variant tags
|
||||
representing the same language-form.
|
||||
|
||||
same_language_tag('x-kadara', 'i-kadara') is TRUE
|
||||
(The x/i- alternation doesn't matter)
|
||||
same_language_tag('X-KADARA', 'i-kadara') is TRUE
|
||||
(...and neither does case)
|
||||
same_language_tag('en', 'en-US') is FALSE
|
||||
(all-English is not the SAME as US English)
|
||||
same_language_tag('x-kadara', 'x-kadar') is FALSE
|
||||
(these are totally unrelated tags)
|
||||
same_language_tag('no-bok', 'nb') is TRUE
|
||||
(no-bok is a legacy tag for nb (Norwegian Bokmal))
|
||||
|
||||
C<same_language_tag> works by just seeing whether
|
||||
C<encode_language_tag($lang1)> is the same as
|
||||
C<encode_language_tag($lang2)>.
|
||||
|
||||
(Yes, I know this function is named a bit oddly. Call it historic
|
||||
reasons.)
|
||||
|
||||
=cut
|
||||
|
||||
sub same_language_tag {
|
||||
my $el1 = &encode_language_tag($_[0]);
|
||||
return 0 unless defined $el1;
|
||||
# this avoids the problem of
|
||||
# encode_language_tag($lang1) eq and encode_language_tag($lang2)
|
||||
# being true if $lang1 and $lang2 are both undef
|
||||
|
||||
return $el1 eq &encode_language_tag($_[1]) ? 1 : 0;
|
||||
}
|
||||
|
||||
###########################################################################
|
||||
|
||||
=item * the function similarity_language_tag($lang1, $lang2)
|
||||
|
||||
Returns an integer representing the degree of similarity between
|
||||
tags $lang1 and $lang2 (the order of which does not matter), where
|
||||
similarity is the number of common elements on the left,
|
||||
without regard to case and to x/i- alternation.
|
||||
|
||||
similarity_language_tag('fr', 'fr-ca') is 1
|
||||
(one element in common)
|
||||
similarity_language_tag('fr-ca', 'fr-FR') is 1
|
||||
(one element in common)
|
||||
|
||||
similarity_language_tag('fr-CA-joual',
|
||||
'fr-CA-PEI') is 2
|
||||
similarity_language_tag('fr-CA-joual', 'fr-CA') is 2
|
||||
(two elements in common)
|
||||
|
||||
similarity_language_tag('x-kadara', 'i-kadara') is 1
|
||||
(x/i- doesn't matter)
|
||||
|
||||
similarity_language_tag('en', 'x-kadar') is 0
|
||||
similarity_language_tag('x-kadara', 'x-kadar') is 0
|
||||
(unrelated tags -- no similarity)
|
||||
|
||||
similarity_language_tag('i-cree-syllabic',
|
||||
'i-cherokee-syllabic') is 0
|
||||
(no B<leftmost> elements in common!)
|
||||
|
||||
=cut
|
||||
|
||||
sub similarity_language_tag {
|
||||
my $lang1 = &encode_language_tag($_[0]);
|
||||
my $lang2 = &encode_language_tag($_[1]);
|
||||
# And encode_language_tag takes care of the whole
|
||||
# no-nyn==nn, i-hakka==zh-hakka, etc, things
|
||||
|
||||
# NB: (i-sil-...)? (i-sgn-...)?
|
||||
|
||||
return undef if !defined($lang1) and !defined($lang2);
|
||||
return 0 if !defined($lang1) or !defined($lang2);
|
||||
|
||||
my @l1_subtags = split('-', $lang1);
|
||||
my @l2_subtags = split('-', $lang2);
|
||||
my $similarity = 0;
|
||||
|
||||
while(@l1_subtags and @l2_subtags) {
|
||||
if(shift(@l1_subtags) eq shift(@l2_subtags)) {
|
||||
++$similarity;
|
||||
} else {
|
||||
last;
|
||||
}
|
||||
}
|
||||
return $similarity;
|
||||
}
|
||||
|
||||
###########################################################################
|
||||
|
||||
=item * the function is_dialect_of($lang1, $lang2)
|
||||
|
||||
Returns true iff language tag $lang1 represents a subform of
|
||||
language tag $lang2.
|
||||
|
||||
B<Get the order right! It doesn't work the other way around!>
|
||||
|
||||
is_dialect_of('en-US', 'en') is TRUE
|
||||
(American English IS a dialect of all-English)
|
||||
|
||||
is_dialect_of('fr-CA-joual', 'fr-CA') is TRUE
|
||||
is_dialect_of('fr-CA-joual', 'fr') is TRUE
|
||||
(Joual is a dialect of (a dialect of) French)
|
||||
|
||||
is_dialect_of('en', 'en-US') is FALSE
|
||||
(all-English is a NOT dialect of American English)
|
||||
|
||||
is_dialect_of('fr', 'en-CA') is FALSE
|
||||
|
||||
is_dialect_of('en', 'en' ) is TRUE
|
||||
is_dialect_of('en-US', 'en-US') is TRUE
|
||||
(B<Note:> these are degenerate cases)
|
||||
|
||||
is_dialect_of('i-mingo-tom', 'x-Mingo') is TRUE
|
||||
(the x/i thing doesn't matter, nor does case)
|
||||
|
||||
is_dialect_of('nn', 'no') is TRUE
|
||||
(because 'nn' (New Norse) is aliased to 'no-nyn',
|
||||
as a special legacy case, and 'no-nyn' is a
|
||||
subform of 'no' (Norwegian))
|
||||
|
||||
=cut
|
||||
|
||||
sub is_dialect_of {
|
||||
|
||||
my $lang1 = &encode_language_tag($_[0]);
|
||||
my $lang2 = &encode_language_tag($_[1]);
|
||||
|
||||
return undef if !defined($lang1) and !defined($lang2);
|
||||
return 0 if !defined($lang1) or !defined($lang2);
|
||||
|
||||
return 1 if $lang1 eq $lang2;
|
||||
return 0 if length($lang1) < length($lang2);
|
||||
|
||||
$lang1 .= '-';
|
||||
$lang2 .= '-';
|
||||
return
|
||||
(substr($lang1, 0, length($lang2)) eq $lang2) ? 1 : 0;
|
||||
}
|
||||
|
||||
###########################################################################
|
||||
|
||||
=item * the function super_languages($lang1)
|
||||
|
||||
Returns a list of language tags that are superordinate tags to $lang1
|
||||
-- it gets this by removing subtags from the end of $lang1 until
|
||||
nothing (or just "i" or "x") is left.
|
||||
|
||||
super_languages("fr-CA-joual") is ("fr-CA", "fr")
|
||||
|
||||
super_languages("en-AU") is ("en")
|
||||
|
||||
super_languages("en") is empty-list, ()
|
||||
|
||||
super_languages("i-cherokee") is empty-list, ()
|
||||
...not ("i"), which would be illegal as well as pointless.
|
||||
|
||||
If $lang1 is not a valid language tag, returns empty-list in
|
||||
a list context, undef in a scalar context.
|
||||
|
||||
A notable and rather unavoidable problem with this method:
|
||||
"x-mingo-tom" has an "x" because the whole tag isn't an
|
||||
IANA-registered tag -- but super_languages('x-mingo-tom') is
|
||||
('x-mingo') -- which isn't really right, since 'i-mingo' is
|
||||
registered. But this module has no way of knowing that. (But note
|
||||
that same_language_tag('x-mingo', 'i-mingo') is TRUE.)
|
||||
|
||||
More importantly, you assume I<at your peril> that superordinates of
|
||||
$lang1 are mutually intelligible with $lang1. Consider this
|
||||
carefully.
|
||||
|
||||
=cut
|
||||
|
||||
sub super_languages {
|
||||
my $lang1 = $_[0];
|
||||
return() unless defined($lang1) && &is_language_tag($lang1);
|
||||
|
||||
# a hack for those annoying new (2001) tags:
|
||||
$lang1 =~ s/^nb\b/no-bok/i; # yes, backwards
|
||||
$lang1 =~ s/^nn\b/no-nyn/i; # yes, backwards
|
||||
$lang1 =~ s/^[ix](-hakka\b)/zh$1/i; # goes the right way
|
||||
# i-hakka-bork-bjork-bjark => zh-hakka-bork-bjork-bjark
|
||||
|
||||
my @l1_subtags = split('-', $lang1);
|
||||
|
||||
## Changes in the language tagging standards may have to be reflected here.
|
||||
|
||||
# NB: (i-sil-...)?
|
||||
|
||||
my @supers = ();
|
||||
foreach my $bit (@l1_subtags) {
|
||||
push @supers,
|
||||
scalar(@supers) ? ($supers[-1] . '-' . $bit) : $bit;
|
||||
}
|
||||
pop @supers if @supers;
|
||||
shift @supers if @supers && $supers[0] =~ m<^[iIxX]$>s;
|
||||
return reverse @supers;
|
||||
}
|
||||
|
||||
###########################################################################
|
||||
|
||||
=item * the function locale2language_tag($locale_identifier)
|
||||
|
||||
This takes a locale name (like "en", "en_US", or "en_US.ISO8859-1")
|
||||
and maps it to a language tag. If it's not mappable (as with,
|
||||
notably, "C" and "POSIX"), this returns empty-list in a list context,
|
||||
or undef in a scalar context.
|
||||
|
||||
locale2language_tag("en") is "en"
|
||||
|
||||
locale2language_tag("en_US") is "en-US"
|
||||
|
||||
locale2language_tag("en_US.ISO8859-1") is "en-US"
|
||||
|
||||
locale2language_tag("C") is undef or ()
|
||||
|
||||
locale2language_tag("POSIX") is undef or ()
|
||||
|
||||
locale2language_tag("POSIX") is undef or ()
|
||||
|
||||
I'm not totally sure that locale names map satisfactorily to language
|
||||
tags. Think REAL hard about how you use this. YOU HAVE BEEN WARNED.
|
||||
|
||||
The output is untainted. If you don't know what tainting is,
|
||||
don't worry about it.
|
||||
|
||||
=cut
|
||||
|
||||
sub locale2language_tag {
|
||||
my $lang =
|
||||
$_[0] =~ m/(.+)/ # to make for an untainted result
|
||||
? $1 : ''
|
||||
;
|
||||
|
||||
return $lang if &is_language_tag($lang); # like "en"
|
||||
|
||||
$lang =~ tr<_><->; # "en_US" -> en-US
|
||||
$lang =~ s<(?:[\.\@][-_a-zA-Z0-9]+)+$><>s; # "en_US.ISO8859-1" -> en-US
|
||||
# it_IT.utf8@euro => it-IT
|
||||
|
||||
return $lang if &is_language_tag($lang);
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
###########################################################################
|
||||
|
||||
=item * the function encode_language_tag($lang1)
|
||||
|
||||
This function, if given a language tag, returns an encoding of it such
|
||||
that:
|
||||
|
||||
* tags representing different languages never get the same encoding.
|
||||
|
||||
* tags representing the same language always get the same encoding.
|
||||
|
||||
* an encoding of a formally valid language tag always is a string
|
||||
value that is defined, has length, and is true if considered as a
|
||||
boolean.
|
||||
|
||||
Note that the encoding itself is B<not> a formally valid language tag.
|
||||
Note also that you cannot, currently, go from an encoding back to a
|
||||
language tag that it's an encoding of.
|
||||
|
||||
Note also that you B<must> consider the encoded value as atomic; i.e.,
|
||||
you should not consider it as anything but an opaque, unanalysable
|
||||
string value. (The internals of the encoding method may change in
|
||||
future versions, as the language tagging standard changes over time.)
|
||||
|
||||
C<encode_language_tag> returns undef if given anything other than a
|
||||
formally valid language tag.
|
||||
|
||||
The reason C<encode_language_tag> exists is because different language
|
||||
tags may represent the same language; this is normally treatable with
|
||||
C<same_language_tag>, but consider this situation:
|
||||
|
||||
You have a data file that expresses greetings in different languages.
|
||||
Its format is "[language tag]=[how to say 'Hello']", like:
|
||||
|
||||
en-US=Hiho
|
||||
fr=Bonjour
|
||||
i-mingo=Hau'
|
||||
|
||||
And suppose you write a program that reads that file and then runs as
|
||||
a daemon, answering client requests that specify a language tag and
|
||||
then expect the string that says how to greet in that language. So an
|
||||
interaction looks like:
|
||||
|
||||
greeting-client asks: fr
|
||||
greeting-server answers: Bonjour
|
||||
|
||||
So far so good. But suppose the way you're implementing this is:
|
||||
|
||||
my %greetings;
|
||||
die unless open(IN, "<", "in.dat");
|
||||
while(<IN>) {
|
||||
chomp;
|
||||
next unless /^([^=]+)=(.+)/s;
|
||||
my($lang, $expr) = ($1, $2);
|
||||
$greetings{$lang} = $expr;
|
||||
}
|
||||
close(IN);
|
||||
|
||||
at which point %greetings has the contents:
|
||||
|
||||
"en-US" => "Hiho"
|
||||
"fr" => "Bonjour"
|
||||
"i-mingo" => "Hau'"
|
||||
|
||||
And suppose then that you answer client requests for language $wanted
|
||||
by just looking up $greetings{$wanted}.
|
||||
|
||||
If the client asks for "fr", that will look up successfully in
|
||||
%greetings, to the value "Bonjour". And if the client asks for
|
||||
"i-mingo", that will look up successfully in %greetings, to the value
|
||||
"Hau'".
|
||||
|
||||
But if the client asks for "i-Mingo" or "x-mingo", or "Fr", then the
|
||||
lookup in %greetings fails. That's the Wrong Thing.
|
||||
|
||||
You could instead do lookups on $wanted with:
|
||||
|
||||
use I18N::LangTags qw(same_language_tag);
|
||||
my $response = '';
|
||||
foreach my $l2 (keys %greetings) {
|
||||
if(same_language_tag($wanted, $l2)) {
|
||||
$response = $greetings{$l2};
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
But that's rather inefficient. A better way to do it is to start your
|
||||
program with:
|
||||
|
||||
use I18N::LangTags qw(encode_language_tag);
|
||||
my %greetings;
|
||||
die unless open(IN, "<", "in.dat");
|
||||
while(<IN>) {
|
||||
chomp;
|
||||
next unless /^([^=]+)=(.+)/s;
|
||||
my($lang, $expr) = ($1, $2);
|
||||
$greetings{
|
||||
encode_language_tag($lang)
|
||||
} = $expr;
|
||||
}
|
||||
close(IN);
|
||||
|
||||
and then just answer client requests for language $wanted by just
|
||||
looking up
|
||||
|
||||
$greetings{encode_language_tag($wanted)}
|
||||
|
||||
And that does the Right Thing.
|
||||
|
||||
=cut
|
||||
|
||||
sub encode_language_tag {
|
||||
# Only similarity_language_tag() is allowed to analyse encodings!
|
||||
|
||||
## Changes in the language tagging standards may have to be reflected here.
|
||||
|
||||
my($tag) = $_[0] || return undef;
|
||||
return undef unless &is_language_tag($tag);
|
||||
|
||||
# For the moment, these legacy variances are few enough that
|
||||
# we can just handle them here with regexps.
|
||||
$tag =~ s/^iw\b/he/i; # Hebrew
|
||||
$tag =~ s/^in\b/id/i; # Indonesian
|
||||
$tag =~ s/^cre\b/cr/i; # Cree
|
||||
$tag =~ s/^jw\b/jv/i; # Javanese
|
||||
$tag =~ s/^[ix]-lux\b/lb/i; # Luxemburger
|
||||
$tag =~ s/^[ix]-navajo\b/nv/i; # Navajo
|
||||
$tag =~ s/^ji\b/yi/i; # Yiddish
|
||||
# SMB 2003 -- Hm. There's a bunch of new XXX->YY variances now,
|
||||
# but maybe they're all so obscure I can ignore them. "Obscure"
|
||||
# meaning either that the language is obscure, and/or that the
|
||||
# XXX form was extant so briefly that it's unlikely it was ever
|
||||
# used. I hope.
|
||||
#
|
||||
# These go FROM the simplex to complex form, to get
|
||||
# similarity-comparison right. And that's okay, since
|
||||
# similarity_language_tag is the only thing that
|
||||
# analyzes our output.
|
||||
$tag =~ s/^[ix]-hakka\b/zh-hakka/i; # Hakka
|
||||
$tag =~ s/^nb\b/no-bok/i; # BACKWARDS for Bokmal
|
||||
$tag =~ s/^nn\b/no-nyn/i; # BACKWARDS for Nynorsk
|
||||
|
||||
$tag =~ s/^[xiXI]-//s;
|
||||
# Just lop off any leading "x/i-"
|
||||
|
||||
return "~" . uc($tag);
|
||||
}
|
||||
|
||||
#--------------------------------------------------------------------------
|
||||
|
||||
=item * the function alternate_language_tags($lang1)
|
||||
|
||||
This function, if given a language tag, returns all language tags that
|
||||
are alternate forms of this language tag. (I.e., tags which refer to
|
||||
the same language.) This is meant to handle legacy tags caused by
|
||||
the minor changes in language tag standards over the years; and
|
||||
the x-/i- alternation is also dealt with.
|
||||
|
||||
Note that this function does I<not> try to equate new (and never-used,
|
||||
and unusable)
|
||||
ISO639-2 three-letter tags to old (and still in use) ISO639-1
|
||||
two-letter equivalents -- like "ara" -> "ar" -- because
|
||||
"ara" has I<never> been in use as an Internet language tag,
|
||||
and RFC 3066 stipulates that it never should be, since a shorter
|
||||
tag ("ar") exists.
|
||||
|
||||
Examples:
|
||||
|
||||
alternate_language_tags('no-bok') is ('nb')
|
||||
alternate_language_tags('nb') is ('no-bok')
|
||||
alternate_language_tags('he') is ('iw')
|
||||
alternate_language_tags('iw') is ('he')
|
||||
alternate_language_tags('i-hakka') is ('zh-hakka', 'x-hakka')
|
||||
alternate_language_tags('zh-hakka') is ('i-hakka', 'x-hakka')
|
||||
alternate_language_tags('en') is ()
|
||||
alternate_language_tags('x-mingo-tom') is ('i-mingo-tom')
|
||||
alternate_language_tags('x-klikitat') is ('i-klikitat')
|
||||
alternate_language_tags('i-klikitat') is ('x-klikitat')
|
||||
|
||||
This function returns empty-list if given anything other than a formally
|
||||
valid language tag.
|
||||
|
||||
=cut
|
||||
|
||||
my %alt = qw( i x x i I X X I );
|
||||
sub alternate_language_tags {
|
||||
my $tag = $_[0];
|
||||
return() unless &is_language_tag($tag);
|
||||
|
||||
my @em; # push 'em real goood!
|
||||
|
||||
# For the moment, these legacy variances are few enough that
|
||||
# we can just handle them here with regexps.
|
||||
|
||||
if( $tag =~ m/^[ix]-hakka\b(.*)/i) {push @em, "zh-hakka$1";
|
||||
} elsif($tag =~ m/^zh-hakka\b(.*)/i) { push @em, "x-hakka$1", "i-hakka$1";
|
||||
|
||||
} elsif($tag =~ m/^he\b(.*)/i) { push @em, "iw$1";
|
||||
} elsif($tag =~ m/^iw\b(.*)/i) { push @em, "he$1";
|
||||
|
||||
} elsif($tag =~ m/^in\b(.*)/i) { push @em, "id$1";
|
||||
} elsif($tag =~ m/^id\b(.*)/i) { push @em, "in$1";
|
||||
|
||||
} elsif($tag =~ m/^[ix]-lux\b(.*)/i) { push @em, "lb$1";
|
||||
} elsif($tag =~ m/^lb\b(.*)/i) { push @em, "i-lux$1", "x-lux$1";
|
||||
|
||||
} elsif($tag =~ m/^[ix]-navajo\b(.*)/i) { push @em, "nv$1";
|
||||
} elsif($tag =~ m/^nv\b(.*)/i) { push @em, "i-navajo$1", "x-navajo$1";
|
||||
|
||||
} elsif($tag =~ m/^yi\b(.*)/i) { push @em, "ji$1";
|
||||
} elsif($tag =~ m/^ji\b(.*)/i) { push @em, "yi$1";
|
||||
|
||||
} elsif($tag =~ m/^nb\b(.*)/i) { push @em, "no-bok$1";
|
||||
} elsif($tag =~ m/^no-bok\b(.*)/i) { push @em, "nb$1";
|
||||
|
||||
} elsif($tag =~ m/^nn\b(.*)/i) { push @em, "no-nyn$1";
|
||||
} elsif($tag =~ m/^no-nyn\b(.*)/i) { push @em, "nn$1";
|
||||
}
|
||||
|
||||
push @em, $alt{$1} . $2 if $tag =~ /^([XIxi])(-.+)/;
|
||||
return @em;
|
||||
}
|
||||
|
||||
###########################################################################
|
||||
|
||||
{
|
||||
# Init %Panic...
|
||||
|
||||
my @panic = ( # MUST all be lowercase!
|
||||
# Only large ("national") languages make it in this list.
|
||||
# If you, as a user, are so bizarre that the /only/ language
|
||||
# you claim to accept is Galician, then no, we won't do you
|
||||
# the favor of providing Catalan as a panic-fallback for
|
||||
# you. Because if I start trying to add "little languages" in
|
||||
# here, I'll just go crazy.
|
||||
|
||||
# Scandinavian lgs. All based on opinion and hearsay.
|
||||
'sv' => [qw(nb no da nn)],
|
||||
'da' => [qw(nb no sv nn)], # I guess
|
||||
[qw(no nn nb)], [qw(no nn nb sv da)],
|
||||
'is' => [qw(da sv no nb nn)],
|
||||
'fo' => [qw(da is no nb nn sv)], # I guess
|
||||
|
||||
# I think this is about the extent of tolerable intelligibility
|
||||
# among large modern Romance languages.
|
||||
'pt' => [qw(es ca it fr)], # Portuguese, Spanish, Catalan, Italian, French
|
||||
'ca' => [qw(es pt it fr)],
|
||||
'es' => [qw(ca it fr pt)],
|
||||
'it' => [qw(es fr ca pt)],
|
||||
'fr' => [qw(es it ca pt)],
|
||||
|
||||
# Also assume that speakers of the main Indian languages prefer
|
||||
# to read/hear Hindi over English
|
||||
[qw(
|
||||
as bn gu kn ks kok ml mni mr ne or pa sa sd te ta ur
|
||||
)] => 'hi',
|
||||
# Assamese, Bengali, Gujarati, [Hindi,] Kannada (Kanarese), Kashmiri,
|
||||
# Konkani, Malayalam, Meithei (Manipuri), Marathi, Nepali, Oriya,
|
||||
# Punjabi, Sanskrit, Sindhi, Telugu, Tamil, and Urdu.
|
||||
'hi' => [qw(bn pa as or)],
|
||||
# I welcome finer data for the other Indian languages.
|
||||
# E.g., what should Oriya's list be, besides just Hindi?
|
||||
|
||||
# And the panic languages for English is, of course, nil!
|
||||
|
||||
# My guesses at Slavic intelligibility:
|
||||
([qw(ru be uk)]) x 2, # Russian, Belarusian, Ukrainian
|
||||
([qw(sr hr bs)]) x 2, # Serbian, Croatian, Bosnian
|
||||
'cs' => 'sk', 'sk' => 'cs', # Czech + Slovak
|
||||
|
||||
'ms' => 'id', 'id' => 'ms', # Malay + Indonesian
|
||||
|
||||
'et' => 'fi', 'fi' => 'et', # Estonian + Finnish
|
||||
|
||||
#?? 'lo' => 'th', 'th' => 'lo', # Lao + Thai
|
||||
|
||||
);
|
||||
my($k,$v);
|
||||
while(@panic) {
|
||||
($k,$v) = splice(@panic,0,2);
|
||||
foreach my $k (ref($k) ? @$k : $k) {
|
||||
foreach my $v (ref($v) ? @$v : $v) {
|
||||
push @{$Panic{$k} ||= []}, $v unless $k eq $v;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
=item * the function @langs = panic_languages(@accept_languages)
|
||||
|
||||
This function takes a list of 0 or more language
|
||||
tags that constitute a given user's Accept-Language list, and
|
||||
returns a list of tags for I<other> (non-super)
|
||||
languages that are probably acceptable to the user, to be
|
||||
used I<if all else fails>.
|
||||
|
||||
For example, if a user accepts only 'ca' (Catalan) and
|
||||
'es' (Spanish), and the documents/interfaces you have
|
||||
available are just in German, Italian, and Chinese, then
|
||||
the user will most likely want the Italian one (and not
|
||||
the Chinese or German one!), instead of getting
|
||||
nothing. So C<panic_languages('ca', 'es')> returns
|
||||
a list containing 'it' (Italian).
|
||||
|
||||
English ('en') is I<always> in the return list, but
|
||||
whether it's at the very end or not depends
|
||||
on the input languages. This function works by consulting
|
||||
an internal table that stipulates what common
|
||||
languages are "close" to each other.
|
||||
|
||||
A useful construct you might consider using is:
|
||||
|
||||
@fallbacks = super_languages(@accept_languages);
|
||||
push @fallbacks, panic_languages(
|
||||
@accept_languages, @fallbacks,
|
||||
);
|
||||
|
||||
=cut
|
||||
|
||||
sub panic_languages {
|
||||
# When in panic or in doubt, run in circles, scream, and shout!
|
||||
my(@out, %seen);
|
||||
foreach my $t (@_) {
|
||||
next unless $t;
|
||||
next if $seen{$t}++; # so we don't return it or hit it again
|
||||
# push @out, super_languages($t); # nah, keep that separate
|
||||
push @out, @{ $Panic{lc $t} || next };
|
||||
}
|
||||
return grep !$seen{$_}++, @out, 'en';
|
||||
}
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
=item * the function implicate_supers( ...languages... )
|
||||
|
||||
This takes a list of strings (which are presumed to be language-tags;
|
||||
strings that aren't, are ignored); and after each one, this function
|
||||
inserts super-ordinate forms that don't already appear in the list.
|
||||
The original list, plus these insertions, is returned.
|
||||
|
||||
In other words, it takes this:
|
||||
|
||||
pt-br de-DE en-US fr pt-br-janeiro
|
||||
|
||||
and returns this:
|
||||
|
||||
pt-br pt de-DE de en-US en fr pt-br-janeiro
|
||||
|
||||
This function is most useful in the idiom
|
||||
|
||||
implicate_supers( I18N::LangTags::Detect::detect() );
|
||||
|
||||
(See L<I18N::LangTags::Detect>.)
|
||||
|
||||
|
||||
=item * the function implicate_supers_strictly( ...languages... )
|
||||
|
||||
This works like C<implicate_supers> except that the implicated
|
||||
forms are added to the end of the return list.
|
||||
|
||||
In other words, implicate_supers_strictly takes a list of strings
|
||||
(which are presumed to be language-tags; strings that aren't, are
|
||||
ignored) and after the whole given list, it inserts the super-ordinate forms
|
||||
of all given tags, minus any tags that already appear in the input list.
|
||||
|
||||
In other words, it takes this:
|
||||
|
||||
pt-br de-DE en-US fr pt-br-janeiro
|
||||
|
||||
and returns this:
|
||||
|
||||
pt-br de-DE en-US fr pt-br-janeiro pt de en
|
||||
|
||||
The reason this function has "_strictly" in its name is that when
|
||||
you're processing an Accept-Language list according to the RFCs, if
|
||||
you interpret the RFCs quite strictly, then you would use
|
||||
implicate_supers_strictly, but for normal use (i.e., common-sense use,
|
||||
as far as I'm concerned) you'd use implicate_supers.
|
||||
|
||||
=cut
|
||||
|
||||
sub implicate_supers {
|
||||
my @languages = grep is_language_tag($_), @_;
|
||||
my %seen_encoded;
|
||||
foreach my $lang (@languages) {
|
||||
$seen_encoded{ I18N::LangTags::encode_language_tag($lang) } = 1
|
||||
}
|
||||
|
||||
my(@output_languages);
|
||||
foreach my $lang (@languages) {
|
||||
push @output_languages, $lang;
|
||||
foreach my $s ( I18N::LangTags::super_languages($lang) ) {
|
||||
# Note that super_languages returns the longest first.
|
||||
last if $seen_encoded{ I18N::LangTags::encode_language_tag($s) };
|
||||
push @output_languages, $s;
|
||||
}
|
||||
}
|
||||
return uniq( @output_languages );
|
||||
|
||||
}
|
||||
|
||||
sub implicate_supers_strictly {
|
||||
my @tags = grep is_language_tag($_), @_;
|
||||
return uniq( @_, map super_languages($_), @_ );
|
||||
}
|
||||
|
||||
|
||||
|
||||
###########################################################################
|
||||
1;
|
||||
__END__
|
||||
|
||||
=back
|
||||
|
||||
=head1 ABOUT LOWERCASING
|
||||
|
||||
I've considered making all the above functions that output language
|
||||
tags return all those tags strictly in lowercase. Having all your
|
||||
language tags in lowercase does make some things easier. But you
|
||||
might as well just lowercase as you like, or call
|
||||
C<encode_language_tag($lang1)> where appropriate.
|
||||
|
||||
=head1 ABOUT UNICODE PLAINTEXT LANGUAGE TAGS
|
||||
|
||||
In some future version of I18N::LangTags, I plan to include support
|
||||
for RFC2482-style language tags -- which are basically just normal
|
||||
language tags with their ASCII characters shifted into Plane 14.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
* L<I18N::LangTags::List|I18N::LangTags::List>
|
||||
|
||||
* RFC 3066, C<L<http://www.ietf.org/rfc/rfc3066.txt>>, "Tags for the
|
||||
Identification of Languages". (Obsoletes RFC 1766)
|
||||
|
||||
* RFC 2277, C<L<http://www.ietf.org/rfc/rfc2277.txt>>, "IETF Policy on
|
||||
Character Sets and Languages".
|
||||
|
||||
* RFC 2231, C<L<http://www.ietf.org/rfc/rfc2231.txt>>, "MIME Parameter
|
||||
Value and Encoded Word Extensions: Character Sets, Languages, and
|
||||
Continuations".
|
||||
|
||||
* RFC 2482, C<L<http://www.ietf.org/rfc/rfc2482.txt>>,
|
||||
"Language Tagging in Unicode Plain Text".
|
||||
|
||||
* Locale::Codes, in
|
||||
C<L<http://www.perl.com/CPAN/modules/by-module/Locale/>>
|
||||
|
||||
* ISO 639-2, "Codes for the representation of names of languages",
|
||||
including two-letter and three-letter codes,
|
||||
C<L<http://www.loc.gov/standards/iso639-2/php/code_list.php>>
|
||||
|
||||
* The IANA list of registered languages (hopefully up-to-date),
|
||||
C<L<http://www.iana.org/assignments/language-tags>>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 1998+ Sean M. Burke. All rights reserved.
|
||||
|
||||
This library is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
||||
The programs and documentation in this dist are distributed in
|
||||
the hope that they will be useful, but without any warranty; without
|
||||
even the implied warranty of merchantability or fitness for a
|
||||
particular purpose.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Sean M. Burke C<sburke@cpan.org>
|
||||
|
||||
=cut
|
||||
|
||||
@@ -0,0 +1,242 @@
|
||||
|
||||
# Time-stamp: "2004-06-20 21:47:55 ADT"
|
||||
|
||||
require 5;
|
||||
package I18N::LangTags::Detect;
|
||||
use strict;
|
||||
|
||||
our ( $MATCH_SUPERS, $USING_LANGUAGE_TAGS,
|
||||
$USE_LITERALS, $MATCH_SUPERS_TIGHTLY);
|
||||
|
||||
BEGIN { unless(defined &DEBUG) { *DEBUG = sub () {0} } }
|
||||
# define the constant 'DEBUG' at compile-time
|
||||
|
||||
our $VERSION = "1.08";
|
||||
our @ISA = ();
|
||||
use I18N::LangTags qw(alternate_language_tags locale2language_tag);
|
||||
|
||||
sub _uniq { my %seen; return grep(!($seen{$_}++), @_); }
|
||||
sub _normalize {
|
||||
my(@languages) =
|
||||
map lc($_),
|
||||
grep $_,
|
||||
map {; $_, alternate_language_tags($_) } @_;
|
||||
return _uniq(@languages) if wantarray;
|
||||
return $languages[0];
|
||||
}
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
# The extent of our functional interface:
|
||||
|
||||
sub detect () { return __PACKAGE__->ambient_langprefs; }
|
||||
|
||||
#===========================================================================
|
||||
|
||||
sub ambient_langprefs { # always returns things untainted
|
||||
my $base_class = $_[0];
|
||||
|
||||
return $base_class->http_accept_langs
|
||||
if length( $ENV{'REQUEST_METHOD'} || '' ); # I'm a CGI
|
||||
# it's off in its own routine because it's complicated
|
||||
|
||||
# Not running as a CGI: try to puzzle out from the environment
|
||||
my @languages;
|
||||
|
||||
foreach my $envname (qw( LANGUAGE LC_ALL LC_MESSAGES LANG )) {
|
||||
next unless $ENV{$envname};
|
||||
DEBUG and print "Noting \$$envname: $ENV{$envname}\n";
|
||||
push @languages,
|
||||
map locale2language_tag($_),
|
||||
# if it's a lg tag, fine, pass thru (untainted)
|
||||
# if it's a locale ID, try converting to a lg tag (untainted),
|
||||
# otherwise nix it.
|
||||
|
||||
split m/[,:]/,
|
||||
$ENV{$envname}
|
||||
;
|
||||
last; # first one wins
|
||||
}
|
||||
|
||||
if($ENV{'IGNORE_WIN32_LOCALE'}) {
|
||||
# no-op
|
||||
} elsif(&_try_use('Win32::Locale')) {
|
||||
# If we have that module installed...
|
||||
push @languages, Win32::Locale::get_language() || ''
|
||||
if defined &Win32::Locale::get_language;
|
||||
}
|
||||
return _normalize @languages;
|
||||
}
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
sub http_accept_langs {
|
||||
# Deal with HTTP "Accept-Language:" stuff. Hassle.
|
||||
# This code is more lenient than RFC 3282, which you must read.
|
||||
# Hm. Should I just move this into I18N::LangTags at some point?
|
||||
no integer;
|
||||
|
||||
my $in = (@_ > 1) ? $_[1] : $ENV{'HTTP_ACCEPT_LANGUAGE'};
|
||||
# (always ends up untainting)
|
||||
|
||||
return() unless defined $in and length $in;
|
||||
|
||||
$in =~ s/\([^\)]*\)//g; # nix just about any comment
|
||||
|
||||
if( $in =~ m/^\s*([a-zA-Z][-a-zA-Z]+)\s*$/s ) {
|
||||
# Very common case: just one language tag
|
||||
return _normalize $1;
|
||||
} elsif( $in =~ m/^\s*[a-zA-Z][-a-zA-Z]+(?:\s*,\s*[a-zA-Z][-a-zA-Z]+)*\s*$/s ) {
|
||||
# Common case these days: just "foo, bar, baz"
|
||||
return _normalize( $in =~ m/([a-zA-Z][-a-zA-Z]+)/g );
|
||||
}
|
||||
|
||||
# Else it's complicated...
|
||||
|
||||
$in =~ s/\s+//g; # Yes, we can just do without the WS!
|
||||
my @in = $in =~ m/([^,]+)/g;
|
||||
my %pref;
|
||||
|
||||
my $q;
|
||||
foreach my $tag (@in) {
|
||||
next unless $tag =~
|
||||
m/^([a-zA-Z][-a-zA-Z]+)
|
||||
(?:
|
||||
;q=
|
||||
(
|
||||
\d* # a bit too broad of a RE, but so what.
|
||||
(?:
|
||||
\.\d+
|
||||
)?
|
||||
)
|
||||
)?
|
||||
$
|
||||
/sx
|
||||
;
|
||||
$q = (defined $2 and length $2) ? $2 : 1;
|
||||
#print "$1 with q=$q\n";
|
||||
push @{ $pref{$q} }, lc $1;
|
||||
}
|
||||
|
||||
return _normalize(
|
||||
# Read off %pref, in descending key order...
|
||||
map @{$pref{$_}},
|
||||
sort {$b <=> $a}
|
||||
keys %pref
|
||||
);
|
||||
}
|
||||
|
||||
#===========================================================================
|
||||
|
||||
my %tried = ();
|
||||
# memoization of whether we've used this module, or found it unusable.
|
||||
|
||||
sub _try_use { # Basically a wrapper around "require Modulename"
|
||||
# "Many men have tried..." "They tried and failed?" "They tried and died."
|
||||
return $tried{$_[0]} if exists $tried{$_[0]}; # memoization
|
||||
|
||||
my $module = $_[0]; # ASSUME sane module name!
|
||||
{ no strict 'refs';
|
||||
no warnings 'once';
|
||||
return($tried{$module} = 1)
|
||||
if %{$module . "::Lexicon"} or @{$module . "::ISA"};
|
||||
# weird case: we never use'd it, but there it is!
|
||||
}
|
||||
|
||||
print " About to use $module ...\n" if DEBUG;
|
||||
{
|
||||
local $SIG{'__DIE__'};
|
||||
local @INC = @INC;
|
||||
pop @INC if $INC[-1] eq '.';
|
||||
eval "require $module"; # used to be "use $module", but no point in that.
|
||||
}
|
||||
if($@) {
|
||||
print "Error using $module \: $@\n" if DEBUG > 1;
|
||||
return $tried{$module} = 0;
|
||||
} else {
|
||||
print " OK, $module is used\n" if DEBUG;
|
||||
return $tried{$module} = 1;
|
||||
}
|
||||
}
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
1;
|
||||
__END__
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
I18N::LangTags::Detect - detect the user's language preferences
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use I18N::LangTags::Detect;
|
||||
my @user_wants = I18N::LangTags::Detect::detect();
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
It is a common problem to want to detect what language(s) the user would
|
||||
prefer output in.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
This module defines one public function,
|
||||
C<I18N::LangTags::Detect::detect()>. This function is not exported
|
||||
(nor is even exportable), and it takes no parameters.
|
||||
|
||||
In scalar context, the function returns the most preferred language
|
||||
tag (or undef if no preference was seen).
|
||||
|
||||
In list context (which is usually what you want),
|
||||
the function returns a
|
||||
(possibly empty) list of language tags representing (best first) what
|
||||
languages the user apparently would accept output in. You will
|
||||
probably want to pass the output of this through
|
||||
C<I18N::LangTags::implicate_supers_tightly(...)>
|
||||
or
|
||||
C<I18N::LangTags::implicate_supers(...)>, like so:
|
||||
|
||||
my @languages =
|
||||
I18N::LangTags::implicate_supers_tightly(
|
||||
I18N::LangTags::Detect::detect()
|
||||
);
|
||||
|
||||
|
||||
=head1 ENVIRONMENT
|
||||
|
||||
This module looks at several environment variables:
|
||||
REQUEST_METHOD, HTTP_ACCEPT_LANGUAGE,
|
||||
LANGUAGE, LC_ALL, LC_MESSAGES, and LANG.
|
||||
|
||||
It will also use the L<Win32::Locale> module, if it's installed
|
||||
and IGNORE_WIN32_LOCALE is not set to a true value in the
|
||||
environment.
|
||||
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<I18N::LangTags>, L<Win32::Locale>, L<Locale::Maketext>.
|
||||
|
||||
(This module's core code started out as a routine in Locale::Maketext;
|
||||
but I moved it here once I realized it was more generally useful.)
|
||||
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 1998-2004 Sean M. Burke. All rights reserved.
|
||||
|
||||
This library is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
||||
The programs and documentation in this dist are distributed in
|
||||
the hope that they will be useful, but without any warranty; without
|
||||
even the implied warranty of merchantability or fitness for a
|
||||
particular purpose.
|
||||
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Sean M. Burke C<sburke@cpan.org>
|
||||
|
||||
=cut
|
||||
|
||||
# a tip: Put a bit of chopped up pickled ginger in your salad. It's tasty!
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,153 @@
|
||||
package IO::Compress::Adapter::Bzip2 ;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use bytes;
|
||||
|
||||
use IO::Compress::Base::Common 2.204 qw(:Status);
|
||||
|
||||
use Compress::Raw::Bzip2 2.204 ;
|
||||
|
||||
our ($VERSION);
|
||||
$VERSION = '2.204';
|
||||
|
||||
sub mkCompObject
|
||||
{
|
||||
my $BlockSize100K = shift ;
|
||||
my $WorkFactor = shift ;
|
||||
my $Verbosity = shift ;
|
||||
|
||||
$BlockSize100K = 1 if ! defined $BlockSize100K ;
|
||||
$WorkFactor = 0 if ! defined $WorkFactor ;
|
||||
$Verbosity = 0 if ! defined $Verbosity ;
|
||||
|
||||
my ($def, $status) = Compress::Raw::Bzip2->new(1, $BlockSize100K,
|
||||
$WorkFactor, $Verbosity);
|
||||
|
||||
return (undef, "Could not create Deflate object: $status", $status)
|
||||
if $status != BZ_OK ;
|
||||
|
||||
return bless {'Def' => $def,
|
||||
'Error' => '',
|
||||
'ErrorNo' => 0,
|
||||
} ;
|
||||
}
|
||||
|
||||
sub compr
|
||||
{
|
||||
my $self = shift ;
|
||||
|
||||
my $def = $self->{Def};
|
||||
|
||||
my $status = $def->bzdeflate($_[0], $_[1]) ;
|
||||
$self->{ErrorNo} = $status;
|
||||
|
||||
if ($status != BZ_RUN_OK)
|
||||
{
|
||||
$self->{Error} = "Deflate Error: $status";
|
||||
return STATUS_ERROR;
|
||||
}
|
||||
|
||||
return STATUS_OK;
|
||||
}
|
||||
|
||||
sub flush
|
||||
{
|
||||
my $self = shift ;
|
||||
|
||||
my $def = $self->{Def};
|
||||
|
||||
my $status = $def->bzflush($_[0]);
|
||||
$self->{ErrorNo} = $status;
|
||||
|
||||
if ($status != BZ_RUN_OK)
|
||||
{
|
||||
$self->{Error} = "Deflate Error: $status";
|
||||
return STATUS_ERROR;
|
||||
}
|
||||
|
||||
return STATUS_OK;
|
||||
|
||||
}
|
||||
|
||||
sub close
|
||||
{
|
||||
my $self = shift ;
|
||||
|
||||
my $def = $self->{Def};
|
||||
|
||||
my $status = $def->bzclose($_[0]);
|
||||
$self->{ErrorNo} = $status;
|
||||
|
||||
if ($status != BZ_STREAM_END)
|
||||
{
|
||||
$self->{Error} = "Deflate Error: $status";
|
||||
return STATUS_ERROR;
|
||||
}
|
||||
|
||||
return STATUS_OK;
|
||||
|
||||
}
|
||||
|
||||
|
||||
sub reset
|
||||
{
|
||||
my $self = shift ;
|
||||
|
||||
my $outer = $self->{Outer};
|
||||
|
||||
my ($def, $status) = Compress::Raw::Bzip2->new();
|
||||
$self->{ErrorNo} = ($status == BZ_OK) ? 0 : $status ;
|
||||
|
||||
if ($status != BZ_OK)
|
||||
{
|
||||
$self->{Error} = "Cannot create Deflate object: $status";
|
||||
return STATUS_ERROR;
|
||||
}
|
||||
|
||||
$self->{Def} = $def;
|
||||
|
||||
return STATUS_OK;
|
||||
}
|
||||
|
||||
sub compressedBytes
|
||||
{
|
||||
my $self = shift ;
|
||||
$self->{Def}->compressedBytes();
|
||||
}
|
||||
|
||||
sub uncompressedBytes
|
||||
{
|
||||
my $self = shift ;
|
||||
$self->{Def}->uncompressedBytes();
|
||||
}
|
||||
|
||||
#sub total_out
|
||||
#{
|
||||
# my $self = shift ;
|
||||
# 0;
|
||||
#}
|
||||
#
|
||||
|
||||
#sub total_in
|
||||
#{
|
||||
# my $self = shift ;
|
||||
# $self->{Def}->total_in();
|
||||
#}
|
||||
#
|
||||
#sub crc32
|
||||
#{
|
||||
# my $self = shift ;
|
||||
# $self->{Def}->crc32();
|
||||
#}
|
||||
#
|
||||
#sub adler32
|
||||
#{
|
||||
# my $self = shift ;
|
||||
# $self->{Def}->adler32();
|
||||
#}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
@@ -0,0 +1,192 @@
|
||||
package IO::Compress::Adapter::Deflate ;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use bytes;
|
||||
|
||||
use IO::Compress::Base::Common 2.204 qw(:Status);
|
||||
use Compress::Raw::Zlib 2.204 qw( !crc32 !adler32 ) ;
|
||||
|
||||
require Exporter;
|
||||
our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, @EXPORT, %DEFLATE_CONSTANTS);
|
||||
|
||||
$VERSION = '2.204';
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT_OK = @Compress::Raw::Zlib::DEFLATE_CONSTANTS;
|
||||
%EXPORT_TAGS = %Compress::Raw::Zlib::DEFLATE_CONSTANTS;
|
||||
@EXPORT = @EXPORT_OK;
|
||||
%DEFLATE_CONSTANTS = %EXPORT_TAGS ;
|
||||
|
||||
sub mkCompObject
|
||||
{
|
||||
my $crc32 = shift ;
|
||||
my $adler32 = shift ;
|
||||
my $level = shift ;
|
||||
my $strategy = shift ;
|
||||
|
||||
my ($def, $status) = Compress::Raw::Zlib::Deflate->new(
|
||||
-AppendOutput => 1,
|
||||
-CRC32 => $crc32,
|
||||
-ADLER32 => $adler32,
|
||||
-Level => $level,
|
||||
-Strategy => $strategy,
|
||||
-WindowBits => - MAX_WBITS);
|
||||
|
||||
return (undef, "Cannot create Deflate object: $status", $status)
|
||||
if $status != Z_OK;
|
||||
|
||||
return bless {'Def' => $def,
|
||||
'Error' => '',
|
||||
} ;
|
||||
}
|
||||
|
||||
sub mkCompObject1
|
||||
{
|
||||
my $crc32 = shift ;
|
||||
my $adler32 = shift ;
|
||||
my $level = shift ;
|
||||
my $strategy = shift ;
|
||||
|
||||
my ($def, $status) = Compress::Raw::Zlib::Deflate->new(
|
||||
-AppendOutput => 1,
|
||||
-CRC32 => $crc32,
|
||||
-ADLER32 => $adler32,
|
||||
-Level => $level,
|
||||
-Strategy => $strategy,
|
||||
-WindowBits => MAX_WBITS);
|
||||
|
||||
return (undef, "Cannot create Deflate object: $status", $status)
|
||||
if $status != Z_OK;
|
||||
|
||||
return bless {'Def' => $def,
|
||||
'Error' => '',
|
||||
} ;
|
||||
}
|
||||
|
||||
sub compr
|
||||
{
|
||||
my $self = shift ;
|
||||
|
||||
my $def = $self->{Def};
|
||||
|
||||
my $status = $def->deflate($_[0], $_[1]) ;
|
||||
$self->{ErrorNo} = $status;
|
||||
|
||||
if ($status != Z_OK)
|
||||
{
|
||||
$self->{Error} = "Deflate Error: $status";
|
||||
return STATUS_ERROR;
|
||||
}
|
||||
|
||||
return STATUS_OK;
|
||||
}
|
||||
|
||||
sub flush
|
||||
{
|
||||
my $self = shift ;
|
||||
|
||||
my $def = $self->{Def};
|
||||
|
||||
my $opt = $_[1] || Z_FINISH;
|
||||
my $status = $def->flush($_[0], $opt);
|
||||
$self->{ErrorNo} = $status;
|
||||
|
||||
if ($status != Z_OK)
|
||||
{
|
||||
$self->{Error} = "Deflate Error: $status";
|
||||
return STATUS_ERROR;
|
||||
}
|
||||
|
||||
return STATUS_OK;
|
||||
}
|
||||
|
||||
sub close
|
||||
{
|
||||
my $self = shift ;
|
||||
|
||||
my $def = $self->{Def};
|
||||
|
||||
$def->flush($_[0], Z_FINISH)
|
||||
if defined $def ;
|
||||
}
|
||||
|
||||
sub reset
|
||||
{
|
||||
my $self = shift ;
|
||||
|
||||
my $def = $self->{Def};
|
||||
|
||||
my $status = $def->deflateReset() ;
|
||||
$self->{ErrorNo} = $status;
|
||||
if ($status != Z_OK)
|
||||
{
|
||||
$self->{Error} = "Deflate Error: $status";
|
||||
return STATUS_ERROR;
|
||||
}
|
||||
|
||||
return STATUS_OK;
|
||||
}
|
||||
|
||||
sub deflateParams
|
||||
{
|
||||
my $self = shift ;
|
||||
|
||||
my $def = $self->{Def};
|
||||
|
||||
my $status = $def->deflateParams(@_);
|
||||
$self->{ErrorNo} = $status;
|
||||
if ($status != Z_OK)
|
||||
{
|
||||
$self->{Error} = "deflateParams Error: $status";
|
||||
return STATUS_ERROR;
|
||||
}
|
||||
|
||||
return STATUS_OK;
|
||||
}
|
||||
|
||||
|
||||
|
||||
#sub total_out
|
||||
#{
|
||||
# my $self = shift ;
|
||||
# $self->{Def}->total_out();
|
||||
#}
|
||||
#
|
||||
#sub total_in
|
||||
#{
|
||||
# my $self = shift ;
|
||||
# $self->{Def}->total_in();
|
||||
#}
|
||||
|
||||
sub compressedBytes
|
||||
{
|
||||
my $self = shift ;
|
||||
|
||||
$self->{Def}->compressedBytes();
|
||||
}
|
||||
|
||||
sub uncompressedBytes
|
||||
{
|
||||
my $self = shift ;
|
||||
$self->{Def}->uncompressedBytes();
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
sub crc32
|
||||
{
|
||||
my $self = shift ;
|
||||
$self->{Def}->crc32();
|
||||
}
|
||||
|
||||
sub adler32
|
||||
{
|
||||
my $self = shift ;
|
||||
$self->{Def}->adler32();
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
@@ -0,0 +1,100 @@
|
||||
package IO::Compress::Adapter::Identity ;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use bytes;
|
||||
|
||||
use IO::Compress::Base::Common 2.204 qw(:Status);
|
||||
our ($VERSION);
|
||||
|
||||
$VERSION = '2.204';
|
||||
|
||||
sub mkCompObject
|
||||
{
|
||||
my $level = shift ;
|
||||
my $strategy = shift ;
|
||||
|
||||
return bless {
|
||||
'CompSize' => 0,
|
||||
'UnCompSize' => 0,
|
||||
'Error' => '',
|
||||
'ErrorNo' => 0,
|
||||
} ;
|
||||
}
|
||||
|
||||
sub compr
|
||||
{
|
||||
my $self = shift ;
|
||||
|
||||
if (defined ${ $_[0] } && length ${ $_[0] }) {
|
||||
$self->{CompSize} += length ${ $_[0] } ;
|
||||
$self->{UnCompSize} = $self->{CompSize} ;
|
||||
|
||||
if ( ref $_[1] )
|
||||
{ ${ $_[1] } .= ${ $_[0] } }
|
||||
else
|
||||
{ $_[1] .= ${ $_[0] } }
|
||||
}
|
||||
|
||||
return STATUS_OK ;
|
||||
}
|
||||
|
||||
sub flush
|
||||
{
|
||||
my $self = shift ;
|
||||
|
||||
return STATUS_OK;
|
||||
}
|
||||
|
||||
sub close
|
||||
{
|
||||
my $self = shift ;
|
||||
|
||||
return STATUS_OK;
|
||||
}
|
||||
|
||||
sub reset
|
||||
{
|
||||
my $self = shift ;
|
||||
|
||||
$self->{CompSize} = 0;
|
||||
$self->{UnCompSize} = 0;
|
||||
|
||||
return STATUS_OK;
|
||||
}
|
||||
|
||||
sub deflateParams
|
||||
{
|
||||
my $self = shift ;
|
||||
|
||||
return STATUS_OK;
|
||||
}
|
||||
|
||||
#sub total_out
|
||||
#{
|
||||
# my $self = shift ;
|
||||
# return $self->{UnCompSize} ;
|
||||
#}
|
||||
#
|
||||
#sub total_in
|
||||
#{
|
||||
# my $self = shift ;
|
||||
# return $self->{UnCompSize} ;
|
||||
#}
|
||||
|
||||
sub compressedBytes
|
||||
{
|
||||
my $self = shift ;
|
||||
return $self->{UnCompSize} ;
|
||||
}
|
||||
|
||||
sub uncompressedBytes
|
||||
{
|
||||
my $self = shift ;
|
||||
return $self->{UnCompSize} ;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
||||
__END__
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,824 @@
|
||||
package IO::Compress::Bzip2 ;
|
||||
|
||||
use strict ;
|
||||
use warnings;
|
||||
use bytes;
|
||||
require Exporter ;
|
||||
|
||||
use IO::Compress::Base 2.204 ;
|
||||
|
||||
use IO::Compress::Base::Common 2.204 qw();
|
||||
use IO::Compress::Adapter::Bzip2 2.204 ;
|
||||
|
||||
|
||||
|
||||
our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $Bzip2Error);
|
||||
|
||||
$VERSION = '2.204';
|
||||
$Bzip2Error = '';
|
||||
|
||||
@ISA = qw(IO::Compress::Base Exporter);
|
||||
@EXPORT_OK = qw( $Bzip2Error bzip2 ) ;
|
||||
%EXPORT_TAGS = %IO::Compress::Base::EXPORT_TAGS ;
|
||||
push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
|
||||
Exporter::export_ok_tags('all');
|
||||
|
||||
|
||||
|
||||
sub new
|
||||
{
|
||||
my $class = shift ;
|
||||
|
||||
my $obj = IO::Compress::Base::Common::createSelfTiedObject($class, \$Bzip2Error);
|
||||
return $obj->_create(undef, @_);
|
||||
}
|
||||
|
||||
sub bzip2
|
||||
{
|
||||
my $obj = IO::Compress::Base::Common::createSelfTiedObject(undef, \$Bzip2Error);
|
||||
$obj->_def(@_);
|
||||
}
|
||||
|
||||
|
||||
sub mkHeader
|
||||
{
|
||||
my $self = shift ;
|
||||
return '';
|
||||
|
||||
}
|
||||
|
||||
sub getExtraParams
|
||||
{
|
||||
my $self = shift ;
|
||||
|
||||
use IO::Compress::Base::Common 2.204 qw(:Parse);
|
||||
|
||||
return (
|
||||
'blocksize100k' => [IO::Compress::Base::Common::Parse_unsigned, 1],
|
||||
'workfactor' => [IO::Compress::Base::Common::Parse_unsigned, 0],
|
||||
'verbosity' => [IO::Compress::Base::Common::Parse_boolean, 0],
|
||||
);
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub ckParams
|
||||
{
|
||||
my $self = shift ;
|
||||
my $got = shift;
|
||||
|
||||
# check that BlockSize100K is a number between 1 & 9
|
||||
if ($got->parsed('blocksize100k')) {
|
||||
my $value = $got->getValue('blocksize100k');
|
||||
return $self->saveErrorString(undef, "Parameter 'BlockSize100K' not between 1 and 9, got $value")
|
||||
unless defined $value && $value >= 1 && $value <= 9;
|
||||
|
||||
}
|
||||
|
||||
# check that WorkFactor between 0 & 250
|
||||
if ($got->parsed('workfactor')) {
|
||||
my $value = $got->getValue('workfactor');
|
||||
return $self->saveErrorString(undef, "Parameter 'WorkFactor' not between 0 and 250, got $value")
|
||||
unless $value >= 0 && $value <= 250;
|
||||
}
|
||||
|
||||
return 1 ;
|
||||
}
|
||||
|
||||
|
||||
sub mkComp
|
||||
{
|
||||
my $self = shift ;
|
||||
my $got = shift ;
|
||||
|
||||
my $BlockSize100K = $got->getValue('blocksize100k');
|
||||
my $WorkFactor = $got->getValue('workfactor');
|
||||
my $Verbosity = $got->getValue('verbosity');
|
||||
|
||||
my ($obj, $errstr, $errno) = IO::Compress::Adapter::Bzip2::mkCompObject(
|
||||
$BlockSize100K, $WorkFactor,
|
||||
$Verbosity);
|
||||
|
||||
return $self->saveErrorString(undef, $errstr, $errno)
|
||||
if ! defined $obj;
|
||||
|
||||
return $obj;
|
||||
}
|
||||
|
||||
|
||||
sub mkTrailer
|
||||
{
|
||||
my $self = shift ;
|
||||
return '';
|
||||
}
|
||||
|
||||
sub mkFinalTrailer
|
||||
{
|
||||
return '';
|
||||
}
|
||||
|
||||
#sub newHeader
|
||||
#{
|
||||
# my $self = shift ;
|
||||
# return '';
|
||||
#}
|
||||
|
||||
sub getInverseClass
|
||||
{
|
||||
return ('IO::Uncompress::Bunzip2');
|
||||
}
|
||||
|
||||
sub getFileInfo
|
||||
{
|
||||
my $self = shift ;
|
||||
my $params = shift;
|
||||
my $file = shift ;
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
IO::Compress::Bzip2 - Write bzip2 files/buffers
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use IO::Compress::Bzip2 qw(bzip2 $Bzip2Error) ;
|
||||
|
||||
my $status = bzip2 $input => $output [,OPTS]
|
||||
or die "bzip2 failed: $Bzip2Error\n";
|
||||
|
||||
my $z = IO::Compress::Bzip2->new( $output [,OPTS] )
|
||||
or die "bzip2 failed: $Bzip2Error\n";
|
||||
|
||||
$z->print($string);
|
||||
$z->printf($format, $string);
|
||||
$z->write($string);
|
||||
$z->syswrite($string [, $length, $offset]);
|
||||
$z->flush();
|
||||
$z->tell();
|
||||
$z->eof();
|
||||
$z->seek($position, $whence);
|
||||
$z->binmode();
|
||||
$z->fileno();
|
||||
$z->opened();
|
||||
$z->autoflush();
|
||||
$z->input_line_number();
|
||||
$z->newStream( [OPTS] );
|
||||
|
||||
$z->close() ;
|
||||
|
||||
$Bzip2Error ;
|
||||
|
||||
# IO::File mode
|
||||
|
||||
print $z $string;
|
||||
printf $z $format, $string;
|
||||
tell $z
|
||||
eof $z
|
||||
seek $z, $position, $whence
|
||||
binmode $z
|
||||
fileno $z
|
||||
close $z ;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides a Perl interface that allows writing bzip2
|
||||
compressed data to files or buffer.
|
||||
|
||||
For reading bzip2 files/buffers, see the companion module
|
||||
L<IO::Uncompress::Bunzip2|IO::Uncompress::Bunzip2>.
|
||||
|
||||
=head1 Functional Interface
|
||||
|
||||
A top-level function, C<bzip2>, is provided to carry out
|
||||
"one-shot" compression between buffers and/or files. For finer
|
||||
control over the compression process, see the L</"OO Interface">
|
||||
section.
|
||||
|
||||
use IO::Compress::Bzip2 qw(bzip2 $Bzip2Error) ;
|
||||
|
||||
bzip2 $input_filename_or_reference => $output_filename_or_reference [,OPTS]
|
||||
or die "bzip2 failed: $Bzip2Error\n";
|
||||
|
||||
The functional interface needs Perl5.005 or better.
|
||||
|
||||
=head2 bzip2 $input_filename_or_reference => $output_filename_or_reference [, OPTS]
|
||||
|
||||
C<bzip2> expects at least two parameters,
|
||||
C<$input_filename_or_reference> and C<$output_filename_or_reference>
|
||||
and zero or more optional parameters (see L</Optional Parameters>)
|
||||
|
||||
=head3 The C<$input_filename_or_reference> parameter
|
||||
|
||||
The parameter, C<$input_filename_or_reference>, is used to define the
|
||||
source of the uncompressed data.
|
||||
|
||||
It can take one of the following forms:
|
||||
|
||||
=over 5
|
||||
|
||||
=item A filename
|
||||
|
||||
If the C<$input_filename_or_reference> parameter is a simple scalar, it is
|
||||
assumed to be a filename. This file will be opened for reading and the
|
||||
input data will be read from it.
|
||||
|
||||
=item A filehandle
|
||||
|
||||
If the C<$input_filename_or_reference> parameter is a filehandle, the input
|
||||
data will be read from it. The string '-' can be used as an alias for
|
||||
standard input.
|
||||
|
||||
=item A scalar reference
|
||||
|
||||
If C<$input_filename_or_reference> is a scalar reference, the input data
|
||||
will be read from C<$$input_filename_or_reference>.
|
||||
|
||||
=item An array reference
|
||||
|
||||
If C<$input_filename_or_reference> is an array reference, each element in
|
||||
the array must be a filename.
|
||||
|
||||
The input data will be read from each file in turn.
|
||||
|
||||
The complete array will be walked to ensure that it only
|
||||
contains valid filenames before any data is compressed.
|
||||
|
||||
=item An Input FileGlob string
|
||||
|
||||
If C<$input_filename_or_reference> is a string that is delimited by the
|
||||
characters "<" and ">" C<bzip2> will assume that it is an
|
||||
I<input fileglob string>. The input is the list of files that match the
|
||||
fileglob.
|
||||
|
||||
See L<File::GlobMapper|File::GlobMapper> for more details.
|
||||
|
||||
=back
|
||||
|
||||
If the C<$input_filename_or_reference> parameter is any other type,
|
||||
C<undef> will be returned.
|
||||
|
||||
=head3 The C<$output_filename_or_reference> parameter
|
||||
|
||||
The parameter C<$output_filename_or_reference> is used to control the
|
||||
destination of the compressed data. This parameter can take one of
|
||||
these forms.
|
||||
|
||||
=over 5
|
||||
|
||||
=item A filename
|
||||
|
||||
If the C<$output_filename_or_reference> parameter is a simple scalar, it is
|
||||
assumed to be a filename. This file will be opened for writing and the
|
||||
compressed data will be written to it.
|
||||
|
||||
=item A filehandle
|
||||
|
||||
If the C<$output_filename_or_reference> parameter is a filehandle, the
|
||||
compressed data will be written to it. The string '-' can be used as
|
||||
an alias for standard output.
|
||||
|
||||
=item A scalar reference
|
||||
|
||||
If C<$output_filename_or_reference> is a scalar reference, the
|
||||
compressed data will be stored in C<$$output_filename_or_reference>.
|
||||
|
||||
=item An Array Reference
|
||||
|
||||
If C<$output_filename_or_reference> is an array reference,
|
||||
the compressed data will be pushed onto the array.
|
||||
|
||||
=item An Output FileGlob
|
||||
|
||||
If C<$output_filename_or_reference> is a string that is delimited by the
|
||||
characters "<" and ">" C<bzip2> will assume that it is an
|
||||
I<output fileglob string>. The output is the list of files that match the
|
||||
fileglob.
|
||||
|
||||
When C<$output_filename_or_reference> is an fileglob string,
|
||||
C<$input_filename_or_reference> must also be a fileglob string. Anything
|
||||
else is an error.
|
||||
|
||||
See L<File::GlobMapper|File::GlobMapper> for more details.
|
||||
|
||||
=back
|
||||
|
||||
If the C<$output_filename_or_reference> parameter is any other type,
|
||||
C<undef> will be returned.
|
||||
|
||||
=head2 Notes
|
||||
|
||||
When C<$input_filename_or_reference> maps to multiple files/buffers and
|
||||
C<$output_filename_or_reference> is a single
|
||||
file/buffer the input files/buffers will be stored
|
||||
in C<$output_filename_or_reference> as a concatenated series of compressed data streams.
|
||||
|
||||
=head2 Optional Parameters
|
||||
|
||||
The optional parameters for the one-shot function C<bzip2>
|
||||
are (for the most part) identical to those used with the OO interface defined in the
|
||||
L</"Constructor Options"> section. The exceptions are listed below
|
||||
|
||||
=over 5
|
||||
|
||||
=item C<< AutoClose => 0|1 >>
|
||||
|
||||
This option applies to any input or output data streams to
|
||||
C<bzip2> that are filehandles.
|
||||
|
||||
If C<AutoClose> is specified, and the value is true, it will result in all
|
||||
input and/or output filehandles being closed once C<bzip2> has
|
||||
completed.
|
||||
|
||||
This parameter defaults to 0.
|
||||
|
||||
=item C<< BinModeIn => 0|1 >>
|
||||
|
||||
This option is now a no-op. All files will be read in binmode.
|
||||
|
||||
=item C<< Append => 0|1 >>
|
||||
|
||||
The behaviour of this option is dependent on the type of output data
|
||||
stream.
|
||||
|
||||
=over 5
|
||||
|
||||
=item * A Buffer
|
||||
|
||||
If C<Append> is enabled, all compressed data will be append to the end of
|
||||
the output buffer. Otherwise the output buffer will be cleared before any
|
||||
compressed data is written to it.
|
||||
|
||||
=item * A Filename
|
||||
|
||||
If C<Append> is enabled, the file will be opened in append mode. Otherwise
|
||||
the contents of the file, if any, will be truncated before any compressed
|
||||
data is written to it.
|
||||
|
||||
=item * A Filehandle
|
||||
|
||||
If C<Append> is enabled, the filehandle will be positioned to the end of
|
||||
the file via a call to C<seek> before any compressed data is
|
||||
written to it. Otherwise the file pointer will not be moved.
|
||||
|
||||
=back
|
||||
|
||||
When C<Append> is specified, and set to true, it will I<append> all compressed
|
||||
data to the output data stream.
|
||||
|
||||
So when the output is a filehandle it will carry out a seek to the eof
|
||||
before writing any compressed data. If the output is a filename, it will be opened for
|
||||
appending. If the output is a buffer, all compressed data will be
|
||||
appended to the existing buffer.
|
||||
|
||||
Conversely when C<Append> is not specified, or it is present and is set to
|
||||
false, it will operate as follows.
|
||||
|
||||
When the output is a filename, it will truncate the contents of the file
|
||||
before writing any compressed data. If the output is a filehandle
|
||||
its position will not be changed. If the output is a buffer, it will be
|
||||
wiped before any compressed data is output.
|
||||
|
||||
Defaults to 0.
|
||||
|
||||
=back
|
||||
|
||||
=head2 Examples
|
||||
|
||||
Here are a few example that show the capabilities of the module.
|
||||
|
||||
=head3 Streaming
|
||||
|
||||
This very simple command line example demonstrates the streaming capabilities of the module.
|
||||
The code reads data from STDIN, compresses it, and writes the compressed data to STDOUT.
|
||||
|
||||
$ echo hello world | perl -MIO::Compress::Bzip2=bzip2 -e 'bzip2 \*STDIN => \*STDOUT' >output.bz2
|
||||
|
||||
The special filename "-" can be used as a standin for both C<\*STDIN> and C<\*STDOUT>,
|
||||
so the above can be rewritten as
|
||||
|
||||
$ echo hello world | perl -MIO::Compress::Bzip2=bzip2 -e 'bzip2 "-" => "-"' >output.bz2
|
||||
|
||||
=head3 Compressing a file from the filesystem
|
||||
|
||||
To read the contents of the file C<file1.txt> and write the compressed
|
||||
data to the file C<file1.txt.bz2>.
|
||||
|
||||
use strict ;
|
||||
use warnings ;
|
||||
use IO::Compress::Bzip2 qw(bzip2 $Bzip2Error) ;
|
||||
|
||||
my $input = "file1.txt";
|
||||
bzip2 $input => "$input.bz2"
|
||||
or die "bzip2 failed: $Bzip2Error\n";
|
||||
|
||||
=head3 Reading from a Filehandle and writing to an in-memory buffer
|
||||
|
||||
To read from an existing Perl filehandle, C<$input>, and write the
|
||||
compressed data to a buffer, C<$buffer>.
|
||||
|
||||
use strict ;
|
||||
use warnings ;
|
||||
use IO::Compress::Bzip2 qw(bzip2 $Bzip2Error) ;
|
||||
use IO::File ;
|
||||
|
||||
my $input = IO::File->new( "<file1.txt" )
|
||||
or die "Cannot open 'file1.txt': $!\n" ;
|
||||
my $buffer ;
|
||||
bzip2 $input => \$buffer
|
||||
or die "bzip2 failed: $Bzip2Error\n";
|
||||
|
||||
=head3 Compressing multiple files
|
||||
|
||||
To compress all files in the directory "/my/home" that match "*.txt"
|
||||
and store the compressed data in the same directory
|
||||
|
||||
use strict ;
|
||||
use warnings ;
|
||||
use IO::Compress::Bzip2 qw(bzip2 $Bzip2Error) ;
|
||||
|
||||
bzip2 '</my/home/*.txt>' => '<*.bz2>'
|
||||
or die "bzip2 failed: $Bzip2Error\n";
|
||||
|
||||
and if you want to compress each file one at a time, this will do the trick
|
||||
|
||||
use strict ;
|
||||
use warnings ;
|
||||
use IO::Compress::Bzip2 qw(bzip2 $Bzip2Error) ;
|
||||
|
||||
for my $input ( glob "/my/home/*.txt" )
|
||||
{
|
||||
my $output = "$input.bz2" ;
|
||||
bzip2 $input => $output
|
||||
or die "Error compressing '$input': $Bzip2Error\n";
|
||||
}
|
||||
|
||||
=head1 OO Interface
|
||||
|
||||
=head2 Constructor
|
||||
|
||||
The format of the constructor for C<IO::Compress::Bzip2> is shown below
|
||||
|
||||
my $z = IO::Compress::Bzip2->new( $output [,OPTS] )
|
||||
or die "IO::Compress::Bzip2 failed: $Bzip2Error\n";
|
||||
|
||||
It returns an C<IO::Compress::Bzip2> object on success and undef on failure.
|
||||
The variable C<$Bzip2Error> will contain an error message on failure.
|
||||
|
||||
If you are running Perl 5.005 or better the object, C<$z>, returned from
|
||||
IO::Compress::Bzip2 can be used exactly like an L<IO::File|IO::File> filehandle.
|
||||
This means that all normal output file operations can be carried out
|
||||
with C<$z>.
|
||||
For example, to write to a compressed file/buffer you can use either of
|
||||
these forms
|
||||
|
||||
$z->print("hello world\n");
|
||||
print $z "hello world\n";
|
||||
|
||||
The mandatory parameter C<$output> is used to control the destination
|
||||
of the compressed data. This parameter can take one of these forms.
|
||||
|
||||
=over 5
|
||||
|
||||
=item A filename
|
||||
|
||||
If the C<$output> parameter is a simple scalar, it is assumed to be a
|
||||
filename. This file will be opened for writing and the compressed data
|
||||
will be written to it.
|
||||
|
||||
=item A filehandle
|
||||
|
||||
If the C<$output> parameter is a filehandle, the compressed data will be
|
||||
written to it.
|
||||
The string '-' can be used as an alias for standard output.
|
||||
|
||||
=item A scalar reference
|
||||
|
||||
If C<$output> is a scalar reference, the compressed data will be stored
|
||||
in C<$$output>.
|
||||
|
||||
=back
|
||||
|
||||
If the C<$output> parameter is any other type, C<IO::Compress::Bzip2>::new will
|
||||
return undef.
|
||||
|
||||
=head2 Constructor Options
|
||||
|
||||
C<OPTS> is any combination of zero or more the following options:
|
||||
|
||||
=over 5
|
||||
|
||||
=item C<< AutoClose => 0|1 >>
|
||||
|
||||
This option is only valid when the C<$output> parameter is a filehandle. If
|
||||
specified, and the value is true, it will result in the C<$output> being
|
||||
closed once either the C<close> method is called or the C<IO::Compress::Bzip2>
|
||||
object is destroyed.
|
||||
|
||||
This parameter defaults to 0.
|
||||
|
||||
=item C<< Append => 0|1 >>
|
||||
|
||||
Opens C<$output> in append mode.
|
||||
|
||||
The behaviour of this option is dependent on the type of C<$output>.
|
||||
|
||||
=over 5
|
||||
|
||||
=item * A Buffer
|
||||
|
||||
If C<$output> is a buffer and C<Append> is enabled, all compressed data
|
||||
will be append to the end of C<$output>. Otherwise C<$output> will be
|
||||
cleared before any data is written to it.
|
||||
|
||||
=item * A Filename
|
||||
|
||||
If C<$output> is a filename and C<Append> is enabled, the file will be
|
||||
opened in append mode. Otherwise the contents of the file, if any, will be
|
||||
truncated before any compressed data is written to it.
|
||||
|
||||
=item * A Filehandle
|
||||
|
||||
If C<$output> is a filehandle, the file pointer will be positioned to the
|
||||
end of the file via a call to C<seek> before any compressed data is written
|
||||
to it. Otherwise the file pointer will not be moved.
|
||||
|
||||
=back
|
||||
|
||||
This parameter defaults to 0.
|
||||
|
||||
=item C<< BlockSize100K => number >>
|
||||
|
||||
Specify the number of 100K blocks bzip2 uses during compression.
|
||||
|
||||
Valid values are from 1 to 9, where 9 is best compression.
|
||||
|
||||
The default is 1.
|
||||
|
||||
=item C<< WorkFactor => number >>
|
||||
|
||||
Specifies how much effort bzip2 should take before resorting to a slower
|
||||
fallback compression algorithm.
|
||||
|
||||
Valid values range from 0 to 250, where 0 means use the default value 30.
|
||||
|
||||
The default is 0.
|
||||
|
||||
=item C<< Strict => 0|1 >>
|
||||
|
||||
This is a placeholder option.
|
||||
|
||||
=back
|
||||
|
||||
=head2 Examples
|
||||
|
||||
TODO
|
||||
|
||||
=head1 Methods
|
||||
|
||||
=head2 print
|
||||
|
||||
Usage is
|
||||
|
||||
$z->print($data)
|
||||
print $z $data
|
||||
|
||||
Compresses and outputs the contents of the C<$data> parameter. This
|
||||
has the same behaviour as the C<print> built-in.
|
||||
|
||||
Returns true if successful.
|
||||
|
||||
=head2 printf
|
||||
|
||||
Usage is
|
||||
|
||||
$z->printf($format, $data)
|
||||
printf $z $format, $data
|
||||
|
||||
Compresses and outputs the contents of the C<$data> parameter.
|
||||
|
||||
Returns true if successful.
|
||||
|
||||
=head2 syswrite
|
||||
|
||||
Usage is
|
||||
|
||||
$z->syswrite $data
|
||||
$z->syswrite $data, $length
|
||||
$z->syswrite $data, $length, $offset
|
||||
|
||||
Compresses and outputs the contents of the C<$data> parameter.
|
||||
|
||||
Returns the number of uncompressed bytes written, or C<undef> if
|
||||
unsuccessful.
|
||||
|
||||
=head2 write
|
||||
|
||||
Usage is
|
||||
|
||||
$z->write $data
|
||||
$z->write $data, $length
|
||||
$z->write $data, $length, $offset
|
||||
|
||||
Compresses and outputs the contents of the C<$data> parameter.
|
||||
|
||||
Returns the number of uncompressed bytes written, or C<undef> if
|
||||
unsuccessful.
|
||||
|
||||
=head2 flush
|
||||
|
||||
Usage is
|
||||
|
||||
$z->flush;
|
||||
|
||||
Flushes any pending compressed data to the output file/buffer.
|
||||
|
||||
TODO
|
||||
|
||||
Returns true on success.
|
||||
|
||||
=head2 tell
|
||||
|
||||
Usage is
|
||||
|
||||
$z->tell()
|
||||
tell $z
|
||||
|
||||
Returns the uncompressed file offset.
|
||||
|
||||
=head2 eof
|
||||
|
||||
Usage is
|
||||
|
||||
$z->eof();
|
||||
eof($z);
|
||||
|
||||
Returns true if the C<close> method has been called.
|
||||
|
||||
=head2 seek
|
||||
|
||||
$z->seek($position, $whence);
|
||||
seek($z, $position, $whence);
|
||||
|
||||
Provides a sub-set of the C<seek> functionality, with the restriction
|
||||
that it is only legal to seek forward in the output file/buffer.
|
||||
It is a fatal error to attempt to seek backward.
|
||||
|
||||
Empty parts of the file/buffer will have NULL (0x00) bytes written to them.
|
||||
|
||||
The C<$whence> parameter takes one the usual values, namely SEEK_SET,
|
||||
SEEK_CUR or SEEK_END.
|
||||
|
||||
Returns 1 on success, 0 on failure.
|
||||
|
||||
=head2 binmode
|
||||
|
||||
Usage is
|
||||
|
||||
$z->binmode
|
||||
binmode $z ;
|
||||
|
||||
This is a noop provided for completeness.
|
||||
|
||||
=head2 opened
|
||||
|
||||
$z->opened()
|
||||
|
||||
Returns true if the object currently refers to a opened file/buffer.
|
||||
|
||||
=head2 autoflush
|
||||
|
||||
my $prev = $z->autoflush()
|
||||
my $prev = $z->autoflush(EXPR)
|
||||
|
||||
If the C<$z> object is associated with a file or a filehandle, this method
|
||||
returns the current autoflush setting for the underlying filehandle. If
|
||||
C<EXPR> is present, and is non-zero, it will enable flushing after every
|
||||
write/print operation.
|
||||
|
||||
If C<$z> is associated with a buffer, this method has no effect and always
|
||||
returns C<undef>.
|
||||
|
||||
B<Note> that the special variable C<$|> B<cannot> be used to set or
|
||||
retrieve the autoflush setting.
|
||||
|
||||
=head2 input_line_number
|
||||
|
||||
$z->input_line_number()
|
||||
$z->input_line_number(EXPR)
|
||||
|
||||
This method always returns C<undef> when compressing.
|
||||
|
||||
=head2 fileno
|
||||
|
||||
$z->fileno()
|
||||
fileno($z)
|
||||
|
||||
If the C<$z> object is associated with a file or a filehandle, C<fileno>
|
||||
will return the underlying file descriptor. Once the C<close> method is
|
||||
called C<fileno> will return C<undef>.
|
||||
|
||||
If the C<$z> object is associated with a buffer, this method will return
|
||||
C<undef>.
|
||||
|
||||
=head2 close
|
||||
|
||||
$z->close() ;
|
||||
close $z ;
|
||||
|
||||
Flushes any pending compressed data and then closes the output file/buffer.
|
||||
|
||||
For most versions of Perl this method will be automatically invoked if
|
||||
the IO::Compress::Bzip2 object is destroyed (either explicitly or by the
|
||||
variable with the reference to the object going out of scope). The
|
||||
exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In
|
||||
these cases, the C<close> method will be called automatically, but
|
||||
not until global destruction of all live objects when the program is
|
||||
terminating.
|
||||
|
||||
Therefore, if you want your scripts to be able to run on all versions
|
||||
of Perl, you should call C<close> explicitly and not rely on automatic
|
||||
closing.
|
||||
|
||||
Returns true on success, otherwise 0.
|
||||
|
||||
If the C<AutoClose> option has been enabled when the IO::Compress::Bzip2
|
||||
object was created, and the object is associated with a file, the
|
||||
underlying file will also be closed.
|
||||
|
||||
=head2 newStream([OPTS])
|
||||
|
||||
Usage is
|
||||
|
||||
$z->newStream( [OPTS] )
|
||||
|
||||
Closes the current compressed data stream and starts a new one.
|
||||
|
||||
OPTS consists of any of the options that are available when creating
|
||||
the C<$z> object.
|
||||
|
||||
See the L</"Constructor Options"> section for more details.
|
||||
|
||||
=head1 Importing
|
||||
|
||||
No symbolic constants are required by IO::Compress::Bzip2 at present.
|
||||
|
||||
=over 5
|
||||
|
||||
=item :all
|
||||
|
||||
Imports C<bzip2> and C<$Bzip2Error>.
|
||||
Same as doing this
|
||||
|
||||
use IO::Compress::Bzip2 qw(bzip2 $Bzip2Error) ;
|
||||
|
||||
=back
|
||||
|
||||
=head1 EXAMPLES
|
||||
|
||||
=head2 Apache::GZip Revisited
|
||||
|
||||
See L<IO::Compress::FAQ|IO::Compress::FAQ/"Apache::GZip Revisited">
|
||||
|
||||
=head2 Working with Net::FTP
|
||||
|
||||
See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP">
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
General feedback/questions/bug reports should be sent to
|
||||
L<https://github.com/pmqs/IO-Compress/issues> (preferred) or
|
||||
L<https://rt.cpan.org/Public/Dist/Display.html?Name=IO-Compress>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzip>, L<IO::Uncompress::UnLzip>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Compress::Zstd>, L<IO::Uncompress::UnZstd>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
|
||||
|
||||
L<IO::Compress::FAQ|IO::Compress::FAQ>
|
||||
|
||||
L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
|
||||
L<Archive::Tar|Archive::Tar>,
|
||||
L<IO::Zlib|IO::Zlib>
|
||||
|
||||
The primary site for the bzip2 program is L<https://sourceware.org/bzip2/>.
|
||||
|
||||
See the module L<Compress::Bzip2|Compress::Bzip2>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
This module was written by Paul Marquess, C<pmqs@cpan.org>.
|
||||
|
||||
=head1 MODIFICATION HISTORY
|
||||
|
||||
See the Changes file.
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright (c) 2005-2023 Paul Marquess. All rights reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
@@ -0,0 +1,898 @@
|
||||
package IO::Compress::Deflate ;
|
||||
|
||||
require 5.006 ;
|
||||
|
||||
use strict ;
|
||||
use warnings;
|
||||
use bytes;
|
||||
|
||||
require Exporter ;
|
||||
|
||||
use IO::Compress::RawDeflate 2.204 ();
|
||||
use IO::Compress::Adapter::Deflate 2.204 ;
|
||||
|
||||
use IO::Compress::Zlib::Constants 2.204 ;
|
||||
use IO::Compress::Base::Common 2.204 qw();
|
||||
|
||||
|
||||
our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, %DEFLATE_CONSTANTS, $DeflateError);
|
||||
|
||||
$VERSION = '2.204';
|
||||
$DeflateError = '';
|
||||
|
||||
@ISA = qw(IO::Compress::RawDeflate Exporter);
|
||||
@EXPORT_OK = qw( $DeflateError deflate ) ;
|
||||
%EXPORT_TAGS = %IO::Compress::RawDeflate::DEFLATE_CONSTANTS ;
|
||||
|
||||
push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
|
||||
Exporter::export_ok_tags('all');
|
||||
|
||||
|
||||
sub new
|
||||
{
|
||||
my $class = shift ;
|
||||
|
||||
my $obj = IO::Compress::Base::Common::createSelfTiedObject($class, \$DeflateError);
|
||||
return $obj->_create(undef, @_);
|
||||
}
|
||||
|
||||
sub deflate
|
||||
{
|
||||
my $obj = IO::Compress::Base::Common::createSelfTiedObject(undef, \$DeflateError);
|
||||
return $obj->_def(@_);
|
||||
}
|
||||
|
||||
sub mkComp
|
||||
{
|
||||
my $self = shift ;
|
||||
my $got = shift ;
|
||||
|
||||
my ($obj, $errstr, $errno) = IO::Compress::Adapter::Deflate::mkCompObject1(
|
||||
$got->getValue('crc32'),
|
||||
$got->getValue('adler32'),
|
||||
$got->getValue('level'),
|
||||
$got->getValue('strategy')
|
||||
);
|
||||
|
||||
return $self->saveErrorString(undef, $errstr, $errno)
|
||||
if ! defined $obj;
|
||||
|
||||
return $obj;
|
||||
}
|
||||
|
||||
|
||||
sub mkHeader
|
||||
{
|
||||
my $self = shift ;
|
||||
return '';
|
||||
}
|
||||
|
||||
sub mkTrailer
|
||||
{
|
||||
my $self = shift ;
|
||||
return '';
|
||||
}
|
||||
|
||||
sub mkFinalTrailer
|
||||
{
|
||||
return '';
|
||||
}
|
||||
|
||||
sub getExtraParams
|
||||
{
|
||||
my $self = shift ;
|
||||
return $self->getZlibParams(),
|
||||
}
|
||||
|
||||
sub getInverseClass
|
||||
{
|
||||
no warnings 'once';
|
||||
return ('IO::Uncompress::Inflate',
|
||||
\$IO::Uncompress::Inflate::InflateError);
|
||||
}
|
||||
|
||||
sub getFileInfo
|
||||
{
|
||||
my $self = shift ;
|
||||
my $params = shift;
|
||||
my $file = shift ;
|
||||
|
||||
}
|
||||
|
||||
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
IO::Compress::Deflate - Write RFC 1950 files/buffers
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use IO::Compress::Deflate qw(deflate $DeflateError) ;
|
||||
|
||||
my $status = deflate $input => $output [,OPTS]
|
||||
or die "deflate failed: $DeflateError\n";
|
||||
|
||||
my $z = IO::Compress::Deflate->new( $output [,OPTS] )
|
||||
or die "deflate failed: $DeflateError\n";
|
||||
|
||||
$z->print($string);
|
||||
$z->printf($format, $string);
|
||||
$z->write($string);
|
||||
$z->syswrite($string [, $length, $offset]);
|
||||
$z->flush();
|
||||
$z->tell();
|
||||
$z->eof();
|
||||
$z->seek($position, $whence);
|
||||
$z->binmode();
|
||||
$z->fileno();
|
||||
$z->opened();
|
||||
$z->autoflush();
|
||||
$z->input_line_number();
|
||||
$z->newStream( [OPTS] );
|
||||
|
||||
$z->deflateParams();
|
||||
|
||||
$z->close() ;
|
||||
|
||||
$DeflateError ;
|
||||
|
||||
# IO::File mode
|
||||
|
||||
print $z $string;
|
||||
printf $z $format, $string;
|
||||
tell $z
|
||||
eof $z
|
||||
seek $z, $position, $whence
|
||||
binmode $z
|
||||
fileno $z
|
||||
close $z ;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides a Perl interface that allows writing compressed
|
||||
data to files or buffer as defined in RFC 1950.
|
||||
|
||||
For reading RFC 1950 files/buffers, see the companion module
|
||||
L<IO::Uncompress::Inflate|IO::Uncompress::Inflate>.
|
||||
|
||||
=head1 Functional Interface
|
||||
|
||||
A top-level function, C<deflate>, is provided to carry out
|
||||
"one-shot" compression between buffers and/or files. For finer
|
||||
control over the compression process, see the L</"OO Interface">
|
||||
section.
|
||||
|
||||
use IO::Compress::Deflate qw(deflate $DeflateError) ;
|
||||
|
||||
deflate $input_filename_or_reference => $output_filename_or_reference [,OPTS]
|
||||
or die "deflate failed: $DeflateError\n";
|
||||
|
||||
The functional interface needs Perl5.005 or better.
|
||||
|
||||
=head2 deflate $input_filename_or_reference => $output_filename_or_reference [, OPTS]
|
||||
|
||||
C<deflate> expects at least two parameters,
|
||||
C<$input_filename_or_reference> and C<$output_filename_or_reference>
|
||||
and zero or more optional parameters (see L</Optional Parameters>)
|
||||
|
||||
=head3 The C<$input_filename_or_reference> parameter
|
||||
|
||||
The parameter, C<$input_filename_or_reference>, is used to define the
|
||||
source of the uncompressed data.
|
||||
|
||||
It can take one of the following forms:
|
||||
|
||||
=over 5
|
||||
|
||||
=item A filename
|
||||
|
||||
If the C<$input_filename_or_reference> parameter is a simple scalar, it is
|
||||
assumed to be a filename. This file will be opened for reading and the
|
||||
input data will be read from it.
|
||||
|
||||
=item A filehandle
|
||||
|
||||
If the C<$input_filename_or_reference> parameter is a filehandle, the input
|
||||
data will be read from it. The string '-' can be used as an alias for
|
||||
standard input.
|
||||
|
||||
=item A scalar reference
|
||||
|
||||
If C<$input_filename_or_reference> is a scalar reference, the input data
|
||||
will be read from C<$$input_filename_or_reference>.
|
||||
|
||||
=item An array reference
|
||||
|
||||
If C<$input_filename_or_reference> is an array reference, each element in
|
||||
the array must be a filename.
|
||||
|
||||
The input data will be read from each file in turn.
|
||||
|
||||
The complete array will be walked to ensure that it only
|
||||
contains valid filenames before any data is compressed.
|
||||
|
||||
=item An Input FileGlob string
|
||||
|
||||
If C<$input_filename_or_reference> is a string that is delimited by the
|
||||
characters "<" and ">" C<deflate> will assume that it is an
|
||||
I<input fileglob string>. The input is the list of files that match the
|
||||
fileglob.
|
||||
|
||||
See L<File::GlobMapper|File::GlobMapper> for more details.
|
||||
|
||||
=back
|
||||
|
||||
If the C<$input_filename_or_reference> parameter is any other type,
|
||||
C<undef> will be returned.
|
||||
|
||||
=head3 The C<$output_filename_or_reference> parameter
|
||||
|
||||
The parameter C<$output_filename_or_reference> is used to control the
|
||||
destination of the compressed data. This parameter can take one of
|
||||
these forms.
|
||||
|
||||
=over 5
|
||||
|
||||
=item A filename
|
||||
|
||||
If the C<$output_filename_or_reference> parameter is a simple scalar, it is
|
||||
assumed to be a filename. This file will be opened for writing and the
|
||||
compressed data will be written to it.
|
||||
|
||||
=item A filehandle
|
||||
|
||||
If the C<$output_filename_or_reference> parameter is a filehandle, the
|
||||
compressed data will be written to it. The string '-' can be used as
|
||||
an alias for standard output.
|
||||
|
||||
=item A scalar reference
|
||||
|
||||
If C<$output_filename_or_reference> is a scalar reference, the
|
||||
compressed data will be stored in C<$$output_filename_or_reference>.
|
||||
|
||||
=item An Array Reference
|
||||
|
||||
If C<$output_filename_or_reference> is an array reference,
|
||||
the compressed data will be pushed onto the array.
|
||||
|
||||
=item An Output FileGlob
|
||||
|
||||
If C<$output_filename_or_reference> is a string that is delimited by the
|
||||
characters "<" and ">" C<deflate> will assume that it is an
|
||||
I<output fileglob string>. The output is the list of files that match the
|
||||
fileglob.
|
||||
|
||||
When C<$output_filename_or_reference> is an fileglob string,
|
||||
C<$input_filename_or_reference> must also be a fileglob string. Anything
|
||||
else is an error.
|
||||
|
||||
See L<File::GlobMapper|File::GlobMapper> for more details.
|
||||
|
||||
=back
|
||||
|
||||
If the C<$output_filename_or_reference> parameter is any other type,
|
||||
C<undef> will be returned.
|
||||
|
||||
=head2 Notes
|
||||
|
||||
When C<$input_filename_or_reference> maps to multiple files/buffers and
|
||||
C<$output_filename_or_reference> is a single
|
||||
file/buffer the input files/buffers will be stored
|
||||
in C<$output_filename_or_reference> as a concatenated series of compressed data streams.
|
||||
|
||||
=head2 Optional Parameters
|
||||
|
||||
The optional parameters for the one-shot function C<deflate>
|
||||
are (for the most part) identical to those used with the OO interface defined in the
|
||||
L</"Constructor Options"> section. The exceptions are listed below
|
||||
|
||||
=over 5
|
||||
|
||||
=item C<< AutoClose => 0|1 >>
|
||||
|
||||
This option applies to any input or output data streams to
|
||||
C<deflate> that are filehandles.
|
||||
|
||||
If C<AutoClose> is specified, and the value is true, it will result in all
|
||||
input and/or output filehandles being closed once C<deflate> has
|
||||
completed.
|
||||
|
||||
This parameter defaults to 0.
|
||||
|
||||
=item C<< BinModeIn => 0|1 >>
|
||||
|
||||
This option is now a no-op. All files will be read in binmode.
|
||||
|
||||
=item C<< Append => 0|1 >>
|
||||
|
||||
The behaviour of this option is dependent on the type of output data
|
||||
stream.
|
||||
|
||||
=over 5
|
||||
|
||||
=item * A Buffer
|
||||
|
||||
If C<Append> is enabled, all compressed data will be append to the end of
|
||||
the output buffer. Otherwise the output buffer will be cleared before any
|
||||
compressed data is written to it.
|
||||
|
||||
=item * A Filename
|
||||
|
||||
If C<Append> is enabled, the file will be opened in append mode. Otherwise
|
||||
the contents of the file, if any, will be truncated before any compressed
|
||||
data is written to it.
|
||||
|
||||
=item * A Filehandle
|
||||
|
||||
If C<Append> is enabled, the filehandle will be positioned to the end of
|
||||
the file via a call to C<seek> before any compressed data is
|
||||
written to it. Otherwise the file pointer will not be moved.
|
||||
|
||||
=back
|
||||
|
||||
When C<Append> is specified, and set to true, it will I<append> all compressed
|
||||
data to the output data stream.
|
||||
|
||||
So when the output is a filehandle it will carry out a seek to the eof
|
||||
before writing any compressed data. If the output is a filename, it will be opened for
|
||||
appending. If the output is a buffer, all compressed data will be
|
||||
appended to the existing buffer.
|
||||
|
||||
Conversely when C<Append> is not specified, or it is present and is set to
|
||||
false, it will operate as follows.
|
||||
|
||||
When the output is a filename, it will truncate the contents of the file
|
||||
before writing any compressed data. If the output is a filehandle
|
||||
its position will not be changed. If the output is a buffer, it will be
|
||||
wiped before any compressed data is output.
|
||||
|
||||
Defaults to 0.
|
||||
|
||||
=back
|
||||
|
||||
=head2 Examples
|
||||
|
||||
Here are a few example that show the capabilities of the module.
|
||||
|
||||
=head3 Streaming
|
||||
|
||||
This very simple command line example demonstrates the streaming capabilities of the module.
|
||||
The code reads data from STDIN, compresses it, and writes the compressed data to STDOUT.
|
||||
|
||||
$ echo hello world | perl -MIO::Compress::Deflate=deflate -e 'deflate \*STDIN => \*STDOUT' >output.1950
|
||||
|
||||
The special filename "-" can be used as a standin for both C<\*STDIN> and C<\*STDOUT>,
|
||||
so the above can be rewritten as
|
||||
|
||||
$ echo hello world | perl -MIO::Compress::Deflate=deflate -e 'deflate "-" => "-"' >output.1950
|
||||
|
||||
=head3 Compressing a file from the filesystem
|
||||
|
||||
To read the contents of the file C<file1.txt> and write the compressed
|
||||
data to the file C<file1.txt.1950>.
|
||||
|
||||
use strict ;
|
||||
use warnings ;
|
||||
use IO::Compress::Deflate qw(deflate $DeflateError) ;
|
||||
|
||||
my $input = "file1.txt";
|
||||
deflate $input => "$input.1950"
|
||||
or die "deflate failed: $DeflateError\n";
|
||||
|
||||
=head3 Reading from a Filehandle and writing to an in-memory buffer
|
||||
|
||||
To read from an existing Perl filehandle, C<$input>, and write the
|
||||
compressed data to a buffer, C<$buffer>.
|
||||
|
||||
use strict ;
|
||||
use warnings ;
|
||||
use IO::Compress::Deflate qw(deflate $DeflateError) ;
|
||||
use IO::File ;
|
||||
|
||||
my $input = IO::File->new( "<file1.txt" )
|
||||
or die "Cannot open 'file1.txt': $!\n" ;
|
||||
my $buffer ;
|
||||
deflate $input => \$buffer
|
||||
or die "deflate failed: $DeflateError\n";
|
||||
|
||||
=head3 Compressing multiple files
|
||||
|
||||
To compress all files in the directory "/my/home" that match "*.txt"
|
||||
and store the compressed data in the same directory
|
||||
|
||||
use strict ;
|
||||
use warnings ;
|
||||
use IO::Compress::Deflate qw(deflate $DeflateError) ;
|
||||
|
||||
deflate '</my/home/*.txt>' => '<*.1950>'
|
||||
or die "deflate failed: $DeflateError\n";
|
||||
|
||||
and if you want to compress each file one at a time, this will do the trick
|
||||
|
||||
use strict ;
|
||||
use warnings ;
|
||||
use IO::Compress::Deflate qw(deflate $DeflateError) ;
|
||||
|
||||
for my $input ( glob "/my/home/*.txt" )
|
||||
{
|
||||
my $output = "$input.1950" ;
|
||||
deflate $input => $output
|
||||
or die "Error compressing '$input': $DeflateError\n";
|
||||
}
|
||||
|
||||
=head1 OO Interface
|
||||
|
||||
=head2 Constructor
|
||||
|
||||
The format of the constructor for C<IO::Compress::Deflate> is shown below
|
||||
|
||||
my $z = IO::Compress::Deflate->new( $output [,OPTS] )
|
||||
or die "IO::Compress::Deflate failed: $DeflateError\n";
|
||||
|
||||
It returns an C<IO::Compress::Deflate> object on success and undef on failure.
|
||||
The variable C<$DeflateError> will contain an error message on failure.
|
||||
|
||||
If you are running Perl 5.005 or better the object, C<$z>, returned from
|
||||
IO::Compress::Deflate can be used exactly like an L<IO::File|IO::File> filehandle.
|
||||
This means that all normal output file operations can be carried out
|
||||
with C<$z>.
|
||||
For example, to write to a compressed file/buffer you can use either of
|
||||
these forms
|
||||
|
||||
$z->print("hello world\n");
|
||||
print $z "hello world\n";
|
||||
|
||||
The mandatory parameter C<$output> is used to control the destination
|
||||
of the compressed data. This parameter can take one of these forms.
|
||||
|
||||
=over 5
|
||||
|
||||
=item A filename
|
||||
|
||||
If the C<$output> parameter is a simple scalar, it is assumed to be a
|
||||
filename. This file will be opened for writing and the compressed data
|
||||
will be written to it.
|
||||
|
||||
=item A filehandle
|
||||
|
||||
If the C<$output> parameter is a filehandle, the compressed data will be
|
||||
written to it.
|
||||
The string '-' can be used as an alias for standard output.
|
||||
|
||||
=item A scalar reference
|
||||
|
||||
If C<$output> is a scalar reference, the compressed data will be stored
|
||||
in C<$$output>.
|
||||
|
||||
=back
|
||||
|
||||
If the C<$output> parameter is any other type, C<IO::Compress::Deflate>::new will
|
||||
return undef.
|
||||
|
||||
=head2 Constructor Options
|
||||
|
||||
C<OPTS> is any combination of zero or more the following options:
|
||||
|
||||
=over 5
|
||||
|
||||
=item C<< AutoClose => 0|1 >>
|
||||
|
||||
This option is only valid when the C<$output> parameter is a filehandle. If
|
||||
specified, and the value is true, it will result in the C<$output> being
|
||||
closed once either the C<close> method is called or the C<IO::Compress::Deflate>
|
||||
object is destroyed.
|
||||
|
||||
This parameter defaults to 0.
|
||||
|
||||
=item C<< Append => 0|1 >>
|
||||
|
||||
Opens C<$output> in append mode.
|
||||
|
||||
The behaviour of this option is dependent on the type of C<$output>.
|
||||
|
||||
=over 5
|
||||
|
||||
=item * A Buffer
|
||||
|
||||
If C<$output> is a buffer and C<Append> is enabled, all compressed data
|
||||
will be append to the end of C<$output>. Otherwise C<$output> will be
|
||||
cleared before any data is written to it.
|
||||
|
||||
=item * A Filename
|
||||
|
||||
If C<$output> is a filename and C<Append> is enabled, the file will be
|
||||
opened in append mode. Otherwise the contents of the file, if any, will be
|
||||
truncated before any compressed data is written to it.
|
||||
|
||||
=item * A Filehandle
|
||||
|
||||
If C<$output> is a filehandle, the file pointer will be positioned to the
|
||||
end of the file via a call to C<seek> before any compressed data is written
|
||||
to it. Otherwise the file pointer will not be moved.
|
||||
|
||||
=back
|
||||
|
||||
This parameter defaults to 0.
|
||||
|
||||
=item C<< Merge => 0|1 >>
|
||||
|
||||
This option is used to compress input data and append it to an existing
|
||||
compressed data stream in C<$output>. The end result is a single compressed
|
||||
data stream stored in C<$output>.
|
||||
|
||||
It is a fatal error to attempt to use this option when C<$output> is not an
|
||||
RFC 1950 data stream.
|
||||
|
||||
There are a number of other limitations with the C<Merge> option:
|
||||
|
||||
=over 5
|
||||
|
||||
=item 1
|
||||
|
||||
This module needs to have been built with zlib 1.2.1 or better to work. A
|
||||
fatal error will be thrown if C<Merge> is used with an older version of
|
||||
zlib.
|
||||
|
||||
=item 2
|
||||
|
||||
If C<$output> is a file or a filehandle, it must be seekable.
|
||||
|
||||
=back
|
||||
|
||||
This parameter defaults to 0.
|
||||
|
||||
=item -Level
|
||||
|
||||
Defines the compression level used by zlib. The value should either be
|
||||
a number between 0 and 9 (0 means no compression and 9 is maximum
|
||||
compression), or one of the symbolic constants defined below.
|
||||
|
||||
Z_NO_COMPRESSION
|
||||
Z_BEST_SPEED
|
||||
Z_BEST_COMPRESSION
|
||||
Z_DEFAULT_COMPRESSION
|
||||
|
||||
The default is Z_DEFAULT_COMPRESSION.
|
||||
|
||||
Note, these constants are not imported by C<IO::Compress::Deflate> by default.
|
||||
|
||||
use IO::Compress::Deflate qw(:strategy);
|
||||
use IO::Compress::Deflate qw(:constants);
|
||||
use IO::Compress::Deflate qw(:all);
|
||||
|
||||
=item -Strategy
|
||||
|
||||
Defines the strategy used to tune the compression. Use one of the symbolic
|
||||
constants defined below.
|
||||
|
||||
Z_FILTERED
|
||||
Z_HUFFMAN_ONLY
|
||||
Z_RLE
|
||||
Z_FIXED
|
||||
Z_DEFAULT_STRATEGY
|
||||
|
||||
The default is Z_DEFAULT_STRATEGY.
|
||||
|
||||
=item C<< Strict => 0|1 >>
|
||||
|
||||
This is a placeholder option.
|
||||
|
||||
=back
|
||||
|
||||
=head2 Examples
|
||||
|
||||
TODO
|
||||
|
||||
=head1 Methods
|
||||
|
||||
=head2 print
|
||||
|
||||
Usage is
|
||||
|
||||
$z->print($data)
|
||||
print $z $data
|
||||
|
||||
Compresses and outputs the contents of the C<$data> parameter. This
|
||||
has the same behaviour as the C<print> built-in.
|
||||
|
||||
Returns true if successful.
|
||||
|
||||
=head2 printf
|
||||
|
||||
Usage is
|
||||
|
||||
$z->printf($format, $data)
|
||||
printf $z $format, $data
|
||||
|
||||
Compresses and outputs the contents of the C<$data> parameter.
|
||||
|
||||
Returns true if successful.
|
||||
|
||||
=head2 syswrite
|
||||
|
||||
Usage is
|
||||
|
||||
$z->syswrite $data
|
||||
$z->syswrite $data, $length
|
||||
$z->syswrite $data, $length, $offset
|
||||
|
||||
Compresses and outputs the contents of the C<$data> parameter.
|
||||
|
||||
Returns the number of uncompressed bytes written, or C<undef> if
|
||||
unsuccessful.
|
||||
|
||||
=head2 write
|
||||
|
||||
Usage is
|
||||
|
||||
$z->write $data
|
||||
$z->write $data, $length
|
||||
$z->write $data, $length, $offset
|
||||
|
||||
Compresses and outputs the contents of the C<$data> parameter.
|
||||
|
||||
Returns the number of uncompressed bytes written, or C<undef> if
|
||||
unsuccessful.
|
||||
|
||||
=head2 flush
|
||||
|
||||
Usage is
|
||||
|
||||
$z->flush;
|
||||
$z->flush($flush_type);
|
||||
|
||||
Flushes any pending compressed data to the output file/buffer.
|
||||
|
||||
This method takes an optional parameter, C<$flush_type>, that controls
|
||||
how the flushing will be carried out. By default the C<$flush_type>
|
||||
used is C<Z_FINISH>. Other valid values for C<$flush_type> are
|
||||
C<Z_NO_FLUSH>, C<Z_SYNC_FLUSH>, C<Z_FULL_FLUSH> and C<Z_BLOCK>. It is
|
||||
strongly recommended that you only set the C<flush_type> parameter if
|
||||
you fully understand the implications of what it does - overuse of C<flush>
|
||||
can seriously degrade the level of compression achieved. See the C<zlib>
|
||||
documentation for details.
|
||||
|
||||
Returns true on success.
|
||||
|
||||
=head2 tell
|
||||
|
||||
Usage is
|
||||
|
||||
$z->tell()
|
||||
tell $z
|
||||
|
||||
Returns the uncompressed file offset.
|
||||
|
||||
=head2 eof
|
||||
|
||||
Usage is
|
||||
|
||||
$z->eof();
|
||||
eof($z);
|
||||
|
||||
Returns true if the C<close> method has been called.
|
||||
|
||||
=head2 seek
|
||||
|
||||
$z->seek($position, $whence);
|
||||
seek($z, $position, $whence);
|
||||
|
||||
Provides a sub-set of the C<seek> functionality, with the restriction
|
||||
that it is only legal to seek forward in the output file/buffer.
|
||||
It is a fatal error to attempt to seek backward.
|
||||
|
||||
Empty parts of the file/buffer will have NULL (0x00) bytes written to them.
|
||||
|
||||
The C<$whence> parameter takes one the usual values, namely SEEK_SET,
|
||||
SEEK_CUR or SEEK_END.
|
||||
|
||||
Returns 1 on success, 0 on failure.
|
||||
|
||||
=head2 binmode
|
||||
|
||||
Usage is
|
||||
|
||||
$z->binmode
|
||||
binmode $z ;
|
||||
|
||||
This is a noop provided for completeness.
|
||||
|
||||
=head2 opened
|
||||
|
||||
$z->opened()
|
||||
|
||||
Returns true if the object currently refers to a opened file/buffer.
|
||||
|
||||
=head2 autoflush
|
||||
|
||||
my $prev = $z->autoflush()
|
||||
my $prev = $z->autoflush(EXPR)
|
||||
|
||||
If the C<$z> object is associated with a file or a filehandle, this method
|
||||
returns the current autoflush setting for the underlying filehandle. If
|
||||
C<EXPR> is present, and is non-zero, it will enable flushing after every
|
||||
write/print operation.
|
||||
|
||||
If C<$z> is associated with a buffer, this method has no effect and always
|
||||
returns C<undef>.
|
||||
|
||||
B<Note> that the special variable C<$|> B<cannot> be used to set or
|
||||
retrieve the autoflush setting.
|
||||
|
||||
=head2 input_line_number
|
||||
|
||||
$z->input_line_number()
|
||||
$z->input_line_number(EXPR)
|
||||
|
||||
This method always returns C<undef> when compressing.
|
||||
|
||||
=head2 fileno
|
||||
|
||||
$z->fileno()
|
||||
fileno($z)
|
||||
|
||||
If the C<$z> object is associated with a file or a filehandle, C<fileno>
|
||||
will return the underlying file descriptor. Once the C<close> method is
|
||||
called C<fileno> will return C<undef>.
|
||||
|
||||
If the C<$z> object is associated with a buffer, this method will return
|
||||
C<undef>.
|
||||
|
||||
=head2 close
|
||||
|
||||
$z->close() ;
|
||||
close $z ;
|
||||
|
||||
Flushes any pending compressed data and then closes the output file/buffer.
|
||||
|
||||
For most versions of Perl this method will be automatically invoked if
|
||||
the IO::Compress::Deflate object is destroyed (either explicitly or by the
|
||||
variable with the reference to the object going out of scope). The
|
||||
exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In
|
||||
these cases, the C<close> method will be called automatically, but
|
||||
not until global destruction of all live objects when the program is
|
||||
terminating.
|
||||
|
||||
Therefore, if you want your scripts to be able to run on all versions
|
||||
of Perl, you should call C<close> explicitly and not rely on automatic
|
||||
closing.
|
||||
|
||||
Returns true on success, otherwise 0.
|
||||
|
||||
If the C<AutoClose> option has been enabled when the IO::Compress::Deflate
|
||||
object was created, and the object is associated with a file, the
|
||||
underlying file will also be closed.
|
||||
|
||||
=head2 newStream([OPTS])
|
||||
|
||||
Usage is
|
||||
|
||||
$z->newStream( [OPTS] )
|
||||
|
||||
Closes the current compressed data stream and starts a new one.
|
||||
|
||||
OPTS consists of any of the options that are available when creating
|
||||
the C<$z> object.
|
||||
|
||||
See the L</"Constructor Options"> section for more details.
|
||||
|
||||
=head2 deflateParams
|
||||
|
||||
Usage is
|
||||
|
||||
$z->deflateParams
|
||||
|
||||
TODO
|
||||
|
||||
=head1 Importing
|
||||
|
||||
A number of symbolic constants are required by some methods in
|
||||
C<IO::Compress::Deflate>. None are imported by default.
|
||||
|
||||
=over 5
|
||||
|
||||
=item :all
|
||||
|
||||
Imports C<deflate>, C<$DeflateError> and all symbolic
|
||||
constants that can be used by C<IO::Compress::Deflate>. Same as doing this
|
||||
|
||||
use IO::Compress::Deflate qw(deflate $DeflateError :constants) ;
|
||||
|
||||
=item :constants
|
||||
|
||||
Import all symbolic constants. Same as doing this
|
||||
|
||||
use IO::Compress::Deflate qw(:flush :level :strategy) ;
|
||||
|
||||
=item :flush
|
||||
|
||||
These symbolic constants are used by the C<flush> method.
|
||||
|
||||
Z_NO_FLUSH
|
||||
Z_PARTIAL_FLUSH
|
||||
Z_SYNC_FLUSH
|
||||
Z_FULL_FLUSH
|
||||
Z_FINISH
|
||||
Z_BLOCK
|
||||
|
||||
=item :level
|
||||
|
||||
These symbolic constants are used by the C<Level> option in the constructor.
|
||||
|
||||
Z_NO_COMPRESSION
|
||||
Z_BEST_SPEED
|
||||
Z_BEST_COMPRESSION
|
||||
Z_DEFAULT_COMPRESSION
|
||||
|
||||
=item :strategy
|
||||
|
||||
These symbolic constants are used by the C<Strategy> option in the constructor.
|
||||
|
||||
Z_FILTERED
|
||||
Z_HUFFMAN_ONLY
|
||||
Z_RLE
|
||||
Z_FIXED
|
||||
Z_DEFAULT_STRATEGY
|
||||
|
||||
=back
|
||||
|
||||
=head1 EXAMPLES
|
||||
|
||||
=head2 Apache::GZip Revisited
|
||||
|
||||
See L<IO::Compress::FAQ|IO::Compress::FAQ/"Apache::GZip Revisited">
|
||||
|
||||
=head2 Working with Net::FTP
|
||||
|
||||
See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP">
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
General feedback/questions/bug reports should be sent to
|
||||
L<https://github.com/pmqs/IO-Compress/issues> (preferred) or
|
||||
L<https://rt.cpan.org/Public/Dist/Display.html?Name=IO-Compress>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzip>, L<IO::Uncompress::UnLzip>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Compress::Zstd>, L<IO::Uncompress::UnZstd>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
|
||||
|
||||
L<IO::Compress::FAQ|IO::Compress::FAQ>
|
||||
|
||||
L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
|
||||
L<Archive::Tar|Archive::Tar>,
|
||||
L<IO::Zlib|IO::Zlib>
|
||||
|
||||
For RFC 1950, 1951 and 1952 see
|
||||
L<https://datatracker.ietf.org/doc/html/rfc1950>,
|
||||
L<https://datatracker.ietf.org/doc/html/rfc1951> and
|
||||
L<https://datatracker.ietf.org/doc/html/rfc1952>
|
||||
|
||||
The I<zlib> compression library was written by Jean-loup Gailly
|
||||
C<gzip@prep.ai.mit.edu> and Mark Adler C<madler@alumni.caltech.edu>.
|
||||
|
||||
The primary site for the I<zlib> compression library is
|
||||
L<http://www.zlib.org>.
|
||||
|
||||
The primary site for the I<zlib-ng> compression library is
|
||||
L<https://github.com/zlib-ng/zlib-ng>.
|
||||
|
||||
The primary site for gzip is L<http://www.gzip.org>.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
This module was written by Paul Marquess, C<pmqs@cpan.org>.
|
||||
|
||||
=head1 MODIFICATION HISTORY
|
||||
|
||||
See the Changes file.
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright (c) 2005-2023 Paul Marquess. All rights reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,148 @@
|
||||
package IO::Compress::Gzip::Constants;
|
||||
|
||||
use strict ;
|
||||
use warnings;
|
||||
use bytes;
|
||||
|
||||
require Exporter;
|
||||
|
||||
our ($VERSION, @ISA, @EXPORT, %GZIP_OS_Names);
|
||||
our ($GZIP_FNAME_INVALID_CHAR_RE, $GZIP_FCOMMENT_INVALID_CHAR_RE);
|
||||
|
||||
$VERSION = '2.204';
|
||||
|
||||
@ISA = qw(Exporter);
|
||||
|
||||
@EXPORT= qw(
|
||||
|
||||
GZIP_ID_SIZE
|
||||
GZIP_ID1
|
||||
GZIP_ID2
|
||||
|
||||
GZIP_FLG_DEFAULT
|
||||
GZIP_FLG_FTEXT
|
||||
GZIP_FLG_FHCRC
|
||||
GZIP_FLG_FEXTRA
|
||||
GZIP_FLG_FNAME
|
||||
GZIP_FLG_FCOMMENT
|
||||
GZIP_FLG_RESERVED
|
||||
|
||||
GZIP_CM_DEFLATED
|
||||
|
||||
GZIP_MIN_HEADER_SIZE
|
||||
GZIP_TRAILER_SIZE
|
||||
|
||||
GZIP_MTIME_DEFAULT
|
||||
GZIP_XFL_DEFAULT
|
||||
GZIP_FEXTRA_HEADER_SIZE
|
||||
GZIP_FEXTRA_MAX_SIZE
|
||||
GZIP_FEXTRA_SUBFIELD_HEADER_SIZE
|
||||
GZIP_FEXTRA_SUBFIELD_ID_SIZE
|
||||
GZIP_FEXTRA_SUBFIELD_LEN_SIZE
|
||||
GZIP_FEXTRA_SUBFIELD_MAX_SIZE
|
||||
|
||||
$GZIP_FNAME_INVALID_CHAR_RE
|
||||
$GZIP_FCOMMENT_INVALID_CHAR_RE
|
||||
|
||||
GZIP_FHCRC_SIZE
|
||||
|
||||
GZIP_ISIZE_MAX
|
||||
GZIP_ISIZE_MOD_VALUE
|
||||
|
||||
|
||||
GZIP_NULL_BYTE
|
||||
|
||||
GZIP_OS_DEFAULT
|
||||
|
||||
%GZIP_OS_Names
|
||||
|
||||
GZIP_MINIMUM_HEADER
|
||||
|
||||
);
|
||||
|
||||
# Constant names derived from RFC 1952
|
||||
|
||||
use constant GZIP_ID_SIZE => 2 ;
|
||||
use constant GZIP_ID1 => 0x1F;
|
||||
use constant GZIP_ID2 => 0x8B;
|
||||
|
||||
use constant GZIP_MIN_HEADER_SIZE => 10 ;# minimum gzip header size
|
||||
use constant GZIP_TRAILER_SIZE => 8 ;
|
||||
|
||||
|
||||
use constant GZIP_FLG_DEFAULT => 0x00 ;
|
||||
use constant GZIP_FLG_FTEXT => 0x01 ;
|
||||
use constant GZIP_FLG_FHCRC => 0x02 ; # called CONTINUATION in gzip
|
||||
use constant GZIP_FLG_FEXTRA => 0x04 ;
|
||||
use constant GZIP_FLG_FNAME => 0x08 ;
|
||||
use constant GZIP_FLG_FCOMMENT => 0x10 ;
|
||||
#use constant GZIP_FLG_ENCRYPTED => 0x20 ; # documented in gzip sources
|
||||
use constant GZIP_FLG_RESERVED => (0x20 | 0x40 | 0x80) ;
|
||||
|
||||
use constant GZIP_XFL_DEFAULT => 0x00 ;
|
||||
|
||||
use constant GZIP_MTIME_DEFAULT => 0x00 ;
|
||||
|
||||
use constant GZIP_FEXTRA_HEADER_SIZE => 2 ;
|
||||
use constant GZIP_FEXTRA_MAX_SIZE => 0xFFFF ;
|
||||
use constant GZIP_FEXTRA_SUBFIELD_ID_SIZE => 2 ;
|
||||
use constant GZIP_FEXTRA_SUBFIELD_LEN_SIZE => 2 ;
|
||||
use constant GZIP_FEXTRA_SUBFIELD_HEADER_SIZE => GZIP_FEXTRA_SUBFIELD_ID_SIZE +
|
||||
GZIP_FEXTRA_SUBFIELD_LEN_SIZE;
|
||||
use constant GZIP_FEXTRA_SUBFIELD_MAX_SIZE => GZIP_FEXTRA_MAX_SIZE -
|
||||
GZIP_FEXTRA_SUBFIELD_HEADER_SIZE ;
|
||||
|
||||
|
||||
if (ord('A') == 193)
|
||||
{
|
||||
# EBCDIC
|
||||
$GZIP_FNAME_INVALID_CHAR_RE = '[\x00-\x3f\xff]';
|
||||
$GZIP_FCOMMENT_INVALID_CHAR_RE = '[\x00-\x0a\x11-\x14\x16-\x3f\xff]';
|
||||
|
||||
}
|
||||
else
|
||||
{
|
||||
$GZIP_FNAME_INVALID_CHAR_RE = '[\x00-\x1F\x7F-\x9F]';
|
||||
$GZIP_FCOMMENT_INVALID_CHAR_RE = '[\x00-\x09\x11-\x1F\x7F-\x9F]';
|
||||
}
|
||||
|
||||
use constant GZIP_FHCRC_SIZE => 2 ; # aka CONTINUATION in gzip
|
||||
|
||||
use constant GZIP_CM_DEFLATED => 8 ;
|
||||
|
||||
use constant GZIP_NULL_BYTE => "\x00";
|
||||
use constant GZIP_ISIZE_MAX => 0xFFFFFFFF ;
|
||||
use constant GZIP_ISIZE_MOD_VALUE => GZIP_ISIZE_MAX + 1 ;
|
||||
|
||||
# OS Names sourced from http://www.gzip.org/format.txt
|
||||
|
||||
use constant GZIP_OS_DEFAULT=> 0xFF ;
|
||||
%GZIP_OS_Names = (
|
||||
0 => 'MS-DOS',
|
||||
1 => 'Amiga',
|
||||
2 => 'VMS',
|
||||
3 => 'Unix',
|
||||
4 => 'VM/CMS',
|
||||
5 => 'Atari TOS',
|
||||
6 => 'HPFS (OS/2, NT)',
|
||||
7 => 'Macintosh',
|
||||
8 => 'Z-System',
|
||||
9 => 'CP/M',
|
||||
10 => 'TOPS-20',
|
||||
11 => 'NTFS (NT)',
|
||||
12 => 'SMS QDOS',
|
||||
13 => 'Acorn RISCOS',
|
||||
14 => 'VFAT file system (Win95, NT)',
|
||||
15 => 'MVS',
|
||||
16 => 'BeOS',
|
||||
17 => 'Tandem/NSK',
|
||||
18 => 'THEOS',
|
||||
GZIP_OS_DEFAULT() => 'Unknown',
|
||||
) ;
|
||||
|
||||
use constant GZIP_MINIMUM_HEADER => pack("C4 V C C",
|
||||
GZIP_ID1, GZIP_ID2, GZIP_CM_DEFLATED, GZIP_FLG_DEFAULT,
|
||||
GZIP_MTIME_DEFAULT, GZIP_XFL_DEFAULT, GZIP_OS_DEFAULT) ;
|
||||
|
||||
|
||||
1;
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,132 @@
|
||||
package IO::Compress::Zip::Constants;
|
||||
|
||||
use strict ;
|
||||
use warnings;
|
||||
|
||||
require Exporter;
|
||||
|
||||
our ($VERSION, @ISA, @EXPORT, %ZIP_CM_MIN_VERSIONS);
|
||||
|
||||
$VERSION = '2.204';
|
||||
|
||||
@ISA = qw(Exporter);
|
||||
|
||||
@EXPORT= qw(
|
||||
|
||||
ZIP_CM_STORE
|
||||
ZIP_CM_DEFLATE
|
||||
ZIP_CM_BZIP2
|
||||
ZIP_CM_LZMA
|
||||
ZIP_CM_PPMD
|
||||
ZIP_CM_XZ
|
||||
ZIP_CM_ZSTD
|
||||
ZIP_CM_AES
|
||||
|
||||
ZIP_LOCAL_HDR_SIG
|
||||
ZIP_DATA_HDR_SIG
|
||||
ZIP_CENTRAL_HDR_SIG
|
||||
ZIP_END_CENTRAL_HDR_SIG
|
||||
ZIP64_END_CENTRAL_REC_HDR_SIG
|
||||
ZIP64_END_CENTRAL_LOC_HDR_SIG
|
||||
ZIP64_ARCHIVE_EXTRA_SIG
|
||||
ZIP64_DIGITAL_SIGNATURE_SIG
|
||||
|
||||
ZIP_GP_FLAG_ENCRYPTED_MASK
|
||||
ZIP_GP_FLAG_STREAMING_MASK
|
||||
ZIP_GP_FLAG_PATCHED_MASK
|
||||
ZIP_GP_FLAG_STRONG_ENCRYPTED_MASK
|
||||
ZIP_GP_FLAG_LZMA_EOS_PRESENT
|
||||
ZIP_GP_FLAG_LANGUAGE_ENCODING
|
||||
|
||||
ZIP_EXTRA_ID_ZIP64
|
||||
ZIP_EXTRA_ID_EXT_TIMESTAMP
|
||||
ZIP_EXTRA_ID_INFO_ZIP_UNIX2
|
||||
ZIP_EXTRA_ID_INFO_ZIP_UNIXN
|
||||
ZIP_EXTRA_ID_INFO_ZIP_Upath
|
||||
ZIP_EXTRA_ID_INFO_ZIP_Ucom
|
||||
ZIP_EXTRA_ID_JAVA_EXE
|
||||
|
||||
ZIP_OS_CODE_UNIX
|
||||
ZIP_OS_CODE_DEFAULT
|
||||
|
||||
ZIP_IFA_TEXT_MASK
|
||||
|
||||
%ZIP_CM_MIN_VERSIONS
|
||||
ZIP64_MIN_VERSION
|
||||
|
||||
ZIP_A_RONLY
|
||||
ZIP_A_HIDDEN
|
||||
ZIP_A_SYSTEM
|
||||
ZIP_A_LABEL
|
||||
ZIP_A_DIR
|
||||
ZIP_A_ARCHIVE
|
||||
);
|
||||
|
||||
# Compression types supported
|
||||
use constant ZIP_CM_STORE => 0 ;
|
||||
use constant ZIP_CM_DEFLATE => 8 ;
|
||||
use constant ZIP_CM_BZIP2 => 12 ;
|
||||
use constant ZIP_CM_LZMA => 14 ;
|
||||
use constant ZIP_CM_ZSTD => 93 ;
|
||||
use constant ZIP_CM_XZ => 95 ;
|
||||
use constant ZIP_CM_PPMD => 98 ; # Not Supported yet
|
||||
use constant ZIP_CM_AES => 99 ;
|
||||
|
||||
# General Purpose Flag
|
||||
use constant ZIP_GP_FLAG_ENCRYPTED_MASK => (1 << 0) ;
|
||||
use constant ZIP_GP_FLAG_STREAMING_MASK => (1 << 3) ;
|
||||
use constant ZIP_GP_FLAG_PATCHED_MASK => (1 << 5) ;
|
||||
use constant ZIP_GP_FLAG_STRONG_ENCRYPTED_MASK => (1 << 6) ;
|
||||
use constant ZIP_GP_FLAG_LZMA_EOS_PRESENT => (1 << 1) ;
|
||||
use constant ZIP_GP_FLAG_LANGUAGE_ENCODING => (1 << 11) ;
|
||||
|
||||
# Internal File Attributes
|
||||
use constant ZIP_IFA_TEXT_MASK => 1;
|
||||
|
||||
# Signatures for each of the headers
|
||||
use constant ZIP_LOCAL_HDR_SIG => 0x04034b50;
|
||||
use constant ZIP_DATA_HDR_SIG => 0x08074b50;
|
||||
use constant packed_ZIP_DATA_HDR_SIG => pack "V", ZIP_DATA_HDR_SIG;
|
||||
use constant ZIP_CENTRAL_HDR_SIG => 0x02014b50;
|
||||
use constant ZIP_END_CENTRAL_HDR_SIG => 0x06054b50;
|
||||
use constant ZIP64_END_CENTRAL_REC_HDR_SIG => 0x06064b50;
|
||||
use constant ZIP64_END_CENTRAL_LOC_HDR_SIG => 0x07064b50;
|
||||
use constant ZIP64_ARCHIVE_EXTRA_SIG => 0x08064b50;
|
||||
use constant ZIP64_DIGITAL_SIGNATURE_SIG => 0x05054b50;
|
||||
|
||||
use constant ZIP_OS_CODE_UNIX => 3;
|
||||
use constant ZIP_OS_CODE_DEFAULT => 3;
|
||||
|
||||
# Extra Field ID's
|
||||
use constant ZIP_EXTRA_ID_ZIP64 => pack "v", 1;
|
||||
use constant ZIP_EXTRA_ID_EXT_TIMESTAMP => "UT";
|
||||
use constant ZIP_EXTRA_ID_INFO_ZIP_UNIX2 => "Ux";
|
||||
use constant ZIP_EXTRA_ID_INFO_ZIP_UNIXN => "ux";
|
||||
use constant ZIP_EXTRA_ID_INFO_ZIP_Upath => "up";
|
||||
use constant ZIP_EXTRA_ID_INFO_ZIP_Ucom => "uc";
|
||||
use constant ZIP_EXTRA_ID_JAVA_EXE => pack "v", 0xCAFE;
|
||||
|
||||
# DOS Attributes
|
||||
use constant ZIP_A_RONLY => 0x01;
|
||||
use constant ZIP_A_HIDDEN => 0x02;
|
||||
use constant ZIP_A_SYSTEM => 0x04;
|
||||
use constant ZIP_A_LABEL => 0x08;
|
||||
use constant ZIP_A_DIR => 0x10;
|
||||
use constant ZIP_A_ARCHIVE => 0x20;
|
||||
|
||||
use constant ZIP64_MIN_VERSION => 45;
|
||||
|
||||
%ZIP_CM_MIN_VERSIONS = (
|
||||
ZIP_CM_STORE() => 20,
|
||||
ZIP_CM_DEFLATE() => 20,
|
||||
ZIP_CM_BZIP2() => 46,
|
||||
ZIP_CM_LZMA() => 63,
|
||||
ZIP_CM_PPMD() => 63,
|
||||
ZIP_CM_ZSTD() => 20, # Winzip needs these to be 20
|
||||
ZIP_CM_XZ() => 20,
|
||||
);
|
||||
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
@@ -0,0 +1,77 @@
|
||||
|
||||
package IO::Compress::Zlib::Constants ;
|
||||
|
||||
use strict ;
|
||||
use warnings;
|
||||
use bytes;
|
||||
|
||||
require Exporter;
|
||||
|
||||
our ($VERSION, @ISA, @EXPORT);
|
||||
|
||||
$VERSION = '2.204';
|
||||
|
||||
@ISA = qw(Exporter);
|
||||
|
||||
@EXPORT= qw(
|
||||
|
||||
ZLIB_HEADER_SIZE
|
||||
ZLIB_TRAILER_SIZE
|
||||
|
||||
ZLIB_CMF_CM_OFFSET
|
||||
ZLIB_CMF_CM_BITS
|
||||
ZLIB_CMF_CM_DEFLATED
|
||||
|
||||
ZLIB_CMF_CINFO_OFFSET
|
||||
ZLIB_CMF_CINFO_BITS
|
||||
ZLIB_CMF_CINFO_MAX
|
||||
|
||||
ZLIB_FLG_FCHECK_OFFSET
|
||||
ZLIB_FLG_FCHECK_BITS
|
||||
|
||||
ZLIB_FLG_FDICT_OFFSET
|
||||
ZLIB_FLG_FDICT_BITS
|
||||
|
||||
ZLIB_FLG_LEVEL_OFFSET
|
||||
ZLIB_FLG_LEVEL_BITS
|
||||
|
||||
ZLIB_FLG_LEVEL_FASTEST
|
||||
ZLIB_FLG_LEVEL_FAST
|
||||
ZLIB_FLG_LEVEL_DEFAULT
|
||||
ZLIB_FLG_LEVEL_SLOWEST
|
||||
|
||||
ZLIB_FDICT_SIZE
|
||||
|
||||
);
|
||||
|
||||
# Constant names derived from RFC1950
|
||||
|
||||
use constant ZLIB_HEADER_SIZE => 2;
|
||||
use constant ZLIB_TRAILER_SIZE => 4;
|
||||
|
||||
use constant ZLIB_CMF_CM_OFFSET => 0;
|
||||
use constant ZLIB_CMF_CM_BITS => 0xF ; # 0b1111
|
||||
use constant ZLIB_CMF_CM_DEFLATED => 8;
|
||||
|
||||
use constant ZLIB_CMF_CINFO_OFFSET => 4;
|
||||
use constant ZLIB_CMF_CINFO_BITS => 0xF ; # 0b1111;
|
||||
use constant ZLIB_CMF_CINFO_MAX => 7;
|
||||
|
||||
use constant ZLIB_FLG_FCHECK_OFFSET => 0;
|
||||
use constant ZLIB_FLG_FCHECK_BITS => 0x1F ; # 0b11111;
|
||||
|
||||
use constant ZLIB_FLG_FDICT_OFFSET => 5;
|
||||
use constant ZLIB_FLG_FDICT_BITS => 0x1 ; # 0b1;
|
||||
|
||||
use constant ZLIB_FLG_LEVEL_OFFSET => 6;
|
||||
use constant ZLIB_FLG_LEVEL_BITS => 0x3 ; # 0b11;
|
||||
|
||||
use constant ZLIB_FLG_LEVEL_FASTEST => 0;
|
||||
use constant ZLIB_FLG_LEVEL_FAST => 1;
|
||||
use constant ZLIB_FLG_LEVEL_DEFAULT => 2;
|
||||
use constant ZLIB_FLG_LEVEL_SLOWEST => 3;
|
||||
|
||||
use constant ZLIB_FDICT_SIZE => 4;
|
||||
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,229 @@
|
||||
package IO::Compress::Zlib::Extra;
|
||||
|
||||
require 5.006 ;
|
||||
|
||||
use strict ;
|
||||
use warnings;
|
||||
use bytes;
|
||||
|
||||
our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS);
|
||||
|
||||
$VERSION = '2.204';
|
||||
|
||||
use IO::Compress::Gzip::Constants 2.204 ;
|
||||
|
||||
sub ExtraFieldError
|
||||
{
|
||||
return $_[0];
|
||||
return "Error with ExtraField Parameter: $_[0]" ;
|
||||
}
|
||||
|
||||
sub validateExtraFieldPair
|
||||
{
|
||||
my $pair = shift ;
|
||||
my $strict = shift;
|
||||
my $gzipMode = shift ;
|
||||
|
||||
return ExtraFieldError("Not an array ref")
|
||||
unless ref $pair && ref $pair eq 'ARRAY';
|
||||
|
||||
return ExtraFieldError("SubField must have two parts")
|
||||
unless @$pair == 2 ;
|
||||
|
||||
return ExtraFieldError("SubField ID is a reference")
|
||||
if ref $pair->[0] ;
|
||||
|
||||
return ExtraFieldError("SubField Data is a reference")
|
||||
if ref $pair->[1] ;
|
||||
|
||||
# ID is exactly two chars
|
||||
return ExtraFieldError("SubField ID not two chars long")
|
||||
unless length $pair->[0] == GZIP_FEXTRA_SUBFIELD_ID_SIZE ;
|
||||
|
||||
# Check that the 2nd byte of the ID isn't 0
|
||||
return ExtraFieldError("SubField ID 2nd byte is 0x00")
|
||||
if $strict && $gzipMode && substr($pair->[0], 1, 1) eq "\x00" ;
|
||||
|
||||
return ExtraFieldError("SubField Data too long")
|
||||
if length $pair->[1] > GZIP_FEXTRA_SUBFIELD_MAX_SIZE ;
|
||||
|
||||
|
||||
return undef ;
|
||||
}
|
||||
|
||||
sub parseRawExtra
|
||||
{
|
||||
my $data = shift ;
|
||||
my $extraRef = shift;
|
||||
my $strict = shift;
|
||||
my $gzipMode = shift ;
|
||||
|
||||
#my $lax = shift ;
|
||||
|
||||
#return undef
|
||||
# if $lax ;
|
||||
|
||||
my $XLEN = length $data ;
|
||||
|
||||
return ExtraFieldError("Too Large")
|
||||
if $XLEN > GZIP_FEXTRA_MAX_SIZE;
|
||||
|
||||
my $offset = 0 ;
|
||||
while ($offset < $XLEN) {
|
||||
|
||||
return ExtraFieldError("Truncated in FEXTRA Body Section")
|
||||
if $offset + GZIP_FEXTRA_SUBFIELD_HEADER_SIZE > $XLEN ;
|
||||
|
||||
my $id = substr($data, $offset, GZIP_FEXTRA_SUBFIELD_ID_SIZE);
|
||||
$offset += GZIP_FEXTRA_SUBFIELD_ID_SIZE;
|
||||
|
||||
my $subLen = unpack("v", substr($data, $offset,
|
||||
GZIP_FEXTRA_SUBFIELD_LEN_SIZE));
|
||||
$offset += GZIP_FEXTRA_SUBFIELD_LEN_SIZE ;
|
||||
|
||||
return ExtraFieldError("Truncated in FEXTRA Body Section")
|
||||
if $offset + $subLen > $XLEN ;
|
||||
|
||||
my $bad = validateExtraFieldPair( [$id,
|
||||
substr($data, $offset, $subLen)],
|
||||
$strict, $gzipMode );
|
||||
return $bad if $bad ;
|
||||
push @$extraRef, [$id => substr($data, $offset, $subLen)]
|
||||
if defined $extraRef;;
|
||||
|
||||
$offset += $subLen ;
|
||||
}
|
||||
|
||||
|
||||
return undef ;
|
||||
}
|
||||
|
||||
sub findID
|
||||
{
|
||||
my $id_want = shift ;
|
||||
my $data = shift;
|
||||
|
||||
my $XLEN = length $data ;
|
||||
|
||||
my $offset = 0 ;
|
||||
while ($offset < $XLEN) {
|
||||
|
||||
return undef
|
||||
if $offset + GZIP_FEXTRA_SUBFIELD_HEADER_SIZE > $XLEN ;
|
||||
|
||||
my $id = substr($data, $offset, GZIP_FEXTRA_SUBFIELD_ID_SIZE);
|
||||
$offset += GZIP_FEXTRA_SUBFIELD_ID_SIZE;
|
||||
|
||||
my $subLen = unpack("v", substr($data, $offset,
|
||||
GZIP_FEXTRA_SUBFIELD_LEN_SIZE));
|
||||
$offset += GZIP_FEXTRA_SUBFIELD_LEN_SIZE ;
|
||||
|
||||
return undef
|
||||
if $offset + $subLen > $XLEN ;
|
||||
|
||||
return substr($data, $offset, $subLen)
|
||||
if $id eq $id_want ;
|
||||
|
||||
$offset += $subLen ;
|
||||
}
|
||||
|
||||
return undef ;
|
||||
}
|
||||
|
||||
|
||||
sub mkSubField
|
||||
{
|
||||
my $id = shift ;
|
||||
my $data = shift ;
|
||||
|
||||
return $id . pack("v", length $data) . $data ;
|
||||
}
|
||||
|
||||
sub parseExtraField
|
||||
{
|
||||
my $dataRef = $_[0];
|
||||
my $strict = $_[1];
|
||||
my $gzipMode = $_[2];
|
||||
#my $lax = @_ == 2 ? $_[1] : 1;
|
||||
|
||||
|
||||
# ExtraField can be any of
|
||||
#
|
||||
# -ExtraField => $data
|
||||
#
|
||||
# -ExtraField => [$id1, $data1,
|
||||
# $id2, $data2]
|
||||
# ...
|
||||
# ]
|
||||
#
|
||||
# -ExtraField => [ [$id1 => $data1],
|
||||
# [$id2 => $data2],
|
||||
# ...
|
||||
# ]
|
||||
#
|
||||
# -ExtraField => { $id1 => $data1,
|
||||
# $id2 => $data2,
|
||||
# ...
|
||||
# }
|
||||
|
||||
if ( ! ref $dataRef ) {
|
||||
|
||||
return undef
|
||||
if ! $strict;
|
||||
|
||||
return parseRawExtra($dataRef, undef, 1, $gzipMode);
|
||||
}
|
||||
|
||||
my $data = $dataRef;
|
||||
my $out = '' ;
|
||||
|
||||
if (ref $data eq 'ARRAY') {
|
||||
if (ref $data->[0]) {
|
||||
|
||||
foreach my $pair (@$data) {
|
||||
return ExtraFieldError("Not list of lists")
|
||||
unless ref $pair eq 'ARRAY' ;
|
||||
|
||||
my $bad = validateExtraFieldPair($pair, $strict, $gzipMode) ;
|
||||
return $bad if $bad ;
|
||||
|
||||
$out .= mkSubField(@$pair);
|
||||
}
|
||||
}
|
||||
else {
|
||||
return ExtraFieldError("Not even number of elements")
|
||||
unless @$data % 2 == 0;
|
||||
|
||||
for (my $ix = 0; $ix <= @$data -1 ; $ix += 2) {
|
||||
my $bad = validateExtraFieldPair([$data->[$ix],
|
||||
$data->[$ix+1]],
|
||||
$strict, $gzipMode) ;
|
||||
return $bad if $bad ;
|
||||
|
||||
$out .= mkSubField($data->[$ix], $data->[$ix+1]);
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif (ref $data eq 'HASH') {
|
||||
while (my ($id, $info) = each %$data) {
|
||||
my $bad = validateExtraFieldPair([$id, $info], $strict, $gzipMode);
|
||||
return $bad if $bad ;
|
||||
|
||||
$out .= mkSubField($id, $info);
|
||||
}
|
||||
}
|
||||
else {
|
||||
return ExtraFieldError("Not a scalar, array ref or hash ref") ;
|
||||
}
|
||||
|
||||
return ExtraFieldError("Too Large")
|
||||
if length $out > GZIP_FEXTRA_MAX_SIZE;
|
||||
|
||||
$_[0] = $out ;
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,111 @@
|
||||
package IO::Uncompress::Adapter::Bunzip2;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use bytes;
|
||||
|
||||
use IO::Compress::Base::Common 2.204 qw(:Status);
|
||||
|
||||
use Compress::Raw::Bzip2 2.204 ;
|
||||
|
||||
our ($VERSION, @ISA);
|
||||
$VERSION = '2.204';
|
||||
|
||||
sub mkUncompObject
|
||||
{
|
||||
my $small = shift || 0;
|
||||
my $verbosity = shift || 0;
|
||||
|
||||
my ($inflate, $status) = Compress::Raw::Bunzip2->new(1, 1, $small, $verbosity, 1);
|
||||
|
||||
return (undef, "Could not create Inflation object: $status", $status)
|
||||
if $status != BZ_OK ;
|
||||
|
||||
return bless {'Inf' => $inflate,
|
||||
'CompSize' => 0,
|
||||
'UnCompSize' => 0,
|
||||
'Error' => '',
|
||||
'ConsumesInput' => 1,
|
||||
} ;
|
||||
|
||||
}
|
||||
|
||||
sub uncompr
|
||||
{
|
||||
my $self = shift ;
|
||||
my $from = shift ;
|
||||
my $to = shift ;
|
||||
my $eof = shift ;
|
||||
|
||||
my $inf = $self->{Inf};
|
||||
|
||||
my $status = $inf->bzinflate($from, $to);
|
||||
$self->{ErrorNo} = $status;
|
||||
|
||||
if ($status != BZ_OK && $status != BZ_STREAM_END )
|
||||
{
|
||||
$self->{Error} = "Inflation Error: $status";
|
||||
return STATUS_ERROR;
|
||||
}
|
||||
|
||||
|
||||
return STATUS_OK if $status == BZ_OK ;
|
||||
return STATUS_ENDSTREAM if $status == BZ_STREAM_END ;
|
||||
return STATUS_ERROR ;
|
||||
}
|
||||
|
||||
|
||||
sub reset
|
||||
{
|
||||
my $self = shift ;
|
||||
|
||||
my ($inf, $status) = Compress::Raw::Bunzip2->new();
|
||||
$self->{ErrorNo} = ($status == BZ_OK) ? 0 : $status ;
|
||||
|
||||
if ($status != BZ_OK)
|
||||
{
|
||||
$self->{Error} = "Cannot create Inflate object: $status";
|
||||
return STATUS_ERROR;
|
||||
}
|
||||
|
||||
$self->{Inf} = $inf;
|
||||
|
||||
return STATUS_OK ;
|
||||
}
|
||||
|
||||
sub compressedBytes
|
||||
{
|
||||
my $self = shift ;
|
||||
$self->{Inf}->compressedBytes();
|
||||
}
|
||||
|
||||
sub uncompressedBytes
|
||||
{
|
||||
my $self = shift ;
|
||||
$self->{Inf}->uncompressedBytes();
|
||||
}
|
||||
|
||||
sub crc32
|
||||
{
|
||||
my $self = shift ;
|
||||
#$self->{Inf}->crc32();
|
||||
}
|
||||
|
||||
sub adler32
|
||||
{
|
||||
my $self = shift ;
|
||||
#$self->{Inf}->adler32();
|
||||
}
|
||||
|
||||
sub sync
|
||||
{
|
||||
my $self = shift ;
|
||||
#( $self->{Inf}->inflateSync(@_) == BZ_OK)
|
||||
# ? STATUS_OK
|
||||
# : STATUS_ERROR ;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
@@ -0,0 +1,188 @@
|
||||
package IO::Uncompress::Adapter::Identity;
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
use bytes;
|
||||
|
||||
use IO::Compress::Base::Common 2.204 qw(:Status);
|
||||
use IO::Compress::Zip::Constants ;
|
||||
|
||||
our ($VERSION);
|
||||
|
||||
$VERSION = '2.204';
|
||||
|
||||
use Compress::Raw::Zlib 2.204 ();
|
||||
|
||||
sub mkUncompObject
|
||||
{
|
||||
my $streaming = shift;
|
||||
my $zip64 = shift;
|
||||
|
||||
my $crc32 = 1; #shift ;
|
||||
my $adler32 = shift;
|
||||
|
||||
bless { 'CompSize' => U64->new(), # 0,
|
||||
'UnCompSize' => 0,
|
||||
'wantCRC32' => $crc32,
|
||||
'CRC32' => Compress::Raw::Zlib::crc32(''),
|
||||
'wantADLER32'=> $adler32,
|
||||
'ADLER32' => Compress::Raw::Zlib::adler32(''),
|
||||
'ConsumesInput' => 1,
|
||||
'Streaming' => $streaming,
|
||||
'Zip64' => $zip64,
|
||||
'DataHdrSize' => $zip64 ? 24 : 16,
|
||||
'Pending' => '',
|
||||
|
||||
} ;
|
||||
}
|
||||
|
||||
|
||||
sub uncompr
|
||||
{
|
||||
my $self = shift;
|
||||
my $in = $_[0];
|
||||
my $eof = $_[2];
|
||||
|
||||
my $len = length $$in;
|
||||
my $remainder = '';
|
||||
|
||||
if (defined $$in && $len) {
|
||||
|
||||
if ($self->{Streaming}) {
|
||||
|
||||
if (length $self->{Pending}) {
|
||||
$$in = $self->{Pending} . $$in ;
|
||||
$len = length $$in;
|
||||
$self->{Pending} = '';
|
||||
}
|
||||
|
||||
my $ind = index($$in, "\x50\x4b\x07\x08");
|
||||
|
||||
if ($ind < 0) {
|
||||
$len = length $$in;
|
||||
if ($len >= 3 && substr($$in, -3) eq "\x50\x4b\x07") {
|
||||
$ind = $len - 3 ;
|
||||
}
|
||||
elsif ($len >= 2 && substr($$in, -2) eq "\x50\x4b") {
|
||||
$ind = $len - 2 ;
|
||||
}
|
||||
elsif ($len >= 1 && substr($$in, -1) eq "\x50") {
|
||||
$ind = $len - 1 ;
|
||||
}
|
||||
}
|
||||
|
||||
if ($ind >= 0) {
|
||||
$remainder = substr($$in, $ind) ;
|
||||
substr($$in, $ind) = '' ;
|
||||
}
|
||||
}
|
||||
|
||||
if (length $remainder && length $remainder < $self->{DataHdrSize}) {
|
||||
$self->{Pending} = $remainder ;
|
||||
$remainder = '';
|
||||
}
|
||||
elsif (length $remainder >= $self->{DataHdrSize}) {
|
||||
my $crc = unpack "V", substr($remainder, 4);
|
||||
if ($crc == Compress::Raw::Zlib::crc32($$in, $self->{CRC32})) {
|
||||
my ($l1, $l2) ;
|
||||
|
||||
if ($self->{Zip64}) {
|
||||
$l1 = U64::newUnpack_V64(substr($remainder, 8));
|
||||
$l2 = U64::newUnpack_V64(substr($remainder, 16));
|
||||
}
|
||||
else {
|
||||
$l1 = U64::newUnpack_V32(substr($remainder, 8));
|
||||
$l2 = U64::newUnpack_V32(substr($remainder, 12));
|
||||
}
|
||||
|
||||
my $newLen = $self->{CompSize}->clone();
|
||||
$newLen->add(length $$in);
|
||||
if ($l1->equal($l2) && $l1->equal($newLen) ) {
|
||||
$eof = 1;
|
||||
}
|
||||
else {
|
||||
$$in .= substr($remainder, 0, 4) ;
|
||||
$remainder = substr($remainder, 4);
|
||||
#$self->{Pending} = substr($remainder, 4);
|
||||
#$remainder = '';
|
||||
$eof = 0;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$$in .= substr($remainder, 0, 4) ;
|
||||
$remainder = substr($remainder, 4);
|
||||
#$self->{Pending} = substr($remainder, 4);
|
||||
#$remainder = '';
|
||||
$eof = 0;
|
||||
}
|
||||
}
|
||||
|
||||
if (length $$in) {
|
||||
$self->{CompSize}->add(length $$in) ;
|
||||
|
||||
$self->{CRC32} = Compress::Raw::Zlib::crc32($$in, $self->{CRC32})
|
||||
if $self->{wantCRC32};
|
||||
|
||||
$self->{ADLER32} = Compress::Zlib::adler32($$in, $self->{ADLER32})
|
||||
if $self->{wantADLER32};
|
||||
}
|
||||
|
||||
${ $_[1] } .= $$in;
|
||||
$$in = $remainder;
|
||||
}
|
||||
|
||||
return STATUS_ENDSTREAM if $eof;
|
||||
return STATUS_OK ;
|
||||
}
|
||||
|
||||
sub reset
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
$self->{CompSize}->reset();
|
||||
$self->{UnCompSize} = 0;
|
||||
$self->{CRC32} = Compress::Raw::Zlib::crc32('');
|
||||
$self->{ADLER32} = Compress::Raw::Zlib::adler32('');
|
||||
|
||||
return STATUS_OK ;
|
||||
}
|
||||
|
||||
#sub count
|
||||
#{
|
||||
# my $self = shift ;
|
||||
# return $self->{UnCompSize} ;
|
||||
#}
|
||||
|
||||
sub compressedBytes
|
||||
{
|
||||
my $self = shift ;
|
||||
return $self->{CompSize} ;
|
||||
}
|
||||
|
||||
sub uncompressedBytes
|
||||
{
|
||||
my $self = shift ;
|
||||
return $self->{CompSize} ;
|
||||
}
|
||||
|
||||
sub sync
|
||||
{
|
||||
return STATUS_OK ;
|
||||
}
|
||||
|
||||
sub crc32
|
||||
{
|
||||
my $self = shift ;
|
||||
return $self->{CRC32};
|
||||
}
|
||||
|
||||
sub adler32
|
||||
{
|
||||
my $self = shift ;
|
||||
return $self->{ADLER32};
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
@@ -0,0 +1,156 @@
|
||||
package IO::Uncompress::Adapter::Inflate;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use bytes;
|
||||
|
||||
use IO::Compress::Base::Common 2.204 qw(:Status);
|
||||
use Compress::Raw::Zlib 2.204 qw(Z_OK Z_BUF_ERROR Z_STREAM_END Z_FINISH MAX_WBITS);
|
||||
|
||||
our ($VERSION);
|
||||
$VERSION = '2.204';
|
||||
|
||||
|
||||
|
||||
sub mkUncompObject
|
||||
{
|
||||
my $crc32 = shift || 1;
|
||||
my $adler32 = shift || 1;
|
||||
my $scan = shift || 0;
|
||||
|
||||
my $inflate ;
|
||||
my $status ;
|
||||
|
||||
if ($scan)
|
||||
{
|
||||
($inflate, $status) = Compress::Raw::Zlib::InflateScan->new(
|
||||
#LimitOutput => 1,
|
||||
CRC32 => $crc32,
|
||||
ADLER32 => $adler32,
|
||||
WindowBits => - MAX_WBITS );
|
||||
}
|
||||
else
|
||||
{
|
||||
($inflate, $status) = Compress::Raw::Zlib::Inflate->new(
|
||||
AppendOutput => 1,
|
||||
LimitOutput => 1,
|
||||
CRC32 => $crc32,
|
||||
ADLER32 => $adler32,
|
||||
WindowBits => - MAX_WBITS );
|
||||
}
|
||||
|
||||
return (undef, "Could not create Inflation object: $status", $status)
|
||||
if $status != Z_OK ;
|
||||
|
||||
return bless {'Inf' => $inflate,
|
||||
'CompSize' => 0,
|
||||
'UnCompSize' => 0,
|
||||
'Error' => '',
|
||||
'ConsumesInput' => 1,
|
||||
} ;
|
||||
|
||||
}
|
||||
|
||||
sub uncompr
|
||||
{
|
||||
my $self = shift ;
|
||||
my $from = shift ;
|
||||
my $to = shift ;
|
||||
my $eof = shift ;
|
||||
|
||||
my $inf = $self->{Inf};
|
||||
|
||||
my $status = $inf->inflate($from, $to, $eof);
|
||||
$self->{ErrorNo} = $status;
|
||||
if ($status != Z_OK && $status != Z_STREAM_END && $status != Z_BUF_ERROR)
|
||||
{
|
||||
$self->{Error} = "Inflation Error: $status";
|
||||
return STATUS_ERROR;
|
||||
}
|
||||
|
||||
return STATUS_OK if $status == Z_BUF_ERROR ; # ???
|
||||
return STATUS_OK if $status == Z_OK ;
|
||||
return STATUS_ENDSTREAM if $status == Z_STREAM_END ;
|
||||
return STATUS_ERROR ;
|
||||
}
|
||||
|
||||
sub reset
|
||||
{
|
||||
my $self = shift ;
|
||||
$self->{Inf}->inflateReset();
|
||||
|
||||
return STATUS_OK ;
|
||||
}
|
||||
|
||||
#sub count
|
||||
#{
|
||||
# my $self = shift ;
|
||||
# $self->{Inf}->inflateCount();
|
||||
#}
|
||||
|
||||
sub crc32
|
||||
{
|
||||
my $self = shift ;
|
||||
$self->{Inf}->crc32();
|
||||
}
|
||||
|
||||
sub compressedBytes
|
||||
{
|
||||
my $self = shift ;
|
||||
$self->{Inf}->compressedBytes();
|
||||
}
|
||||
|
||||
sub uncompressedBytes
|
||||
{
|
||||
my $self = shift ;
|
||||
$self->{Inf}->uncompressedBytes();
|
||||
}
|
||||
|
||||
sub adler32
|
||||
{
|
||||
my $self = shift ;
|
||||
$self->{Inf}->adler32();
|
||||
}
|
||||
|
||||
sub sync
|
||||
{
|
||||
my $self = shift ;
|
||||
( $self->{Inf}->inflateSync(@_) == Z_OK)
|
||||
? STATUS_OK
|
||||
: STATUS_ERROR ;
|
||||
}
|
||||
|
||||
|
||||
sub getLastBlockOffset
|
||||
{
|
||||
my $self = shift ;
|
||||
$self->{Inf}->getLastBlockOffset();
|
||||
}
|
||||
|
||||
sub getEndOffset
|
||||
{
|
||||
my $self = shift ;
|
||||
$self->{Inf}->getEndOffset();
|
||||
}
|
||||
|
||||
sub resetLastBlockByte
|
||||
{
|
||||
my $self = shift ;
|
||||
$self->{Inf}->resetLastBlockByte(@_);
|
||||
}
|
||||
|
||||
sub createDeflateStream
|
||||
{
|
||||
my $self = shift ;
|
||||
my $deflate = $self->{Inf}->createDeflateStream(@_);
|
||||
return bless {'Def' => $deflate,
|
||||
'CompSize' => 0,
|
||||
'UnCompSize' => 0,
|
||||
'Error' => '',
|
||||
}, 'IO::Compress::Adapter::Deflate';
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
||||
__END__
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,915 @@
|
||||
package IO::Uncompress::Bunzip2 ;
|
||||
|
||||
use strict ;
|
||||
use warnings;
|
||||
use bytes;
|
||||
|
||||
use IO::Compress::Base::Common 2.204 qw(:Status );
|
||||
|
||||
use IO::Uncompress::Base 2.204 ;
|
||||
use IO::Uncompress::Adapter::Bunzip2 2.204 ;
|
||||
|
||||
require Exporter ;
|
||||
our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $Bunzip2Error);
|
||||
|
||||
$VERSION = '2.204';
|
||||
$Bunzip2Error = '';
|
||||
|
||||
@ISA = qw(IO::Uncompress::Base Exporter);
|
||||
@EXPORT_OK = qw( $Bunzip2Error bunzip2 ) ;
|
||||
#%EXPORT_TAGS = %IO::Uncompress::Base::EXPORT_TAGS ;
|
||||
push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
|
||||
#Exporter::export_ok_tags('all');
|
||||
|
||||
|
||||
sub new
|
||||
{
|
||||
my $class = shift ;
|
||||
my $obj = IO::Compress::Base::Common::createSelfTiedObject($class, \$Bunzip2Error);
|
||||
|
||||
$obj->_create(undef, 0, @_);
|
||||
}
|
||||
|
||||
sub bunzip2
|
||||
{
|
||||
my $obj = IO::Compress::Base::Common::createSelfTiedObject(undef, \$Bunzip2Error);
|
||||
return $obj->_inf(@_);
|
||||
}
|
||||
|
||||
sub getExtraParams
|
||||
{
|
||||
return (
|
||||
'verbosity' => [IO::Compress::Base::Common::Parse_boolean, 0],
|
||||
'small' => [IO::Compress::Base::Common::Parse_boolean, 0],
|
||||
);
|
||||
}
|
||||
|
||||
|
||||
sub ckParams
|
||||
{
|
||||
my $self = shift ;
|
||||
my $got = shift ;
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub mkUncomp
|
||||
{
|
||||
my $self = shift ;
|
||||
my $got = shift ;
|
||||
|
||||
my $magic = $self->ckMagic()
|
||||
or return 0;
|
||||
|
||||
*$self->{Info} = $self->readHeader($magic)
|
||||
or return undef ;
|
||||
|
||||
my $Small = $got->getValue('small');
|
||||
my $Verbosity = $got->getValue('verbosity');
|
||||
|
||||
my ($obj, $errstr, $errno) = IO::Uncompress::Adapter::Bunzip2::mkUncompObject(
|
||||
$Small, $Verbosity);
|
||||
|
||||
return $self->saveErrorString(undef, $errstr, $errno)
|
||||
if ! defined $obj;
|
||||
|
||||
*$self->{Uncomp} = $obj;
|
||||
|
||||
return 1;
|
||||
|
||||
}
|
||||
|
||||
|
||||
sub ckMagic
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
my $magic ;
|
||||
$self->smartReadExact(\$magic, 4);
|
||||
|
||||
*$self->{HeaderPending} = $magic ;
|
||||
|
||||
return $self->HeaderError("Header size is " .
|
||||
4 . " bytes")
|
||||
if length $magic != 4;
|
||||
|
||||
return $self->HeaderError("Bad Magic.")
|
||||
if ! isBzip2Magic($magic) ;
|
||||
|
||||
|
||||
*$self->{Type} = 'bzip2';
|
||||
return $magic;
|
||||
}
|
||||
|
||||
sub readHeader
|
||||
{
|
||||
my $self = shift;
|
||||
my $magic = shift ;
|
||||
|
||||
$self->pushBack($magic);
|
||||
*$self->{HeaderPending} = '';
|
||||
|
||||
|
||||
return {
|
||||
'Type' => 'bzip2',
|
||||
'FingerprintLength' => 4,
|
||||
'HeaderLength' => 4,
|
||||
'TrailerLength' => 0,
|
||||
'Header' => '$magic'
|
||||
};
|
||||
|
||||
}
|
||||
|
||||
sub chkTrailer
|
||||
{
|
||||
return STATUS_OK;
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub isBzip2Magic
|
||||
{
|
||||
my $buffer = shift ;
|
||||
|
||||
# ASCII: B Z h 0 9
|
||||
return $buffer =~ qr/^\x42\x5A\x68[\x30-\x39]$/;
|
||||
}
|
||||
|
||||
1 ;
|
||||
|
||||
__END__
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
IO::Uncompress::Bunzip2 - Read bzip2 files/buffers
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use IO::Uncompress::Bunzip2 qw(bunzip2 $Bunzip2Error) ;
|
||||
|
||||
my $status = bunzip2 $input => $output [,OPTS]
|
||||
or die "bunzip2 failed: $Bunzip2Error\n";
|
||||
|
||||
my $z = IO::Uncompress::Bunzip2->new( $input [OPTS] )
|
||||
or die "bunzip2 failed: $Bunzip2Error\n";
|
||||
|
||||
$status = $z->read($buffer)
|
||||
$status = $z->read($buffer, $length)
|
||||
$status = $z->read($buffer, $length, $offset)
|
||||
$line = $z->getline()
|
||||
$char = $z->getc()
|
||||
$char = $z->ungetc()
|
||||
$char = $z->opened()
|
||||
|
||||
$data = $z->trailingData()
|
||||
$status = $z->nextStream()
|
||||
$data = $z->getHeaderInfo()
|
||||
$z->tell()
|
||||
$z->seek($position, $whence)
|
||||
$z->binmode()
|
||||
$z->fileno()
|
||||
$z->eof()
|
||||
$z->close()
|
||||
|
||||
$Bunzip2Error ;
|
||||
|
||||
# IO::File mode
|
||||
|
||||
<$z>
|
||||
read($z, $buffer);
|
||||
read($z, $buffer, $length);
|
||||
read($z, $buffer, $length, $offset);
|
||||
tell($z)
|
||||
seek($z, $position, $whence)
|
||||
binmode($z)
|
||||
fileno($z)
|
||||
eof($z)
|
||||
close($z)
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides a Perl interface that allows the reading of
|
||||
bzip2 files/buffers.
|
||||
|
||||
For writing bzip2 files/buffers, see the companion module IO::Compress::Bzip2.
|
||||
|
||||
=head1 Functional Interface
|
||||
|
||||
A top-level function, C<bunzip2>, is provided to carry out
|
||||
"one-shot" uncompression between buffers and/or files. For finer
|
||||
control over the uncompression process, see the L</"OO Interface">
|
||||
section.
|
||||
|
||||
use IO::Uncompress::Bunzip2 qw(bunzip2 $Bunzip2Error) ;
|
||||
|
||||
bunzip2 $input_filename_or_reference => $output_filename_or_reference [,OPTS]
|
||||
or die "bunzip2 failed: $Bunzip2Error\n";
|
||||
|
||||
The functional interface needs Perl5.005 or better.
|
||||
|
||||
=head2 bunzip2 $input_filename_or_reference => $output_filename_or_reference [, OPTS]
|
||||
|
||||
C<bunzip2> expects at least two parameters,
|
||||
C<$input_filename_or_reference> and C<$output_filename_or_reference>
|
||||
and zero or more optional parameters (see L</Optional Parameters>)
|
||||
|
||||
=head3 The C<$input_filename_or_reference> parameter
|
||||
|
||||
The parameter, C<$input_filename_or_reference>, is used to define the
|
||||
source of the compressed data.
|
||||
|
||||
It can take one of the following forms:
|
||||
|
||||
=over 5
|
||||
|
||||
=item A filename
|
||||
|
||||
If the C<$input_filename_or_reference> parameter is a simple scalar, it is
|
||||
assumed to be a filename. This file will be opened for reading and the
|
||||
input data will be read from it.
|
||||
|
||||
=item A filehandle
|
||||
|
||||
If the C<$input_filename_or_reference> parameter is a filehandle, the input
|
||||
data will be read from it. The string '-' can be used as an alias for
|
||||
standard input.
|
||||
|
||||
=item A scalar reference
|
||||
|
||||
If C<$input_filename_or_reference> is a scalar reference, the input data
|
||||
will be read from C<$$input_filename_or_reference>.
|
||||
|
||||
=item An array reference
|
||||
|
||||
If C<$input_filename_or_reference> is an array reference, each element in
|
||||
the array must be a filename.
|
||||
|
||||
The input data will be read from each file in turn.
|
||||
|
||||
The complete array will be walked to ensure that it only
|
||||
contains valid filenames before any data is uncompressed.
|
||||
|
||||
=item An Input FileGlob string
|
||||
|
||||
If C<$input_filename_or_reference> is a string that is delimited by the
|
||||
characters "<" and ">" C<bunzip2> will assume that it is an
|
||||
I<input fileglob string>. The input is the list of files that match the
|
||||
fileglob.
|
||||
|
||||
See L<File::GlobMapper|File::GlobMapper> for more details.
|
||||
|
||||
=back
|
||||
|
||||
If the C<$input_filename_or_reference> parameter is any other type,
|
||||
C<undef> will be returned.
|
||||
|
||||
=head3 The C<$output_filename_or_reference> parameter
|
||||
|
||||
The parameter C<$output_filename_or_reference> is used to control the
|
||||
destination of the uncompressed data. This parameter can take one of
|
||||
these forms.
|
||||
|
||||
=over 5
|
||||
|
||||
=item A filename
|
||||
|
||||
If the C<$output_filename_or_reference> parameter is a simple scalar, it is
|
||||
assumed to be a filename. This file will be opened for writing and the
|
||||
uncompressed data will be written to it.
|
||||
|
||||
=item A filehandle
|
||||
|
||||
If the C<$output_filename_or_reference> parameter is a filehandle, the
|
||||
uncompressed data will be written to it. The string '-' can be used as
|
||||
an alias for standard output.
|
||||
|
||||
=item A scalar reference
|
||||
|
||||
If C<$output_filename_or_reference> is a scalar reference, the
|
||||
uncompressed data will be stored in C<$$output_filename_or_reference>.
|
||||
|
||||
=item An Array Reference
|
||||
|
||||
If C<$output_filename_or_reference> is an array reference,
|
||||
the uncompressed data will be pushed onto the array.
|
||||
|
||||
=item An Output FileGlob
|
||||
|
||||
If C<$output_filename_or_reference> is a string that is delimited by the
|
||||
characters "<" and ">" C<bunzip2> will assume that it is an
|
||||
I<output fileglob string>. The output is the list of files that match the
|
||||
fileglob.
|
||||
|
||||
When C<$output_filename_or_reference> is an fileglob string,
|
||||
C<$input_filename_or_reference> must also be a fileglob string. Anything
|
||||
else is an error.
|
||||
|
||||
See L<File::GlobMapper|File::GlobMapper> for more details.
|
||||
|
||||
=back
|
||||
|
||||
If the C<$output_filename_or_reference> parameter is any other type,
|
||||
C<undef> will be returned.
|
||||
|
||||
=head2 Notes
|
||||
|
||||
When C<$input_filename_or_reference> maps to multiple compressed
|
||||
files/buffers and C<$output_filename_or_reference> is
|
||||
a single file/buffer, after uncompression C<$output_filename_or_reference> will contain a
|
||||
concatenation of all the uncompressed data from each of the input
|
||||
files/buffers.
|
||||
|
||||
=head2 Optional Parameters
|
||||
|
||||
The optional parameters for the one-shot function C<bunzip2>
|
||||
are (for the most part) identical to those used with the OO interface defined in the
|
||||
L</"Constructor Options"> section. The exceptions are listed below
|
||||
|
||||
=over 5
|
||||
|
||||
=item C<< AutoClose => 0|1 >>
|
||||
|
||||
This option applies to any input or output data streams to
|
||||
C<bunzip2> that are filehandles.
|
||||
|
||||
If C<AutoClose> is specified, and the value is true, it will result in all
|
||||
input and/or output filehandles being closed once C<bunzip2> has
|
||||
completed.
|
||||
|
||||
This parameter defaults to 0.
|
||||
|
||||
=item C<< BinModeOut => 0|1 >>
|
||||
|
||||
This option is now a no-op. All files will be written in binmode.
|
||||
|
||||
=item C<< Append => 0|1 >>
|
||||
|
||||
The behaviour of this option is dependent on the type of output data
|
||||
stream.
|
||||
|
||||
=over 5
|
||||
|
||||
=item * A Buffer
|
||||
|
||||
If C<Append> is enabled, all uncompressed data will be append to the end of
|
||||
the output buffer. Otherwise the output buffer will be cleared before any
|
||||
uncompressed data is written to it.
|
||||
|
||||
=item * A Filename
|
||||
|
||||
If C<Append> is enabled, the file will be opened in append mode. Otherwise
|
||||
the contents of the file, if any, will be truncated before any uncompressed
|
||||
data is written to it.
|
||||
|
||||
=item * A Filehandle
|
||||
|
||||
If C<Append> is enabled, the filehandle will be positioned to the end of
|
||||
the file via a call to C<seek> before any uncompressed data is
|
||||
written to it. Otherwise the file pointer will not be moved.
|
||||
|
||||
=back
|
||||
|
||||
When C<Append> is specified, and set to true, it will I<append> all uncompressed
|
||||
data to the output data stream.
|
||||
|
||||
So when the output is a filehandle it will carry out a seek to the eof
|
||||
before writing any uncompressed data. If the output is a filename, it will be opened for
|
||||
appending. If the output is a buffer, all uncompressed data will be
|
||||
appended to the existing buffer.
|
||||
|
||||
Conversely when C<Append> is not specified, or it is present and is set to
|
||||
false, it will operate as follows.
|
||||
|
||||
When the output is a filename, it will truncate the contents of the file
|
||||
before writing any uncompressed data. If the output is a filehandle
|
||||
its position will not be changed. If the output is a buffer, it will be
|
||||
wiped before any uncompressed data is output.
|
||||
|
||||
Defaults to 0.
|
||||
|
||||
=item C<< MultiStream => 0|1 >>
|
||||
|
||||
If the input file/buffer contains multiple compressed data streams, this
|
||||
option will uncompress the whole lot as a single data stream.
|
||||
|
||||
Defaults to 0.
|
||||
|
||||
=item C<< TrailingData => $scalar >>
|
||||
|
||||
Returns the data, if any, that is present immediately after the compressed
|
||||
data stream once uncompression is complete.
|
||||
|
||||
This option can be used when there is useful information immediately
|
||||
following the compressed data stream, and you don't know the length of the
|
||||
compressed data stream.
|
||||
|
||||
If the input is a buffer, C<trailingData> will return everything from the
|
||||
end of the compressed data stream to the end of the buffer.
|
||||
|
||||
If the input is a filehandle, C<trailingData> will return the data that is
|
||||
left in the filehandle input buffer once the end of the compressed data
|
||||
stream has been reached. You can then use the filehandle to read the rest
|
||||
of the input file.
|
||||
|
||||
Don't bother using C<trailingData> if the input is a filename.
|
||||
|
||||
If you know the length of the compressed data stream before you start
|
||||
uncompressing, you can avoid having to use C<trailingData> by setting the
|
||||
C<InputLength> option.
|
||||
|
||||
=back
|
||||
|
||||
=head2 Examples
|
||||
|
||||
To read the contents of the file C<file1.txt.bz2> and write the
|
||||
uncompressed data to the file C<file1.txt>.
|
||||
|
||||
use strict ;
|
||||
use warnings ;
|
||||
use IO::Uncompress::Bunzip2 qw(bunzip2 $Bunzip2Error) ;
|
||||
|
||||
my $input = "file1.txt.bz2";
|
||||
my $output = "file1.txt";
|
||||
bunzip2 $input => $output
|
||||
or die "bunzip2 failed: $Bunzip2Error\n";
|
||||
|
||||
To read from an existing Perl filehandle, C<$input>, and write the
|
||||
uncompressed data to a buffer, C<$buffer>.
|
||||
|
||||
use strict ;
|
||||
use warnings ;
|
||||
use IO::Uncompress::Bunzip2 qw(bunzip2 $Bunzip2Error) ;
|
||||
use IO::File ;
|
||||
|
||||
my $input = IO::File->new( "<file1.txt.bz2" )
|
||||
or die "Cannot open 'file1.txt.bz2': $!\n" ;
|
||||
my $buffer ;
|
||||
bunzip2 $input => \$buffer
|
||||
or die "bunzip2 failed: $Bunzip2Error\n";
|
||||
|
||||
To uncompress all files in the directory "/my/home" that match "*.txt.bz2" and store the compressed data in the same directory
|
||||
|
||||
use strict ;
|
||||
use warnings ;
|
||||
use IO::Uncompress::Bunzip2 qw(bunzip2 $Bunzip2Error) ;
|
||||
|
||||
bunzip2 '</my/home/*.txt.bz2>' => '</my/home/#1.txt>'
|
||||
or die "bunzip2 failed: $Bunzip2Error\n";
|
||||
|
||||
and if you want to compress each file one at a time, this will do the trick
|
||||
|
||||
use strict ;
|
||||
use warnings ;
|
||||
use IO::Uncompress::Bunzip2 qw(bunzip2 $Bunzip2Error) ;
|
||||
|
||||
for my $input ( glob "/my/home/*.txt.bz2" )
|
||||
{
|
||||
my $output = $input;
|
||||
$output =~ s/.bz2// ;
|
||||
bunzip2 $input => $output
|
||||
or die "Error compressing '$input': $Bunzip2Error\n";
|
||||
}
|
||||
|
||||
=head1 OO Interface
|
||||
|
||||
=head2 Constructor
|
||||
|
||||
The format of the constructor for IO::Uncompress::Bunzip2 is shown below
|
||||
|
||||
my $z = IO::Uncompress::Bunzip2->new( $input [OPTS] )
|
||||
or die "IO::Uncompress::Bunzip2 failed: $Bunzip2Error\n";
|
||||
|
||||
Returns an C<IO::Uncompress::Bunzip2> object on success and undef on failure.
|
||||
The variable C<$Bunzip2Error> will contain an error message on failure.
|
||||
|
||||
If you are running Perl 5.005 or better the object, C<$z>, returned from
|
||||
IO::Uncompress::Bunzip2 can be used exactly like an L<IO::File|IO::File> filehandle.
|
||||
This means that all normal input file operations can be carried out with
|
||||
C<$z>. For example, to read a line from a compressed file/buffer you can
|
||||
use either of these forms
|
||||
|
||||
$line = $z->getline();
|
||||
$line = <$z>;
|
||||
|
||||
The mandatory parameter C<$input> is used to determine the source of the
|
||||
compressed data. This parameter can take one of three forms.
|
||||
|
||||
=over 5
|
||||
|
||||
=item A filename
|
||||
|
||||
If the C<$input> parameter is a scalar, it is assumed to be a filename. This
|
||||
file will be opened for reading and the compressed data will be read from it.
|
||||
|
||||
=item A filehandle
|
||||
|
||||
If the C<$input> parameter is a filehandle, the compressed data will be
|
||||
read from it.
|
||||
The string '-' can be used as an alias for standard input.
|
||||
|
||||
=item A scalar reference
|
||||
|
||||
If C<$input> is a scalar reference, the compressed data will be read from
|
||||
C<$$input>.
|
||||
|
||||
=back
|
||||
|
||||
=head2 Constructor Options
|
||||
|
||||
The option names defined below are case insensitive and can be optionally
|
||||
prefixed by a '-'. So all of the following are valid
|
||||
|
||||
-AutoClose
|
||||
-autoclose
|
||||
AUTOCLOSE
|
||||
autoclose
|
||||
|
||||
OPTS is a combination of the following options:
|
||||
|
||||
=over 5
|
||||
|
||||
=item C<< AutoClose => 0|1 >>
|
||||
|
||||
This option is only valid when the C<$input> parameter is a filehandle. If
|
||||
specified, and the value is true, it will result in the file being closed once
|
||||
either the C<close> method is called or the IO::Uncompress::Bunzip2 object is
|
||||
destroyed.
|
||||
|
||||
This parameter defaults to 0.
|
||||
|
||||
=item C<< MultiStream => 0|1 >>
|
||||
|
||||
Allows multiple concatenated compressed streams to be treated as a single
|
||||
compressed stream. Decompression will stop once either the end of the
|
||||
file/buffer is reached, an error is encountered (premature eof, corrupt
|
||||
compressed data) or the end of a stream is not immediately followed by the
|
||||
start of another stream.
|
||||
|
||||
This parameter defaults to 0.
|
||||
|
||||
=item C<< Prime => $string >>
|
||||
|
||||
This option will uncompress the contents of C<$string> before processing the
|
||||
input file/buffer.
|
||||
|
||||
This option can be useful when the compressed data is embedded in another
|
||||
file/data structure and it is not possible to work out where the compressed
|
||||
data begins without having to read the first few bytes. If this is the
|
||||
case, the uncompression can be I<primed> with these bytes using this
|
||||
option.
|
||||
|
||||
=item C<< Transparent => 0|1 >>
|
||||
|
||||
If this option is set and the input file/buffer is not compressed data,
|
||||
the module will allow reading of it anyway.
|
||||
|
||||
In addition, if the input file/buffer does contain compressed data and
|
||||
there is non-compressed data immediately following it, setting this option
|
||||
will make this module treat the whole file/buffer as a single data stream.
|
||||
|
||||
This option defaults to 1.
|
||||
|
||||
=item C<< BlockSize => $num >>
|
||||
|
||||
When reading the compressed input data, IO::Uncompress::Bunzip2 will read it in
|
||||
blocks of C<$num> bytes.
|
||||
|
||||
This option defaults to 4096.
|
||||
|
||||
=item C<< InputLength => $size >>
|
||||
|
||||
When present this option will limit the number of compressed bytes read
|
||||
from the input file/buffer to C<$size>. This option can be used in the
|
||||
situation where there is useful data directly after the compressed data
|
||||
stream and you know beforehand the exact length of the compressed data
|
||||
stream.
|
||||
|
||||
This option is mostly used when reading from a filehandle, in which case
|
||||
the file pointer will be left pointing to the first byte directly after the
|
||||
compressed data stream.
|
||||
|
||||
This option defaults to off.
|
||||
|
||||
=item C<< Append => 0|1 >>
|
||||
|
||||
This option controls what the C<read> method does with uncompressed data.
|
||||
|
||||
If set to 1, all uncompressed data will be appended to the output parameter
|
||||
of the C<read> method.
|
||||
|
||||
If set to 0, the contents of the output parameter of the C<read> method
|
||||
will be overwritten by the uncompressed data.
|
||||
|
||||
Defaults to 0.
|
||||
|
||||
=item C<< Strict => 0|1 >>
|
||||
|
||||
This option is a no-op.
|
||||
|
||||
=item C<< Small => 0|1 >>
|
||||
|
||||
When non-zero this options will make bzip2 use a decompression algorithm
|
||||
that uses less memory at the expense of increasing the amount of time
|
||||
taken for decompression.
|
||||
|
||||
Default is 0.
|
||||
|
||||
=back
|
||||
|
||||
=head2 Examples
|
||||
|
||||
TODO
|
||||
|
||||
=head1 Methods
|
||||
|
||||
=head2 read
|
||||
|
||||
Usage is
|
||||
|
||||
$status = $z->read($buffer)
|
||||
|
||||
Reads a block of compressed data (the size of the compressed block is
|
||||
determined by the C<Buffer> option in the constructor), uncompresses it and
|
||||
writes any uncompressed data into C<$buffer>. If the C<Append> parameter is
|
||||
set in the constructor, the uncompressed data will be appended to the
|
||||
C<$buffer> parameter. Otherwise C<$buffer> will be overwritten.
|
||||
|
||||
Returns the number of uncompressed bytes written to C<$buffer>, zero if eof
|
||||
or a negative number on error.
|
||||
|
||||
=head2 read
|
||||
|
||||
Usage is
|
||||
|
||||
$status = $z->read($buffer, $length)
|
||||
$status = $z->read($buffer, $length, $offset)
|
||||
|
||||
$status = read($z, $buffer, $length)
|
||||
$status = read($z, $buffer, $length, $offset)
|
||||
|
||||
Attempt to read C<$length> bytes of uncompressed data into C<$buffer>.
|
||||
|
||||
The main difference between this form of the C<read> method and the
|
||||
previous one, is that this one will attempt to return I<exactly> C<$length>
|
||||
bytes. The only circumstances that this function will not is if end-of-file
|
||||
or an IO error is encountered.
|
||||
|
||||
Returns the number of uncompressed bytes written to C<$buffer>, zero if eof
|
||||
or a negative number on error.
|
||||
|
||||
=head2 getline
|
||||
|
||||
Usage is
|
||||
|
||||
$line = $z->getline()
|
||||
$line = <$z>
|
||||
|
||||
Reads a single line.
|
||||
|
||||
This method fully supports the use of the variable C<$/> (or
|
||||
C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to
|
||||
determine what constitutes an end of line. Paragraph mode, record mode and
|
||||
file slurp mode are all supported.
|
||||
|
||||
=head2 getc
|
||||
|
||||
Usage is
|
||||
|
||||
$char = $z->getc()
|
||||
|
||||
Read a single character.
|
||||
|
||||
=head2 ungetc
|
||||
|
||||
Usage is
|
||||
|
||||
$char = $z->ungetc($string)
|
||||
|
||||
=head2 getHeaderInfo
|
||||
|
||||
Usage is
|
||||
|
||||
$hdr = $z->getHeaderInfo();
|
||||
@hdrs = $z->getHeaderInfo();
|
||||
|
||||
This method returns either a hash reference (in scalar context) or a list
|
||||
or hash references (in array context) that contains information about each
|
||||
of the header fields in the compressed data stream(s).
|
||||
|
||||
=head2 tell
|
||||
|
||||
Usage is
|
||||
|
||||
$z->tell()
|
||||
tell $z
|
||||
|
||||
Returns the uncompressed file offset.
|
||||
|
||||
=head2 eof
|
||||
|
||||
Usage is
|
||||
|
||||
$z->eof();
|
||||
eof($z);
|
||||
|
||||
Returns true if the end of the compressed input stream has been reached.
|
||||
|
||||
=head2 seek
|
||||
|
||||
$z->seek($position, $whence);
|
||||
seek($z, $position, $whence);
|
||||
|
||||
Provides a sub-set of the C<seek> functionality, with the restriction
|
||||
that it is only legal to seek forward in the input file/buffer.
|
||||
It is a fatal error to attempt to seek backward.
|
||||
|
||||
Note that the implementation of C<seek> in this module does not provide
|
||||
true random access to a compressed file/buffer. It works by uncompressing
|
||||
data from the current offset in the file/buffer until it reaches the
|
||||
uncompressed offset specified in the parameters to C<seek>. For very small
|
||||
files this may be acceptable behaviour. For large files it may cause an
|
||||
unacceptable delay.
|
||||
|
||||
The C<$whence> parameter takes one the usual values, namely SEEK_SET,
|
||||
SEEK_CUR or SEEK_END.
|
||||
|
||||
Returns 1 on success, 0 on failure.
|
||||
|
||||
=head2 binmode
|
||||
|
||||
Usage is
|
||||
|
||||
$z->binmode
|
||||
binmode $z ;
|
||||
|
||||
This is a noop provided for completeness.
|
||||
|
||||
=head2 opened
|
||||
|
||||
$z->opened()
|
||||
|
||||
Returns true if the object currently refers to a opened file/buffer.
|
||||
|
||||
=head2 autoflush
|
||||
|
||||
my $prev = $z->autoflush()
|
||||
my $prev = $z->autoflush(EXPR)
|
||||
|
||||
If the C<$z> object is associated with a file or a filehandle, this method
|
||||
returns the current autoflush setting for the underlying filehandle. If
|
||||
C<EXPR> is present, and is non-zero, it will enable flushing after every
|
||||
write/print operation.
|
||||
|
||||
If C<$z> is associated with a buffer, this method has no effect and always
|
||||
returns C<undef>.
|
||||
|
||||
B<Note> that the special variable C<$|> B<cannot> be used to set or
|
||||
retrieve the autoflush setting.
|
||||
|
||||
=head2 input_line_number
|
||||
|
||||
$z->input_line_number()
|
||||
$z->input_line_number(EXPR)
|
||||
|
||||
Returns the current uncompressed line number. If C<EXPR> is present it has
|
||||
the effect of setting the line number. Note that setting the line number
|
||||
does not change the current position within the file/buffer being read.
|
||||
|
||||
The contents of C<$/> are used to determine what constitutes a line
|
||||
terminator.
|
||||
|
||||
=head2 fileno
|
||||
|
||||
$z->fileno()
|
||||
fileno($z)
|
||||
|
||||
If the C<$z> object is associated with a file or a filehandle, C<fileno>
|
||||
will return the underlying file descriptor. Once the C<close> method is
|
||||
called C<fileno> will return C<undef>.
|
||||
|
||||
If the C<$z> object is associated with a buffer, this method will return
|
||||
C<undef>.
|
||||
|
||||
=head2 close
|
||||
|
||||
$z->close() ;
|
||||
close $z ;
|
||||
|
||||
Closes the output file/buffer.
|
||||
|
||||
For most versions of Perl this method will be automatically invoked if
|
||||
the IO::Uncompress::Bunzip2 object is destroyed (either explicitly or by the
|
||||
variable with the reference to the object going out of scope). The
|
||||
exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In
|
||||
these cases, the C<close> method will be called automatically, but
|
||||
not until global destruction of all live objects when the program is
|
||||
terminating.
|
||||
|
||||
Therefore, if you want your scripts to be able to run on all versions
|
||||
of Perl, you should call C<close> explicitly and not rely on automatic
|
||||
closing.
|
||||
|
||||
Returns true on success, otherwise 0.
|
||||
|
||||
If the C<AutoClose> option has been enabled when the IO::Uncompress::Bunzip2
|
||||
object was created, and the object is associated with a file, the
|
||||
underlying file will also be closed.
|
||||
|
||||
=head2 nextStream
|
||||
|
||||
Usage is
|
||||
|
||||
my $status = $z->nextStream();
|
||||
|
||||
Skips to the next compressed data stream in the input file/buffer. If a new
|
||||
compressed data stream is found, the eof marker will be cleared and C<$.>
|
||||
will be reset to 0.
|
||||
|
||||
Returns 1 if a new stream was found, 0 if none was found, and -1 if an
|
||||
error was encountered.
|
||||
|
||||
=head2 trailingData
|
||||
|
||||
Usage is
|
||||
|
||||
my $data = $z->trailingData();
|
||||
|
||||
Returns the data, if any, that is present immediately after the compressed
|
||||
data stream once uncompression is complete. It only makes sense to call
|
||||
this method once the end of the compressed data stream has been
|
||||
encountered.
|
||||
|
||||
This option can be used when there is useful information immediately
|
||||
following the compressed data stream, and you don't know the length of the
|
||||
compressed data stream.
|
||||
|
||||
If the input is a buffer, C<trailingData> will return everything from the
|
||||
end of the compressed data stream to the end of the buffer.
|
||||
|
||||
If the input is a filehandle, C<trailingData> will return the data that is
|
||||
left in the filehandle input buffer once the end of the compressed data
|
||||
stream has been reached. You can then use the filehandle to read the rest
|
||||
of the input file.
|
||||
|
||||
Don't bother using C<trailingData> if the input is a filename.
|
||||
|
||||
If you know the length of the compressed data stream before you start
|
||||
uncompressing, you can avoid having to use C<trailingData> by setting the
|
||||
C<InputLength> option in the constructor.
|
||||
|
||||
=head1 Importing
|
||||
|
||||
No symbolic constants are required by IO::Uncompress::Bunzip2 at present.
|
||||
|
||||
=over 5
|
||||
|
||||
=item :all
|
||||
|
||||
Imports C<bunzip2> and C<$Bunzip2Error>.
|
||||
Same as doing this
|
||||
|
||||
use IO::Uncompress::Bunzip2 qw(bunzip2 $Bunzip2Error) ;
|
||||
|
||||
=back
|
||||
|
||||
=head1 EXAMPLES
|
||||
|
||||
=head2 Working with Net::FTP
|
||||
|
||||
See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP">
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
General feedback/questions/bug reports should be sent to
|
||||
L<https://github.com/pmqs/IO-Compress/issues> (preferred) or
|
||||
L<https://rt.cpan.org/Public/Dist/Display.html?Name=IO-Compress>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzip>, L<IO::Uncompress::UnLzip>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Compress::Zstd>, L<IO::Uncompress::UnZstd>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
|
||||
|
||||
L<IO::Compress::FAQ|IO::Compress::FAQ>
|
||||
|
||||
L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
|
||||
L<Archive::Tar|Archive::Tar>,
|
||||
L<IO::Zlib|IO::Zlib>
|
||||
|
||||
The primary site for the bzip2 program is L<https://sourceware.org/bzip2/>.
|
||||
|
||||
See the module L<Compress::Bzip2|Compress::Bzip2>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
This module was written by Paul Marquess, C<pmqs@cpan.org>.
|
||||
|
||||
=head1 MODIFICATION HISTORY
|
||||
|
||||
See the Changes file.
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright (c) 2005-2023 Paul Marquess. All rights reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,740 @@
|
||||
# IO::Zlib.pm
|
||||
#
|
||||
# Copyright (c) 1998-2004 Tom Hughes <tom@compton.nu>.
|
||||
# All rights reserved. This program is free software; you can redistribute
|
||||
# it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
package IO::Zlib;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
IO::Zlib - IO:: style interface to L<Compress::Zlib>
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
With any version of Perl 5 you can use the basic OO interface:
|
||||
|
||||
use IO::Zlib;
|
||||
|
||||
$fh = new IO::Zlib;
|
||||
if ($fh->open("file.gz", "rb")) {
|
||||
print <$fh>;
|
||||
$fh->close;
|
||||
}
|
||||
|
||||
$fh = IO::Zlib->new("file.gz", "wb9");
|
||||
if (defined $fh) {
|
||||
print $fh "bar\n";
|
||||
$fh->close;
|
||||
}
|
||||
|
||||
$fh = IO::Zlib->new("file.gz", "rb");
|
||||
if (defined $fh) {
|
||||
print <$fh>;
|
||||
undef $fh; # automatically closes the file
|
||||
}
|
||||
|
||||
With Perl 5.004 you can also use the TIEHANDLE interface to access
|
||||
compressed files just like ordinary files:
|
||||
|
||||
use IO::Zlib;
|
||||
|
||||
tie *FILE, 'IO::Zlib', "file.gz", "wb";
|
||||
print FILE "line 1\nline2\n";
|
||||
|
||||
tie *FILE, 'IO::Zlib', "file.gz", "rb";
|
||||
while (<FILE>) { print "LINE: ", $_ };
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
C<IO::Zlib> provides an IO:: style interface to L<Compress::Zlib> and
|
||||
hence to gzip/zlib compressed files. It provides many of the same methods
|
||||
as the L<IO::Handle> interface.
|
||||
|
||||
Starting from IO::Zlib version 1.02, IO::Zlib can also use an
|
||||
external F<gzip> command. The default behaviour is to try to use
|
||||
an external F<gzip> if no C<Compress::Zlib> can be loaded, unless
|
||||
explicitly disabled by
|
||||
|
||||
use IO::Zlib qw(:gzip_external 0);
|
||||
|
||||
If explicitly enabled by
|
||||
|
||||
use IO::Zlib qw(:gzip_external 1);
|
||||
|
||||
then the external F<gzip> is used B<instead> of C<Compress::Zlib>.
|
||||
|
||||
=head1 CONSTRUCTOR
|
||||
|
||||
=over 4
|
||||
|
||||
=item new ( [ARGS] )
|
||||
|
||||
Creates an C<IO::Zlib> object. If it receives any parameters, they are
|
||||
passed to the method C<open>; if the open fails, the object is destroyed.
|
||||
Otherwise, it is returned to the caller.
|
||||
|
||||
=back
|
||||
|
||||
=head1 OBJECT METHODS
|
||||
|
||||
=over 4
|
||||
|
||||
=item open ( FILENAME, MODE )
|
||||
|
||||
C<open> takes two arguments. The first is the name of the file to open
|
||||
and the second is the open mode. The mode can be anything acceptable to
|
||||
L<Compress::Zlib> and by extension anything acceptable to I<zlib> (that
|
||||
basically means POSIX fopen() style mode strings plus an optional number
|
||||
to indicate the compression level).
|
||||
|
||||
=item opened
|
||||
|
||||
Returns true if the object currently refers to a opened file.
|
||||
|
||||
=item close
|
||||
|
||||
Close the file associated with the object and disassociate
|
||||
the file from the handle.
|
||||
Done automatically on destroy.
|
||||
|
||||
=item getc
|
||||
|
||||
Return the next character from the file, or undef if none remain.
|
||||
|
||||
=item getline
|
||||
|
||||
Return the next line from the file, or undef on end of string.
|
||||
Can safely be called in an array context.
|
||||
Currently ignores $/ ($INPUT_RECORD_SEPARATOR or $RS when L<English>
|
||||
is in use) and treats lines as delimited by "\n".
|
||||
|
||||
=item getlines
|
||||
|
||||
Get all remaining lines from the file.
|
||||
It will croak() if accidentally called in a scalar context.
|
||||
|
||||
=item print ( ARGS... )
|
||||
|
||||
Print ARGS to the file.
|
||||
|
||||
=item read ( BUF, NBYTES, [OFFSET] )
|
||||
|
||||
Read some bytes from the file.
|
||||
Returns the number of bytes actually read, 0 on end-of-file, undef on error.
|
||||
|
||||
=item eof
|
||||
|
||||
Returns true if the handle is currently positioned at end of file?
|
||||
|
||||
=item seek ( OFFSET, WHENCE )
|
||||
|
||||
Seek to a given position in the stream.
|
||||
Not yet supported.
|
||||
|
||||
=item tell
|
||||
|
||||
Return the current position in the stream, as a numeric offset.
|
||||
Not yet supported.
|
||||
|
||||
=item setpos ( POS )
|
||||
|
||||
Set the current position, using the opaque value returned by C<getpos()>.
|
||||
Not yet supported.
|
||||
|
||||
=item getpos ( POS )
|
||||
|
||||
Return the current position in the string, as an opaque object.
|
||||
Not yet supported.
|
||||
|
||||
=back
|
||||
|
||||
=head1 USING THE EXTERNAL GZIP
|
||||
|
||||
If the external F<gzip> is used, the following C<open>s are used:
|
||||
|
||||
open(FH, "gzip -dc $filename |") # for read opens
|
||||
open(FH, " | gzip > $filename") # for write opens
|
||||
|
||||
You can modify the 'commands' for example to hardwire
|
||||
an absolute path by e.g.
|
||||
|
||||
use IO::Zlib ':gzip_read_open' => '/some/where/gunzip -c %s |';
|
||||
use IO::Zlib ':gzip_write_open' => '| /some/where/gzip.exe > %s';
|
||||
|
||||
The C<%s> is expanded to be the filename (C<sprintf> is used, so be
|
||||
careful to escape any other C<%> signs). The 'commands' are checked
|
||||
for sanity - they must contain the C<%s>, and the read open must end
|
||||
with the pipe sign, and the write open must begin with the pipe sign.
|
||||
|
||||
=head1 CLASS METHODS
|
||||
|
||||
=over 4
|
||||
|
||||
=item has_Compress_Zlib
|
||||
|
||||
Returns true if C<Compress::Zlib> is available. Note that this does
|
||||
not mean that C<Compress::Zlib> is being used: see L</gzip_external>
|
||||
and L<gzip_used>.
|
||||
|
||||
=item gzip_external
|
||||
|
||||
Undef if an external F<gzip> B<can> be used if C<Compress::Zlib> is
|
||||
not available (see L</has_Compress_Zlib>), true if an external F<gzip>
|
||||
is explicitly used, false if an external F<gzip> must not be used.
|
||||
See L</gzip_used>.
|
||||
|
||||
=item gzip_used
|
||||
|
||||
True if an external F<gzip> is being used, false if not.
|
||||
|
||||
=item gzip_read_open
|
||||
|
||||
Return the 'command' being used for opening a file for reading using an
|
||||
external F<gzip>.
|
||||
|
||||
=item gzip_write_open
|
||||
|
||||
Return the 'command' being used for opening a file for writing using an
|
||||
external F<gzip>.
|
||||
|
||||
=back
|
||||
|
||||
=head1 DIAGNOSTICS
|
||||
|
||||
=over 4
|
||||
|
||||
=item IO::Zlib::getlines: must be called in list context
|
||||
|
||||
If you want read lines, you must read in list context.
|
||||
|
||||
=item IO::Zlib::gzopen_external: mode '...' is illegal
|
||||
|
||||
Use only modes 'rb' or 'wb' or /wb[1-9]/.
|
||||
|
||||
=item IO::Zlib::import: '...' is illegal
|
||||
|
||||
The known import symbols are the C<:gzip_external>, C<:gzip_read_open>,
|
||||
and C<:gzip_write_open>. Anything else is not recognized.
|
||||
|
||||
=item IO::Zlib::import: ':gzip_external' requires an argument
|
||||
|
||||
The C<:gzip_external> requires one boolean argument.
|
||||
|
||||
=item IO::Zlib::import: 'gzip_read_open' requires an argument
|
||||
|
||||
The C<:gzip_external> requires one string argument.
|
||||
|
||||
=item IO::Zlib::import: 'gzip_read' '...' is illegal
|
||||
|
||||
The C<:gzip_read_open> argument must end with the pipe sign (|)
|
||||
and have the C<%s> for the filename. See L</"USING THE EXTERNAL GZIP">.
|
||||
|
||||
=item IO::Zlib::import: 'gzip_write_open' requires an argument
|
||||
|
||||
The C<:gzip_external> requires one string argument.
|
||||
|
||||
=item IO::Zlib::import: 'gzip_write_open' '...' is illegal
|
||||
|
||||
The C<:gzip_write_open> argument must begin with the pipe sign (|)
|
||||
and have the C<%s> for the filename. An output redirect (>) is also
|
||||
often a good idea, depending on your operating system shell syntax.
|
||||
See L</"USING THE EXTERNAL GZIP">.
|
||||
|
||||
=item IO::Zlib::import: no Compress::Zlib and no external gzip
|
||||
|
||||
Given that we failed to load C<Compress::Zlib> and that the use of
|
||||
an external F<gzip> was disabled, IO::Zlib has not much chance of working.
|
||||
|
||||
=item IO::Zlib::open: needs a filename
|
||||
|
||||
No filename, no open.
|
||||
|
||||
=item IO::Zlib::READ: NBYTES must be specified
|
||||
|
||||
We must know how much to read.
|
||||
|
||||
=item IO::Zlib::WRITE: too long LENGTH
|
||||
|
||||
The LENGTH must be less than or equal to the buffer size.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<perlfunc>,
|
||||
L<perlop/"I/O Operators">,
|
||||
L<IO::Handle>,
|
||||
L<Compress::Zlib>
|
||||
|
||||
=head1 HISTORY
|
||||
|
||||
Created by Tom Hughes E<lt>F<tom@compton.nu>E<gt>.
|
||||
|
||||
Support for external gzip added by Jarkko Hietaniemi E<lt>F<jhi@iki.fi>E<gt>.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 1998-2004 Tom Hughes E<lt>F<tom@compton.nu>E<gt>.
|
||||
All rights reserved. This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
require 5.006;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Carp;
|
||||
use Fcntl qw(SEEK_SET);
|
||||
use Symbol;
|
||||
use Tie::Handle;
|
||||
|
||||
our $VERSION = "1.14";
|
||||
our $AUTOLOAD;
|
||||
our @ISA = qw(Tie::Handle);
|
||||
|
||||
my $has_Compress_Zlib;
|
||||
my $gzip_external;
|
||||
my $gzip_used;
|
||||
my $gzip_read_open = "gzip -dc %s |";
|
||||
my $gzip_write_open = "| gzip > %s";
|
||||
my $aliased;
|
||||
|
||||
BEGIN {
|
||||
eval { require Compress::Zlib };
|
||||
$has_Compress_Zlib = $@ || $Compress::Zlib::VERSION < 2.000 ? 0 : 1;
|
||||
}
|
||||
|
||||
sub has_Compress_Zlib
|
||||
{
|
||||
$has_Compress_Zlib;
|
||||
}
|
||||
|
||||
sub gzip_external
|
||||
{
|
||||
$gzip_external;
|
||||
}
|
||||
|
||||
sub gzip_used
|
||||
{
|
||||
$gzip_used;
|
||||
}
|
||||
|
||||
sub gzip_read_open
|
||||
{
|
||||
$gzip_read_open;
|
||||
}
|
||||
|
||||
sub gzip_write_open
|
||||
{
|
||||
$gzip_write_open;
|
||||
}
|
||||
|
||||
sub can_gunzip
|
||||
{
|
||||
$has_Compress_Zlib || $gzip_external;
|
||||
}
|
||||
|
||||
sub _import
|
||||
{
|
||||
my $import = shift;
|
||||
|
||||
while (@_)
|
||||
{
|
||||
if ($_[0] eq ':gzip_external')
|
||||
{
|
||||
shift;
|
||||
|
||||
if (@_)
|
||||
{
|
||||
$gzip_external = shift;
|
||||
}
|
||||
else
|
||||
{
|
||||
croak "$import: ':gzip_external' requires an argument";
|
||||
}
|
||||
}
|
||||
elsif ($_[0] eq ':gzip_read_open')
|
||||
{
|
||||
shift;
|
||||
|
||||
if (@_)
|
||||
{
|
||||
$gzip_read_open = shift;
|
||||
|
||||
croak "$import: ':gzip_read_open' '$gzip_read_open' is illegal"
|
||||
unless $gzip_read_open =~ /^.+%s.+\|\s*$/;
|
||||
}
|
||||
else
|
||||
{
|
||||
croak "$import: ':gzip_read_open' requires an argument";
|
||||
}
|
||||
}
|
||||
elsif ($_[0] eq ':gzip_write_open')
|
||||
{
|
||||
shift;
|
||||
|
||||
if (@_)
|
||||
{
|
||||
$gzip_write_open = shift;
|
||||
|
||||
croak "$import: ':gzip_write_open' '$gzip_read_open' is illegal"
|
||||
unless $gzip_write_open =~ /^\s*\|.+%s.*$/;
|
||||
}
|
||||
else
|
||||
{
|
||||
croak "$import: ':gzip_write_open' requires an argument";
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
return @_;
|
||||
}
|
||||
|
||||
sub _alias
|
||||
{
|
||||
my $import = shift;
|
||||
|
||||
if ($gzip_external || (!$has_Compress_Zlib && !defined($gzip_external)))
|
||||
{
|
||||
require IO::Handle;
|
||||
|
||||
undef *gzopen;
|
||||
*gzopen = \&gzopen_external;
|
||||
|
||||
*IO::Handle::gzread = \&gzread_external;
|
||||
*IO::Handle::gzwrite = \&gzwrite_external;
|
||||
*IO::Handle::gzreadline = \&gzreadline_external;
|
||||
*IO::Handle::gzeof = \&gzeof_external;
|
||||
*IO::Handle::gzclose = \&gzclose_external;
|
||||
|
||||
$gzip_used = 1;
|
||||
}
|
||||
elsif ($has_Compress_Zlib)
|
||||
{
|
||||
*gzopen = \&Compress::Zlib::gzopen;
|
||||
*gzread = \&Compress::Zlib::gzread;
|
||||
*gzwrite = \&Compress::Zlib::gzwrite;
|
||||
*gzreadline = \&Compress::Zlib::gzreadline;
|
||||
*gzeof = \&Compress::Zlib::gzeof;
|
||||
}
|
||||
else
|
||||
{
|
||||
croak "$import: no Compress::Zlib and no external gzip";
|
||||
}
|
||||
|
||||
$aliased = 1;
|
||||
}
|
||||
|
||||
sub import
|
||||
{
|
||||
my $class = shift;
|
||||
my $import = "IO::Zlib::import";
|
||||
|
||||
if (@_)
|
||||
{
|
||||
if (_import($import, @_))
|
||||
{
|
||||
croak "$import: '@_' is illegal";
|
||||
}
|
||||
}
|
||||
|
||||
_alias($import);
|
||||
}
|
||||
|
||||
sub TIEHANDLE
|
||||
{
|
||||
my $class = shift;
|
||||
my @args = @_;
|
||||
|
||||
my $self = bless {}, $class;
|
||||
|
||||
return @args ? $self->OPEN(@args) : $self;
|
||||
}
|
||||
|
||||
sub DESTROY
|
||||
{
|
||||
}
|
||||
|
||||
sub OPEN
|
||||
{
|
||||
my $self = shift;
|
||||
my $filename = shift;
|
||||
my $mode = shift;
|
||||
|
||||
croak "IO::Zlib::open: needs a filename" unless defined($filename);
|
||||
|
||||
$self->{'file'} = gzopen($filename,$mode);
|
||||
|
||||
return defined($self->{'file'}) ? $self : undef;
|
||||
}
|
||||
|
||||
sub CLOSE
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
return undef unless defined($self->{'file'});
|
||||
|
||||
my $status = $self->{'file'}->gzclose();
|
||||
|
||||
delete $self->{'file'};
|
||||
|
||||
return ($status == 0) ? 1 : undef;
|
||||
}
|
||||
|
||||
sub READ
|
||||
{
|
||||
my $self = shift;
|
||||
my $bufref = \$_[0];
|
||||
my $nbytes = $_[1];
|
||||
my $offset = $_[2] || 0;
|
||||
|
||||
croak "IO::Zlib::READ: NBYTES must be specified" unless defined($nbytes);
|
||||
|
||||
$$bufref = "" unless defined($$bufref);
|
||||
|
||||
my $bytesread = $self->{'file'}->gzread(substr($$bufref,$offset),$nbytes);
|
||||
|
||||
return undef if $bytesread < 0;
|
||||
|
||||
return $bytesread;
|
||||
}
|
||||
|
||||
sub READLINE
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
my $line;
|
||||
|
||||
return () if $self->{'file'}->gzreadline($line) <= 0;
|
||||
|
||||
return $line unless wantarray;
|
||||
|
||||
my @lines = $line;
|
||||
|
||||
while ($self->{'file'}->gzreadline($line) > 0)
|
||||
{
|
||||
push @lines, $line;
|
||||
}
|
||||
|
||||
return @lines;
|
||||
}
|
||||
|
||||
sub WRITE
|
||||
{
|
||||
my $self = shift;
|
||||
my $buf = shift;
|
||||
my $length = shift;
|
||||
my $offset = shift;
|
||||
|
||||
croak "IO::Zlib::WRITE: too long LENGTH" unless $offset + $length <= length($buf);
|
||||
|
||||
return $self->{'file'}->gzwrite(substr($buf,$offset,$length));
|
||||
}
|
||||
|
||||
sub EOF
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
return $self->{'file'}->gzeof();
|
||||
}
|
||||
|
||||
sub FILENO
|
||||
{
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub new
|
||||
{
|
||||
my $class = shift;
|
||||
my @args = @_;
|
||||
|
||||
_alias("new", @_) unless $aliased; # Some call new IO::Zlib directly...
|
||||
|
||||
my $self = gensym();
|
||||
|
||||
tie *{$self}, $class, @args;
|
||||
|
||||
return tied(${$self}) ? bless $self, $class : undef;
|
||||
}
|
||||
|
||||
sub getline
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
return scalar tied(*{$self})->READLINE();
|
||||
}
|
||||
|
||||
sub getlines
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
croak "IO::Zlib::getlines: must be called in list context"
|
||||
unless wantarray;
|
||||
|
||||
return tied(*{$self})->READLINE();
|
||||
}
|
||||
|
||||
sub opened
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
return defined tied(*{$self})->{'file'};
|
||||
}
|
||||
|
||||
sub AUTOLOAD
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
$AUTOLOAD =~ s/.*:://;
|
||||
$AUTOLOAD =~ tr/a-z/A-Z/;
|
||||
|
||||
return tied(*{$self})->$AUTOLOAD(@_);
|
||||
}
|
||||
|
||||
sub gzopen_external
|
||||
{
|
||||
my $filename = shift;
|
||||
my $mode = shift;
|
||||
my $fh = IO::Handle->new();
|
||||
|
||||
if ($mode =~ /r/)
|
||||
{
|
||||
# Because someone will try to read ungzipped files
|
||||
# with this we peek and verify the signature. Yes,
|
||||
# this means that we open the file twice (if it is
|
||||
# gzipped).
|
||||
# Plenty of race conditions exist in this code, but
|
||||
# the alternative would be to capture the stderr of
|
||||
# gzip and parse it, which would be a portability nightmare.
|
||||
if (-e $filename && open($fh, $filename))
|
||||
{
|
||||
binmode $fh;
|
||||
|
||||
my $sig;
|
||||
my $rdb = read($fh, $sig, 2);
|
||||
|
||||
if ($rdb == 2 && $sig eq "\x1F\x8B")
|
||||
{
|
||||
my $ropen = sprintf($gzip_read_open, $filename);
|
||||
|
||||
if (open($fh, $ropen))
|
||||
{
|
||||
binmode $fh;
|
||||
|
||||
return $fh;
|
||||
}
|
||||
else
|
||||
{
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
seek($fh, 0, SEEK_SET) or
|
||||
die "IO::Zlib: open('$filename', 'r'): seek: $!";
|
||||
|
||||
return $fh;
|
||||
}
|
||||
else
|
||||
{
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
elsif ($mode =~ /w/)
|
||||
{
|
||||
my $level = $mode =~ /([1-9])/ ? "-$1" : "";
|
||||
|
||||
# To maximize portability we would need to open
|
||||
# two filehandles here, one for "| gzip $level"
|
||||
# and another for "> $filename", and then when
|
||||
# writing copy bytes from the first to the second.
|
||||
# We are using IO::Handle objects for now, however,
|
||||
# and they can only contain one stream at a time.
|
||||
my $wopen = sprintf($gzip_write_open, $filename);
|
||||
|
||||
if (open($fh, $wopen))
|
||||
{
|
||||
$fh->autoflush(1);
|
||||
binmode $fh;
|
||||
|
||||
return $fh;
|
||||
}
|
||||
else
|
||||
{
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
croak "IO::Zlib::gzopen_external: mode '$mode' is illegal";
|
||||
}
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub gzread_external
|
||||
{
|
||||
my $file = shift;
|
||||
my $bufref = \$_[0];
|
||||
my $nbytes = $_[1] || 4096;
|
||||
|
||||
# Use read() instead of sysread() because people may
|
||||
# mix reads and readlines, and we don't want to mess
|
||||
# the stdio buffering. See also gzreadline_external()
|
||||
# and gzwrite_external().
|
||||
my $nread = read($file, $$bufref, $nbytes);
|
||||
|
||||
return defined $nread ? $nread : -1;
|
||||
}
|
||||
|
||||
sub gzwrite_external
|
||||
{
|
||||
my $file = shift;
|
||||
my $buf = shift;
|
||||
|
||||
# Using syswrite() is okay (cf. gzread_external())
|
||||
# since the bytes leave this process and buffering
|
||||
# is therefore not an issue.
|
||||
my $nwrote = syswrite($file, $buf);
|
||||
|
||||
return defined $nwrote ? $nwrote : -1;
|
||||
}
|
||||
|
||||
sub gzreadline_external
|
||||
{
|
||||
my $file = shift;
|
||||
my $bufref = \$_[0];
|
||||
|
||||
# See the comment in gzread_external().
|
||||
$$bufref = readline($file);
|
||||
|
||||
return defined $$bufref ? length($$bufref) : -1;
|
||||
}
|
||||
|
||||
sub gzeof_external
|
||||
{
|
||||
my $file = shift;
|
||||
|
||||
return eof($file);
|
||||
}
|
||||
|
||||
sub gzclose_external
|
||||
{
|
||||
my $file = shift;
|
||||
|
||||
close($file);
|
||||
|
||||
# I am not entirely certain why this is needed but it seems
|
||||
# the above close() always fails (as if the stream would have
|
||||
# been already closed - something to do with using external
|
||||
# processes via pipes?)
|
||||
return 0;
|
||||
}
|
||||
|
||||
1;
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,122 @@
|
||||
package IPC::Open2;
|
||||
|
||||
use strict;
|
||||
|
||||
require 5.006;
|
||||
use Exporter 'import';
|
||||
|
||||
our $VERSION = 1.06;
|
||||
our @EXPORT = qw(open2);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
IPC::Open2 - open a process for both reading and writing using open2()
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use IPC::Open2;
|
||||
|
||||
my $pid = open2(my $chld_out, my $chld_in,
|
||||
'some', 'cmd', 'and', 'args');
|
||||
# or passing the command through the shell
|
||||
my $pid = open2(my $chld_out, my $chld_in, 'some cmd and args');
|
||||
|
||||
# read from parent STDIN and write to already open handle
|
||||
open my $outfile, '>', 'outfile.txt' or die "open failed: $!";
|
||||
my $pid = open2($outfile, '<&STDIN', 'some', 'cmd', 'and', 'args');
|
||||
|
||||
# read from already open handle and write to parent STDOUT
|
||||
open my $infile, '<', 'infile.txt' or die "open failed: $!";
|
||||
my $pid = open2('>&STDOUT', $infile, 'some', 'cmd', 'and', 'args');
|
||||
|
||||
# reap zombie and retrieve exit status
|
||||
waitpid( $pid, 0 );
|
||||
my $child_exit_status = $? >> 8;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The open2() function runs the given command and connects $chld_out for
|
||||
reading and $chld_in for writing. It's what you think should work
|
||||
when you try
|
||||
|
||||
my $pid = open(my $fh, "|cmd args|");
|
||||
|
||||
The $chld_in filehandle will have autoflush turned on.
|
||||
|
||||
If $chld_out is a string (that is, a bareword filehandle rather than a glob
|
||||
or a reference) and it begins with C<< >& >>, then the child will send output
|
||||
directly to that file handle. If $chld_in is a string that begins with
|
||||
C<< <& >>, then $chld_in will be closed in the parent, and the child will
|
||||
read from it directly. In both cases, there will be a L<dup(2)> instead of a
|
||||
L<pipe(2)> made.
|
||||
|
||||
If either reader or writer is the empty string or undefined, this will be
|
||||
replaced by an autogenerated filehandle. If so, you must pass a valid lvalue
|
||||
in the parameter slot so it can be overwritten in the caller, or
|
||||
an exception will be raised.
|
||||
|
||||
open2() returns the process ID of the child process. It doesn't return on
|
||||
failure: it just raises an exception matching C</^open2:/>. However,
|
||||
C<exec> failures in the child are not detected. You'll have to
|
||||
trap SIGPIPE yourself.
|
||||
|
||||
open2() does not wait for and reap the child process after it exits.
|
||||
Except for short programs where it's acceptable to let the operating system
|
||||
take care of this, you need to do this yourself. This is normally as
|
||||
simple as calling C<waitpid $pid, 0> when you're done with the process.
|
||||
Failing to do this can result in an accumulation of defunct or "zombie"
|
||||
processes. See L<perlfunc/waitpid> for more information.
|
||||
|
||||
This whole affair is quite dangerous, as you may block forever. It
|
||||
assumes it's going to talk to something like L<bc(1)>, both writing
|
||||
to it and reading from it. This is presumably safe because you
|
||||
"know" that commands like L<bc(1)> will read a line at a time and
|
||||
output a line at a time. Programs like L<sort(1)> that read their
|
||||
entire input stream first, however, are quite apt to cause deadlock.
|
||||
|
||||
The big problem with this approach is that if you don't have control
|
||||
over source code being run in the child process, you can't control
|
||||
what it does with pipe buffering. Thus you can't just open a pipe to
|
||||
C<cat -v> and continually read and write a line from it.
|
||||
|
||||
The L<IO::Pty> and L<Expect> modules from CPAN can help with this, as
|
||||
they provide a real tty (well, a pseudo-tty, actually), which gets you
|
||||
back to line buffering in the invoked command again.
|
||||
|
||||
=head1 WARNING
|
||||
|
||||
The order of arguments differs from that of open3().
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
See L<IPC::Open3> for an alternative that handles STDERR as well. This
|
||||
function is really just a wrapper around open3().
|
||||
|
||||
=cut
|
||||
|
||||
# &open2: tom christiansen, <tchrist@convex.com>
|
||||
#
|
||||
# usage: $pid = open2('rdr', 'wtr', 'some cmd and args');
|
||||
# or $pid = open2('rdr', 'wtr', 'some', 'cmd', 'and', 'args');
|
||||
#
|
||||
# spawn the given $cmd and connect $rdr for
|
||||
# reading and $wtr for writing. return pid
|
||||
# of child, or 0 on failure.
|
||||
#
|
||||
# WARNING: this is dangerous, as you may block forever
|
||||
# unless you are very careful.
|
||||
#
|
||||
# $wtr is left unbuffered.
|
||||
#
|
||||
# abort program if
|
||||
# rdr or wtr are null
|
||||
# a system call fails
|
||||
|
||||
require IPC::Open3;
|
||||
|
||||
sub open2 {
|
||||
local $Carp::CarpLevel = $Carp::CarpLevel + 1;
|
||||
return IPC::Open3::_open3('open2', $_[1], $_[0], '>&STDERR', @_[2 .. $#_]);
|
||||
}
|
||||
|
||||
1
|
||||
@@ -0,0 +1,442 @@
|
||||
package IPC::Open3;
|
||||
|
||||
use strict;
|
||||
no strict 'refs'; # because users pass me bareword filehandles
|
||||
|
||||
use Exporter 'import';
|
||||
|
||||
use Carp;
|
||||
use Symbol qw(gensym qualify);
|
||||
|
||||
our $VERSION = '1.22';
|
||||
our @EXPORT = qw(open3);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
IPC::Open3 - open a process for reading, writing, and error handling using open3()
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Symbol 'gensym'; # vivify a separate handle for STDERR
|
||||
my $pid = open3(my $chld_in, my $chld_out, my $chld_err = gensym,
|
||||
'some', 'cmd', 'and', 'args');
|
||||
# or pass the command through the shell
|
||||
my $pid = open3(my $chld_in, my $chld_out, my $chld_err = gensym,
|
||||
'some cmd and args');
|
||||
|
||||
# read from parent STDIN
|
||||
# send STDOUT and STDERR to already open handle
|
||||
open my $outfile, '>>', 'output.txt' or die "open failed: $!";
|
||||
my $pid = open3('<&STDIN', $outfile, undef,
|
||||
'some', 'cmd', 'and', 'args');
|
||||
|
||||
# write to parent STDOUT and STDERR
|
||||
my $pid = open3(my $chld_in, '>&STDOUT', '>&STDERR',
|
||||
'some', 'cmd', 'and', 'args');
|
||||
|
||||
# reap zombie and retrieve exit status
|
||||
waitpid( $pid, 0 );
|
||||
my $child_exit_status = $? >> 8;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Extremely similar to open2(), open3() spawns the given command and
|
||||
connects $chld_out for reading from the child, $chld_in for writing to
|
||||
the child, and $chld_err for errors. If $chld_err is false, or the
|
||||
same file descriptor as $chld_out, then STDOUT and STDERR of the child
|
||||
are on the same filehandle. This means that an autovivified lexical
|
||||
cannot be used for the STDERR filehandle, but gensym from L<Symbol> can
|
||||
be used to vivify a new glob reference, see L</SYNOPSIS>. The $chld_in
|
||||
will have autoflush turned on.
|
||||
|
||||
If $chld_in begins with C<< <& >>, then $chld_in will be closed in the
|
||||
parent, and the child will read from it directly. If $chld_out or
|
||||
$chld_err begins with C<< >& >>, then the child will send output
|
||||
directly to that filehandle. In both cases, there will be a L<dup(2)>
|
||||
instead of a L<pipe(2)> made.
|
||||
|
||||
If either reader or writer is the empty string or undefined, this will
|
||||
be replaced by an autogenerated filehandle. If so, you must pass a
|
||||
valid lvalue in the parameter slot so it can be overwritten in the
|
||||
caller, or an exception will be raised.
|
||||
|
||||
The filehandles may also be integers, in which case they are understood
|
||||
as file descriptors.
|
||||
|
||||
open3() returns the process ID of the child process. It doesn't return on
|
||||
failure: it just raises an exception matching C</^open3:/>. However,
|
||||
C<exec> failures in the child (such as no such file or permission denied),
|
||||
are just reported to $chld_err under Windows and OS/2, as it is not possible
|
||||
to trap them.
|
||||
|
||||
If the child process dies for any reason, the next write to $chld_in is
|
||||
likely to generate a SIGPIPE in the parent, which is fatal by default.
|
||||
So you may wish to handle this signal.
|
||||
|
||||
Note if you specify C<-> as the command, in an analogous fashion to
|
||||
C<open(my $fh, "-|")> the child process will just be the forked Perl
|
||||
process rather than an external command. This feature isn't yet
|
||||
supported on Win32 platforms.
|
||||
|
||||
open3() does not wait for and reap the child process after it exits.
|
||||
Except for short programs where it's acceptable to let the operating system
|
||||
take care of this, you need to do this yourself. This is normally as
|
||||
simple as calling C<waitpid $pid, 0> when you're done with the process.
|
||||
Failing to do this can result in an accumulation of defunct or "zombie"
|
||||
processes. See L<perlfunc/waitpid> for more information.
|
||||
|
||||
If you try to read from the child's stdout writer and their stderr
|
||||
writer, you'll have problems with blocking, which means you'll want
|
||||
to use select() or L<IO::Select>, which means you'd best use
|
||||
sysread() instead of readline() for normal stuff.
|
||||
|
||||
This is very dangerous, as you may block forever. It assumes it's
|
||||
going to talk to something like L<bc(1)>, both writing to it and reading
|
||||
from it. This is presumably safe because you "know" that commands
|
||||
like L<bc(1)> will read a line at a time and output a line at a time.
|
||||
Programs like L<sort(1)> that read their entire input stream first,
|
||||
however, are quite apt to cause deadlock.
|
||||
|
||||
The big problem with this approach is that if you don't have control
|
||||
over source code being run in the child process, you can't control
|
||||
what it does with pipe buffering. Thus you can't just open a pipe to
|
||||
C<cat -v> and continually read and write a line from it.
|
||||
|
||||
=head1 See Also
|
||||
|
||||
=over 4
|
||||
|
||||
=item L<IPC::Open2>
|
||||
|
||||
Like Open3 but without STDERR capture.
|
||||
|
||||
=item L<IPC::Run>
|
||||
|
||||
This is a CPAN module that has better error handling and more facilities
|
||||
than Open3.
|
||||
|
||||
=back
|
||||
|
||||
=head1 WARNING
|
||||
|
||||
The order of arguments differs from that of open2().
|
||||
|
||||
=cut
|
||||
|
||||
# &open3: Marc Horowitz <marc@mit.edu>
|
||||
# derived mostly from &open2 by tom christiansen, <tchrist@convex.com>
|
||||
# fixed for 5.001 by Ulrich Kunitz <kunitz@mai-koeln.com>
|
||||
# ported to Win32 by Ron Schmidt, Merrill Lynch almost ended my career
|
||||
# fixed for autovivving FHs, tchrist again
|
||||
# allow fd numbers to be used, by Frank Tobin
|
||||
# allow '-' as command (c.f. open "-|"), by Adam Spiers <perl@adamspiers.org>
|
||||
#
|
||||
# usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...);
|
||||
#
|
||||
# spawn the given $cmd and connect rdr for
|
||||
# reading, wtr for writing, and err for errors.
|
||||
# if err is '', or the same as rdr, then stdout and
|
||||
# stderr of the child are on the same fh. returns pid
|
||||
# of child (or dies on failure).
|
||||
|
||||
|
||||
# if wtr begins with '<&', then wtr will be closed in the parent, and
|
||||
# the child will read from it directly. if rdr or err begins with
|
||||
# '>&', then the child will send output directly to that fd. In both
|
||||
# cases, there will be a dup() instead of a pipe() made.
|
||||
|
||||
|
||||
# WARNING: this is dangerous, as you may block forever
|
||||
# unless you are very careful.
|
||||
#
|
||||
# $wtr is left unbuffered.
|
||||
#
|
||||
# abort program if
|
||||
# rdr or wtr are null
|
||||
# a system call fails
|
||||
|
||||
our $Me = 'open3 (bug)'; # you should never see this, it's always localized
|
||||
|
||||
# Fatal.pm needs to be fixed WRT prototypes.
|
||||
|
||||
sub xpipe {
|
||||
pipe $_[0], $_[1] or croak "$Me: pipe($_[0], $_[1]) failed: $!";
|
||||
}
|
||||
|
||||
# I tried using a * prototype character for the filehandle but it still
|
||||
# disallows a bareword while compiling under strict subs.
|
||||
|
||||
sub xopen {
|
||||
open $_[0], $_[1], @_[2..$#_] and return;
|
||||
local $" = ', ';
|
||||
carp "$Me: open(@_) failed: $!";
|
||||
}
|
||||
|
||||
sub xclose {
|
||||
$_[0] =~ /\A=?(\d+)\z/
|
||||
? do { my $fh; open($fh, $_[1] . '&=' . $1) and close($fh); }
|
||||
: close $_[0]
|
||||
or croak "$Me: close($_[0]) failed: $!";
|
||||
}
|
||||
|
||||
sub xfileno {
|
||||
return $1 if $_[0] =~ /\A=?(\d+)\z/; # deal with fh just being an fd
|
||||
return fileno $_[0];
|
||||
}
|
||||
|
||||
use constant FORCE_DEBUG_SPAWN => 0;
|
||||
use constant DO_SPAWN => $^O eq 'os2' || $^O eq 'MSWin32' || FORCE_DEBUG_SPAWN;
|
||||
|
||||
sub _open3 {
|
||||
local $Me = shift;
|
||||
|
||||
# simulate autovivification of filehandles because
|
||||
# it's too ugly to use @_ throughout to make perl do it for us
|
||||
# tchrist 5-Mar-00
|
||||
|
||||
# Historically, open3(undef...) has silently worked, so keep
|
||||
# it working.
|
||||
splice @_, 0, 1, undef if \$_[0] == \undef;
|
||||
splice @_, 1, 1, undef if \$_[1] == \undef;
|
||||
unless (eval {
|
||||
$_[0] = gensym unless defined $_[0] && length $_[0];
|
||||
$_[1] = gensym unless defined $_[1] && length $_[1];
|
||||
1; })
|
||||
{
|
||||
# must strip crud for croak to add back, or looks ugly
|
||||
$@ =~ s/(?<=value attempted) at .*//s;
|
||||
croak "$Me: $@";
|
||||
}
|
||||
|
||||
my @handles = ({ mode => '<', handle => \*STDIN },
|
||||
{ mode => '>', handle => \*STDOUT },
|
||||
{ mode => '>', handle => \*STDERR },
|
||||
);
|
||||
|
||||
foreach (@handles) {
|
||||
$_->{parent} = shift;
|
||||
$_->{open_as} = gensym;
|
||||
}
|
||||
|
||||
if (@_ > 1 and $_[0] eq '-') {
|
||||
croak "Arguments don't make sense when the command is '-'"
|
||||
}
|
||||
|
||||
$handles[2]{parent} ||= $handles[1]{parent};
|
||||
$handles[2]{dup_of_out} = $handles[1]{parent} eq $handles[2]{parent};
|
||||
|
||||
my $package;
|
||||
foreach (@handles) {
|
||||
$_->{dup} = ($_->{parent} =~ s/^[<>]&//);
|
||||
|
||||
if ($_->{parent} !~ /\A=?(\d+)\z/) {
|
||||
# force unqualified filehandles into caller's package
|
||||
$package //= caller 1;
|
||||
$_->{parent} = qualify $_->{parent}, $package;
|
||||
}
|
||||
|
||||
next if $_->{dup} or $_->{dup_of_out};
|
||||
if ($_->{mode} eq '<') {
|
||||
xpipe $_->{open_as}, $_->{parent};
|
||||
} else {
|
||||
xpipe $_->{parent}, $_->{open_as};
|
||||
}
|
||||
}
|
||||
|
||||
my $kidpid;
|
||||
if (!DO_SPAWN) {
|
||||
# Used to communicate exec failures.
|
||||
xpipe my $stat_r, my $stat_w;
|
||||
|
||||
$kidpid = fork;
|
||||
croak "$Me: fork failed: $!" unless defined $kidpid;
|
||||
if ($kidpid == 0) { # Kid
|
||||
eval {
|
||||
# A tie in the parent should not be allowed to cause problems.
|
||||
untie *STDIN;
|
||||
untie *STDOUT;
|
||||
untie *STDERR;
|
||||
|
||||
close $stat_r;
|
||||
require Fcntl;
|
||||
my $flags = fcntl $stat_w, &Fcntl::F_GETFD, 0;
|
||||
croak "$Me: fcntl failed: $!" unless $flags;
|
||||
fcntl $stat_w, &Fcntl::F_SETFD, $flags|&Fcntl::FD_CLOEXEC
|
||||
or croak "$Me: fcntl failed: $!";
|
||||
|
||||
# If she wants to dup the kid's stderr onto her stdout I need to
|
||||
# save a copy of her stdout before I put something else there.
|
||||
if (!$handles[2]{dup_of_out} && $handles[2]{dup}
|
||||
&& xfileno($handles[2]{parent}) == fileno \*STDOUT) {
|
||||
my $tmp = gensym;
|
||||
xopen($tmp, '>&', $handles[2]{parent});
|
||||
$handles[2]{parent} = $tmp;
|
||||
}
|
||||
|
||||
foreach (@handles) {
|
||||
if ($_->{dup_of_out}) {
|
||||
xopen \*STDERR, ">&STDOUT"
|
||||
if defined fileno STDERR && fileno STDERR != fileno STDOUT;
|
||||
} elsif ($_->{dup}) {
|
||||
xopen $_->{handle}, $_->{mode} . '&', $_->{parent}
|
||||
if fileno $_->{handle} != xfileno($_->{parent});
|
||||
} else {
|
||||
xclose $_->{parent}, $_->{mode};
|
||||
xopen $_->{handle}, $_->{mode} . '&=',
|
||||
fileno $_->{open_as};
|
||||
}
|
||||
}
|
||||
return 1 if ($_[0] eq '-');
|
||||
exec @_ or do {
|
||||
local($")=(" ");
|
||||
croak "$Me: exec of @_ failed: $!";
|
||||
};
|
||||
} and do {
|
||||
close $stat_w;
|
||||
return 0;
|
||||
};
|
||||
|
||||
my $bang = 0+$!;
|
||||
my $err = $@;
|
||||
utf8::encode $err if $] >= 5.008;
|
||||
print $stat_w pack('IIa*', $bang, length($err), $err);
|
||||
close $stat_w;
|
||||
|
||||
eval { require POSIX; POSIX::_exit(255); };
|
||||
exit 255;
|
||||
}
|
||||
else { # Parent
|
||||
close $stat_w;
|
||||
my $to_read = length(pack('I', 0)) * 2;
|
||||
my $bytes_read = read($stat_r, my $buf = '', $to_read);
|
||||
if ($bytes_read) {
|
||||
(my $bang, $to_read) = unpack('II', $buf);
|
||||
read($stat_r, my $err = '', $to_read);
|
||||
waitpid $kidpid, 0; # Reap child which should have exited
|
||||
if ($err) {
|
||||
utf8::decode $err if $] >= 5.008;
|
||||
} else {
|
||||
$err = "$Me: " . ($! = $bang);
|
||||
}
|
||||
$! = $bang;
|
||||
die($err);
|
||||
}
|
||||
}
|
||||
}
|
||||
else { # DO_SPAWN
|
||||
# All the bookkeeping of coincidence between handles is
|
||||
# handled in spawn_with_handles.
|
||||
|
||||
my @close;
|
||||
|
||||
foreach (@handles) {
|
||||
if ($_->{dup_of_out}) {
|
||||
$_->{open_as} = $handles[1]{open_as};
|
||||
} elsif ($_->{dup}) {
|
||||
$_->{open_as} = $_->{parent} =~ /\A[0-9]+\z/
|
||||
? $_->{parent} : \*{$_->{parent}};
|
||||
push @close, $_->{open_as};
|
||||
} else {
|
||||
push @close, \*{$_->{parent}}, $_->{open_as};
|
||||
}
|
||||
}
|
||||
require IO::Pipe;
|
||||
$kidpid = eval {
|
||||
spawn_with_handles(\@handles, \@close, @_);
|
||||
};
|
||||
die "$Me: $@" if $@;
|
||||
}
|
||||
|
||||
foreach (@handles) {
|
||||
next if $_->{dup} or $_->{dup_of_out};
|
||||
xclose $_->{open_as}, $_->{mode};
|
||||
}
|
||||
|
||||
# If the write handle is a dup give it away entirely, close my copy
|
||||
# of it.
|
||||
xclose $handles[0]{parent}, $handles[0]{mode} if $handles[0]{dup};
|
||||
|
||||
select((select($handles[0]{parent}), $| = 1)[0]); # unbuffer pipe
|
||||
$kidpid;
|
||||
}
|
||||
|
||||
sub open3 {
|
||||
if (@_ < 4) {
|
||||
local $" = ', ';
|
||||
croak "open3(@_): not enough arguments";
|
||||
}
|
||||
return _open3 'open3', @_
|
||||
}
|
||||
|
||||
sub spawn_with_handles {
|
||||
my $fds = shift; # Fields: handle, mode, open_as
|
||||
my $close_in_child = shift;
|
||||
my ($fd, %saved, @errs);
|
||||
|
||||
foreach $fd (@$fds) {
|
||||
$fd->{tmp_copy} = IO::Handle->new_from_fd($fd->{handle}, $fd->{mode});
|
||||
$saved{fileno $fd->{handle}} = $fd->{tmp_copy} if $fd->{tmp_copy};
|
||||
}
|
||||
foreach $fd (@$fds) {
|
||||
bless $fd->{handle}, 'IO::Handle'
|
||||
unless eval { $fd->{handle}->isa('IO::Handle') } ;
|
||||
# If some of handles to redirect-to coincide with handles to
|
||||
# redirect, we need to use saved variants:
|
||||
my $open_as = $fd->{open_as};
|
||||
my $fileno = fileno($open_as);
|
||||
$fd->{handle}->fdopen(defined($fileno)
|
||||
? $saved{$fileno} || $open_as
|
||||
: $open_as,
|
||||
$fd->{mode});
|
||||
}
|
||||
unless ($^O eq 'MSWin32') {
|
||||
require Fcntl;
|
||||
# Stderr may be redirected below, so we save the err text:
|
||||
foreach $fd (@$close_in_child) {
|
||||
next unless fileno $fd;
|
||||
fcntl($fd, Fcntl::F_SETFD(), 1) or push @errs, "fcntl $fd: $!"
|
||||
unless $saved{fileno $fd}; # Do not close what we redirect!
|
||||
}
|
||||
}
|
||||
|
||||
my $pid;
|
||||
unless (@errs) {
|
||||
if (FORCE_DEBUG_SPAWN) {
|
||||
pipe my $r, my $w or die "Pipe failed: $!";
|
||||
$pid = fork;
|
||||
die "Fork failed: $!" unless defined $pid;
|
||||
if (!$pid) {
|
||||
{ no warnings; exec @_ }
|
||||
print $w 0 + $!;
|
||||
close $w;
|
||||
require POSIX;
|
||||
POSIX::_exit(255);
|
||||
}
|
||||
close $w;
|
||||
my $bad = <$r>;
|
||||
if (defined $bad) {
|
||||
$! = $bad;
|
||||
undef $pid;
|
||||
}
|
||||
} else {
|
||||
$pid = eval { system 1, @_ }; # 1 == P_NOWAIT
|
||||
}
|
||||
if($@) {
|
||||
push @errs, "IO::Pipe: Can't spawn-NOWAIT: $@";
|
||||
} elsif(!$pid || $pid < 0) {
|
||||
push @errs, "IO::Pipe: Can't spawn-NOWAIT: $!";
|
||||
}
|
||||
}
|
||||
|
||||
# Do this in reverse, so that STDERR is restored first:
|
||||
foreach $fd (reverse @$fds) {
|
||||
$fd->{handle}->fdopen($fd->{tmp_copy}, $fd->{mode});
|
||||
}
|
||||
foreach (values %saved) {
|
||||
$_->close or croak "Can't close: $!";
|
||||
}
|
||||
croak join "\n", @errs if @errs;
|
||||
return $pid;
|
||||
}
|
||||
|
||||
1; # so require is happy
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,43 @@
|
||||
package JSON::PP::Boolean;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use overload ();
|
||||
overload::unimport('overload', qw(0+ ++ -- fallback));
|
||||
overload::import('overload',
|
||||
"0+" => sub { ${$_[0]} },
|
||||
"++" => sub { $_[0] = ${$_[0]} + 1 },
|
||||
"--" => sub { $_[0] = ${$_[0]} - 1 },
|
||||
fallback => 1,
|
||||
);
|
||||
|
||||
our $VERSION = '4.16';
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JSON::PP::Boolean - dummy module providing JSON::PP::Boolean
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# do not "use" yourself
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module exists only to provide overload resolution for Storable and similar modules. See
|
||||
L<JSON::PP> for more info about this class.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
This idea is from L<JSON::XS::Boolean> written by Marc Lehmann <schmorp[at]schmorp.de>
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
This library is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,76 @@
|
||||
# -*- mode: perl; -*-
|
||||
|
||||
package Math::BigFloat::Trace;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Exporter;
|
||||
use Math::BigFloat;
|
||||
|
||||
our @ISA = qw(Exporter Math::BigFloat);
|
||||
|
||||
our $VERSION = '0.66';
|
||||
|
||||
use overload; # inherit overload from Math::BigFloat
|
||||
|
||||
# Globals
|
||||
our $accuracy = undef;
|
||||
our $precision = undef;
|
||||
our $round_mode = 'even';
|
||||
our $div_scale = 40;
|
||||
|
||||
sub new {
|
||||
my $proto = shift;
|
||||
my $class = ref($proto) || $proto;
|
||||
|
||||
my $value = shift;
|
||||
|
||||
my $a = $accuracy;
|
||||
$a = $_[0] if defined $_[0];
|
||||
|
||||
my $p = $precision;
|
||||
$p = $_[1] if defined $_[1];
|
||||
|
||||
my $self = $class -> SUPER::new($value, $a, $p, $round_mode);
|
||||
|
||||
printf "Math::BigFloat new '%s' => '%s' (%s)\n",
|
||||
$value, $self, ref($self);
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub import {
|
||||
my $class = shift;
|
||||
|
||||
printf "%s -> import(%s)\n", $class, join(", ", @_);
|
||||
|
||||
# we catch the constants, the rest goes to parent
|
||||
|
||||
my $constant = grep { $_ eq ':constant' } @_;
|
||||
my @a = grep { $_ ne ':constant' } @_;
|
||||
|
||||
if ($constant) {
|
||||
overload::constant
|
||||
|
||||
integer => sub {
|
||||
$class -> new(shift);
|
||||
},
|
||||
|
||||
float => sub {
|
||||
$class -> new(shift);
|
||||
},
|
||||
|
||||
binary => sub {
|
||||
# E.g., a literal 0377 shall result in an object whose value
|
||||
# is decimal 255, but new("0377") returns decimal 377.
|
||||
return $class -> from_oct($_[0]) if $_[0] =~ /^0_*[0-7]/;
|
||||
$class -> new(shift);
|
||||
};
|
||||
}
|
||||
|
||||
$class -> SUPER::import(@a); # need it for subclasses
|
||||
#$self -> export_to_level(1, $class, @_); # need this ?
|
||||
}
|
||||
|
||||
1;
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user