OpenCores
URL https://opencores.org/ocsvn/an-fpga-implementation-of-low-latency-noc-based-mpsoc/an-fpga-implementation-of-low-latency-noc-based-mpsoc/trunk

Subversion Repositories an-fpga-implementation-of-low-latency-noc-based-mpsoc

Compare Revisions

  • This comparison shows the changes necessary to convert path 
    /an-fpga-implementation-of-low-latency-noc-based-mpsoc/trunk/mpsoc/Integration_test/synthetic_sim
    from Rev 55 to Rev 56
    ↔ Reverse comparison
  •

Rev 55 → Rev 56

/failed-model/line2_2cycle_mcast_f
0,0 → 1,12
$model = bless( {
'noc_param'=> {
TOPOLOGY=>"\"LINE\"",
"T1" => "4",
"T2" => "4",
"CAST_TYPE" => "\"MULTICAST_FULL\"",
"Fpay" => "64",
"MCAST_ENDP_LIST" => "'b11",
 
}
}, 'ProNOC' );
/line/Line_3x2_v2
0,0 → 1,18
$model = bless( {
'noc_param'=> {
"TOPOLOGY" => "\"LINE\"",
"T1" => "3",
"T2" => "1",
"T3" => "4",
"V" => "2",
"B" => "4",
"LB" => "4",
"Fpay" => "32",
"ROUTE_NAME"=>"\"XY\""
}
}, 'ProNOC' );
 
 
 
/line/line2_openpiton
0,0 → 1,14
$model = bless( {
'noc_param'=> {
TOPOLOGY=>"\"LINE\"",
"T1" => "2",
"V" => "1",
"ESCAP_VC_MASK" => "1'b1",
"B" => "4",
"LB" => "16",
"Fpay" => "64",
"SSA_EN" => "\"YES\"",
"SELF_LOOP_EN" => "\"YES\"",
"MCAST_ENDP_LIST" => "'b11",
}
}, 'ProNOC' );
/line/line4_smart3
0,0 → 1,16
$model = bless( {
'noc_param'=> {
"SMART_MAX" => "3",
TOPOLOGY=>"\"LINE\"",
"T1" => "4",
"T2" => "4",
"V" => "1",
"ESCAP_VC_MASK" => "1'b1",
"B" => "4",
"LB" => "16",
"Fpay" => "64",
"SSA_EN" => "\"NO\"",
"SELF_LOOP_EN" => "\"YES\"",
"MCAST_ENDP_LIST" => "'b11",
}
}, 'ProNOC' );
/line/line_4_v1_B15
0,0 → 1,21
$model = bless( {
'noc_param'=> {
TOPOLOGY=>"\"LINE\"",
"T1" => "4",
"T2" => "4",
"V" => "1",
"ESCAP_VC_MASK" => "1'b1",
"B" => "15",
"LB" => "15",
"Fpay" => "64",
"SSA_EN" => "\"NO\"",
"SELF_LOOP_EN" => "\"NO\"",
}
}, 'ProNOC' );
 
 
 
 
 
 
 
/line/line_4x3_2cycle_xy
0,0 → 1,10
$model = bless( {
'compile' => "verilate_mesh.sh",
'noc_param'=> {
TOPOLOGY=>"\"LINE\"",
"T1" => "4",
"T2" => "4",
"T3" => "3",
"ROUTE_NAME" => "\"XY\"",
}
}, 'ProNOC' );
/line/line_8_2cycle_xy
0,0 → 1,6
$model = bless( {
'noc_param'=> {
TOPOLOGY=>"\"LINE\"",
"ROUTE_NAME" => "\"XY\"",
}
}, 'ProNOC' );
/line/line_8_b2
0,0 → 1,8
$model = bless( {
'noc_param'=> {
TOPOLOGY=>"\"LINE\"",
"ROUTE_NAME" => "\"XY\"",
"B"=> "2",
"LB"=> 2
}
}, 'ProNOC' );
/line/line_8_sbp6_xy
0,0 → 1,6
$model = bless( {
'noc_param'=> {
TOPOLOGY=>"\"LINE\"",
"SMART_MAX" => "6",
}
}, 'ProNOC' );
/line/line_8_single_flit
0,0 → 1,10
$model = bless( {
'noc_param'=> {
TOPOLOGY=>"\"LINE\"",
"B" => "5",
"LB" => "5",
"MIN_PCK_SIZE" => "1",
"PCK_TYPE" => " \"SINGLE_FLIT\"",
}
}, 'ProNOC' );
/line/line_8x8_ssa_xy
0,0 → 1,6
$model = bless( {
'noc_param'=> {
TOPOLOGY=>"\"LINE\"",
"SSA_EN" => "\"YES\"",
}
}, 'ProNOC' );
/line/linex8_4vc_4c
0,0 → 1,10
$model = bless( {
'noc_param'=> {
TOPOLOGY=>"\"LINE\"",
"ROUTE_NAME" => "\"XY\"",
"V" => 4,
"C" => 4,
"CLASS_SETTING" => "16'b1000010000100001",
"ESCAP_VC_MASK" => "4'b1000"
}
}, 'ProNOC' );
/line/ring_8x8_2cycle_xy
0,0 → 1,8
$model = bless( {
'compile' => "verilate_mesh.sh",
'noc_param'=> {
TOPOLOGY=>"\"RING\"",
"TOPOLOGY" => "\"TORUS\"",
"ROUTE_NAME" => "\"TRANC_XY\"",
}
}, 'ProNOC' );
/models/mesh_4x4_smart3
0,0 → 1,15
$model = bless( {
'noc_param'=> {
"SMART_MAX" => "3",
"TOPOLOGY"=> "\"FMESH\"",
"T1" => "4",
"T2" => "4",
"V" => "1",
"ESCAP_VC_MASK" => "1'b1",
"B" => "4",
"LB" => "16",
"Fpay" => "64",
"SSA_EN" => "\"NO\"",
"SELF_LOOP_EN" => "\"YES\"",
}
}, 'ProNOC' );
/perl_lib/Class/Accessor/Fast.pm
0,0 → 1,97
package Class::Accessor::Fast;
use base 'Class::Accessor';
use strict;
use B 'perlstring';
$Class::Accessor::Fast::VERSION = '0.51';
 
sub make_accessor {
my ($class, $field) = @_;
 
eval sprintf q{
sub {
return $_[0]{%s} if scalar(@_) == 1;
return $_[0]{%s} = scalar(@_) == 2 ? $_[1] : [@_[1..$#_]];
}
}, map { perlstring($_) } $field, $field;
}
 
sub make_ro_accessor {
my($class, $field) = @_;
 
eval sprintf q{
sub {
return $_[0]{%s} if @_ == 1;
my $caller = caller;
$_[0]->_croak(sprintf "'$caller' cannot alter the value of '%%s' on objects of class '%%s'", %s, %s);
}
}, map { perlstring($_) } $field, $field, $class;
}
 
sub make_wo_accessor {
my($class, $field) = @_;
 
eval sprintf q{
sub {
if (@_ == 1) {
my $caller = caller;
$_[0]->_croak(sprintf "'$caller' cannot access the value of '%%s' on objects of class '%%s'", %s, %s);
}
else {
return $_[0]{%s} = $_[1] if @_ == 2;
return (shift)->{%s} = \@_;
}
}
}, map { perlstring($_) } $field, $class, $field, $field;
}
 
1;
 
__END__
 
=head1 NAME
 
Class::Accessor::Fast - Faster, but less expandable, accessors
 
=head1 SYNOPSIS
 
package Foo;
use base qw(Class::Accessor::Fast);
 
# The rest is the same as Class::Accessor but without set() and get().
 
=head1 DESCRIPTION
 
This is a faster but less expandable version of Class::Accessor.
Class::Accessor's generated accessors require two method calls to accomplish
their task (one for the accessor, another for get() or set()).
Class::Accessor::Fast eliminates calling set()/get() and does the access itself,
resulting in a somewhat faster accessor.
 
The downside is that you can't easily alter the behavior of your
accessors, nor can your subclasses. Of course, should you need this
later, you can always swap out Class::Accessor::Fast for
Class::Accessor.
 
Read the documentation for Class::Accessor for more info.
 
=head1 EFFICIENCY
 
L<Class::Accessor/EFFICIENCY> for an efficiency comparison.
 
=head1 AUTHORS
 
Copyright 2017 Marty Pauley <marty+perl@martian.org>
 
This program is free software; you can redistribute it and/or modify it under
the same terms as Perl itself. That means either (a) the GNU General Public
License or (b) the Artistic License.
 
=head2 ORIGINAL AUTHOR
 
Michael G Schwern <schwern@pobox.com>
 
=head1 SEE ALSO
 
L<Class::Accessor>
 
=cut
/perl_lib/Class/Accessor/Faster.pm
0,0 → 1,109
package Class::Accessor::Faster;
use base 'Class::Accessor';
use strict;
use B 'perlstring';
$Class::Accessor::Faster::VERSION = '0.51';
 
my %slot;
sub _slot {
my($class, $field) = @_;
my $n = $slot{$class}->{$field};
return $n if defined $n;
$n = keys %{$slot{$class}};
$slot{$class}->{$field} = $n;
return $n;
}
 
sub new {
my($proto, $fields) = @_;
my($class) = ref $proto || $proto;
my $self = bless [], $class;
 
$fields = {} unless defined $fields;
for my $k (keys %$fields) {
my $n = $class->_slot($k);
$self->[$n] = $fields->{$k};
}
return $self;
}
 
sub make_accessor {
my($class, $field) = @_;
my $n = $class->_slot($field);
eval sprintf q{
sub {
return $_[0][%d] if scalar(@_) == 1;
return $_[0][%d] = scalar(@_) == 2 ? $_[1] : [@_[1..$#_]];
}
}, $n, $n;
}
 
sub make_ro_accessor {
my($class, $field) = @_;
my $n = $class->_slot($field);
eval sprintf q{
sub {
return $_[0][%d] if @_ == 1;
my $caller = caller;
$_[0]->_croak(sprintf "'$caller' cannot alter the value of '%%s' on objects of class '%%s'", %s, %s);
}
}, $n, map(perlstring($_), $field, $class);
}
 
sub make_wo_accessor {
my($class, $field) = @_;
my $n = $class->_slot($field);
eval sprintf q{
sub {
if (@_ == 1) {
my $caller = caller;
$_[0]->_croak(sprintf "'$caller' cannot access the value of '%%s' on objects of class '%%s'", %s, %s);
}
else {
return $_[0][%d] = $_[1] if @_ == 2;
return (shift)->[%d] = \@_;
}
}
}, map(perlstring($_), $field, $class), $n, $n;
}
 
1;
 
__END__
 
=head1 NAME
 
Class::Accessor::Faster - Even faster, but less expandable, accessors
 
=head1 SYNOPSIS
 
package Foo;
use base qw(Class::Accessor::Faster);
 
=head1 DESCRIPTION
 
This is a faster but less expandable version of Class::Accessor::Fast.
 
Class::Accessor's generated accessors require two method calls to accomplish
their task (one for the accessor, another for get() or set()).
 
Class::Accessor::Fast eliminates calling set()/get() and does the access itself,
resulting in a somewhat faster accessor.
 
Class::Accessor::Faster uses an array reference underneath to be faster.
 
Read the documentation for Class::Accessor for more info.
 
=head1 AUTHORS
 
Copyright 2017 Marty Pauley <marty+perl@martian.org>
 
This program is free software; you can redistribute it and/or modify it under
the same terms as Perl itself. That means either (a) the GNU General Public
License or (b) the Artistic License.
 
=head1 SEE ALSO
 
L<Class::Accessor>
 
=cut
/perl_lib/Class/Accessor.pm
0,0 → 1,742
package Class::Accessor;
require 5.00502;
use strict;
$Class::Accessor::VERSION = '0.51';
 
sub new {
return bless
defined $_[1]
? {%{$_[1]}} # make a copy of $fields.
: {},
ref $_[0] || $_[0];
}
 
sub mk_accessors {
my($self, @fields) = @_;
 
$self->_mk_accessors('rw', @fields);
}
 
if (eval { require Sub::Name }) {
Sub::Name->import;
}
 
{
no strict 'refs';
 
sub import {
my ($class, @what) = @_;
my $caller = caller;
for (@what) {
if (/^(?:antlers|moose-?like)$/i) {
*{"${caller}::has"} = sub {
my ($f, %args) = @_;
$caller->_mk_accessors(($args{is}||"rw"), $f);
};
*{"${caller}::extends"} = sub {
@{"${caller}::ISA"} = @_;
unless (grep $_->can("_mk_accessors"), @_) {
push @{"${caller}::ISA"}, $class;
}
};
# we'll use their @ISA as a default, in case it happens to be
# set already
&{"${caller}::extends"}(@{"${caller}::ISA"});
}
}
}
 
sub follow_best_practice {
my($self) = @_;
my $class = ref $self || $self;
*{"${class}::accessor_name_for"} = \&best_practice_accessor_name_for;
*{"${class}::mutator_name_for"} = \&best_practice_mutator_name_for;
}
 
sub _mk_accessors {
my($self, $access, @fields) = @_;
my $class = ref $self || $self;
my $ra = $access eq 'rw' || $access eq 'ro';
my $wa = $access eq 'rw' || $access eq 'wo';
 
foreach my $field (@fields) {
my $accessor_name = $self->accessor_name_for($field);
my $mutator_name = $self->mutator_name_for($field);
if( $accessor_name eq 'DESTROY' or $mutator_name eq 'DESTROY' ) {
$self->_carp("Having a data accessor named DESTROY in '$class' is unwise.");
}
if ($accessor_name eq $mutator_name) {
my $accessor;
if ($ra && $wa) {
$accessor = $self->make_accessor($field);
} elsif ($ra) {
$accessor = $self->make_ro_accessor($field);
} else {
$accessor = $self->make_wo_accessor($field);
}
my $fullname = "${class}::$accessor_name";
my $subnamed = 0;
unless (defined &{$fullname}) {
subname($fullname, $accessor) if defined &subname;
$subnamed = 1;
*{$fullname} = $accessor;
}
if ($accessor_name eq $field) {
# the old behaviour
my $alias = "${class}::_${field}_accessor";
subname($alias, $accessor) if defined &subname and not $subnamed;
*{$alias} = $accessor unless defined &{$alias};
}
} else {
my $fullaccname = "${class}::$accessor_name";
my $fullmutname = "${class}::$mutator_name";
if ($ra and not defined &{$fullaccname}) {
my $accessor = $self->make_ro_accessor($field);
subname($fullaccname, $accessor) if defined &subname;
*{$fullaccname} = $accessor;
}
if ($wa and not defined &{$fullmutname}) {
my $mutator = $self->make_wo_accessor($field);
subname($fullmutname, $mutator) if defined &subname;
*{$fullmutname} = $mutator;
}
}
}
}
 
}
 
sub mk_ro_accessors {
my($self, @fields) = @_;
 
$self->_mk_accessors('ro', @fields);
}
 
sub mk_wo_accessors {
my($self, @fields) = @_;
 
$self->_mk_accessors('wo', @fields);
}
 
sub best_practice_accessor_name_for {
my ($class, $field) = @_;
return "get_$field";
}
 
sub best_practice_mutator_name_for {
my ($class, $field) = @_;
return "set_$field";
}
 
sub accessor_name_for {
my ($class, $field) = @_;
return $field;
}
 
sub mutator_name_for {
my ($class, $field) = @_;
return $field;
}
 
sub set {
my($self, $key) = splice(@_, 0, 2);
 
if(@_ == 1) {
$self->{$key} = $_[0];
}
elsif(@_ > 1) {
$self->{$key} = [@_];
}
else {
$self->_croak("Wrong number of arguments received");
}
}
 
sub get {
my $self = shift;
 
if(@_ == 1) {
return $self->{$_[0]};
}
elsif( @_ > 1 ) {
return @{$self}{@_};
}
else {
$self->_croak("Wrong number of arguments received");
}
}
 
sub make_accessor {
my ($class, $field) = @_;
 
return sub {
my $self = shift;
 
if(@_) {
return $self->set($field, @_);
} else {
return $self->get($field);
}
};
}
 
sub make_ro_accessor {
my($class, $field) = @_;
 
return sub {
my $self = shift;
 
if (@_) {
my $caller = caller;
$self->_croak("'$caller' cannot alter the value of '$field' on objects of class '$class'");
}
else {
return $self->get($field);
}
};
}
 
sub make_wo_accessor {
my($class, $field) = @_;
 
return sub {
my $self = shift;
 
unless (@_) {
my $caller = caller;
$self->_croak("'$caller' cannot access the value of '$field' on objects of class '$class'");
}
else {
return $self->set($field, @_);
}
};
}
 
 
use Carp ();
 
sub _carp {
my ($self, $msg) = @_;
Carp::carp($msg || $self);
return;
}
 
sub _croak {
my ($self, $msg) = @_;
Carp::croak($msg || $self);
return;
}
 
1;
 
__END__
 
=head1 NAME
 
Class::Accessor - Automated accessor generation
 
=head1 SYNOPSIS
 
package Foo;
use base qw(Class::Accessor);
Foo->follow_best_practice;
Foo->mk_accessors(qw(name role salary));
 
# or if you prefer a Moose-like interface...
 
package Foo;
use Class::Accessor "antlers";
has name => ( is => "rw", isa => "Str" );
has role => ( is => "rw", isa => "Str" );
has salary => ( is => "rw", isa => "Num" );
 
# Meanwhile, in a nearby piece of code!
# Class::Accessor provides new().
my $mp = Foo->new({ name => "Marty", role => "JAPH" });
 
my $job = $mp->role; # gets $mp->{role}
$mp->salary(400000); # sets $mp->{salary} = 400000 # I wish
 
# like my @info = @{$mp}{qw(name role)}
my @info = $mp->get(qw(name role));
 
# $mp->{salary} = 400000
$mp->set('salary', 400000);
 
 
=head1 DESCRIPTION
 
This module automagically generates accessors/mutators for your class.
 
Most of the time, writing accessors is an exercise in cutting and
pasting. You usually wind up with a series of methods like this:
 
sub name {
my $self = shift;
if(@_) {
$self->{name} = $_[0];
}
return $self->{name};
}
 
sub salary {
my $self = shift;
if(@_) {
$self->{salary} = $_[0];
}
return $self->{salary};
}
 
# etc...
 
One for each piece of data in your object. While some will be unique,
doing value checks and special storage tricks, most will simply be
exercises in repetition. Not only is it Bad Style to have a bunch of
repetitious code, but it's also simply not lazy, which is the real
tragedy.
 
If you make your module a subclass of Class::Accessor and declare your
accessor fields with mk_accessors() then you'll find yourself with a
set of automatically generated accessors which can even be
customized!
 
The basic set up is very simple:
 
package Foo;
use base qw(Class::Accessor);
Foo->mk_accessors( qw(far bar car) );
 
Done. Foo now has simple far(), bar() and car() accessors
defined.
 
Alternatively, if you want to follow Damian's I<best practice> guidelines
you can use:
 
package Foo;
use base qw(Class::Accessor);
Foo->follow_best_practice;
Foo->mk_accessors( qw(far bar car) );
 
B<Note:> you must call C<follow_best_practice> before calling C<mk_accessors>.
 
=head2 Moose-like
 
By popular demand we now have a simple Moose-like interface. You can now do:
 
package Foo;
use Class::Accessor "antlers";
has far => ( is => "rw" );
has bar => ( is => "rw" );
has car => ( is => "rw" );
 
Currently only the C<is> attribute is supported.
 
=head1 CONSTRUCTOR
 
Class::Accessor provides a basic constructor, C<new>. It generates a
hash-based object and can be called as either a class method or an
object method.
 
=head2 new
 
my $obj = Foo->new;
my $obj = $other_obj->new;
 
my $obj = Foo->new(\%fields);
my $obj = $other_obj->new(\%fields);
 
It takes an optional %fields hash which is used to initialize the
object (handy if you use read-only accessors). The fields of the hash
correspond to the names of your accessors, so...
 
package Foo;
use base qw(Class::Accessor);
Foo->mk_accessors('foo');
 
my $obj = Foo->new({ foo => 42 });
print $obj->foo; # 42
 
however %fields can contain anything, new() will shove them all into
your object.
 
=head1 MAKING ACCESSORS
 
=head2 follow_best_practice
 
In Damian's Perl Best Practices book he recommends separate get and set methods
with the prefix set_ and get_ to make it explicit what you intend to do. If you
want to create those accessor methods instead of the default ones, call:
 
__PACKAGE__->follow_best_practice
 
B<before> you call any of the accessor-making methods.
 
=head2 accessor_name_for / mutator_name_for
 
You may have your own crazy ideas for the names of the accessors, so you can
make those happen by overriding C<accessor_name_for> and C<mutator_name_for> in
your subclass. (I copied that idea from Class::DBI.)
 
=head2 mk_accessors
 
__PACKAGE__->mk_accessors(@fields);
 
This creates accessor/mutator methods for each named field given in
@fields. Foreach field in @fields it will generate two accessors.
One called "field()" and the other called "_field_accessor()". For
example:
 
# Generates foo(), _foo_accessor(), bar() and _bar_accessor().
__PACKAGE__->mk_accessors(qw(foo bar));
 
See L<CAVEATS AND TRICKS/"Overriding autogenerated accessors">
for details.
 
=head2 mk_ro_accessors
 
__PACKAGE__->mk_ro_accessors(@read_only_fields);
 
Same as mk_accessors() except it will generate read-only accessors
(ie. true accessors). If you attempt to set a value with these
accessors it will throw an exception. It only uses get() and not
set().
 
package Foo;
use base qw(Class::Accessor);
Foo->mk_ro_accessors(qw(foo bar));
 
# Let's assume we have an object $foo of class Foo...
print $foo->foo; # ok, prints whatever the value of $foo->{foo} is
$foo->foo(42); # BOOM! Naughty you.
 
 
=head2 mk_wo_accessors
 
__PACKAGE__->mk_wo_accessors(@write_only_fields);
 
Same as mk_accessors() except it will generate write-only accessors
(ie. mutators). If you attempt to read a value with these accessors
it will throw an exception. It only uses set() and not get().
 
B<NOTE> I'm not entirely sure why this is useful, but I'm sure someone
will need it. If you've found a use, let me know. Right now it's here
for orthogonality and because it's easy to implement.
 
package Foo;
use base qw(Class::Accessor);
Foo->mk_wo_accessors(qw(foo bar));
 
# Let's assume we have an object $foo of class Foo...
$foo->foo(42); # OK. Sets $self->{foo} = 42
print $foo->foo; # BOOM! Can't read from this accessor.
 
=head1 Moose!
 
If you prefer a Moose-like interface to create accessors, you can use C<has> by
importing this module like this:
 
use Class::Accessor "antlers";
 
or
 
use Class::Accessor "moose-like";
 
Then you can declare accessors like this:
 
has alpha => ( is => "rw", isa => "Str" );
has beta => ( is => "ro", isa => "Str" );
has gamma => ( is => "wo", isa => "Str" );
 
Currently only the C<is> attribute is supported. And our C<is> also supports
the "wo" value to make a write-only accessor.
 
If you are using the Moose-like interface then you should use the C<extends>
rather than tweaking your C<@ISA> directly. Basically, replace
 
@ISA = qw/Foo Bar/;
 
with
 
extends(qw/Foo Bar/);
 
=head1 DETAILS
 
An accessor generated by Class::Accessor looks something like
this:
 
# Your foo may vary.
sub foo {
my($self) = shift;
if(@_) { # set
return $self->set('foo', @_);
}
else {
return $self->get('foo');
}
}
 
Very simple. All it does is determine if you're wanting to set a
value or get a value and calls the appropriate method.
Class::Accessor provides default get() and set() methods which
your class can override. They're detailed later.
 
=head2 Modifying the behavior of the accessor
 
Rather than actually modifying the accessor itself, it is much more
sensible to simply override the two key methods which the accessor
calls. Namely set() and get().
 
If you -really- want to, you can override make_accessor().
 
=head2 set
 
$obj->set($key, $value);
$obj->set($key, @values);
 
set() defines how generally one stores data in the object.
 
override this method to change how data is stored by your accessors.
 
=head2 get
 
$value = $obj->get($key);
@values = $obj->get(@keys);
 
get() defines how data is retrieved from your objects.
 
override this method to change how it is retrieved.
 
=head2 make_accessor
 
$accessor = __PACKAGE__->make_accessor($field);
 
Generates a subroutine reference which acts as an accessor for the given
$field. It calls get() and set().
 
If you wish to change the behavior of your accessors, try overriding
get() and set() before you start mucking with make_accessor().
 
=head2 make_ro_accessor
 
$read_only_accessor = __PACKAGE__->make_ro_accessor($field);
 
Generates a subroutine reference which acts as a read-only accessor for
the given $field. It only calls get().
 
Override get() to change the behavior of your accessors.
 
=head2 make_wo_accessor
 
$write_only_accessor = __PACKAGE__->make_wo_accessor($field);
 
Generates a subroutine reference which acts as a write-only accessor
(mutator) for the given $field. It only calls set().
 
Override set() to change the behavior of your accessors.
 
=head1 EXCEPTIONS
 
If something goes wrong Class::Accessor will warn or die by calling Carp::carp
or Carp::croak. If you don't like this you can override _carp() and _croak() in
your subclass and do whatever else you want.
 
=head1 EFFICIENCY
 
Class::Accessor does not employ an autoloader, thus it is much faster
than you'd think. Its generated methods incur no special penalty over
ones you'd write yourself.
 
accessors:
Rate Basic Fast Faster Direct
Basic 367589/s -- -51% -55% -89%
Fast 747964/s 103% -- -9% -77%
Faster 819199/s 123% 10% -- -75%
Direct 3245887/s 783% 334% 296% --
 
mutators:
Rate Acc Fast Faster Direct
Acc 265564/s -- -54% -63% -91%
Fast 573439/s 116% -- -21% -80%
Faster 724710/s 173% 26% -- -75%
Direct 2860979/s 977% 399% 295% --
 
Class::Accessor::Fast is faster than methods written by an average programmer
(where "average" is based on Schwern's example code).
 
Class::Accessor is slower than average, but more flexible.
 
Class::Accessor::Faster is even faster than Class::Accessor::Fast. It uses an
array internally, not a hash. This could be a good or bad feature depending on
your point of view.
 
Direct hash access is, of course, much faster than all of these, but it
provides no encapsulation.
 
Of course, it's not as simple as saying "Class::Accessor is slower than
average". These are benchmarks for a simple accessor. If your accessors do
any sort of complicated work (such as talking to a database or writing to a
file) the time spent doing that work will quickly swamp the time spend just
calling the accessor. In that case, Class::Accessor and the ones you write
will be roughly the same speed.
 
 
=head1 EXAMPLES
 
Here's an example of generating an accessor for every public field of
your class.
 
package Altoids;
 
use base qw(Class::Accessor Class::Fields);
use fields qw(curiously strong mints);
Altoids->mk_accessors( Altoids->show_fields('Public') );
 
sub new {
my $proto = shift;
my $class = ref $proto || $proto;
return fields::new($class);
}
 
my Altoids $tin = Altoids->new;
 
$tin->curiously('Curiouser and curiouser');
print $tin->{curiously}; # prints 'Curiouser and curiouser'
 
 
# Subclassing works, too.
package Mint::Snuff;
use base qw(Altoids);
 
my Mint::Snuff $pouch = Mint::Snuff->new;
$pouch->strong('Blow your head off!');
print $pouch->{strong}; # prints 'Blow your head off!'
 
 
Here's a simple example of altering the behavior of your accessors.
 
package Foo;
use base qw(Class::Accessor);
Foo->mk_accessors(qw(this that up down));
 
sub get {
my $self = shift;
 
# Note every time someone gets some data.
print STDERR "Getting @_\n";
 
$self->SUPER::get(@_);
}
 
sub set {
my ($self, $key) = splice(@_, 0, 2);
 
# Note every time someone sets some data.
print STDERR "Setting $key to @_\n";
 
$self->SUPER::set($key, @_);
}
 
 
=head1 CAVEATS AND TRICKS
 
Class::Accessor has to do some internal wackiness to get its
job done quickly and efficiently. Because of this, there's a few
tricks and traps one must know about.
 
Hey, nothing's perfect.
 
=head2 Don't make a field called DESTROY
 
This is bad. Since DESTROY is a magical method it would be bad for us
to define an accessor using that name. Class::Accessor will
carp if you try to use it with a field named "DESTROY".
 
=head2 Overriding autogenerated accessors
 
You may want to override the autogenerated accessor with your own, yet
have your custom accessor call the default one. For instance, maybe
you want to have an accessor which checks its input. Normally, one
would expect this to work:
 
package Foo;
use base qw(Class::Accessor);
Foo->mk_accessors(qw(email this that whatever));
 
# Only accept addresses which look valid.
sub email {
my($self) = shift;
my($email) = @_;
 
if( @_ ) { # Setting
require Email::Valid;
unless( Email::Valid->address($email) ) {
carp("$email doesn't look like a valid address.");
return;
}
}
 
return $self->SUPER::email(@_);
}
 
There's a subtle problem in the last example, and it's in this line:
 
return $self->SUPER::email(@_);
 
If we look at how Foo was defined, it called mk_accessors() which
stuck email() right into Foo's namespace. There *is* no
SUPER::email() to delegate to! Two ways around this... first is to
make a "pure" base class for Foo. This pure class will generate the
accessors and provide the necessary super class for Foo to use:
 
package Pure::Organic::Foo;
use base qw(Class::Accessor);
Pure::Organic::Foo->mk_accessors(qw(email this that whatever));
 
package Foo;
use base qw(Pure::Organic::Foo);
 
And now Foo::email() can override the generated
Pure::Organic::Foo::email() and use it as SUPER::email().
 
This is probably the most obvious solution to everyone but me.
Instead, what first made sense to me was for mk_accessors() to define
an alias of email(), _email_accessor(). Using this solution,
Foo::email() would be written with:
 
return $self->_email_accessor(@_);
 
instead of the expected SUPER::email().
 
 
=head1 AUTHORS
 
Copyright 2017 Marty Pauley <marty+perl@martian.org>
 
This program is free software; you can redistribute it and/or modify it under
the same terms as Perl itself. That means either (a) the GNU General Public
License or (b) the Artistic License.
 
=head2 ORIGINAL AUTHOR
 
Michael G Schwern <schwern@pobox.com>
 
=head2 THANKS
 
Liz and RUZ for performance tweaks.
 
Tels, for his big feature request/bug report.
 
Various presenters at YAPC::Asia 2009 for criticising the non-Moose interface.
 
=head1 SEE ALSO
 
See L<Class::Accessor::Fast> and L<Class::Accessor::Faster> if speed is more
important than flexibility.
 
These are some modules which do similar things in different ways
L<Class::Struct>, L<Class::Methodmaker>, L<Class::Generate>,
L<Class::Class>, L<Class::Contract>, L<Moose>, L<Mouse>
 
See L<Class::DBI> for an example of this module in use.
 
=cut
/perl_lib/Exporter/Tiny.pm
0,0 → 1,508
package Exporter::Tiny;
 
use 5.006001;
use strict;
use warnings; no warnings qw(void once uninitialized numeric redefine);
 
our $AUTHORITY = 'cpan:TOBYINK';
our $VERSION = '1.002002';
our @EXPORT_OK = qw< mkopt mkopt_hash _croak _carp >;
 
sub _croak ($;@) { require Carp; my $fmt = shift; @_ = sprintf($fmt, @_); goto \&Carp::croak }
sub _carp ($;@) { require Carp; my $fmt = shift; @_ = sprintf($fmt, @_); goto \&Carp::carp }
 
my $_process_optlist = sub
{
my $class = shift;
my ($global_opts, $opts, $want, $not_want) = @_;
while (@$opts)
{
my $opt = shift @{$opts};
my ($name, $value) = @$opt;
($name =~ m{\A\!(/.+/[msixpodual]*)\z}) ?
do {
my @not = $class->_exporter_expand_regexp($1, $value, $global_opts);
++$not_want->{$_->[0]} for @not;
} :
($name =~ m{\A\!(.+)\z}) ?
(++$not_want->{$1}) :
($name =~ m{\A[:-](.+)\z}) ?
push(@$opts, $class->_exporter_expand_tag($1, $value, $global_opts)) :
($name =~ m{\A/.+/[msixpodual]*\z}) ?
push(@$opts, $class->_exporter_expand_regexp($name, $value, $global_opts)) :
# else ?
push(@$want, $opt);
}
};
 
sub import
{
my $class = shift;
my $global_opts = +{ @_ && ref($_[0]) eq q(HASH) ? %{+shift} : () };
$global_opts->{into} = caller unless exists $global_opts->{into};
my @want;
my %not_want; $global_opts->{not} = \%not_want;
my @args = do { no strict qw(refs); @_ ? @_ : @{"$class\::EXPORT"} };
my $opts = mkopt(\@args);
$class->$_process_optlist($global_opts, $opts, \@want, \%not_want);
my $permitted = $class->_exporter_permitted_regexp($global_opts);
$class->_exporter_validate_opts($global_opts);
for my $wanted (@want)
{
next if $not_want{$wanted->[0]};
my %symbols = $class->_exporter_expand_sub(@$wanted, $global_opts, $permitted);
$class->_exporter_install_sub($_, $wanted->[1], $global_opts, $symbols{$_})
for keys %symbols;
}
}
 
sub unimport
{
my $class = shift;
my $global_opts = +{ @_ && ref($_[0]) eq q(HASH) ? %{+shift} : () };
$global_opts->{into} = caller unless exists $global_opts->{into};
$global_opts->{is_unimport} = 1;
my @want;
my %not_want; $global_opts->{not} = \%not_want;
my @args = do { our %TRACKED; @_ ? @_ : keys(%{$TRACKED{$class}{$global_opts->{into}}}) };
my $opts = mkopt(\@args);
$class->$_process_optlist($global_opts, $opts, \@want, \%not_want);
my $permitted = $class->_exporter_permitted_regexp($global_opts);
$class->_exporter_validate_unimport_opts($global_opts);
my $expando = $class->can('_exporter_expand_sub');
$expando = undef if $expando == \&_exporter_expand_sub;
for my $wanted (@want)
{
next if $not_want{$wanted->[0]};
if ($wanted->[1])
{
_carp("Passing options to unimport '%s' makes no sense", $wanted->[0])
unless (ref($wanted->[1]) eq 'HASH' and not keys %{$wanted->[1]});
}
my %symbols = defined($expando)
? $class->$expando(@$wanted, $global_opts, $permitted)
: ($wanted->[0] => sub { "dummy" });
$class->_exporter_uninstall_sub($_, $wanted->[1], $global_opts)
for keys %symbols;
}
}
 
# Called once per import/unimport, passed the "global" import options.
# Expected to validate the options and carp or croak if there are problems.
# Can also take the opportunity to do other stuff if needed.
#
sub _exporter_validate_opts { 1 }
sub _exporter_validate_unimport_opts { 1 }
 
# Called after expanding a tag or regexp to merge the tag's options with
# any sub-specific options.
#
sub _exporter_merge_opts
{
my $class = shift;
my ($tag_opts, $global_opts, @stuff) = @_;
$tag_opts = {} unless ref($tag_opts) eq q(HASH);
_croak('Cannot provide an -as option for tags')
if exists $tag_opts->{-as} && ref $tag_opts->{-as} ne 'CODE';
my $optlist = mkopt(\@stuff);
for my $export (@$optlist)
{
next if defined($export->[1]) && ref($export->[1]) ne q(HASH);
my %sub_opts = ( %{ $export->[1] or {} }, %$tag_opts );
$sub_opts{-prefix} = sprintf('%s%s', $tag_opts->{-prefix}, $export->[1]{-prefix})
if exists($export->[1]{-prefix}) && exists($tag_opts->{-prefix});
$sub_opts{-suffix} = sprintf('%s%s', $export->[1]{-suffix}, $tag_opts->{-suffix})
if exists($export->[1]{-suffix}) && exists($tag_opts->{-suffix});
$export->[1] = \%sub_opts;
}
return @$optlist;
}
 
# Given a tag name, looks it up in %EXPORT_TAGS and returns the list of
# associated functions. The default implementation magically handles tags
# "all" and "default". The default implementation interprets any undefined
# tags as being global options.
#
sub _exporter_expand_tag
{
no strict qw(refs);
my $class = shift;
my ($name, $value, $globals) = @_;
my $tags = \%{"$class\::EXPORT_TAGS"};
return $class->_exporter_merge_opts($value, $globals, $tags->{$name}->($class, @_))
if ref($tags->{$name}) eq q(CODE);
return $class->_exporter_merge_opts($value, $globals, @{$tags->{$name}})
if exists $tags->{$name};
return $class->_exporter_merge_opts($value, $globals, @{"$class\::EXPORT"}, @{"$class\::EXPORT_OK"})
if $name eq 'all';
return $class->_exporter_merge_opts($value, $globals, @{"$class\::EXPORT"})
if $name eq 'default';
$globals->{$name} = $value || 1;
return;
}
 
# Given a regexp-like string, looks it up in @EXPORT_OK and returns the
# list of matching functions.
#
sub _exporter_expand_regexp
{
no strict qw(refs);
our %TRACKED;
my $class = shift;
my ($name, $value, $globals) = @_;
my $compiled = eval("qr$name");
my @possible = $globals->{is_unimport}
? keys( %{$TRACKED{$class}{$globals->{into}}} )
: @{"$class\::EXPORT_OK"};
$class->_exporter_merge_opts($value, $globals, grep /$compiled/, @possible);
}
 
# Helper for _exporter_expand_sub. Returns a regexp matching all subs in
# the exporter package which are available for export.
#
sub _exporter_permitted_regexp
{
no strict qw(refs);
my $class = shift;
my $re = join "|", map quotemeta, sort {
length($b) <=> length($a) or $a cmp $b
} @{"$class\::EXPORT"}, @{"$class\::EXPORT_OK"};
qr{^(?:$re)$}ms;
}
 
# Given a sub name, returns a hash of subs to install (usually just one sub).
# Keys are sub names, values are coderefs.
#
sub _exporter_expand_sub
{
my $class = shift;
my ($name, $value, $globals, $permitted) = @_;
$permitted ||= $class->_exporter_permitted_regexp($globals);
no strict qw(refs);
my $sigil = "&";
if ($name =~ /\A([&\$\%\@\*])(.+)\z/) {
$sigil = $1;
$name = $2;
if ($sigil eq '*') {
_croak("Cannot export symbols with a * sigil");
}
}
my $sigilname = $sigil eq '&' ? $name : "$sigil$name";
if ($sigilname =~ $permitted)
{
my $generatorprefix = {
'&' => "_generate_",
'$' => "_generateScalar_",
'@' => "_generateArray_",
'%' => "_generateHash_",
}->{$sigil};
my $generator = $class->can("$generatorprefix$name");
return $sigilname => $class->$generator($sigilname, $value, $globals) if $generator;
my $sub = $class->can($name);
return $sigilname => $sub if $sub;
# Could do this more cleverly, but this works.
if ($sigil ne '&') {
my $evalled = eval "\\${sigil}${class}::${name}";
return $sigilname => $evalled if $evalled;
}
}
$class->_exporter_fail(@_);
}
 
# Called by _exporter_expand_sub if it is unable to generate a key-value
# pair for a sub.
#
sub _exporter_fail
{
my $class = shift;
my ($name, $value, $globals) = @_;
return if $globals->{is_unimport};
_croak("Could not find sub '%s' exported by %s", $name, $class);
}
 
# Actually performs the installation of the sub into the target package. This
# also handles renaming the sub.
#
sub _exporter_install_sub
{
my $class = shift;
my ($name, $value, $globals, $sym) = @_;
my $into = $globals->{into};
my $installer = $globals->{installer} || $globals->{exporter};
$name =
ref $globals->{as} ? $globals->{as}->($name) :
ref $value->{-as} ? $value->{-as}->($name) :
exists $value->{-as} ? $value->{-as} :
$name;
return unless defined $name;
my $sigil = "&";
unless (ref($name)) {
if ($name =~ /\A([&\$\%\@\*])(.+)\z/) {
$sigil = $1;
$name = $2;
if ($sigil eq '*') {
_croak("Cannot export symbols with a * sigil");
}
}
my ($prefix) = grep defined, $value->{-prefix}, $globals->{prefix}, q();
my ($suffix) = grep defined, $value->{-suffix}, $globals->{suffix}, q();
$name = "$prefix$name$suffix";
}
my $sigilname = $sigil eq '&' ? $name : "$sigil$name";
# if ({qw/$ SCALAR @ ARRAY % HASH & CODE/}->{$sigil} ne ref($sym)) {
# warn $sym;
# warn $sigilname;
# _croak("Reference type %s does not match sigil %s", ref($sym), $sigil);
# }
return ($$name = $sym) if ref($name) eq q(SCALAR);
return ($into->{$sigilname} = $sym) if ref($into) eq q(HASH);
no strict qw(refs);
our %TRACKED;
if (ref($sym) eq 'CODE' and exists &{"$into\::$name"} and \&{"$into\::$name"} != $sym)
{
my ($level) = grep defined, $value->{-replace}, $globals->{replace}, q(0);
my $action = {
carp => \&_carp,
0 => \&_carp,
'' => \&_carp,
warn => \&_carp,
nonfatal => \&_carp,
croak => \&_croak,
fatal => \&_croak,
die => \&_croak,
}->{$level} || sub {};
# Don't complain about double-installing the same sub. This isn't ideal
# because the same named sub might be generated in two different ways.
$action = sub {} if $TRACKED{$class}{$into}{$sigilname};
$action->(
$action == \&_croak
? "Refusing to overwrite existing sub '%s::%s' with sub '%s' exported by %s"
: "Overwriting existing sub '%s::%s' with sub '%s' exported by %s",
$into,
$name,
$_[0],
$class,
);
}
$TRACKED{$class}{$into}{$sigilname} = $sym;
no warnings qw(prototype);
$installer
? $installer->($globals, [$sigilname, $sym])
: (*{"$into\::$name"} = $sym);
}
 
sub _exporter_uninstall_sub
{
our %TRACKED;
my $class = shift;
my ($name, $value, $globals, $sym) = @_;
my $into = $globals->{into};
ref $into and return;
no strict qw(refs);
 
my $sigil = "&";
if ($name =~ /\A([&\$\%\@\*])(.+)\z/) {
$sigil = $1;
$name = $2;
if ($sigil eq '*') {
_croak("Cannot export symbols with a * sigil");
}
}
my $sigilname = $sigil eq '&' ? $name : "$sigil$name";
if ($sigil ne '&') {
_croak("Unimporting non-code symbols not supported yet");
}
 
# Cowardly refuse to uninstall a sub that differs from the one
# we installed!
my $our_coderef = $TRACKED{$class}{$into}{$name};
my $cur_coderef = exists(&{"$into\::$name"}) ? \&{"$into\::$name"} : -1;
return unless $our_coderef == $cur_coderef;
my $stash = \%{"$into\::"};
my $old = delete $stash->{$name};
my $full_name = join('::', $into, $name);
foreach my $type (qw(SCALAR HASH ARRAY IO)) # everything but the CODE
{
next unless defined(*{$old}{$type});
*$full_name = *{$old}{$type};
}
delete $TRACKED{$class}{$into}{$name};
}
 
sub mkopt
{
my $in = shift or return [];
my @out;
$in = [map(($_ => ref($in->{$_}) ? $in->{$_} : ()), sort keys %$in)]
if ref($in) eq q(HASH);
for (my $i = 0; $i < @$in; $i++)
{
my $k = $in->[$i];
my $v;
($i == $#$in) ? ($v = undef) :
!defined($in->[$i+1]) ? (++$i, ($v = undef)) :
!ref($in->[$i+1]) ? ($v = undef) :
($v = $in->[++$i]);
push @out, [ $k => $v ];
}
\@out;
}
 
sub mkopt_hash
{
my $in = shift or return;
my %out = map +($_->[0] => $_->[1]), @{ mkopt($in) };
\%out;
}
 
1;
 
__END__
 
=pod
 
=encoding utf-8
 
=for stopwords frobnicate greps regexps
 
=head1 NAME
 
Exporter::Tiny - an exporter with the features of Sub::Exporter but only core dependencies
 
=head1 SYNOPSIS
 
package MyUtils;
use base "Exporter::Tiny";
our @EXPORT = qw(frobnicate);
sub frobnicate { ... }
1;
 
package MyScript;
use MyUtils "frobnicate" => { -as => "frob" };
print frob(42);
exit;
 
=head1 DESCRIPTION
 
Exporter::Tiny supports many of Sub::Exporter's external-facing features
including renaming imported functions with the C<< -as >>, C<< -prefix >> and
C<< -suffix >> options; explicit destinations with the C<< into >> option;
and alternative installers with the C<< installer >> option. But it's written
in only about 40% as many lines of code and with zero non-core dependencies.
 
Its internal-facing interface is closer to Exporter.pm, with configuration
done through the C<< @EXPORT >>, C<< @EXPORT_OK >> and C<< %EXPORT_TAGS >>
package variables.
 
If you are trying to B<write> a module that inherits from Exporter::Tiny,
then look at:
 
=over
 
=item *
 
L<Exporter::Tiny::Manual::QuickStart>
 
=item *
 
L<Exporter::Tiny::Manual::Exporting>
 
=back
 
If you are trying to B<use> a module that inherits from Exporter::Tiny,
then look at:
 
=over
 
=item *
 
L<Exporter::Tiny::Manual::Importing>
 
=back
 
=head1 BUGS
 
Please report any bugs to
L<http://rt.cpan.org/Dist/Display.html?Queue=Exporter-Tiny>.
 
=head1 SUPPORT
 
B<< IRC: >> support is available through in the I<< #moops >> channel
on L<irc.perl.org|http://www.irc.perl.org/channels.html>.
 
=head1 SEE ALSO
 
Simplified interface to this module: L<Exporter::Shiny>.
 
Other interesting exporters: L<Sub::Exporter>, L<Exporter>.
 
=head1 AUTHOR
 
Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
 
=head1 COPYRIGHT AND LICENCE
 
This software is copyright (c) 2013-2014, 2017 by Toby Inkster.
 
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
 
=head1 DISCLAIMER OF WARRANTIES
 
THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
 
/perl_lib/File/Copy/Recursive.pm
0,0 → 1,808
package File::Copy::Recursive;
 
use strict;
 
BEGIN {
# Keep older versions of Perl from trying to use lexical warnings
$INC{'warnings.pm'} = "fake warnings entry for < 5.6 perl ($])" if $] < 5.006;
}
use warnings;
 
use Carp;
use File::Copy;
use File::Spec; #not really needed because File::Copy already gets it, but for good measure :)
use Cwd ();
 
use vars qw(
@ISA @EXPORT_OK $VERSION $MaxDepth $KeepMode $CPRFComp $CopyLink
$PFSCheck $RemvBase $NoFtlPth $ForcePth $CopyLoop $RMTrgFil $RMTrgDir
$CondCopy $BdTrgWrn $SkipFlop $DirPerms
);
 
require Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw(fcopy rcopy dircopy fmove rmove dirmove pathmk pathrm pathempty pathrmdir rcopy_glob rmove_glob);
 
$VERSION = '0.45';
 
$MaxDepth = 0;
$KeepMode = 1;
$CPRFComp = 0;
$CopyLink = eval { local $SIG{'__DIE__'}; symlink '', ''; 1 } || 0;
$PFSCheck = 1;
$RemvBase = 0;
$NoFtlPth = 0;
$ForcePth = 0;
$CopyLoop = 0;
$RMTrgFil = 0;
$RMTrgDir = 0;
$CondCopy = {};
$BdTrgWrn = 0;
$SkipFlop = 0;
$DirPerms = 0777;
 
my $samecheck = sub {
return 1 if $^O eq 'MSWin32'; # need better way to check for this on winders...
return if @_ != 2 || !defined $_[0] || !defined $_[1];
return if $_[0] eq $_[1];
 
my $one = '';
if ($PFSCheck) {
$one = join( '-', ( stat $_[0] )[ 0, 1 ] ) || '';
my $two = join( '-', ( stat $_[1] )[ 0, 1 ] ) || '';
if ( $one eq $two && $one ) {
carp "$_[0] and $_[1] are identical";
return;
}
}
 
if ( -d $_[0] && !$CopyLoop ) {
$one = join( '-', ( stat $_[0] )[ 0, 1 ] ) if !$one;
my $abs = File::Spec->rel2abs( $_[1] );
my @pth = File::Spec->splitdir($abs);
while (@pth) {
if ( $pth[-1] eq '..' ) { # cheaper than Cwd::realpath() plus we don't want to resolve symlinks at this point, right?
pop @pth;
pop @pth unless -l File::Spec->catdir(@pth);
next;
}
my $cur = File::Spec->catdir(@pth);
last if !$cur; # probably not necessary, but nice to have just in case :)
my $two = join( '-', ( stat $cur )[ 0, 1 ] ) || '';
if ( $one eq $two && $one ) {
 
# $! = 62; # Too many levels of symbolic links
carp "Caught Deep Recursion Condition: $_[0] contains $_[1]";
return;
}
 
pop @pth;
}
}
 
return 1;
};
 
my $glob = sub {
my ( $do, $src_glob, @args ) = @_;
 
local $CPRFComp = 1;
require File::Glob;
 
my @rt;
for my $path ( File::Glob::bsd_glob($src_glob) ) {
my @call = [ $do->( $path, @args ) ] or return;
push @rt, \@call;
}
 
return @rt;
};
 
my $move = sub {
my $fl = shift;
my @x;
if ($fl) {
@x = fcopy(@_) or return;
}
else {
@x = dircopy(@_) or return;
}
if (@x) {
if ($fl) {
unlink $_[0] or return;
}
else {
pathrmdir( $_[0] ) or return;
}
if ($RemvBase) {
my ( $volm, $path ) = File::Spec->splitpath( $_[0] );
pathrm( File::Spec->catpath( $volm, $path, '' ), $ForcePth, $NoFtlPth ) or return;
}
}
return wantarray ? @x : $x[0];
};
 
my $ok_todo_asper_condcopy = sub {
my $org = shift;
my $copy = 1;
if ( exists $CondCopy->{$org} ) {
if ( $CondCopy->{$org}{'md5'} ) {
 
}
if ($copy) {
 
}
}
return $copy;
};
 
sub fcopy {
$samecheck->(@_) or return;
if ( $RMTrgFil && ( -d $_[1] || -e $_[1] ) ) {
my $trg = $_[1];
if ( -d $trg ) {
my @trgx = File::Spec->splitpath( $_[0] );
$trg = File::Spec->catfile( $_[1], $trgx[$#trgx] );
}
$samecheck->( $_[0], $trg ) or return;
if ( -e $trg ) {
if ( $RMTrgFil == 1 ) {
unlink $trg or carp "\$RMTrgFil failed: $!";
}
else {
unlink $trg or return;
}
}
}
my ( $volm, $path ) = File::Spec->splitpath( $_[1] );
if ( $path && !-d $path ) {
pathmk( File::Spec->catpath( $volm, $path, '' ), $NoFtlPth );
}
if ( -l $_[0] && $CopyLink ) {
my $target = readlink( shift() );
($target) = $target =~ m/(.*)/; # mass-untaint is OK since we have to allow what the file system does
carp "Copying a symlink ($_[0]) whose target does not exist"
if !-e $target && $BdTrgWrn;
my $new = shift();
unlink $new if -l $new;
symlink( $target, $new ) or return;
}
elsif ( -d $_[0] && -f $_[1] ) {
return;
}
else {
return if -d $_[0]; # address File::Copy::copy() bug outlined in https://rt.perl.org/Public/Bug/Display.html?id=132866
copy(@_) or return;
 
my @base_file = File::Spec->splitpath( $_[0] );
my $mode_trg = -d $_[1] ? File::Spec->catfile( $_[1], $base_file[$#base_file] ) : $_[1];
 
chmod scalar( ( stat( $_[0] ) )[2] ), $mode_trg if $KeepMode;
}
return wantarray ? ( 1, 0, 0 ) : 1; # use 0's incase they do math on them and in case rcopy() is called in list context = no uninit val warnings
}
 
sub rcopy {
if ( -l $_[0] && $CopyLink ) {
goto &fcopy;
}
 
goto &dircopy if -d $_[0] || substr( $_[0], ( 1 * -1 ), 1 ) eq '*';
goto &fcopy;
}
 
sub rcopy_glob {
$glob->( \&rcopy, @_ );
}
 
sub dircopy {
if ( $RMTrgDir && -d $_[1] ) {
if ( $RMTrgDir == 1 ) {
pathrmdir( $_[1] ) or carp "\$RMTrgDir failed: $!";
}
else {
pathrmdir( $_[1] ) or return;
}
}
my $globstar = 0;
my $_zero = $_[0];
my $_one = $_[1];
if ( substr( $_zero, ( 1 * -1 ), 1 ) eq '*' ) {
$globstar = 1;
$_zero = substr( $_zero, 0, ( length($_zero) - 1 ) );
}
 
$samecheck->( $_zero, $_[1] ) or return;
if ( !-d $_zero || ( -e $_[1] && !-d $_[1] ) ) {
$! = 20;
return;
}
 
if ( !-d $_[1] ) {
pathmk( $_[1], $NoFtlPth ) or return;
}
else {
if ( $CPRFComp && !$globstar ) {
my @parts = File::Spec->splitdir($_zero);
while ( $parts[$#parts] eq '' ) { pop @parts; }
$_one = File::Spec->catdir( $_[1], $parts[$#parts] );
}
}
my $baseend = $_one;
my $level = 0;
my $filen = 0;
my $dirn = 0;
 
my $recurs; #must be my()ed before sub {} since it calls itself
$recurs = sub {
my ( $str, $end, $buf ) = @_;
$filen++ if $end eq $baseend;
$dirn++ if $end eq $baseend;
 
$DirPerms = oct($DirPerms) if substr( $DirPerms, 0, 1 ) eq '0';
mkdir( $end, $DirPerms ) or return if !-d $end;
if ( $MaxDepth && $MaxDepth =~ m/^\d+$/ && $level >= $MaxDepth ) {
chmod scalar( ( stat($str) )[2] ), $end if $KeepMode;
return ( $filen, $dirn, $level ) if wantarray;
return $filen;
}
 
$level++;
 
my @files;
if ( $] < 5.006 ) {
opendir( STR_DH, $str ) or return;
@files = grep( $_ ne '.' && $_ ne '..', readdir(STR_DH) );
closedir STR_DH;
}
else {
opendir( my $str_dh, $str ) or return;
@files = grep( $_ ne '.' && $_ ne '..', readdir($str_dh) );
closedir $str_dh;
}
 
for my $file (@files) {
my ($file_ut) = $file =~ m{ (.*) }xms;
my $org = File::Spec->catfile( $str, $file_ut );
my $new = File::Spec->catfile( $end, $file_ut );
if ( -l $org && $CopyLink ) {
my $target = readlink($org);
($target) = $target =~ m/(.*)/; # mass-untaint is OK since we have to allow what the file system does
carp "Copying a symlink ($org) whose target does not exist"
if !-e $target && $BdTrgWrn;
unlink $new if -l $new;
symlink( $target, $new ) or return;
}
elsif ( -d $org ) {
my $rc;
if ( !-w $org && $KeepMode ) {
local $KeepMode = 0;
$rc = $recurs->( $org, $new, $buf ) if defined $buf;
$rc = $recurs->( $org, $new ) if !defined $buf;
chmod scalar( ( stat($org) )[2] ), $new;
}
else {
$rc = $recurs->( $org, $new, $buf ) if defined $buf;
$rc = $recurs->( $org, $new ) if !defined $buf;
}
if ( !$rc ) {
if ($SkipFlop) {
next;
}
else {
return;
}
}
$filen++;
$dirn++;
}
else {
if ( $ok_todo_asper_condcopy->($org) ) {
if ($SkipFlop) {
fcopy( $org, $new, $buf ) or next if defined $buf;
fcopy( $org, $new ) or next if !defined $buf;
}
else {
fcopy( $org, $new, $buf ) or return if defined $buf;
fcopy( $org, $new ) or return if !defined $buf;
}
chmod scalar( ( stat($org) )[2] ), $new if $KeepMode;
$filen++;
}
}
}
$level--;
chmod scalar( ( stat($str) )[2] ), $end if $KeepMode;
1;
 
};
 
$recurs->( $_zero, $_one, $_[2] ) or return;
return wantarray ? ( $filen, $dirn, $level ) : $filen;
}
 
sub fmove { $move->( 1, @_ ) }
 
sub rmove {
if ( -l $_[0] && $CopyLink ) {
goto &fmove;
}
 
goto &dirmove if -d $_[0] || substr( $_[0], ( 1 * -1 ), 1 ) eq '*';
goto &fmove;
}
 
sub rmove_glob {
$glob->( \&rmove, @_ );
}
 
sub dirmove { $move->( 0, @_ ) }
 
sub pathmk {
my ( $vol, $dir, $file ) = File::Spec->splitpath( shift() );
my $nofatal = shift;
 
$DirPerms = oct($DirPerms) if substr( $DirPerms, 0, 1 ) eq '0';
 
if ( defined($dir) ) {
my (@dirs) = File::Spec->splitdir($dir);
 
for ( my $i = 0; $i < scalar(@dirs); $i++ ) {
my $newdir = File::Spec->catdir( @dirs[ 0 .. $i ] );
my $newpth = File::Spec->catpath( $vol, $newdir, "" );
 
mkdir( $newpth, $DirPerms ) or return if !-d $newpth && !$nofatal;
mkdir( $newpth, $DirPerms ) if !-d $newpth && $nofatal;
}
}
 
if ( defined($file) ) {
my $newpth = File::Spec->catpath( $vol, $dir, $file );
 
mkdir( $newpth, $DirPerms ) or return if !-d $newpth && !$nofatal;
mkdir( $newpth, $DirPerms ) if !-d $newpth && $nofatal;
}
 
1;
}
 
sub pathempty {
my $pth = shift;
 
my ( $orig_dev, $orig_ino ) = ( lstat $pth )[ 0, 1 ];
return 2 if !-d _ || !defined($orig_dev) || ( $^O ne 'MSWin32' && !$orig_ino ); #stat.inode is 0 on Windows
 
my $starting_point = Cwd::cwd();
my ( $starting_dev, $starting_ino ) = ( lstat $starting_point )[ 0, 1 ];
chdir($pth) or Carp::croak("Failed to change directory to “$pth”: $!");
$pth = '.';
_bail_if_changed( $pth, $orig_dev, $orig_ino );
 
my @names;
my $pth_dh;
if ( $] < 5.006 ) {
opendir( PTH_DH, $pth ) or return;
@names = grep !/^\.\.?$/, readdir(PTH_DH);
closedir PTH_DH;
}
else {
opendir( $pth_dh, $pth ) or return;
@names = grep !/^\.\.?$/, readdir($pth_dh);
closedir $pth_dh;
}
_bail_if_changed( $pth, $orig_dev, $orig_ino );
 
for my $name (@names) {
my ($name_ut) = $name =~ m{ (.*) }xms;
my $flpth = File::Spec->catdir( $pth, $name_ut );
 
if ( -l $flpth ) {
_bail_if_changed( $pth, $orig_dev, $orig_ino );
unlink $flpth or return;
}
elsif ( -d $flpth ) {
_bail_if_changed( $pth, $orig_dev, $orig_ino );
pathrmdir($flpth) or return;
}
else {
_bail_if_changed( $pth, $orig_dev, $orig_ino );
unlink $flpth or return;
}
}
 
chdir($starting_point) or Carp::croak("Failed to change directory to “$starting_point”: $!");
_bail_if_changed( ".", $starting_dev, $starting_ino );
 
return 1;
}
 
sub pathrm {
my ( $path, $force, $nofail ) = @_;
 
my ( $orig_dev, $orig_ino ) = ( lstat $path )[ 0, 1 ];
return 2 if !-d _ || !defined($orig_dev) || !$orig_ino;
 
# Manual test (I hate this function :/):
# sudo mkdir /foo && perl -MFile::Copy::Recursive=pathrm -le 'print pathrm("/foo",1)' && sudo rm -rf /foo
if ( $force && File::Spec->file_name_is_absolute($path) ) {
Carp::croak("pathrm() w/ force on abspath is not allowed");
}
 
my @pth = File::Spec->splitdir($path);
 
my %fs_check;
my $aggregate_path;
for my $part (@pth) {
$aggregate_path = defined $aggregate_path ? File::Spec->catdir( $aggregate_path, $part ) : $part;
$fs_check{$aggregate_path} = [ ( lstat $aggregate_path )[ 0, 1 ] ];
}
 
while (@pth) {
my $cur = File::Spec->catdir(@pth);
last if !$cur; # necessary ???
 
if ($force) {
_bail_if_changed( $cur, $fs_check{$cur}->[0], $fs_check{$cur}->[1] );
if ( !pathempty($cur) ) {
return unless $nofail;
}
}
_bail_if_changed( $cur, $fs_check{$cur}->[0], $fs_check{$cur}->[1] );
if ($nofail) {
rmdir $cur;
}
else {
rmdir $cur or return;
}
pop @pth;
}
 
return 1;
}
 
sub pathrmdir {
my $dir = shift;
if ( -e $dir ) {
return if !-d $dir;
}
else {
return 2;
}
 
my ( $orig_dev, $orig_ino ) = ( lstat $dir )[ 0, 1 ];
return 2 if !defined($orig_dev) || ( $^O ne 'MSWin32' && !$orig_ino );
 
pathempty($dir) or return;
_bail_if_changed( $dir, $orig_dev, $orig_ino );
rmdir $dir or return;
 
return 1;
}
 
sub _bail_if_changed {
my ( $path, $orig_dev, $orig_ino ) = @_;
 
my ( $cur_dev, $cur_ino ) = ( lstat $path )[ 0, 1 ];
 
if ( !defined $cur_dev || !defined $cur_ino ) {
$cur_dev ||= "undef(path went away?)";
$cur_ino ||= "undef(path went away?)";
}
else {
$path = Cwd::abs_path($path);
}
 
if ( $orig_dev ne $cur_dev || $orig_ino ne $cur_ino ) {
local $Carp::CarpLevel += 1;
Carp::croak("directory $path changed: expected dev=$orig_dev ino=$orig_ino, actual dev=$cur_dev ino=$cur_ino, aborting");
}
}
 
1;
 
__END__
 
=head1 NAME
 
File::Copy::Recursive - Perl extension for recursively copying files and directories
 
=head1 SYNOPSIS
 
use File::Copy::Recursive qw(fcopy rcopy dircopy fmove rmove dirmove);
 
fcopy($orig,$new[,$buf]) or die $!;
rcopy($orig,$new[,$buf]) or die $!;
dircopy($orig,$new[,$buf]) or die $!;
 
fmove($orig,$new[,$buf]) or die $!;
rmove($orig,$new[,$buf]) or die $!;
dirmove($orig,$new[,$buf]) or die $!;
rcopy_glob("orig/stuff-*", $trg [, $buf]) or die $!;
rmove_glob("orig/stuff-*", $trg [,$buf]) or die $!;
 
=head1 DESCRIPTION
 
This module copies and moves directories recursively (or single files, well... singley) to an optional depth and attempts to preserve each file or directory's mode.
 
=head1 EXPORT
 
None by default. But you can export all the functions as in the example above and the path* functions if you wish.
 
=head2 fcopy()
 
This function uses File::Copy's copy() function to copy a file but not a directory. Any directories are recursively created if need be.
One difference to File::Copy::copy() is that fcopy attempts to preserve the mode (see Preserving Mode below)
The optional $buf in the synopsis is the same as File::Copy::copy()'s 3rd argument.
This function returns the same as File::Copy::copy() in scalar context and 1,0,0 in list context to accomodate rcopy()'s list context on regular files. (See below for more info)
 
=head2 dircopy()
 
This function recursively traverses the $orig directory's structure and recursively copies it to the $new directory.
$new is created if necessary (multiple non existent directories is ok (i.e. foo/bar/baz). The script logically and portably creates all of them if necessary).
It attempts to preserve the mode (see Preserving Mode below) and
by default it copies all the way down into the directory (see Managing Depth, below).
If a directory is not specified it croaks just like fcopy croaks if its not a file that is specified.
 
This function returns true or false: for true in scalar context it returns the number of files and directories copied,
whereas in list context it returns the number of files and directories, number of directories only, depth level traversed.
 
my $num_of_files_and_dirs = dircopy($orig,$new);
my($num_of_files_and_dirs,$num_of_dirs,$depth_traversed) = dircopy($orig,$new);
Normally it stops and returns if a copy fails. To continue on regardless, set $File::Copy::Recursive::SkipFlop to true.
 
local $File::Copy::Recursive::SkipFlop = 1;
 
That way it will copy everythging it can in a directory and won't stop because of permissions, etc...
 
=head2 rcopy()
 
This function will allow you to specify a file *or* a directory. It calls fcopy() if you passed file and dircopy() if you passed a directory.
If you call rcopy() (or fcopy() for that matter) on a file in list context, the values will be 1,0,0 since no directories and no depth are used.
This is important because if it's a directory in list context and there is only the initial directory the return value is 1,1,1.
 
=head2 rcopy_glob()
 
This function lets you specify a pattern suitable for perl's File::Glob::bsd_glob() as the first argument. Subsequently each path returned by perl's File::Glob::bsd_glob() gets rcopy()ied.
 
It returns and array whose items are array refs that contain the return value of each rcopy() call.
 
It forces behavior as if $File::Copy::Recursive::CPRFComp is true.
 
=head2 fmove()
 
Copies the file then removes the original. You can manage the path the original file is in according to $RemvBase.
 
=head2 dirmove()
 
Uses dircopy() to copy the directory then removes the original. You can manage the path the original directory is in according to $RemvBase.
 
=head2 rmove()
 
Like rcopy() but calls fmove() or dirmove() instead.
 
=head2 rmove_glob()
 
Like rcopy_glob() but calls rmove() instead of rcopy()
 
=head3 $RemvBase
 
Default is false. When set to true the *move() functions will not only attempt to remove the original file or directory but will remove the given path it is in.
 
So if you:
 
rmove('foo/bar/baz', '/etc/');
# "baz" is removed from foo/bar after it is successfully copied to /etc/
local $File::Copy::Recursive::Remvbase = 1;
rmove('foo/bar/baz','/etc/');
# if baz is successfully copied to /etc/ :
# first "baz" is removed from foo/bar
# then "foo/bar is removed via pathrm()
 
=head4 $ForcePth
 
Default is false. When set to true it calls pathempty() before any directories are removed to empty the directory so it can be rmdir()'ed when $RemvBase is in effect.
 
=head2 Creating and Removing Paths
 
=head3 $NoFtlPth
 
Default is false. If set to true rmdir(), mkdir(), and pathempty() calls in pathrm() and pathmk() do not return() on failure.
 
If its set to true they just silently go about their business regardless. This isn't a good idea but it's there if you want it.
 
=head3 $DirPerms
 
Mode to pass to any mkdir() calls. Defaults to 0777 as per umask()'s POD. Explicitly having this allows older perls to be able to use FCR and might add a bit of flexibility for you.
 
Any value you set it to should be suitable for oct().
 
=head3 Path functions
 
These functions exist solely because they were necessary for the move and copy functions to have the features they do and not because they are of themselves the purpose of this module. That being said, here is how they work so you can understand how the copy and move functions work and use them by themselves if you wish.
 
=head4 pathrm()
 
Removes a given path recursively. It removes the *entire* path so be careful!!!
 
Returns 2 if the given path is not a directory.
 
File::Copy::Recursive::pathrm('foo/bar/baz') or die $!;
# foo no longer exists
 
Same as:
 
rmdir 'foo/bar/baz' or die $!;
rmdir 'foo/bar' or die $!;
rmdir 'foo' or die $!;
 
An optional second argument makes it call pathempty() before any rmdir()'s when set to true.
 
File::Copy::Recursive::pathrm('foo/bar/baz', 1) or die $!;
# foo no longer exists
 
Same as:PFSCheck
 
File::Copy::Recursive::pathempty('foo/bar/baz') or die $!;
rmdir 'foo/bar/baz' or die $!;
File::Copy::Recursive::pathempty('foo/bar/') or die $!;
rmdir 'foo/bar' or die $!;
File::Copy::Recursive::pathempty('foo/') or die $!;
rmdir 'foo' or die $!;
 
An optional third argument acts like $File::Copy::Recursive::NoFtlPth, again probably not a good idea.
 
=head4 pathempty()
 
Recursively removes the given directory's contents so it is empty. Returns 2 if the given argument is not a directory, 1 on successfully emptying the directory.
 
File::Copy::Recursive::pathempty($pth) or die $!;
# $pth is now an empty directory
 
=head4 pathmk()
 
Creates a given path recursively. Creates foo/bar/baz even if foo does not exist.
 
File::Copy::Recursive::pathmk('foo/bar/baz') or die $!;
 
An optional second argument if true acts just like $File::Copy::Recursive::NoFtlPth, which means you'd never get your die() if something went wrong. Again, probably a *bad* idea.
 
=head4 pathrmdir()
 
Same as rmdir() but it calls pathempty() first to recursively empty it first since rmdir can not remove a directory with contents.
Just removes the top directory the path given instead of the entire path like pathrm(). Returns 2 if the given argument does not exist (i.e. it's already gone). Returns false if it exists but is not a directory.
 
=head2 Preserving Mode
 
By default a quiet attempt is made to change the new file or directory to the mode of the old one.
To turn this behavior off set
$File::Copy::Recursive::KeepMode
to false;
 
=head2 Managing Depth
 
You can set the maximum depth a directory structure is recursed by setting:
$File::Copy::Recursive::MaxDepth
to a whole number greater than 0.
 
=head2 SymLinks
 
If your system supports symlinks then symlinks will be copied as symlinks instead of as the target file.
Perl's symlink() is used instead of File::Copy's copy().
You can customize this behavior by setting $File::Copy::Recursive::CopyLink to a true or false value.
It is already set to true or false depending on your system's support of symlinks so you can check it with an if statement to see how it will behave:
 
if($File::Copy::Recursive::CopyLink) {
print "Symlinks will be preserved\n";
} else {
print "Symlinks will not be preserved because your system does not support it\n";
}
 
If symlinks are being copied you can set $File::Copy::Recursive::BdTrgWrn to true to make it carp when it copies a link whose target does not exist. It's false by default.
 
local $File::Copy::Recursive::BdTrgWrn = 1;
 
=head2 Removing existing target file or directory before copying.
 
This can be done by setting $File::Copy::Recursive::RMTrgFil or $File::Copy::Recursive::RMTrgDir for file or directory behavior respectively.
 
0 = off (This is the default)
 
1 = carp() $! if removal fails
 
2 = return if removal fails
 
local $File::Copy::Recursive::RMTrgFil = 1;
fcopy($orig, $target) or die $!;
# if it fails it does warn() and keeps going
 
local $File::Copy::Recursive::RMTrgDir = 2;
dircopy($orig, $target) or die $!;
# if it fails it does your "or die"
 
This should be unnecessary most of the time but it's there if you need it :)
 
=head2 Turning off stat() check
 
By default the files or directories are checked to see if they are the same (i.e. linked, or two paths (absolute/relative or different relative paths) to the same file) by comparing the file's stat() info.
It's a very efficient check that croaks if they are and shouldn't be turned off but if you must for some weird reason just set $File::Copy::Recursive::PFSCheck to a false value. ("PFS" stands for "Physical File System")
 
=head2 Emulating cp -rf dir1/ dir2/
 
By default dircopy($dir1,$dir2) will put $dir1's contents right into $dir2 whether $dir2 exists or not.
 
You can make dircopy() emulate cp -rf by setting $File::Copy::Recursive::CPRFComp to true.
 
NOTE: This only emulates -f in the sense that it does not prompt. It does not remove the target file or directory if it exists.
If you need to do that then use the variables $RMTrgFil and $RMTrgDir described in "Removing existing target file or directory before copying" above.
 
That means that if $dir2 exists it puts the contents into $dir2/$dir1 instead of $dir2 just like cp -rf.
If $dir2 does not exist then the contents go into $dir2 like normal (also like cp -rf).
 
So assuming 'foo/file':
 
dircopy('foo', 'bar') or die $!;
# if bar does not exist the result is bar/file
# if bar does exist the result is bar/file
 
$File::Copy::Recursive::CPRFComp = 1;
dircopy('foo', 'bar') or die $!;
# if bar does not exist the result is bar/file
# if bar does exist the result is bar/foo/file
 
You can also specify a star for cp -rf glob type behavior:
 
dircopy('foo/*', 'bar') or die $!;
# if bar does not exist the result is bar/file
# if bar does exist the result is bar/file
 
$File::Copy::Recursive::CPRFComp = 1;
dircopy('foo/*', 'bar') or die $!;
# if bar does not exist the result is bar/file
# if bar does exist the result is bar/file
 
NOTE: The '*' is only like cp -rf foo/* and *DOES NOT EXPAND PARTIAL DIRECTORY NAMES LIKE YOUR SHELL DOES* (i.e. not like cp -rf fo* to copy foo/*).
 
=head2 Allowing Copy Loops
 
If you want to allow:
 
cp -rf . foo/
 
type behavior set $File::Copy::Recursive::CopyLoop to true.
 
This is false by default so that a check is done to see if the source directory will contain the target directory and croaks to avoid this problem.
 
If you ever find a situation where $CopyLoop = 1 is desirable let me know. (i.e. it's a bad bad idea but is there if you want it)
 
(Note: On Windows this was necessary since it uses stat() to determine sameness and stat() is essentially useless for this on Windows.
The test is now simply skipped on Windows but I'd rather have an actual reliable check if anyone in Microsoft land would care to share)
 
=head1 SEE ALSO
 
L<File::Copy> L<File::Spec>
 
=head1 TO DO
 
I am currently working on and reviewing some other modules to use in the new interface so we can lose the horrid globals as well as some other undesirable traits and also more easily make available some long standing requests.
 
Tests will be easier to do with the new interface and hence the testing focus will shift to the new interface and aim to be comprehensive.
 
The old interface will work, it just won't be brought in until it is used, so it will add no overhead for users of the new interface.
 
I'll add this after the latest version has been out for a while with no new features or issues found :)
 
=head1 AUTHOR
 
Daniel Muey, L<http://drmuey.com/cpan_contact.pl>
 
=head1 COPYRIGHT AND LICENSE
 
Copyright 2004 by Daniel Muey
 
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
 
=cut
/perl_lib/File/Find/Rule/Extending.pod
0,0 → 1,91
=head1 NAME
 
File::Find::Rule::Extending - the mini-guide to extending File::Find::Rule
 
=head1 SYNOPSIS
 
package File::Find::Rule::Random;
use strict;
# take useful things from File::Find::Rule
use base 'File::Find::Rule';
 
# and force our crack into the main namespace
sub File::Find::Rule::random () {
my $self = shift()->_force_object;
$self->exec( sub { rand > 0.5 } );
}
1;
 
=head1 DESCRIPTION
 
File::Find::Rule went down so well with the buying public that
everyone wanted to add extra features. With the 0.07 release this
became a possibility, using the following conventions.
 
=head2 Declare your package
 
package File::Find::Rule::Random;
use strict;
 
=head2 Inherit methods from File::Find::Rule
 
# take useful things from File::Find::Rule
use base 'File::Find::Rule';
=head3 Force your madness into the main package
 
# and force our crack into the main namespace
sub File::Find::Rule::random () {
my $self = shift()->_force_object;
$self->exec( sub { rand > 0.5 } );
}
 
Yes, we're being very cavalier here and defining things into the main
File::Find::Rule namespace. This is due to lack of imaginiation on my
part - I simply can't find a way for the functional and oo interface
to work without doing this or some kind of inheritance, and
inheritance stops you using two File::Find::Rule::Foo modules
together.
 
For this reason try and pick distinct names for your extensions. If
this becomes a problem then I may institute a semi-official registry
of taken names.
 
=head2 Taking no arguments.
 
Note the null prototype on random. This is a cheat for the procedural
interface to know that your sub takes no arguments, and so allows this
to happen:
 
find( random => in => '.' );
 
If you hadn't declared C<random> with a null prototype it would have
consumed C<in> as a parameter to it, then got all confused as it
doesn't know about a C<'.'> rule.
 
=head1 AUTHOR
 
Richard Clamp <richardc@unixbeard.net>
 
=head1 COPYRIGHT
 
Copyright (C) 2002 Richard Clamp. All Rights Reserved.
 
This module is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
 
=head1 SEE ALSO
 
L<File::Find::Rule>
 
L<File::Find::Rule::MMagic> was the first extension module, so maybe
check that out.
 
=cut
 
 
 
 
/perl_lib/File/Find/Rule/Procedural.pod
0,0 → 1,72
=head1 NAME
 
File::Find::Rule::Procedural - File::Find::Rule's procedural interface
 
=head1 SYNOPSIS
 
use File::Find::Rule;
 
# find all .pm files, procedurally
my @files = find(file => name => '*.pm', in => \@INC);
 
=head1 DESCRIPTION
 
In addition to the regular object-oriented interface,
L<File::Find::Rule> provides two subroutines for you to use.
 
=over
 
=item C<find( @clauses )>
 
=item C<rule( @clauses )>
 
C<find> and C<rule> can be used to invoke any methods available to the
OO version. C<rule> is a synonym for C<find>
 
=back
 
Passing more than one value to a clause is done with an anonymous
array:
 
my $finder = find( name => [ '*.mp3', '*.ogg' ] );
 
C<find> and C<rule> both return a File::Find::Rule instance, unless
one of the arguments is C<in>, in which case it returns a list of
things that match the rule.
 
my @files = find( name => [ '*.mp3', '*.ogg' ], in => $ENV{HOME} );
 
Please note that C<in> will be the last clause evaluated, and so this
code will search for mp3s regardless of size.
 
my @files = find( name => '*.mp3', in => $ENV{HOME}, size => '<2k' );
^
|
Clause processing stopped here ------/
 
It is also possible to invert a single rule by prefixing it with C<!>
like so:
 
# large files that aren't videos
my @files = find( file =>
'!name' => [ '*.avi', '*.mov' ],
size => '>20M',
in => $ENV{HOME} );
 
 
=head1 AUTHOR
 
Richard Clamp <richardc@unixbeard.net>
 
=head1 COPYRIGHT
 
Copyright (C) 2003 Richard Clamp. All Rights Reserved.
 
This module is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
 
=head1 SEE ALSO
 
L<File::Find::Rule>
 
=cut
/perl_lib/File/Find/Rule.pm
0,0 → 1,817
# $Id$
 
package File::Find::Rule;
use strict;
use File::Spec;
use Text::Glob 'glob_to_regex';
use Number::Compare;
use Carp qw/croak/;
use File::Find (); # we're only wrapping for now
 
our $VERSION = '0.34';
 
# we'd just inherit from Exporter, but I want the colon
sub import {
my $pkg = shift;
my $to = caller;
for my $sym ( qw( find rule ) ) {
no strict 'refs';
*{"$to\::$sym"} = \&{$sym};
}
for (grep /^:/, @_) {
my ($extension) = /^:(.*)/;
eval "require File::Find::Rule::$extension";
croak "couldn't bootstrap File::Find::Rule::$extension: $@" if $@;
}
}
 
=head1 NAME
 
File::Find::Rule - Alternative interface to File::Find
 
=head1 SYNOPSIS
 
use File::Find::Rule;
# find all the subdirectories of a given directory
my @subdirs = File::Find::Rule->directory->in( $directory );
 
# find all the .pm files in @INC
my @files = File::Find::Rule->file()
->name( '*.pm' )
->in( @INC );
 
# as above, but without method chaining
my $rule = File::Find::Rule->new;
$rule->file;
$rule->name( '*.pm' );
my @files = $rule->in( @INC );
 
=head1 DESCRIPTION
 
File::Find::Rule is a friendlier interface to File::Find. It allows
you to build rules which specify the desired files and directories.
 
=cut
 
# the procedural shim
 
*rule = \&find;
sub find {
my $object = __PACKAGE__->new();
my $not = 0;
 
while (@_) {
my $method = shift;
my @args;
 
if ($method =~ s/^\!//) {
# jinkies, we're really negating this
unshift @_, $method;
$not = 1;
next;
}
unless (defined prototype $method) {
my $args = shift;
@args = ref $args eq 'ARRAY' ? @$args : $args;
}
if ($not) {
$not = 0;
@args = $object->new->$method(@args);
$method = "not";
}
 
my @return = $object->$method(@args);
return @return if $method eq 'in';
}
$object;
}
 
 
=head1 METHODS
 
=over
 
=item C<new>
 
A constructor. You need not invoke C<new> manually unless you wish
to, as each of the rule-making methods will auto-create a suitable
object if called as class methods.
 
=cut
 
sub new {
my $referent = shift;
my $class = ref $referent || $referent;
bless {
rules => [],
subs => {},
iterator => [],
extras => {},
maxdepth => undef,
mindepth => undef,
}, $class;
}
 
sub _force_object {
my $object = shift;
$object = $object->new()
unless ref $object;
$object;
}
 
=back
 
=head2 Matching Rules
 
=over
 
=item C<name( @patterns )>
 
Specifies names that should match. May be globs or regular
expressions.
 
$set->name( '*.mp3', '*.ogg' ); # mp3s or oggs
$set->name( qr/\.(mp3|ogg)$/ ); # the same as a regex
$set->name( 'foo.bar' ); # just things named foo.bar
 
=cut
 
sub _flatten {
my @flat;
while (@_) {
my $item = shift;
ref $item eq 'ARRAY' ? push @_, @{ $item } : push @flat, $item;
}
return @flat;
}
 
sub name {
my $self = _force_object shift;
my @names = map { ref $_ eq "Regexp" ? $_ : glob_to_regex $_ } _flatten( @_ );
 
push @{ $self->{rules} }, {
rule => 'name',
code => join( ' || ', map { "m{$_}" } @names ),
args => \@_,
};
 
$self;
}
 
=item -X tests
 
Synonyms are provided for each of the -X tests. See L<perlfunc/-X> for
details. None of these methods take arguments.
 
Test | Method Test | Method
------|------------- ------|----------------
-r | readable -R | r_readable
-w | writeable -W | r_writeable
-w | writable -W | r_writable
-x | executable -X | r_executable
-o | owned -O | r_owned
| |
-e | exists -f | file
-z | empty -d | directory
-s | nonempty -l | symlink
| -p | fifo
-u | setuid -S | socket
-g | setgid -b | block
-k | sticky -c | character
| -t | tty
-M | modified |
-A | accessed -T | ascii
-C | changed -B | binary
 
Though some tests are fairly meaningless as binary flags (C<modified>,
C<accessed>, C<changed>), they have been included for completeness.
 
# find nonempty files
$rule->file,
->nonempty;
 
=cut
 
use vars qw( %X_tests );
%X_tests = (
-r => readable => -R => r_readable =>
-w => writeable => -W => r_writeable =>
-w => writable => -W => r_writable =>
-x => executable => -X => r_executable =>
-o => owned => -O => r_owned =>
 
-e => exists => -f => file =>
-z => empty => -d => directory =>
-s => nonempty => -l => symlink =>
=> -p => fifo =>
-u => setuid => -S => socket =>
-g => setgid => -b => block =>
-k => sticky => -c => character =>
=> -t => tty =>
-M => modified =>
-A => accessed => -T => ascii =>
-C => changed => -B => binary =>
);
 
for my $test (keys %X_tests) {
my $sub = eval 'sub () {
my $self = _force_object shift;
push @{ $self->{rules} }, {
code => "' . $test . ' \$_",
rule => "'.$X_tests{$test}.'",
};
$self;
} ';
no strict 'refs';
*{ $X_tests{$test} } = $sub;
}
 
 
=item stat tests
 
The following C<stat> based methods are provided: C<dev>, C<ino>,
C<mode>, C<nlink>, C<uid>, C<gid>, C<rdev>, C<size>, C<atime>,
C<mtime>, C<ctime>, C<blksize>, and C<blocks>. See L<perlfunc/stat>
for details.
 
Each of these can take a number of targets, which will follow
L<Number::Compare> semantics.
 
$rule->size( 7 ); # exactly 7
$rule->size( ">7Ki" ); # larger than 7 * 1024 * 1024 bytes
$rule->size( ">=7" )
->size( "<=90" ); # between 7 and 90, inclusive
$rule->size( 7, 9, 42 ); # 7, 9 or 42
 
=cut
 
use vars qw( @stat_tests );
@stat_tests = qw( dev ino mode nlink uid gid rdev
size atime mtime ctime blksize blocks );
{
my $i = 0;
for my $test (@stat_tests) {
my $index = $i++; # to close over
my $sub = sub {
my $self = _force_object shift;
 
my @tests = map { Number::Compare->parse_to_perl($_) } @_;
 
push @{ $self->{rules} }, {
rule => $test,
args => \@_,
code => 'do { my $val = (stat $_)['.$index.'] || 0;'.
join ('||', map { "(\$val $_)" } @tests ).' }',
};
$self;
};
no strict 'refs';
*$test = $sub;
}
}
 
=item C<any( @rules )>
 
=item C<or( @rules )>
 
Allows shortcircuiting boolean evaluation as an alternative to the
default and-like nature of combined rules. C<any> and C<or> are
interchangeable.
 
# find avis, movs, things over 200M and empty files
$rule->any( File::Find::Rule->name( '*.avi', '*.mov' ),
File::Find::Rule->size( '>200M' ),
File::Find::Rule->file->empty,
);
 
=cut
 
sub any {
my $self = _force_object shift;
# compile all the subrules to code fragments
push @{ $self->{rules} }, {
rule => "any",
code => '(' . join( ' || ', map '( ' . $_->_compile . ' )', @_ ). ')',
args => \@_,
};
 
# merge all the subs hashes of the kids into ourself
%{ $self->{subs} } = map { %{ $_->{subs} } } $self, @_;
$self;
}
 
*or = \&any;
 
=item C<none( @rules )>
 
=item C<not( @rules )>
 
Negates a rule. (The inverse of C<any>.) C<none> and C<not> are
interchangeable.
 
# files that aren't 8.3 safe
$rule->file
->not( $rule->new->name( qr/^[^.]{1,8}(\.[^.]{0,3})?$/ ) );
 
=cut
 
sub not {
my $self = _force_object shift;
 
push @{ $self->{rules} }, {
rule => 'not',
args => \@_,
code => '(' . join ( ' && ', map { "!(". $_->_compile . ")" } @_ ) . ")",
};
 
# merge all the subs hashes into us
%{ $self->{subs} } = map { %{ $_->{subs} } } $self, @_;
$self;
}
 
*none = \&not;
 
=item C<prune>
 
Traverse no further. This rule always matches.
 
=cut
 
sub prune () {
my $self = _force_object shift;
 
push @{ $self->{rules} },
{
rule => 'prune',
code => '$File::Find::prune = 1'
};
$self;
}
 
=item C<discard>
 
Don't keep this file. This rule always matches.
 
=cut
 
sub discard () {
my $self = _force_object shift;
 
push @{ $self->{rules} }, {
rule => 'discard',
code => '$discarded = 1',
};
$self;
}
 
=item C<exec( \&subroutine( $shortname, $path, $fullname ) )>
 
Allows user-defined rules. Your subroutine will be invoked with C<$_>
set to the current short name, and with parameters of the name, the
path you're in, and the full relative filename.
 
Return a true value if your rule matched.
 
# get things with long names
$rules->exec( sub { length > 20 } );
 
=cut
 
sub exec {
my $self = _force_object shift;
my $code = shift;
 
push @{ $self->{rules} }, {
rule => 'exec',
code => $code,
};
$self;
}
 
=item C<grep( @specifiers )>
 
Opens a file and tests it each line at a time.
 
For each line it evaluates each of the specifiers, stopping at the
first successful match. A specifier may be a regular expression or a
subroutine. The subroutine will be invoked with the same parameters
as an ->exec subroutine.
 
It is possible to provide a set of negative specifiers by enclosing
them in anonymous arrays. Should a negative specifier match the
iteration is aborted and the clause is failed. For example:
 
$rule->grep( qr/^#!.*\bperl/, [ sub { 1 } ] );
 
Is a passing clause if the first line of a file looks like a perl
shebang line.
 
=cut
 
sub grep {
my $self = _force_object shift;
my @pattern = map {
ref $_
? ref $_ eq 'ARRAY'
? map { [ ( ref $_ ? $_ : qr/$_/ ) => 0 ] } @$_
: [ $_ => 1 ]
: [ qr/$_/ => 1 ]
} @_;
 
$self->exec( sub {
local *FILE;
open FILE, $_ or return;
local ($_, $.);
while (<FILE>) {
for my $p (@pattern) {
my ($rule, $ret) = @$p;
return $ret
if ref $rule eq 'Regexp'
? /$rule/
: $rule->(@_);
}
}
return;
} );
}
 
=item C<maxdepth( $level )>
 
Descend at most C<$level> (a non-negative integer) levels of directories
below the starting point.
 
May be invoked many times per rule, but only the most recent value is
used.
 
=item C<mindepth( $level )>
 
Do not apply any tests at levels less than C<$level> (a non-negative
integer).
 
=item C<extras( \%extras )>
 
Specifies extra values to pass through to C<File::File::find> as part
of the options hash.
 
For example this allows you to specify following of symlinks like so:
 
my $rule = File::Find::Rule->extras({ follow => 1 });
 
May be invoked many times per rule, but only the most recent value is
used.
 
=cut
 
for my $setter (qw( maxdepth mindepth extras )) {
my $sub = sub {
my $self = _force_object shift;
$self->{$setter} = shift;
$self;
};
no strict 'refs';
*$setter = $sub;
}
 
 
=item C<relative>
 
Trim the leading portion of any path found
 
=cut
 
sub relative () {
my $self = _force_object shift;
$self->{relative} = 1;
$self;
}
 
=item C<canonpath>
 
Normalize paths found using C<File::Spec->canonpath>. This will return paths
with a file-seperator that is native to your OS (as determined by L<File::Spec>),
instead of the default C</>.
 
For example, this will return C<tmp/foobar> on Unix-ish OSes
and C<tmp\foobar> on Win32.
 
=cut
 
sub canonpath () {
my $self = _force_object shift;
$self->{canonpath} = 1;
$self;
}
 
=item C<not_*>
 
Negated version of the rule. An effective shortand related to ! in
the procedural interface.
 
$foo->not_name('*.pl');
 
$foo->not( $foo->new->name('*.pl' ) );
 
=cut
 
sub DESTROY {}
sub AUTOLOAD {
our $AUTOLOAD;
$AUTOLOAD =~ /::not_([^:]*)$/
or croak "Can't locate method $AUTOLOAD";
my $method = $1;
 
my $sub = sub {
my $self = _force_object shift;
$self->not( $self->new->$method(@_) );
};
{
no strict 'refs';
*$AUTOLOAD = $sub;
}
&$sub;
}
 
=back
 
=head2 Query Methods
 
=over
 
=item C<in( @directories )>
 
Evaluates the rule, returns a list of paths to matching files and
directories.
 
=cut
 
sub in {
my $self = _force_object shift;
 
my @found;
my $fragment = $self->_compile;
my %subs = %{ $self->{subs} };
 
warn "relative mode handed multiple paths - that's a bit silly\n"
if $self->{relative} && @_ > 1;
 
my $topdir;
my $code = 'sub {
(my $path = $File::Find::name) =~ s#^(?:\./+)+##;
my @args = ($_, $File::Find::dir, $path);
my $maxdepth = $self->{maxdepth};
my $mindepth = $self->{mindepth};
my $relative = $self->{relative};
my $canonpath = $self->{canonpath};
 
# figure out the relative path and depth
my $relpath = $File::Find::name;
$relpath =~ s{^\Q$topdir\E/?}{};
my $depth = scalar File::Spec->splitdir($relpath);
#print "name: \'$File::Find::name\' ";
#print "relpath: \'$relpath\' depth: $depth relative: $relative\n";
 
defined $maxdepth && $depth >= $maxdepth
and $File::Find::prune = 1;
 
defined $mindepth && $depth < $mindepth
and return;
 
#print "Testing \'$_\'\n";
 
my $discarded;
return unless ' . $fragment . ';
return if $discarded;
if ($relative) {
if ($relpath ne "") {
push @found, $canonpath ? File::Spec->canonpath($relpath) : $relpath;
}
}
else {
push @found, $canonpath ? File::Spec->canonpath($path) : $path;
}
}';
 
#use Data::Dumper;
#print Dumper \%subs;
#warn "Compiled sub: '$code'\n";
 
my $sub = eval "$code" or die "compile error '$code' $@";
for my $path (@_) {
# $topdir is used for relative and maxdepth
$topdir = $path;
# slice off the trailing slash if there is one (the
# maxdepth/mindepth code is fussy)
$topdir =~ s{/?$}{}
unless $topdir eq '/';
$self->_call_find( { %{ $self->{extras} }, wanted => $sub }, $path );
}
 
return @found;
}
 
sub _call_find {
my $self = shift;
File::Find::find( @_ );
}
 
sub _compile {
my $self = shift;
 
return '1' unless @{ $self->{rules} };
my $code = join " && ", map {
if (ref $_->{code}) {
my $key = "$_->{code}";
$self->{subs}{$key} = $_->{code};
"\$subs{'$key'}->(\@args) # $_->{rule}\n";
}
else {
"( $_->{code} ) # $_->{rule}\n";
}
} @{ $self->{rules} };
 
#warn $code;
return $code;
}
 
=item C<start( @directories )>
 
Starts a find across the specified directories. Matching items may
then be queried using L</match>. This allows you to use a rule as an
iterator.
 
my $rule = File::Find::Rule->file->name("*.jpeg")->start( "/web" );
while ( defined ( my $image = $rule->match ) ) {
...
}
 
=cut
 
sub start {
my $self = _force_object shift;
 
$self->{iterator} = [ $self->in( @_ ) ];
$self;
}
 
=item C<match>
 
Returns the next file which matches, false if there are no more.
 
=cut
 
sub match {
my $self = _force_object shift;
 
return shift @{ $self->{iterator} };
}
 
1;
 
__END__
 
=back
 
=head2 Extensions
 
Extension modules are available from CPAN in the File::Find::Rule
namespace. In order to use these extensions either use them directly:
 
use File::Find::Rule::ImageSize;
use File::Find::Rule::MMagic;
 
# now your rules can use the clauses supplied by the ImageSize and
# MMagic extension
 
or, specify that File::Find::Rule should load them for you:
 
use File::Find::Rule qw( :ImageSize :MMagic );
 
For notes on implementing your own extensions, consult
L<File::Find::Rule::Extending>
 
=head2 Further examples
 
=over
 
=item Finding perl scripts
 
my $finder = File::Find::Rule->or
(
File::Find::Rule->name( '*.pl' ),
File::Find::Rule->exec(
sub {
if (open my $fh, $_) {
my $shebang = <$fh>;
close $fh;
return $shebang =~ /^#!.*\bperl/;
}
return 0;
} ),
);
 
Based upon this message http://use.perl.org/comments.pl?sid=7052&cid=10842
 
=item ignore CVS directories
 
my $rule = File::Find::Rule->new;
$rule->or($rule->new
->directory
->name('CVS')
->prune
->discard,
$rule->new);
 
Note here the use of a null rule. Null rules match anything they see,
so the effect is to match (and discard) directories called 'CVS' or to
match anything.
 
=back
 
=head1 TWO FOR THE PRICE OF ONE
 
File::Find::Rule also gives you a procedural interface. This is
documented in L<File::Find::Rule::Procedural>
 
=head1 EXPORTS
 
L</find>, L</rule>
 
=head1 TAINT MODE INTERACTION
 
As of 0.32 File::Find::Rule doesn't capture the current working directory in
a taint-unsafe manner. File::Find itself still does operations that the taint
system will flag as insecure but you can use the L</extras> feature to ask
L<File::Find> to internally C<untaint> file paths with a regex like so:
 
my $rule = File::Find::Rule->extras({ untaint => 1 });
 
Please consult L<File::Find>'s documentation for C<untaint>,
C<untaint_pattern>, and C<untaint_skip> for more information.
 
=head1 BUGS
 
The code makes use of the C<our> keyword and as such requires perl version
5.6.0 or newer.
 
Currently it isn't possible to remove a clause from a rule object. If
this becomes a significant issue it will be addressed.
 
=head1 AUTHOR
 
Richard Clamp <richardc@unixbeard.net> with input gained from this
use.perl discussion: http://use.perl.org/~richardc/journal/6467
 
Additional proofreading and input provided by Kake, Greg McCarroll,
and Andy Lester andy@petdance.com.
 
=head1 COPYRIGHT
 
Copyright (C) 2002, 2003, 2004, 2006, 2009, 2011 Richard Clamp. All Rights Reserved.
 
This module is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
 
=head1 SEE ALSO
 
L<File::Find>, L<Text::Glob>, L<Number::Compare>, find(1)
 
If you want to know about the procedural interface, see
L<File::Find::Rule::Procedural>, and if you have an idea for a neat
extension L<File::Find::Rule::Extending>
 
=cut
 
Implementation notes:
 
$self->rules is an array of hashrefs. it may be a code fragment or a call
to a subroutine.
 
Anonymous subroutines are stored in the $self->subs hashref keyed on the
stringfied version of the coderef.
 
When one File::Find::Rule object is combined with another, such as in the any
and not operations, this entire hash is merged.
 
The _compile method walks the rules element and simply glues the code
fragments together so they can be compiled into an anyonymous File::Find
match sub for speed
 
 
[*] There's probably a win to be made with the current model in making
stat calls use C<_>. For
 
find( file => size => "> 20M" => size => "< 400M" );
 
up to 3 stats will happen for each candidate. Adding a priming _
would be a bit blind if the first operation was C< name => 'foo' >,
since that can be tested by a single regex. Simply checking what the
next type of operation doesn't work since any arbritary exec sub may
or may not stat. Potentially worse, they could stat something else
like so:
 
# extract from the worlds stupidest make(1)
find( exec => sub { my $f = $_; $f =~ s/\.c$/.o/ && !-e $f } );
 
Maybe the best way is to treat C<_> as invalid after calling an exec,
and doc that C<_> will only be meaningful after stat and -X tests if
they're wanted in exec blocks.
/perl_lib/List/MoreUtils/PP.pm
0,0 → 1,953
package List::MoreUtils::PP;
 
use 5.008_001;
use strict;
use warnings;
 
our $VERSION = '0.430';
 
=pod
 
=head1 NAME
 
List::MoreUtils::PP - Provide List::MoreUtils pure Perl implementation
 
=head1 SYNOPSIS
 
BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; }
use List::MoreUtils qw(:all);
 
=cut
 
## no critic (Subroutines::ProhibitSubroutinePrototypes, Subroutines::RequireArgUnpacking)
## no critic (Subroutines::ProhibitManyArgs)
 
sub any (&@)
{
my $f = shift;
foreach (@_)
{
return 1 if $f->();
}
return 0;
}
 
sub all (&@)
{
my $f = shift;
foreach (@_)
{
return 0 unless $f->();
}
return 1;
}
 
sub none (&@)
{
my $f = shift;
foreach (@_)
{
return 0 if $f->();
}
return 1;
}
 
sub notall (&@)
{
my $f = shift;
foreach (@_)
{
return 1 unless $f->();
}
return 0;
}
 
sub one (&@)
{
my $f = shift;
my $found = 0;
foreach (@_)
{
$f->() and $found++ and return 0;
}
return $found;
}
 
sub any_u (&@)
{
my $f = shift;
return if !@_;
$f->() and return 1 foreach (@_);
return 0;
}
 
sub all_u (&@)
{
my $f = shift;
return if !@_;
$f->() or return 0 foreach (@_);
return 1;
}
 
sub none_u (&@)
{
my $f = shift;
return if !@_;
$f->() and return 0 foreach (@_);
return 1;
}
 
sub notall_u (&@)
{
my $f = shift;
return if !@_;
$f->() or return 1 foreach (@_);
return 0;
}
 
sub one_u (&@)
{
my $f = shift;
return if !@_;
my $found = 0;
foreach (@_)
{
$f->() and $found++ and return 0;
}
return $found;
}
 
sub reduce_u(&@)
{
my $code = shift;
 
# Localise $a, $b
my ($caller_a, $caller_b) = do
{
my $pkg = caller();
## no critic (TestingAndDebugging::ProhibitNoStrict, ValuesAndExpressions::ProhibitCommaSeparatedStatements)
no strict 'refs';
\*{$pkg . '::a'}, \*{$pkg . '::b'};
};
 
## no critic (Variables::RequireInitializationForLocalVars)
local (*$caller_a, *$caller_b);
*$caller_a = \();
for (0 .. $#_)
{
*$caller_b = \$_[$_];
*$caller_a = \($code->());
}
 
return ${*$caller_a};
}
 
sub reduce_0(&@)
{
my $code = shift;
 
# Localise $a, $b
my ($caller_a, $caller_b) = do
{
my $pkg = caller();
## no critic (TestingAndDebugging::ProhibitNoStrict, ValuesAndExpressions::ProhibitCommaSeparatedStatements)
no strict 'refs';
\*{$pkg . '::a'}, \*{$pkg . '::b'};
};
 
## no critic (Variables::RequireInitializationForLocalVars)
local (*$caller_a, *$caller_b);
*$caller_a = \0;
for (0 .. $#_)
{
*$caller_b = \$_[$_];
*$caller_a = \($code->());
}
 
return ${*$caller_a};
}
 
sub reduce_1(&@)
{
my $code = shift;
 
# Localise $a, $b
my ($caller_a, $caller_b) = do
{
my $pkg = caller();
## no critic (TestingAndDebugging::ProhibitNoStrict, ValuesAndExpressions::ProhibitCommaSeparatedStatements)
no strict 'refs';
\*{$pkg . '::a'}, \*{$pkg . '::b'};
};
 
## no critic (Variables::RequireInitializationForLocalVars)
local (*$caller_a, *$caller_b);
*$caller_a = \1;
for (0 .. $#_)
{
*$caller_b = \$_[$_];
*$caller_a = \($code->());
}
 
return ${*$caller_a};
}
 
sub true (&@)
{
my $f = shift;
my $count = 0;
$f->() and ++$count foreach (@_);
return $count;
}
 
sub false (&@)
{
my $f = shift;
my $count = 0;
$f->() or ++$count foreach (@_);
return $count;
}
 
sub firstidx (&@)
{
my $f = shift;
foreach my $i (0 .. $#_)
{
local *_ = \$_[$i];
return $i if $f->();
}
return -1;
}
 
sub firstval (&@)
{
my $test = shift;
foreach (@_)
{
return $_ if $test->();
}
## no critic (Subroutines::ProhibitExplicitReturnUndef)
return undef;
}
 
sub firstres (&@)
{
my $test = shift;
foreach (@_)
{
my $testval = $test->();
$testval and return $testval;
}
## no critic (Subroutines::ProhibitExplicitReturnUndef)
return undef;
}
 
sub onlyidx (&@)
{
my $f = shift;
my $found;
foreach my $i (0 .. $#_)
{
local *_ = \$_[$i];
$f->() or next;
defined $found and return -1;
$found = $i;
}
return defined $found ? $found : -1;
}
 
sub onlyval (&@)
{
my $test = shift;
my $result = undef;
my $found = 0;
foreach (@_)
{
$test->() or next;
$result = $_;
## no critic (Subroutines::ProhibitExplicitReturnUndef)
$found++ and return undef;
}
return $result;
}
 
sub onlyres (&@)
{
my $test = shift;
my $result = undef;
my $found = 0;
foreach (@_)
{
my $rv = $test->() or next;
$result = $rv;
## no critic (Subroutines::ProhibitExplicitReturnUndef)
$found++ and return undef;
}
return $found ? $result : undef;
}
 
sub lastidx (&@)
{
my $f = shift;
foreach my $i (reverse 0 .. $#_)
{
local *_ = \$_[$i];
return $i if $f->();
}
return -1;
}
 
sub lastval (&@)
{
my $test = shift;
my $ix;
for ($ix = $#_; $ix >= 0; $ix--)
{
local *_ = \$_[$ix];
my $testval = $test->();
 
# Simulate $_ as alias
$_[$ix] = $_;
return $_ if $testval;
}
## no critic (Subroutines::ProhibitExplicitReturnUndef)
return undef;
}
 
sub lastres (&@)
{
my $test = shift;
my $ix;
for ($ix = $#_; $ix >= 0; $ix--)
{
local *_ = \$_[$ix];
my $testval = $test->();
 
# Simulate $_ as alias
$_[$ix] = $_;
return $testval if $testval;
}
## no critic (Subroutines::ProhibitExplicitReturnUndef)
return undef;
}
 
sub insert_after (&$\@)
{
my ($f, $val, $list) = @_;
my $c = &firstidx($f, @$list);
@$list = (@{$list}[0 .. $c], $val, @{$list}[$c + 1 .. $#$list],) and return 1 if $c != -1;
return 0;
}
 
sub insert_after_string ($$\@)
{
my ($string, $val, $list) = @_;
my $c = firstidx { defined $_ and $string eq $_ } @$list;
@$list = (@{$list}[0 .. $c], $val, @{$list}[$c + 1 .. $#$list],) and return 1 if $c != -1;
return 0;
}
 
sub apply (&@)
{
my $action = shift;
&$action foreach my @values = @_;
return wantarray ? @values : $values[-1];
}
 
sub after (&@)
{
my $test = shift;
my $started;
my $lag;
## no critic (BuiltinFunctions::RequireBlockGrep)
return grep $started ||= do
{
my $x = $lag;
$lag = $test->();
$x;
}, @_;
}
 
sub after_incl (&@)
{
my $test = shift;
my $started;
return grep { $started ||= $test->() } @_;
}
 
sub before (&@)
{
my $test = shift;
my $more = 1;
return grep { $more &&= !$test->() } @_;
}
 
sub before_incl (&@)
{
my $test = shift;
my $more = 1;
my $lag = 1;
## no critic (BuiltinFunctions::RequireBlockGrep)
return grep $more &&= do
{
my $x = $lag;
$lag = !$test->();
$x;
}, @_;
}
 
sub indexes (&@)
{
my $test = shift;
return grep {
local *_ = \$_[$_];
$test->()
} 0 .. $#_;
}
 
sub pairwise (&\@\@)
{
my $op = shift;
 
# Symbols for caller's input arrays
use vars qw{ @A @B };
local (*A, *B) = @_;
 
# Localise $a, $b
my ($caller_a, $caller_b) = do
{
my $pkg = caller();
## no critic (TestingAndDebugging::ProhibitNoStrict, ValuesAndExpressions::ProhibitCommaSeparatedStatements)
no strict 'refs';
\*{$pkg . '::a'}, \*{$pkg . '::b'};
};
 
# Loop iteration limit
my $limit = $#A > $#B ? $#A : $#B;
 
## no critic (Variables::RequireInitializationForLocalVars)
# This map expression is also the return value
local (*$caller_a, *$caller_b);
## no critic (BuiltinFunctions::ProhibitComplexMappings)
return map {
# Assign to $a, $b as refs to caller's array elements
(*$caller_a, *$caller_b) = \($#A < $_ ? undef : $A[$_], $#B < $_ ? undef : $B[$_]);
 
# Perform the transformation
$op->();
} 0 .. $limit;
}
 
sub each_array (\@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@)
{
return each_arrayref(@_);
}
 
sub each_arrayref
{
my @list = @_; # The list of references to the arrays
my $index = 0; # Which one the caller will get next
my $max = 0; # Number of elements in longest array
 
# Get the length of the longest input array
foreach (@list)
{
unless (ref $_ eq 'ARRAY')
{
require Carp;
Carp::croak("each_arrayref: argument is not an array reference\n");
}
$max = @$_ if @$_ > $max;
}
 
# Return the iterator as a closure wrt the above variables.
return sub {
if (@_)
{
my $method = shift;
unless ($method eq 'index')
{
require Carp;
Carp::croak("each_array: unknown argument '$method' passed to iterator.");
}
 
## no critic (Subroutines::ProhibitExplicitReturnUndef)
return undef if $index == 0 || $index > $max;
# Return current (last fetched) index
return $index - 1;
}
 
# No more elements to return
return if $index >= $max;
my $i = $index++;
 
# Return ith elements
## no critic (BuiltinFunctions::RequireBlockMap)
return map $_->[$i], @list;
}
}
 
sub natatime ($@)
{
my $n = shift;
my @list = @_;
return sub { return splice @list, 0, $n; }
}
 
# "leaks" when lexically hidden in arrayify
my $flatten;
$flatten = sub {
return map { (ref $_ and ("ARRAY" eq ref $_ or overload::Method($_, '@{}'))) ? ($flatten->(@{$_})) : ($_) } @_;
};
 
sub arrayify
{
return map { $flatten->($_) } @_;
}
 
sub mesh (\@\@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@)
{
my $max = -1;
$max < $#$_ && ($max = $#$_) foreach @_;
## no critic (BuiltinFunctions::ProhibitComplexMappings)
return map {
my $ix = $_;
## no critic (BuiltinFunctions::RequireBlockMap)
map $_->[$ix], @_;
} 0 .. $max;
}
 
sub zip6 (\@\@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@)
{
my $max = -1;
$max < $#$_ && ($max = $#$_) foreach @_;
## no critic (BuiltinFunctions::ProhibitComplexMappings)
return map {
my $ix = $_;
## no critic (BuiltinFunctions::RequireBlockMap)
[map $_->[$ix], @_];
} 0 .. $max;
}
 
sub listcmp (\@\@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@)
{
my %ret;
for (my $i = 0; $i < scalar @_; ++$i)
{
my %seen;
my $k;
foreach my $w (grep { defined $_ and not $seen{$k = $_}++ } @{$_[$i]})
{
$ret{$w} ||= [];
push @{$ret{$w}}, $i;
}
}
return %ret;
}
 
sub uniq (@)
{
my %seen = ();
my $k;
my $seen_undef;
return grep { defined $_ ? not $seen{$k = $_}++ : not $seen_undef++ } @_;
}
 
sub singleton (@)
{
my %seen = ();
my $k;
my $seen_undef;
return grep { 1 == (defined $_ ? $seen{$k = $_} : $seen_undef) }
grep { defined $_ ? not $seen{$k = $_}++ : not $seen_undef++ } @_;
}
 
sub duplicates (@)
{
my %seen = ();
my $k;
my $seen_undef;
return grep { 1 < (defined $_ ? $seen{$k = $_} : $seen_undef) }
grep { defined $_ ? not $seen{$k = $_}++ : not $seen_undef++ } @_;
}
 
sub frequency (@)
{
my %seen = ();
my $k;
my $seen_undef;
my %h = map { defined $_ ? ($_ => $seen{$k = $_}) : () }
grep { defined $_ ? not $seen{$k = $_}++ : not $seen_undef++ } @_;
wantarray or return (scalar keys %h) + ($seen_undef ? 1 : 0);
undef $k;
return (%h, $seen_undef ? (\$k => $seen_undef) : ());
}
 
sub occurrences (@)
{
my %seen = ();
my $k;
my $seen_undef;
my @ret;
foreach my $l (map { $_ } grep { defined $_ ? not $seen{$k = $_}++ : not $seen_undef++ } @_)
{
my $n = defined $l ? $seen{$l} : $seen_undef;
defined $ret[$n] or $ret[$n] = [];
push @{$ret[$n]}, $l;
}
return @ret;
}
 
sub mode (@)
{
my %seen = ();
my ($max, $k, $seen_undef) = (1);
 
foreach (@_) { defined $_ ? ($max < ++$seen{$k = $_} and ++$max) : ($max < ++$seen_undef and ++$max) }
wantarray or return $max;
 
my @ret = ($max);
foreach my $l (grep { $seen{$_} == $max } keys %seen)
{
push @ret, $l;
}
$seen_undef and $seen_undef == $max and push @ret, undef;
return @ret;
}
 
sub samples ($@)
{
my $n = shift;
if ($n > @_)
{
require Carp;
Carp::croak(sprintf("Cannot get %d samples from %d elements", $n, scalar @_));
}
 
for (my $i = @_; @_ - $i > $n;)
{
my $idx = @_ - $i;
my $swp = $idx + int(rand(--$i));
my $xchg = $_[$swp];
$_[$swp] = $_[$idx];
$_[$idx] = $xchg;
}
 
return splice @_, 0, $n;
}
 
sub minmax (@)
{
return unless @_;
my $min = my $max = $_[0];
 
for (my $i = 1; $i < @_; $i += 2)
{
if ($_[$i - 1] <= $_[$i])
{
$min = $_[$i - 1] if $min > $_[$i - 1];
$max = $_[$i] if $max < $_[$i];
}
else
{
$min = $_[$i] if $min > $_[$i];
$max = $_[$i - 1] if $max < $_[$i - 1];
}
}
 
if (@_ & 1)
{
my $i = $#_;
if ($_[$i - 1] <= $_[$i])
{
$min = $_[$i - 1] if $min > $_[$i - 1];
$max = $_[$i] if $max < $_[$i];
}
else
{
$min = $_[$i] if $min > $_[$i];
$max = $_[$i - 1] if $max < $_[$i - 1];
}
}
 
return ($min, $max);
}
 
sub minmaxstr (@)
{
return unless @_;
my $min = my $max = $_[0];
 
for (my $i = 1; $i < @_; $i += 2)
{
if ($_[$i - 1] le $_[$i])
{
$min = $_[$i - 1] if $min gt $_[$i - 1];
$max = $_[$i] if $max lt $_[$i];
}
else
{
$min = $_[$i] if $min gt $_[$i];
$max = $_[$i - 1] if $max lt $_[$i - 1];
}
}
 
if (@_ & 1)
{
my $i = $#_;
if ($_[$i - 1] le $_[$i])
{
$min = $_[$i - 1] if $min gt $_[$i - 1];
$max = $_[$i] if $max lt $_[$i];
}
else
{
$min = $_[$i] if $min gt $_[$i];
$max = $_[$i - 1] if $max lt $_[$i - 1];
}
}
 
return ($min, $max);
}
 
sub part (&@)
{
my ($code, @list) = @_;
my @parts;
push @{$parts[$code->($_)]}, $_ foreach @list;
return @parts;
}
 
sub bsearch(&@)
{
my $code = shift;
 
my $rc;
my $i = 0;
my $j = @_;
## no critic (ControlStructures::ProhibitNegativeExpressionsInUnlessAndUntilConditions)
do
{
my $k = int(($i + $j) / 2);
 
$k >= @_ and return;
 
local *_ = \$_[$k];
$rc = $code->();
 
$rc == 0
and return wantarray ? $_ : 1;
 
if ($rc < 0)
{
$i = $k + 1;
}
else
{
$j = $k - 1;
}
} until $i > $j;
 
return;
}
 
sub bsearchidx(&@)
{
my $code = shift;
 
my $rc;
my $i = 0;
my $j = @_;
## no critic (ControlStructures::ProhibitNegativeExpressionsInUnlessAndUntilConditions)
do
{
my $k = int(($i + $j) / 2);
 
$k >= @_ and return -1;
 
local *_ = \$_[$k];
$rc = $code->();
 
$rc == 0 and return $k;
 
if ($rc < 0)
{
$i = $k + 1;
}
else
{
$j = $k - 1;
}
} until $i > $j;
 
return -1;
}
 
sub lower_bound(&@)
{
my $code = shift;
my $count = @_;
my $first = 0;
while ($count > 0)
{
my $step = $count >> 1;
my $it = $first + $step;
local *_ = \$_[$it];
if ($code->() < 0)
{
$first = ++$it;
$count -= $step + 1;
}
else
{
$count = $step;
}
}
 
return $first;
}
 
sub upper_bound(&@)
{
my $code = shift;
my $count = @_;
my $first = 0;
while ($count > 0)
{
my $step = $count >> 1;
my $it = $first + $step;
local *_ = \$_[$it];
if ($code->() <= 0)
{
$first = ++$it;
$count -= $step + 1;
}
else
{
$count = $step;
}
}
 
return $first;
}
 
sub equal_range(&@)
{
my $lb = &lower_bound(@_);
my $ub = &upper_bound(@_);
return ($lb, $ub);
}
 
sub binsert (&$\@)
{
my $lb = &lower_bound($_[0], @{$_[2]});
splice @{$_[2]}, $lb, 0, $_[1];
return $lb;
}
 
sub bremove (&\@)
{
my $lb = &lower_bound($_[0], @{$_[1]});
return splice @{$_[1]}, $lb, 1;
}
 
sub qsort(&\@)
{
require Carp;
Carp::croak("It's insane to use a pure-perl qsort");
}
 
sub slide(&@)
{
my $op = shift;
my @l = @_;
 
## no critic (TestingAndDebugging::ProhibitNoStrict, ValuesAndExpressions::ProhibitCommaSeparatedStatements)
# Localise $a, $b
my ($caller_a, $caller_b) = do
{
my $pkg = caller();
no strict 'refs';
\*{$pkg . '::a'}, \*{$pkg . '::b'};
};
 
## no critic (Variables::RequireInitializationForLocalVars)
# This map expression is also the return value
local (*$caller_a, *$caller_b);
## no critic (BuiltinFunctions::ProhibitComplexMappings)
return map {
# Assign to $a, $b as refs to caller's array elements
(*$caller_a, *$caller_b) = \($l[$_], $l[$_ + 1]);
 
# Perform the transformation
$op->();
} 0 .. ($#l - 1);
}
 
sub slideatatime ($$@)
{
my ($m, $w, @list) = @_;
my $n = $w - $m - 1;
return $n >= 0
? sub { my @r = splice @list, 0, $m; $#list < $n and $n = $#list; @r and push @r, (@list ? @list[0 .. $n] : ()); return @r; }
: sub { return splice @list, 0, $m; };
}
 
sub sort_by(&@)
{
my ($code, @list) = @_;
return map { $_->[0] }
sort { $a->[1] cmp $b->[1] }
map { [$_, scalar($code->())] } @list;
}
 
sub nsort_by(&@)
{
my ($code, @list) = @_;
return map { $_->[0] }
sort { $a->[1] <=> $b->[1] }
map { [$_, scalar($code->())] } @list;
}
 
## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
sub _XScompiled { return 0 }
 
=head1 SEE ALSO
 
L<List::Util>
 
=head1 AUTHOR
 
Jens Rehsack E<lt>rehsack AT cpan.orgE<gt>
 
Adam Kennedy E<lt>adamk@cpan.orgE<gt>
 
Tassilo von Parseval E<lt>tassilo.von.parseval@rwth-aachen.deE<gt>
 
=head1 COPYRIGHT AND LICENSE
 
Some parts copyright 2011 Aaron Crane.
 
Copyright 2004 - 2010 by Tassilo von Parseval
 
Copyright 2013 - 2017 by Jens Rehsack
 
All code added with 0.417 or later is licensed under the Apache License,
Version 2.0 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
 
http://www.apache.org/licenses/LICENSE-2.0
 
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
 
All code until 0.416 is licensed under the same terms as Perl itself,
either Perl version 5.8.4 or, at your option, any later version of
Perl 5 you may have available.
 
=cut
 
1;
/perl_lib/List/MoreUtils.pm
0,0 → 1,1286
package List::MoreUtils;
 
use 5.008_001;
use strict;
use warnings;
 
my $have_xs;
our $VERSION = '0.430';
 
BEGIN
{
unless (defined($have_xs))
{
## no critic (ErrorHandling::RequireCheckingReturnValueOfEval)
eval { require List::MoreUtils::XS; } unless $ENV{LIST_MOREUTILS_PP};
## no critic (ErrorHandling::RequireCarping)
die $@ if $@ && defined $ENV{LIST_MOREUTILS_PP} && $ENV{LIST_MOREUTILS_PP} == 0;
$have_xs = 0 + defined($INC{'List/MoreUtils/XS.pm'});
}
 
use List::MoreUtils::PP qw();
}
 
use Exporter::Tiny qw();
 
my @junctions = qw(any all none notall);
my @v0_22 = qw(
true false
firstidx lastidx
insert_after insert_after_string
apply indexes
after after_incl before before_incl
firstval lastval
each_array each_arrayref
pairwise natatime
mesh uniq
minmax part
_XScompiled
);
my @v0_24 = qw(bsearch);
my @v0_33 = qw(sort_by nsort_by);
my @v0_400 = qw(one any_u all_u none_u notall_u one_u
firstres onlyidx onlyval onlyres lastres
singleton bsearchidx
);
my @v0_420 = qw(arrayify duplicates minmaxstr samples zip6 reduce_0 reduce_1 reduce_u
listcmp frequency occurrences mode
binsert bremove equal_range lower_bound upper_bound qsort
slide slideatatime);
 
my @all_functions = (@junctions, @v0_22, @v0_24, @v0_33, @v0_400, @v0_420);
 
## no critic (TestingAndDebugging::ProhibitNoStrict)
no strict "refs";
if ($have_xs)
{
my $x;
for (@all_functions)
{
List::MoreUtils->can($_) or *$_ = $x if ($x = List::MoreUtils::XS->can($_));
}
}
List::MoreUtils->can($_) or *$_ = List::MoreUtils::PP->can($_) for (@all_functions);
use strict;
## use critic (TestingAndDebugging::ProhibitNoStrict)
use parent qw(Exporter::Tiny);
 
my %alias_list = (
v0_22 => {
first_index => "firstidx",
last_index => "lastidx",
first_value => "firstval",
last_value => "lastval",
zip => "mesh",
},
v0_33 => {
distinct => "uniq",
},
v0_400 => {
first_result => "firstres",
only_index => "onlyidx",
only_value => "onlyval",
only_result => "onlyres",
last_result => "lastres",
bsearch_index => "bsearchidx",
},
v0_420 => {
bsearch_insert => "binsert",
bsearch_remove => "bremove",
zip_unflatten => "zip6",
},
);
 
our @EXPORT_OK = (@all_functions, map { keys %$_ } values %alias_list);
our %EXPORT_TAGS = (
all => \@EXPORT_OK,
'like_0.22' => [
any_u => {-as => 'any'},
all_u => {-as => 'all'},
none_u => {-as => 'none'},
notall_u => {-as => 'notall'},
@v0_22,
keys %{$alias_list{v0_22}},
],
'like_0.24' => [
any_u => {-as => 'any'},
all_u => {-as => 'all'},
notall_u => {-as => 'notall'},
'none',
@v0_22,
@v0_24,
keys %{$alias_list{v0_22}},
],
'like_0.33' => [
@junctions,
@v0_22,
# v0_24 functions were omitted
@v0_33,
keys %{$alias_list{v0_22}},
keys %{$alias_list{v0_33}},
],
);
 
for my $set (values %alias_list)
{
for my $alias (keys %$set)
{
## no critic (TestingAndDebugging::ProhibitNoStrict)
no strict qw(refs);
*$alias = __PACKAGE__->can($set->{$alias});
## use critic (TestingAndDebugging::ProhibitNoStrict)
}
}
use strict;
 
=pod
 
=head1 NAME
 
List::MoreUtils - Provide the stuff missing in List::Util
 
=head1 SYNOPSIS
 
# import specific functions
 
use List::MoreUtils qw(any uniq);
 
if ( any { /foo/ } uniq @has_duplicates ) {
# do stuff
}
 
# import everything
 
use List::MoreUtils ':all';
 
# import by API
 
# has "original" any/all/none/notall behavior
use List::MoreUtils ':like_0.22';
# 0.22 + bsearch
use List::MoreUtils ':like_0.24';
# has "simplified" any/all/none/notall behavior + (n)sort_by
use List::MoreUtils ':like_0.33';
 
=head1 DESCRIPTION
 
B<List::MoreUtils> provides some trivial but commonly needed functionality on
lists which is not going to go into L<List::Util>.
 
All of the below functions are implementable in only a couple of lines of Perl
code. Using the functions from this module however should give slightly better
performance as everything is implemented in C. The pure-Perl implementation of
these functions only serves as a fallback in case the C portions of this module
couldn't be compiled on this machine.
 
=head1 EXPORTS
 
=head2 Default behavior
 
Nothing by default. To import all of this module's symbols use the C<:all> tag.
Otherwise functions can be imported by name as usual:
 
use List::MoreUtils ':all';
 
use List::MoreUtils qw{ any firstidx };
 
Because historical changes to the API might make upgrading List::MoreUtils
difficult for some projects, the legacy API is available via special import
tags.
 
=head2 Like version 0.22 (last release with original API)
 
This API was available from 2006 to 2009, returning undef for empty lists on
C<all>/C<any>/C<none>/C<notall>:
 
use List::MoreUtils ':like_0.22';
 
This import tag will import all functions available as of version 0.22.
However, it will import C<any_u> as C<any>, C<all_u> as C<all>, C<none_u> as
C<none>, and C<notall_u> as C<notall>.
 
=head2 Like version 0.24 (first incompatible change)
 
This API was available from 2010 to 2011. It changed the return value of C<none>
and added the C<bsearch> function.
 
use List::MoreUtils ':like_0.24';
 
This import tag will import all functions available as of version 0.24.
However it will import C<any_u> as C<any>, C<all_u> as C<all>, and
C<notall_u> as C<notall>. It will import C<none> as described in
the documentation below (true for empty list).
 
=head2 Like version 0.33 (second incompatible change)
 
This API was available from 2011 to 2014. It is widely used in several CPAN
modules and thus it's closest to the current API. It changed the return values
of C<any>, C<all>, and C<notall>. It added the C<sort_by> and C<nsort_by> functions
and the C<distinct> alias for C<uniq>. It omitted C<bsearch>.
 
use List::MoreUtils ':like_0.33';
 
This import tag will import all functions available as of version 0.33. Note:
it will not import C<bsearch> for consistency with the 0.33 API.
 
=head1 FUNCTIONS
 
=head2 Junctions
 
=head3 I<Treatment of an empty list>
 
There are two schools of thought for how to evaluate a junction on an
empty list:
 
=over
 
=item *
 
Reduction to an identity (boolean)
 
=item *
 
Result is undefined (three-valued)
 
=back
 
In the first case, the result of the junction applied to the empty list is
determined by a mathematical reduction to an identity depending on whether
the underlying comparison is "or" or "and". Conceptually:
 
"any are true" "all are true"
-------------- --------------
2 elements: A || B || 0 A && B && 1
1 element: A || 0 A && 1
0 elements: 0 1
 
In the second case, three-value logic is desired, in which a junction
applied to an empty list returns C<undef> rather than true or false
 
Junctions with a C<_u> suffix implement three-valued logic. Those
without are boolean.
 
=head3 all BLOCK LIST
 
=head3 all_u BLOCK LIST
 
Returns a true value if all items in LIST meet the criterion given through
BLOCK. Sets C<$_> for each item in LIST in turn:
 
print "All values are non-negative"
if all { $_ >= 0 } ($x, $y, $z);
 
For an empty LIST, C<all> returns true (i.e. no values failed the condition)
and C<all_u> returns C<undef>.
 
Thus, C<< all_u(@list) >> is equivalent to C<< @list ? all(@list) : undef >>.
 
B<Note>: because Perl treats C<undef> as false, you must check the return value
of C<all_u> with C<defined> or you will get the opposite result of what you
expect.
 
=head3 any BLOCK LIST
 
=head3 any_u BLOCK LIST
 
Returns a true value if any item in LIST meets the criterion given through
BLOCK. Sets C<$_> for each item in LIST in turn:
 
print "At least one non-negative value"
if any { $_ >= 0 } ($x, $y, $z);
 
For an empty LIST, C<any> returns false and C<any_u> returns C<undef>.
 
Thus, C<< any_u(@list) >> is equivalent to C<< @list ? any(@list) : undef >>.
 
=head3 none BLOCK LIST
 
=head3 none_u BLOCK LIST
 
Logically the negation of C<any>. Returns a true value if no item in LIST meets
the criterion given through BLOCK. Sets C<$_> for each item in LIST in turn:
 
print "No non-negative values"
if none { $_ >= 0 } ($x, $y, $z);
 
For an empty LIST, C<none> returns true (i.e. no values failed the condition)
and C<none_u> returns C<undef>.
 
Thus, C<< none_u(@list) >> is equivalent to C<< @list ? none(@list) : undef >>.
 
B<Note>: because Perl treats C<undef> as false, you must check the return value
of C<none_u> with C<defined> or you will get the opposite result of what you
expect.
 
=head3 notall BLOCK LIST
 
=head3 notall_u BLOCK LIST
 
Logically the negation of C<all>. Returns a true value if not all items in LIST
meet the criterion given through BLOCK. Sets C<$_> for each item in LIST in
turn:
 
print "Not all values are non-negative"
if notall { $_ >= 0 } ($x, $y, $z);
 
For an empty LIST, C<notall> returns false and C<notall_u> returns C<undef>.
 
Thus, C<< notall_u(@list) >> is equivalent to C<< @list ? notall(@list) : undef >>.
 
=head3 one BLOCK LIST
 
=head3 one_u BLOCK LIST
 
Returns a true value if precisely one item in LIST meets the criterion
given through BLOCK. Sets C<$_> for each item in LIST in turn:
 
print "Precisely one value defined"
if one { defined($_) } @list;
 
Returns false otherwise.
 
For an empty LIST, C<one> returns false and C<one_u> returns C<undef>.
 
The expression C<one BLOCK LIST> is almost equivalent to
C<1 == true BLOCK LIST>, except for short-cutting.
Evaluation of BLOCK will immediately stop at the second true value.
 
=head2 Transformation
 
=head3 apply BLOCK LIST
 
Applies BLOCK to each item in LIST and returns a list of the values after BLOCK
has been applied. In scalar context, the last element is returned. This
function is similar to C<map> but will not modify the elements of the input
list:
 
my @list = (1 .. 4);
my @mult = apply { $_ *= 2 } @list;
print "\@list = @list\n";
print "\@mult = @mult\n";
__END__
@list = 1 2 3 4
@mult = 2 4 6 8
 
Think of it as syntactic sugar for
 
for (my @mult = @list) { $_ *= 2 }
 
=head3 insert_after BLOCK VALUE LIST
 
Inserts VALUE after the first item in LIST for which the criterion in BLOCK is
true. Sets C<$_> for each item in LIST in turn.
 
my @list = qw/This is a list/;
insert_after { $_ eq "a" } "longer" => @list;
print "@list";
__END__
This is a longer list
 
=head3 insert_after_string STRING VALUE LIST
 
Inserts VALUE after the first item in LIST which is equal to STRING.
 
my @list = qw/This is a list/;
insert_after_string "a", "longer" => @list;
print "@list";
__END__
This is a longer list
 
=head3 pairwise BLOCK ARRAY1 ARRAY2
 
Evaluates BLOCK for each pair of elements in ARRAY1 and ARRAY2 and returns a
new list consisting of BLOCK's return values. The two elements are set to C<$a>
and C<$b>. Note that those two are aliases to the original value so changing
them will modify the input arrays.
 
@a = (1 .. 5);
@b = (11 .. 15);
@x = pairwise { $a + $b } @a, @b; # returns 12, 14, 16, 18, 20
 
# mesh with pairwise
@a = qw/a b c/;
@b = qw/1 2 3/;
@x = pairwise { ($a, $b) } @a, @b; # returns a, 1, b, 2, c, 3
 
=head3 mesh ARRAY1 ARRAY2 [ ARRAY3 ... ]
 
=head3 zip ARRAY1 ARRAY2 [ ARRAY3 ... ]
 
Returns a list consisting of the first elements of each array, then
the second, then the third, etc, until all arrays are exhausted.
 
Examples:
 
@x = qw/a b c d/;
@y = qw/1 2 3 4/;
@z = mesh @x, @y; # returns a, 1, b, 2, c, 3, d, 4
 
@a = ('x');
@b = ('1', '2');
@c = qw/zip zap zot/;
@d = mesh @a, @b, @c; # x, 1, zip, undef, 2, zap, undef, undef, zot
 
C<zip> is an alias for C<mesh>.
 
=head3 zip6
 
=head3 zip_unflatten
 
Returns a list of arrays consisting of the first elements of each array,
then the second, then the third, etc, until all arrays are exhausted.
 
@x = qw/a b c d/;
@y = qw/1 2 3 4/;
@z = zip6 @x, @y; # returns [a, 1], [b, 2], [c, 3], [d, 4]
 
@a = ('x');
@b = ('1', '2');
@c = qw/zip zap zot/;
@d = zip6 @a, @b, @c; # [x, 1, zip], [undef, 2, zap], [undef, undef, zot]
 
C<zip_unflatten> is an alias for C<zip6>.
 
=head3 listcmp ARRAY0 ARRAY1 [ ARRAY2 ... ]
 
Returns an associative list of elements and every I<id> of the list it
was found in. Allows easy implementation of @a & @b, @a | @b, @a ^ @b and
so on.
Undefined entries in any given array are skipped.
 
my @a = qw(one two three four five six seven eight nine ten eleven twelve thirteen);
my @b = qw(two three five seven eleven thirteen seventeen);
my @c = qw(one one two three five eight thirteen twentyone);
my %cmp = listcmp @a, @b, @c; # returns (one => [0, 2], two => [0, 1, 2], three => [0, 1, 2], four => [0], ...)
 
my @seq = (1, 2, 3);
my @prim = (undef, 2, 3, 5);
my @fib = (1, 1, 2);
my %cmp = listcmp @seq, @prim, @fib;
# returns ( 1 => [0, 2], 2 => [0, 1, 2], 3 => [0, 1], 5 => [1] )
 
=head3 arrayify LIST[,LIST[,LIST...]]
 
Returns a list consisting of each element of given arrays. Recursive arrays
are flattened, too.
 
@a = (1, [[2], 3], 4, [5], 6, [7], 8, 9);
@l = arrayify @a; # returns 1, 2, 3, 4, 5, 6, 7, 8, 9
 
=head3 uniq LIST
 
=head3 distinct LIST
 
Returns a new list by stripping duplicate values in LIST by comparing
the values as hash keys, except that undef is considered separate from ''.
The order of elements in the returned list is the same as in LIST. In
scalar context, returns the number of unique elements in LIST.
 
my @x = uniq 1, 1, 2, 2, 3, 5, 3, 4; # returns 1 2 3 5 4
my $x = uniq 1, 1, 2, 2, 3, 5, 3, 4; # returns 5
# returns "Mike", "Michael", "Richard", "Rick"
my @n = distinct "Mike", "Michael", "Richard", "Rick", "Michael", "Rick"
# returns "A8", "", undef, "A5", "S1"
my @s = distinct "A8", "", undef, "A5", "S1", "A5", "A8"
# returns "Giulia", "Giulietta", undef, "", 156, "GTA", "GTV", 159, "Brera", "4C"
my @w = uniq "Giulia", "Giulietta", undef, "", 156, "GTA", "GTV", 159, "Brera", "4C", "Giulietta", "Giulia"
 
C<distinct> is an alias for C<uniq>.
 
B<RT#49800> can be used to give feedback about this behavior.
 
=head3 singleton LIST
 
Returns a new list by stripping values in LIST occurring more than once by
comparing the values as hash keys, except that undef is considered separate
from ''. The order of elements in the returned list is the same as in LIST.
In scalar context, returns the number of elements occurring only once in LIST.
 
my @x = singleton 1,1,2,2,3,4,5 # returns 3 4 5
 
=head3 duplicates LIST
 
Returns a new list by stripping values in LIST occurring less than twice by
comparing the values as hash keys, except that undef is considered separate
from ''. The order of elements in the returned list is the same as in LIST.
In scalar context, returns the number of elements occurring more than once
in LIST.
 
my @y = duplicates 1,1,2,4,7,2,3,4,6,9; #returns 1,2,4
 
=head3 frequency LIST
 
Returns an associative list of distinct values and the corresponding frequency.
 
my @f = frequency values %radio_nrw; # returns (
# 'Deutschlandfunk (DLF)' => 9, 'WDR 3' => 10,
# 'WDR 4' => 11, 'WDR 5' => 14, 'WDR Eins Live' => 14,
# 'Deutschlandradio Kultur' => 8,...)
 
=head3 occurrences LIST
 
Returns a new list of frequencies and the corresponding values from LIST.
 
my @o = occurrences ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4);
# @o = (undef, undef, [3, 5], [1], [2, 6], undef, undef, [4]);
 
=head3 mode LIST
 
Returns the modal value of LIST. In scalar context, just the modal value
is returned, in list context all probes occurring I<modal> times are returned,
too.
 
my @m = mode ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4, (7) x 3, (8) x 7);
# @m = (7, 4, 8) - bimodal LIST
 
=head3 slide BLOCK LIST
 
The function C<slide> operates on pairs of list elements like:
 
my @s = slide { "$a and $b" } (0..3);
# @s = ("0 and 1", "1 and 2", "2 and 3")
 
The idea behind this function is a kind of magnifying glass that is moved
along a list and calls C<BLOCK> every time the next list item is reached.
 
=head2 Partitioning
 
=head3 after BLOCK LIST
 
Returns a list of the values of LIST after (and not including) the point
where BLOCK returns a true value. Sets C<$_> for each element in LIST in turn.
 
@x = after { $_ % 5 == 0 } (1..9); # returns 6, 7, 8, 9
 
=head3 after_incl BLOCK LIST
 
Same as C<after> but also includes the element for which BLOCK is true.
 
=head3 before BLOCK LIST
 
Returns a list of values of LIST up to (and not including) the point where BLOCK
returns a true value. Sets C<$_> for each element in LIST in turn.
 
=head3 before_incl BLOCK LIST
 
Same as C<before> but also includes the element for which BLOCK is true.
 
=head3 part BLOCK LIST
 
Partitions LIST based on the return value of BLOCK which denotes into which
partition the current value is put.
 
Returns a list of the partitions thusly created. Each partition created is a
reference to an array.
 
my $i = 0;
my @part = part { $i++ % 2 } 1 .. 8; # returns [1, 3, 5, 7], [2, 4, 6, 8]
 
You can have a sparse list of partitions as well where non-set partitions will
be undef:
 
my @part = part { 2 } 1 .. 10; # returns undef, undef, [ 1 .. 10 ]
 
Be careful with negative values, though:
 
my @part = part { -1 } 1 .. 10;
__END__
Modification of non-creatable array value attempted, subscript -1 ...
 
Negative values are only ok when they refer to a partition previously created:
 
my @idx = ( 0, 1, -1 );
my $i = 0;
my @part = part { $idx[$i++ % 3] } 1 .. 8; # [1, 4, 7], [2, 3, 5, 6, 8]
 
=head3 samples COUNT LIST
 
Returns a new list containing COUNT random samples from LIST. Is similar to
L<List::Util/shuffle>, but stops after COUNT.
 
@r = samples 10, 1..10; # same as shuffle
@r2 = samples 5, 1..10; # gives 5 values from 1..10;
 
=head2 Iteration
 
=head3 each_array ARRAY1 ARRAY2 ...
 
Creates an array iterator to return the elements of the list of arrays ARRAY1,
ARRAY2 throughout ARRAYn in turn. That is, the first time it is called, it
returns the first element of each array. The next time, it returns the second
elements. And so on, until all elements are exhausted.
 
This is useful for looping over more than one array at once:
 
my $ea = each_array(@a, @b, @c);
while ( my ($a, $b, $c) = $ea->() ) { .... }
 
The iterator returns the empty list when it reached the end of all arrays.
 
If the iterator is passed an argument of 'C<index>', then it returns
the index of the last fetched set of values, as a scalar.
 
=head3 each_arrayref LIST
 
Like each_array, but the arguments are references to arrays, not the
plain arrays.
 
=head3 natatime EXPR, LIST
 
Creates an array iterator, for looping over an array in chunks of
C<$n> items at a time. (n at a time, get it?). An example is
probably a better explanation than I could give in words.
 
Example:
 
my @x = ('a' .. 'g');
my $it = natatime 3, @x;
while (my @vals = $it->())
{
print "@vals\n";
}
 
This prints
 
a b c
d e f
g
 
=head3 slideatatime STEP, WINDOW, LIST
 
Creates an array iterator, for looping over an array in chunks of
C<$windows-size> items at a time.
 
The idea behind this function is a kind of magnifying glass (finer
controllable compared to L</slide>) that is moved along a list.
 
Example:
 
my @x = ('a' .. 'g');
my $it = slideatatime 2, 3, @x;
while (my @vals = $it->())
{
print "@vals\n";
}
 
This prints
 
a b c
c d e
e f g
g
 
=head2 Searching
 
=head3 firstval BLOCK LIST
 
=head3 first_value BLOCK LIST
 
Returns the first element in LIST for which BLOCK evaluates to true. Each
element of LIST is set to C<$_> in turn. Returns C<undef> if no such element
has been found.
 
C<first_value> is an alias for C<firstval>.
 
=head3 onlyval BLOCK LIST
 
=head3 only_value BLOCK LIST
 
Returns the only element in LIST for which BLOCK evaluates to true. Sets
C<$_> for each item in LIST in turn. Returns C<undef> if no such element
has been found.
 
C<only_value> is an alias for C<onlyval>.
 
=head3 lastval BLOCK LIST
 
=head3 last_value BLOCK LIST
 
Returns the last value in LIST for which BLOCK evaluates to true. Each element
of LIST is set to C<$_> in turn. Returns C<undef> if no such element has been
found.
 
C<last_value> is an alias for C<lastval>.
 
=head3 firstres BLOCK LIST
 
=head3 first_result BLOCK LIST
 
Returns the result of BLOCK for the first element in LIST for which BLOCK
evaluates to true. Each element of LIST is set to C<$_> in turn. Returns
C<undef> if no such element has been found.
 
C<first_result> is an alias for C<firstres>.
 
=head3 onlyres BLOCK LIST
 
=head3 only_result BLOCK LIST
 
Returns the result of BLOCK for the first element in LIST for which BLOCK
evaluates to true. Sets C<$_> for each item in LIST in turn. Returns
C<undef> if no such element has been found.
 
C<only_result> is an alias for C<onlyres>.
 
=head3 lastres BLOCK LIST
 
=head3 last_result BLOCK LIST
 
Returns the result of BLOCK for the last element in LIST for which BLOCK
evaluates to true. Each element of LIST is set to C<$_> in turn. Returns
C<undef> if no such element has been found.
 
C<last_result> is an alias for C<lastres>.
 
=head3 indexes BLOCK LIST
 
Evaluates BLOCK for each element in LIST (assigned to C<$_>) and returns a list
of the indices of those elements for which BLOCK returned a true value. This is
just like C<grep> only that it returns indices instead of values:
 
@x = indexes { $_ % 2 == 0 } (1..10); # returns 1, 3, 5, 7, 9
 
=head3 firstidx BLOCK LIST
 
=head3 first_index BLOCK LIST
 
Returns the index of the first element in LIST for which the criterion in BLOCK
is true. Sets C<$_> for each item in LIST in turn:
 
my @list = (1, 4, 3, 2, 4, 6);
printf "item with index %i in list is 4", firstidx { $_ == 4 } @list;
__END__
item with index 1 in list is 4
 
Returns C<-1> if no such item could be found.
 
C<first_index> is an alias for C<firstidx>.
 
=head3 onlyidx BLOCK LIST
 
=head3 only_index BLOCK LIST
 
Returns the index of the only element in LIST for which the criterion
in BLOCK is true. Sets C<$_> for each item in LIST in turn:
 
my @list = (1, 3, 4, 3, 2, 4);
printf "uniqe index of item 2 in list is %i", onlyidx { $_ == 2 } @list;
__END__
unique index of item 2 in list is 4
 
Returns C<-1> if either no such item or more than one of these
has been found.
 
C<only_index> is an alias for C<onlyidx>.
 
=head3 lastidx BLOCK LIST
 
=head3 last_index BLOCK LIST
 
Returns the index of the last element in LIST for which the criterion in BLOCK
is true. Sets C<$_> for each item in LIST in turn:
 
my @list = (1, 4, 3, 2, 4, 6);
printf "item with index %i in list is 4", lastidx { $_ == 4 } @list;
__END__
item with index 4 in list is 4
 
Returns C<-1> if no such item could be found.
 
C<last_index> is an alias for C<lastidx>.
 
=head2 Sorting
 
=head3 sort_by BLOCK LIST
 
Returns the list of values sorted according to the string values returned by the
KEYFUNC block or function. A typical use of this may be to sort objects according
to the string value of some accessor, such as
 
sort_by { $_->name } @people
 
The key function is called in scalar context, being passed each value in turn as
both $_ and the only argument in the parameters, @_. The values are then sorted
according to string comparisons on the values returned.
This is equivalent to
 
sort { $a->name cmp $b->name } @people
 
except that it guarantees the name accessor will be executed only once per value.
One interesting use-case is to sort strings which may have numbers embedded in them
"naturally", rather than lexically.
 
sort_by { s/(\d+)/sprintf "%09d", $1/eg; $_ } @strings
 
This sorts strings by generating sort keys which zero-pad the embedded numbers to
some level (9 digits in this case), helping to ensure the lexical sort puts them
in the correct order.
 
=head3 nsort_by BLOCK LIST
 
Similar to sort_by but compares its key values numerically.
 
=head3 qsort BLOCK ARRAY
 
This sorts the given array B<in place> using the given compare code. Except for
tiny compare code like C<< $a <=> $b >>, qsort is much faster than Perl's C<sort>
depending on the version.
 
Compared 5.8 and 5.26:
 
my @rl;
for(my $i = 0; $i < 1E6; ++$i) { push @rl, rand(1E5) }
my $idx;
 
sub ext_cmp { $_[0] <=> $_[1] }
 
cmpthese( -60, {
'qsort' => sub {
my @qrl = @rl;
qsort { ext_cmp($a, $b) } @qrl;
$idx = bsearchidx { ext_cmp($_, $rl[0]) } @qrl
},
'reverse qsort' => sub {
my @qrl = @rl;
qsort { ext_cmp($b, $a) } @qrl;
$idx = bsearchidx { ext_cmp($rl[0], $_) } @qrl
},
'sort' => sub {
my @srl = @rl;
@srl = sort { ext_cmp($a, $b) } @srl;
$idx = bsearchidx { ext_cmp($_, $rl[0]) } @srl
},
'reverse sort' => sub {
my @srl = @rl;
@srl = sort { ext_cmp($b, $a) } @srl;
$idx = bsearchidx { ext_cmp($rl[0], $_) } @srl
},
});
 
5.8 results
 
s/iter reverse sort sort reverse qsort qsort
reverse sort 6.21 -- -0% -8% -10%
sort 6.19 0% -- -7% -10%
reverse qsort 5.73 8% 8% -- -2%
qsort 5.60 11% 11% 2% --
 
5.26 results
 
s/iter reverse sort sort reverse qsort qsort
reverse sort 4.54 -- -0% -96% -96%
sort 4.52 0% -- -96% -96%
reverse qsort 0.203 2139% 2131% -- -19%
qsort 0.164 2666% 2656% 24% --
 
Use it where external data sources might have to be compared (think of L<Unix::Statgrab>
"tables").
 
C<qsort> is available from List::MoreUtils::XS only. It's insane to maintain
a wrapper around Perl's sort nor having a pure Perl implementation. One could
create a flip-book in same speed as PP runs a qsort.
 
=head2 Searching in sorted Lists
 
=head3 bsearch BLOCK LIST
 
Performs a binary search on LIST which must be a sorted list of values. BLOCK
must return a negative value if the current element (stored in C<$_>) is smaller,
a positive value if it is bigger and zero if it matches.
 
Returns a boolean value in scalar context. In list context, it returns the element
if it was found, otherwise the empty list.
 
=head3 bsearchidx BLOCK LIST
 
=head3 bsearch_index BLOCK LIST
 
Performs a binary search on LIST which must be a sorted list of values. BLOCK
must return a negative value if the current element (stored in C<$_>) is smaller,
a positive value if it is bigger and zero if it matches.
 
Returns the index of found element, otherwise C<-1>.
 
C<bsearch_index> is an alias for C<bsearchidx>.
 
=head3 lower_bound BLOCK LIST
 
Returns the index of the first element in LIST which does not compare
I<less than val>. Technically it's the first element in LIST which does
not return a value below zero when passed to BLOCK.
 
@ids = (1, 1, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 6, 7, 7, 7, 8, 8, 9, 9, 9, 9, 9, 11, 13, 13, 13, 17);
$lb = lower_bound { $_ <=> 2 } @ids; # returns 2
$lb = lower_bound { $_ <=> 4 } @ids; # returns 10
 
lower_bound has a complexity of O(log n).
 
=head3 upper_bound BLOCK LIST
 
Returns the index of the first element in LIST which does not compare
I<greater than val>. Technically it's the first element in LIST which does
not return a value below or equal to zero when passed to BLOCK.
 
@ids = (1, 1, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 6, 7, 7, 7, 8, 8, 9, 9, 9, 9, 9, 11, 13, 13, 13, 17);
$lb = upper_bound { $_ <=> 2 } @ids; # returns 4
$lb = upper_bound { $_ <=> 4 } @ids; # returns 14
 
upper_bound has a complexity of O(log n).
 
=head3 equal_range BLOCK LIST
 
Returns a pair of indices containing the lower_bound and the upper_bound.
 
=head2 Operations on sorted Lists
 
=head3 binsert BLOCK ITEM LIST
 
=head3 bsearch_insert BLOCK ITEM LIST
 
Performs a binary search on LIST which must be a sorted list of values. BLOCK
must return a negative value if the current element (stored in C<$_>) is smaller,
a positive value if it is bigger and zero if it matches.
 
ITEM is inserted at the index where the ITEM should be placed (based on above
search). That means, it's inserted before the next bigger element.
 
@l = (2,3,5,7);
binsert { $_ <=> 4 } 4, @l; # @l = (2,3,4,5,7)
binsert { $_ <=> 6 } 42, @l; # @l = (2,3,4,42,7)
 
You take care that the inserted element matches the compare result.
 
=head3 bremove BLOCK LIST
 
=head3 bsearch_remove BLOCK LIST
 
Performs a binary search on LIST which must be a sorted list of values. BLOCK
must return a negative value if the current element (stored in C<$_>) is smaller,
a positive value if it is bigger and zero if it matches.
 
The item at the found position is removed and returned.
 
@l = (2,3,4,5,7);
bremove { $_ <=> 4 }, @l; # @l = (2,3,5,7);
 
=head2 Counting and calculation
 
=head3 true BLOCK LIST
 
Counts the number of elements in LIST for which the criterion in BLOCK is true.
Sets C<$_> for each item in LIST in turn:
 
printf "%i item(s) are defined", true { defined($_) } @list;
 
=head3 false BLOCK LIST
 
Counts the number of elements in LIST for which the criterion in BLOCK is false.
Sets C<$_> for each item in LIST in turn:
 
printf "%i item(s) are not defined", false { defined($_) } @list;
 
=head3 reduce_0 BLOCK LIST
 
Reduce LIST by calling BLOCK in scalar context for each element of LIST.
C<$a> contains the progressional result and is initialized with 0.
C<$b> contains the current processed element of LIST and C<$_> contains the
index of the element in C<$b>.
 
The idea behind reduce_0 is B<summation> (addition of a sequence of numbers).
 
=head3 reduce_1 BLOCK LIST
 
Reduce LIST by calling BLOCK in scalar context for each element of LIST.
C<$a> contains the progressional result and is initialized with 1.
C<$b> contains the current processed element of LIST and C<$_> contains the
index of the element in C<$b>.
 
The idea behind reduce_1 is product of a sequence of numbers.
 
=head3 reduce_u BLOCK LIST
 
Reduce LIST by calling BLOCK in scalar context for each element of LIST.
C<$a> contains the progressional result and is uninitialized.
C<$b> contains the current processed element of LIST and C<$_> contains the
index of the element in C<$b>.
 
This function has been added if one might need the extra of the index
value but need an individual initialization.
 
B<Use with caution>: In most cases L<List::Util/reduce> will do the
job better.
 
=head3 minmax LIST
 
Calculates the minimum and maximum of LIST and returns a two element list with
the first element being the minimum and the second the maximum. Returns the
empty list if LIST was empty.
 
The C<minmax> algorithm differs from a naive iteration over the list where each
element is compared to two values being the so far calculated min and max value
in that it only requires 3n/2 - 2 comparisons. Thus it is the most efficient
possible algorithm.
 
However, the Perl implementation of it has some overhead simply due to the fact
that there are more lines of Perl code involved. Therefore, LIST needs to be
fairly big in order for C<minmax> to win over a naive implementation. This
limitation does not apply to the XS version.
 
=head3 minmaxstr LIST
 
Computes the minimum and maximum of LIST using string compare and returns a
two element list with the first element being the minimum and the second the
maximum. Returns the empty list if LIST was empty.
 
The implementation is similar to C<minmax>.
 
=head1 ENVIRONMENT
 
When C<LIST_MOREUTILS_PP> is set, the module will always use the pure-Perl
implementation and not the XS one. This environment variable is really just
there for the test-suite to force testing the Perl implementation, and possibly
for reporting of bugs. I don't see any reason to use it in a production
environment.
 
=head1 MAINTENANCE
 
The maintenance goal is to preserve the documented semantics of the API;
bug fixes that bring actual behavior in line with semantics are allowed.
New API functions may be added over time. If a backwards incompatible
change is unavoidable, we will attempt to provide support for the legacy
API using the same export tag mechanism currently in place.
 
This module attempts to use few non-core dependencies. Non-core
configuration and testing modules will be bundled when reasonable;
run-time dependencies will be added only if they deliver substantial
benefit.
 
=head1 CONTRIBUTING
 
While contributions are appreciated, a contribution should not cause more
effort for the maintainer than the contribution itself saves (see
L<Open Source Contribution Etiquette|http://tirania.org/blog/archive/2010/Dec-31.html>).
 
To get more familiar where help could be needed - see L<List::MoreUtils::Contributing>.
 
=head1 BUGS
 
There is a problem with a bug in 5.6.x perls. It is a syntax error to write
things like:
 
my @x = apply { s/foo/bar/ } qw{ foo bar baz };
 
It has to be written as either
 
my @x = apply { s/foo/bar/ } 'foo', 'bar', 'baz';
 
or
 
my @x = apply { s/foo/bar/ } my @dummy = qw/foo bar baz/;
 
Perl 5.5.x and Perl 5.8.x don't suffer from this limitation.
 
If you have a functionality that you could imagine being in this module, please
drop me a line. This module's policy will be less strict than L<List::Util>'s
when it comes to additions as it isn't a core module.
 
When you report bugs, it would be nice if you could additionally give me the
output of your program with the environment variable C<LIST_MOREUTILS_PP> set
to a true value. That way I know where to look for the problem (in XS,
pure-Perl or possibly both).
 
=head1 SUPPORT
 
Bugs should always be submitted via the CPAN bug tracker.
 
You can find documentation for this module with the perldoc command.
 
perldoc List::MoreUtils
 
You can also look for information at:
 
=over 4
 
=item * RT: CPAN's request tracker
 
L<https://rt.cpan.org/Dist/Display.html?Name=List-MoreUtils>
 
=item * AnnoCPAN: Annotated CPAN documentation
 
L<http://annocpan.org/dist/List-MoreUtils>
 
=item * CPAN Ratings
 
L<http://cpanratings.perl.org/dist/List-MoreUtils>
 
=item * MetaCPAN
 
L<https://metacpan.org/release/List-MoreUtils>
 
=item * CPAN Search
 
L<http://search.cpan.org/dist/List-MoreUtils/>
 
=item * Git Repository
 
L<https://github.com/perl5-utils/List-MoreUtils>
 
=back
 
=head2 Where can I go for help?
 
If you have a bug report, a patch or a suggestion, please open a new
report ticket at CPAN (but please check previous reports first in case
your issue has already been addressed) or open an issue on GitHub.
 
Report tickets should contain a detailed description of the bug or
enhancement request and at least an easily verifiable way of
reproducing the issue or fix. Patches are always welcome, too - and
it's cheap to send pull-requests on GitHub. Please keep in mind that
code changes are more likely accepted when they're bundled with an
approving test.
 
If you think you've found a bug then please read
"How to Report Bugs Effectively" by Simon Tatham:
L<http://www.chiark.greenend.org.uk/~sgtatham/bugs.html>.
 
=head2 Where can I go for help with a concrete version?
 
Bugs and feature requests are accepted against the latest version
only. To get patches for earlier versions, you need to get an
agreement with a developer of your choice - who may or not report the
issue and a suggested fix upstream (depends on the license you have
chosen).
 
=head2 Business support and maintenance
 
Generally, in volunteered projects, there is no right for support.
While every maintainer is happy to improve the provided software,
spare time is limited.
 
For those who have a use case which requires guaranteed support, one of
the maintainers should be hired or contracted. For business support you
can contact Jens via his CPAN email address rehsackATcpan.org. Please
keep in mind that business support is neither available for free nor
are you eligible to receive any support based on the license distributed
with this package.
 
=head1 THANKS
 
=head2 Tassilo von Parseval
 
Credits go to a number of people: Steve Purkis for giving me namespace advice
and James Keenan and Terrence Branno for their effort of keeping the CPAN
tidier by making L<List::Utils> obsolete.
 
Brian McCauley suggested the inclusion of apply() and provided the pure-Perl
implementation for it.
 
Eric J. Roode asked me to add all functions from his module C<List::MoreUtil>
into this one. With minor modifications, the pure-Perl implementations of those
are by him.
 
The bunch of people who almost immediately pointed out the many problems with
the glitchy 0.07 release (Slaven Rezic, Ron Savage, CPAN testers).
 
A particularly nasty memory leak was spotted by Thomas A. Lowery.
 
Lars Thegler made me aware of problems with older Perl versions.
 
Anno Siegel de-orphaned each_arrayref().
 
David Filmer made me aware of a problem in each_arrayref that could ultimately
lead to a segfault.
 
Ricardo Signes suggested the inclusion of part() and provided the
Perl-implementation.
 
Robin Huston kindly fixed a bug in perl's MULTICALL API to make the
XS-implementation of part() work.
 
=head2 Jens Rehsack
 
Credits goes to all people contributing feedback during the v0.400
development releases.
 
Special thanks goes to David Golden who spent a lot of effort to develop
a design to support current state of CPAN as well as ancient software
somewhere in the dark. He also contributed a lot of patches to refactor
the API frontend to welcome any user of List::MoreUtils - from ancient
past to recently last used.
 
Toby Inkster provided a lot of useful feedback for sane importer code
and was a nice sounding board for API discussions.
 
Peter Rabbitson provided a sane git repository setup containing entire
package history.
 
=head1 TODO
 
A pile of requests from other people is still pending further processing in
my mailbox. This includes:
 
=over 4
 
=item * delete_index
 
=item * random_item
 
=item * random_item_delete_index
 
=item * list_diff_hash
 
=item * list_diff_inboth
 
=item * list_diff_infirst
 
=item * list_diff_insecond
 
These were all suggested by Dan Muey.
 
=item * listify
 
Always return a flat list when either a simple scalar value was passed or an
array-reference. Suggested by Mark Summersault.
 
=back
 
=head1 SEE ALSO
 
L<List::Util>, L<List::AllUtils>, L<List::UtilsBy>
 
=head1 AUTHOR
 
Jens Rehsack E<lt>rehsack AT cpan.orgE<gt>
 
Adam Kennedy E<lt>adamk@cpan.orgE<gt>
 
Tassilo von Parseval E<lt>tassilo.von.parseval@rwth-aachen.deE<gt>
 
=head1 COPYRIGHT AND LICENSE
 
Some parts copyright 2011 Aaron Crane.
 
Copyright 2004 - 2010 by Tassilo von Parseval
 
Copyright 2013 - 2017 by Jens Rehsack
 
All code added with 0.417 or later is licensed under the Apache License,
Version 2.0 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
 
http://www.apache.org/licenses/LICENSE-2.0
 
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
 
All code until 0.416 is licensed under the same terms as Perl itself,
either Perl version 5.8.4 or, at your option, any later version of
Perl 5 you may have available.
 
=cut
 
1;
/perl_lib/Number/Compare.pm
0,0 → 1,99
package Number::Compare;
use strict;
use Carp qw(croak);
use vars qw/$VERSION/;
$VERSION = '0.03';
 
sub new {
my $referent = shift;
my $class = ref $referent || $referent;
my $expr = $class->parse_to_perl( shift );
 
bless eval "sub { \$_[0] $expr }", $class;
}
 
sub parse_to_perl {
shift;
my $test = shift;
 
$test =~ m{^
([<>]=?)? # comparison
(.*?) # value
([kmg]i?)? # magnitude
$}ix
or croak "don't understand '$test' as a test";
 
my $comparison = $1 || '==';
my $target = $2;
my $magnitude = $3 || '';
$target *= 1000 if lc $magnitude eq 'k';
$target *= 1024 if lc $magnitude eq 'ki';
$target *= 1000000 if lc $magnitude eq 'm';
$target *= 1024*1024 if lc $magnitude eq 'mi';
$target *= 1000000000 if lc $magnitude eq 'g';
$target *= 1024*1024*1024 if lc $magnitude eq 'gi';
 
return "$comparison $target";
}
 
sub test { $_[0]->( $_[1] ) }
 
1;
 
__END__
 
=head1 NAME
 
Number::Compare - numeric comparisons
 
=head1 SYNOPSIS
 
Number::Compare->new(">1Ki")->test(1025); # is 1025 > 1024
 
my $c = Number::Compare->new(">1M");
$c->(1_200_000); # slightly terser invocation
 
=head1 DESCRIPTION
 
Number::Compare compiles a simple comparison to an anonymous
subroutine, which you can call with a value to be tested again.
 
Now this would be very pointless, if Number::Compare didn't understand
magnitudes.
 
The target value may use magnitudes of kilobytes (C<k>, C<ki>),
megabytes (C<m>, C<mi>), or gigabytes (C<g>, C<gi>). Those suffixed
with an C<i> use the appropriate 2**n version in accordance with the
IEC standard: http://physics.nist.gov/cuu/Units/binary.html
 
=head1 METHODS
 
=head2 ->new( $test )
 
Returns a new object that compares the specified test.
 
=head2 ->test( $value )
 
A longhanded version of $compare->( $value ). Predates blessed
subroutine reference implementation.
 
=head2 ->parse_to_perl( $test )
 
Returns a perl code fragment equivalent to the test.
 
=head1 AUTHOR
 
Richard Clamp <richardc@unixbeard.net>
 
=head1 COPYRIGHT
 
Copyright (C) 2002,2011 Richard Clamp. All Rights Reserved.
 
This module is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
 
=head1 SEE ALSO
 
http://physics.nist.gov/cuu/Units/binary.html
 
=cut
/perl_lib/Proc/Background/Unix.pm
0,0 → 1,300
package Proc::Background::Unix;
$Proc::Background::Unix::VERSION = '1.30';
# ABSTRACT: Unix-specific implementation of process create/wait/kill
require 5.004_04;
 
use strict;
use Exporter;
use Carp;
use POSIX qw( :errno_h :sys_wait_h );
 
# Test for existence of FD_CLOEXEC, needed for child-error-through-pipe trick
my ($FD_CLOEXEC);
eval {
require Fcntl;
$FD_CLOEXEC= Fcntl::FD_CLOEXEC();
};
 
# For un-explained mysterious reasons, Time::HiRes::alarm seem to misbehave on 5.10 and earlier
# but core alarm works fine.
my $alarm= ($] >= 5.012)? do { require Time::HiRes; \&Time::HiRes::alarm; }
: sub {
# round up to whole seconds
CORE::alarm(POSIX::ceil($_[0]));
};
 
@Proc::Background::Unix::ISA = qw(Exporter);
 
# Start the background process. If it is started sucessfully, then record
# the process id in $self->{_os_obj}.
sub _start {
my ($self, $options)= @_;
 
# There are three main scenarios for how-to-exec:
# * single-string command, to be handled by shell
# * arrayref command, to be handled by execve
# * arrayref command with 'exe' (fake argv0)
# and one that isn't logical:
# * single-string command with exe
# throw an error for that last one rather than trying something awkward
# like splitting the command string.
 
my @argv;
my $cmd= $self->{_command};
my $exe= $self->{_exe};
 
if (ref $cmd eq 'ARRAY') {
@argv= @$cmd;
($exe, my $err) = Proc::Background::_resolve_path(defined $exe? $exe : $argv[0]);
return $self->_fatal($err) unless defined $exe;
$self->{_exe}= $exe;
} elsif (defined $exe) {
croak "Can't combine 'exe' option with single-string 'command', use arrayref 'command' instead.";
}
 
if (defined $options->{cwd}) {
-d $options->{cwd}
or return $self->_fatal("directory does not exist: '$options->{cwd}'");
}
 
my ($new_stdin, $new_stdout, $new_stderr);
$new_stdin= _resolve_file_handle($options->{stdin}, '<', \*STDIN)
if exists $options->{stdin};
$new_stdout= _resolve_file_handle($options->{stdout}, '>>', \*STDOUT)
if exists $options->{stdout};
$new_stderr= _resolve_file_handle($options->{stderr}, '>>', \*STDERR)
if exists $options->{stderr};
 
# Fork a child process.
my ($pipe_r, $pipe_w);
if (defined $FD_CLOEXEC) {
# use a pipe for the child to report exec() errors
pipe $pipe_r, $pipe_w or return $self->_fatal("pipe: $!");
# This pipe needs to be in the non-preserved range that doesn't exist after exec().
# In the edge case where a pipe received a FD less than $^F, the CLOEXEC flag isn't set.
# Try again on higher descriptors, then close the lower ones.
my @rejects;
while (fileno $pipe_r <= $^F or fileno $pipe_w <= $^F) {
push @rejects, $pipe_r, $pipe_w;
pipe $pipe_r, $pipe_w or return $self->_fatal("pipe: $!");
}
}
my $pid;
{
if ($pid = fork()) {
# parent
$self->{_os_obj} = $pid;
$self->{_pid} = $pid;
if (defined $pipe_r) {
close $pipe_w;
# wait for child to reply or close the pipe
local $SIG{PIPE}= sub {};
my $msg= '';
while (0 < read $pipe_r, $msg, 1024, length $msg) {}
close $pipe_r;
# If child wrote anything to the pipe, it failed to exec.
# Reap it before dying.
if (length $msg) {
waitpid $pid, 0;
return $self->_fatal($msg);
}
}
last;
} elsif (defined $pid) {
# child
# Make absolutely sure nothing in this block interacts with the rest of the
# process state, and that flow control never skips the _exit().
eval {
local $SIG{__DIE__}= undef;
eval {
chdir($options->{cwd}) or die "chdir($options->{cwd}): $!\n"
if defined $options->{cwd};
 
open STDIN, '<&', $new_stdin or die "Can't redirect STDIN: $!\n"
if defined $new_stdin;
open STDOUT, '>&', $new_stdout or die "Can't redirect STDOUT: $!\n"
if defined $new_stdout;
open STDERR, '>&', $new_stderr or die "Can't redirect STDERR: $!\n"
if defined $new_stderr;
 
if (defined $exe) {
exec { $exe } @argv or die "$0: exec failed: $!\n";
} else {
exec $cmd or die "$0: exec failed: $!\n";
}
};
if (defined $pipe_w) {
print $pipe_w $@;
close $pipe_w; # force it to flush. Nothing else needs closed because we are about to _exit
} else {
print STDERR $@;
}
};
POSIX::_exit(1);
} elsif ($! == EAGAIN) {
sleep 5;
redo;
} else {
return $self->_fatal("fork: $!");
}
}
 
$self;
}
 
sub _resolve_file_handle {
my ($thing, $mode, $default)= @_;
if (!defined $thing) {
open my $fh, $mode, '/dev/null' or croak "open(/dev/null): $!";
return $fh;
} elsif (ref $thing) {
# use 'undef' to mean no-change
return (fileno($thing) == fileno($default))? undef : $thing;
} else {
open my $fh, $mode, $thing or croak "open($thing): $!";
return $fh;
}
}
 
# Wait for the child.
# (0, exit_value) : sucessfully waited on.
# (1, undef) : process already reaped and exit value lost.
# (2, undef) : process still running.
sub _waitpid {
my ($self, $blocking, $wait_seconds) = @_;
 
{
# Try to wait on the process.
# Implement the optional timeout with the 'alarm' call.
my $result= 0;
if ($blocking && $wait_seconds) {
local $SIG{ALRM}= sub { die "alarm\n" };
$alarm->($wait_seconds);
eval { $result= waitpid($self->{_os_obj}, 0); };
$alarm->(0);
}
else {
$result= waitpid($self->{_os_obj}, $blocking? 0 : WNOHANG);
}
 
# Process finished. Grab the exit value.
if ($result == $self->{_os_obj}) {
delete $self->{_suspended};
return (0, $?);
}
# Process already reaped. We don't know the exist status.
elsif ($result == -1 and $! == ECHILD) {
return (1, 0);
}
# Process still running.
elsif ($result == 0) {
return (2, 0);
}
# If we reach here, then waitpid caught a signal, so let's retry it.
redo;
}
return 0;
}
 
sub _suspend {
kill STOP => $_[0]->{_os_obj};
}
 
sub _resume {
kill CONT => $_[0]->{_os_obj};
}
 
sub _terminate {
my $self = shift;
my @kill_sequence= @_ && ref $_[0] eq 'ARRAY'? @{ $_[0] } : qw( TERM 2 TERM 8 KILL 3 KILL 7 );
# Try to kill the process with different signals. Calling alive() will
# collect the exit status of the program.
while (@kill_sequence and $self->alive) {
my $sig= shift @kill_sequence;
my $delay= shift @kill_sequence;
kill($sig, $self->{_os_obj});
next unless defined $delay;
last if $self->_reap(1, $delay); # block before sending next signal
}
}
 
1;
 
__END__
 
=pod
 
=encoding UTF-8
 
=head1 NAME
 
Proc::Background::Unix - Unix-specific implementation of process create/wait/kill
 
=head1 DESCRIPTION
 
This module does not have a public interface. Use L<Proc::Background>.
 
=head1 NAME
 
Proc::Background::Unix - Implementation of process management for Unix systems
 
=head1 IMPLEMENTATION
 
=head2 Command vs. Exec
 
Unix systems start a new process by creating a mirror of the current process
(C<fork>) and then having it alter its own state to prepare for the new
program, and then calling C<exec> to replace the running code with code loaded
from a new file. However, there is a second common method where the user
wants to specify a command line string as they would type it in their shell.
In this case, the actual program being executed is the shell, and the command
line is given as one element of its argument list.
 
Perl already supports both methods, such that if you pass one string to C<exec>
containing shell characters, it calls the shell, and if you pass multiple
arguments, it directly invokes C<exec>.
 
This module mostly just lets Perl's C<exec> do its job, but also checks for
the existence of the executable first, to make errors easier to catch. This
check is skipped if there is a single-string command line.
 
Unix lets you run a different executable than what is listed in the first
argument. (this feature lets one Unix executable behave as multiple
different programs depending on what name it sees in the first argument)
You can use that feature by passing separate options of C<exe> and C<command>
to this module's constructor instead of a simple argument list. But, you
can't mix a C<exe> option with a shell-interpreted command line string.
 
=head2 Errors during Exec
 
If the C<autodie> option is enabled, and the system supports C<FD_CLOEXEC>,
this module uses a trick where the forked child relays any errors through
a pipe so that the parent can throw and handle the exception directly instead
of creating a child process that is dead-on-arrival with the error on STDERR.
 
=head1 AUTHORS
 
=over 4
 
=item *
 
Blair Zajac <blair@orcaware.com>
 
=item *
 
Michael Conrad <mike@nrdvana.net>
 
=back
 
=head1 VERSION
 
version 1.30
 
=head1 COPYRIGHT AND LICENSE
 
This software is copyright (c) 2021 by Michael Conrad, (C) 1998-2009 by Blair Zajac.
 
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
 
=cut
/perl_lib/Proc/Background.pm
0,0 → 1,721
package Proc::Background;
$Proc::Background::VERSION = '1.30';
# ABSTRACT: Generic interface to Unix and Win32 background process management
require 5.004_04;
 
use strict;
use Exporter;
use Carp;
use Cwd;
use Scalar::Util;
@Proc::Background::ISA = qw(Exporter);
@Proc::Background::EXPORT_OK = qw(timeout_system);
 
# Determine if the operating system is Windows.
my $is_windows = $^O eq 'MSWin32';
my $weaken_subref = Scalar::Util->can('weaken');
 
# Set up a regular expression that tests if the path is absolute and
# if it has a directory separator in it. Also create a list of file
# extensions of append to the programs name to look for the real
# executable.
my $is_absolute_re;
my $has_dir_element_re;
my $path_sep;
my @extensions = ('');
if ($is_windows) {
$is_absolute_re = '^(?:(?:[a-zA-Z]:[\\\\/])|(?:[\\\\/]{2}\w+[\\\\/]))';
$has_dir_element_re = "[\\\\/]";
$path_sep = "\\";
push(@extensions, '.exe');
} else {
$is_absolute_re = "^/";
$has_dir_element_re = "/";
$path_sep = "/";
}
 
# Make this class a subclass of Proc::Win32 or Proc::Unix. Any
# unresolved method calls will go to either of these classes.
if ($is_windows) {
require Proc::Background::Win32;
unshift(@Proc::Background::ISA, 'Proc::Background::Win32');
} else {
require Proc::Background::Unix;
unshift(@Proc::Background::ISA, 'Proc::Background::Unix');
}
 
# Take either a relative or absolute path to a command and make it an
# absolute path.
sub _resolve_path {
my $command = shift;
 
return ( undef, 'empty command string' ) unless length $command;
 
# Make the path to the progam absolute if it isn't already. If the
# path is not absolute and if the path contains a directory element
# separator, then only prepend the current working to it. If the
# path is not absolute, then look through the PATH environment to
# find the executable. In all cases, look for the programs with any
# extensions added to the original path name.
my $path;
if ($command =~ /$is_absolute_re/o) {
foreach my $ext (@extensions) {
my $p = "$command$ext";
if (-f $p and -x _) {
$path = $p;
last;
}
}
return defined $path? ( $path, undef ) : ( undef, "no executable program located at $command" );
} else {
my $cwd = cwd;
if ($command =~ /$has_dir_element_re/o) {
my $p1 = "$cwd$path_sep$command";
foreach my $ext (@extensions) {
my $p2 = "$p1$ext";
if (-f $p2 and -x _) {
$path = $p2;
last;
}
}
} else {
foreach my $dir (split($is_windows ? ';' : ':', $ENV{PATH})) {
next unless length $dir;
$dir = "$cwd$path_sep$dir" unless $dir =~ /$is_absolute_re/o;
my $p1 = "$dir$path_sep$command";
foreach my $ext (@extensions) {
my $p2 = "$p1$ext";
if (-f $p2 and -x _) {
$path = $p2;
last;
}
}
last if defined $path;
}
}
return defined $path? ( $path, undef ) : ( undef, "cannot find absolute location of $command" );
}
}
 
# Define the set of allowed options, to warn about unknown ones.
# Make it a method so subclasses can override it.
%Proc::Background::_available_options= (
autodie => 1, command => 1, exe => 1,
cwd => 1, stdin => 1, stdout => 1, stderr => 1,
autoterminate => 1, die_upon_destroy => 1,
);
 
sub _available_options {
return \%Proc::Background::_available_options;
}
 
# We want the created object to live in Proc::Background instead of
# the OS specific class so that generic method calls can be used.
sub new {
my $class = shift;
 
# The parameters are an optional %options hashref followed by any number
# of arguments to become the @argv for exec(). If options are given, check
# the keys for typos.
my $options;
if (@_ and ref $_[0] eq 'HASH') {
$options= shift;
my $known= $class->_available_options;
my @unknown= grep !$known->{$_}, keys %$options;
carp "Unknown options: ".join(', ', @unknown)
if @unknown;
}
else {
$options= {};
}
 
my $self= bless {}, $class;
$self->{_autodie}= 1 if $options->{autodie};
 
# Resolve any confusion between the 'command' option and positional @argv params.
# Store the command in $self->{_command} so that the ::Unix and ::Win32 don't have
# to deal with it redundantly.
my $cmd= $options->{command};
if (defined $cmd) {
croak "Can't use both 'command' option and command argument list"
if @_;
# Can be an arrayref or a single string
croak "command must be a non-empty string or an arrayref of strings"
unless (ref $cmd eq 'ARRAY' && defined $cmd->[0] && length $cmd->[0])
or (!ref $cmd && defined $cmd && length $cmd);
}
else {
# Back-compat: maintain original API quirks
confess "Proc::Background::new called with insufficient number of arguments"
unless @_;
return $self->_fatal('command is undefined') unless defined $_[0];
 
# Interpret the parameters as an @argv if there is more than one,
# or if the 'exe' option was given.
$cmd= (@_ > 1 || defined $options->{exe})? [ @_ ] : $_[0];
}
 
$self->{_command}= $cmd;
$self->{_exe}= $options->{exe} if defined $options->{exe};
 
# Also back-compat: failing to fork or CreateProcess returns undef
return unless $self->_start($options);
 
# Save the start time
$self->{_start_time} = time;
 
if ($options->{autoterminate} || $options->{die_upon_destroy}) {
$self->autoterminate(1);
}
 
return $self;
}
 
# The original API returns undef from the constructor in case of various errors.
# The autodie option converts these undefs into exceptions.
sub _fatal {
my ($self, $message)= @_;
croak $message if $self->{_autodie};
warn "$0: $message";
return undef;
}
 
sub autoterminate {
my ($self, $newval)= @_;
if (@_ > 1 and ($newval xor $self->{_die_upon_destroy})) {
if ($newval) {
# Global destruction can break this feature, because there are no guarantees
# on which order object destructors are called. In order to avoid that, need
# to run all the ->die methods during END{}, and that requires weak
# references which weren't available until 5.8
$weaken_subref->( $Proc::Background::_die_upon_destroy{$self+0}= $self )
if $weaken_subref;
# could warn about it for earlier perl... but has been broken for 15 years and
# who is still using < 5.8 anyway?
}
else {
delete $Proc::Background::_die_upon_destroy{$self+0};
}
$self->{_die_upon_destroy}= $newval? 1 : 0;
}
$self->{_die_upon_destroy} || 0
}
 
sub DESTROY {
my $self = shift;
if ($self->{_die_upon_destroy}) {
# During a mainline exit() $? is the prospective exit code from the
# parent program. Preserve it across any waitpid() in die()
local $?;
$self->terminate;
delete $Proc::Background::_die_upon_destroy{$self+0};
}
}
 
END {
# Child processes need killed before global destruction, else the
# Win32::Process objects might get destroyed first.
for (grep defined, values %Proc::Background::_die_upon_destroy) {
$_->terminate;
delete $_->{_die_upon_destroy}
}
%Proc::Background::_die_upon_destroy= ();
}
 
# Reap the child. If the first argument is false, then return immediately.
# Else, block waiting for the process to exit. If no second argument is
# given, wait forever, else wait for that number of seconds.
# If the wait was sucessful, then delete
# $self->{_os_obj} and set $self->{_exit_value} to the OS specific
# class return of _reap. Return 1 if we sucessfully waited, 0
# otherwise.
sub _reap {
my ($self, $blocking, $wait_seconds) = @_;
 
return 0 unless exists($self->{_os_obj});
 
# Try to wait on the process. Use the OS dependent wait call using
# the Proc::Background::*::waitpid call, which returns one of three
# values.
# (0, exit_value) : sucessfully waited on.
# (1, undef) : process already reaped and exit value lost.
# (2, undef) : process still running.
my ($result, $exit_value) = $self->_waitpid($blocking, $wait_seconds);
if ($result == 0 or $result == 1) {
$self->{_exit_value} = defined($exit_value) ? $exit_value : 0;
delete $self->{_os_obj};
# Save the end time of the class.
$self->{_end_time} = time;
return 1;
}
return 0;
}
 
sub alive {
my $self = shift;
 
# If $self->{_os_obj} is not set, then the process is definitely
# not running.
return 0 unless exists($self->{_os_obj});
 
# If $self->{_exit_value} is set, then the process has already finished.
return 0 if exists($self->{_exit_value});
 
# Try to reap the child. If it doesn't reap, then it's alive.
!$self->_reap(0);
}
 
sub suspended {
$_[0]->{_suspended}? 1 : 0
}
 
sub suspend {
my $self= shift;
return $self->_fatal("can't suspend, process has exited")
if !$self->{_os_obj};
$self->{_suspended} = 1 if $self->_suspend;
return $self->{_suspended};
}
 
sub resume {
my $self= shift;
return $self->_fatal("can't resume, process has exited")
if !$self->{_os_obj};
$self->{_suspended} = 0 if $self->_resume;
return !$self->{_suspended};
}
 
sub wait {
my ($self, $timeout_seconds) = @_;
 
# If $self->{_exit_value} exists, then we already waited.
return $self->{_exit_value} if exists($self->{_exit_value});
 
carp "calling ->wait on a suspended process" if $self->{_suspended};
 
# If neither _os_obj or _exit_value are set, then something is wrong.
return undef if !exists($self->{_os_obj});
 
# Otherwise, wait for the process to finish.
return $self->_reap(1, $timeout_seconds)? $self->{_exit_value} : undef;
}
 
sub terminate { shift->die(@_) }
sub die {
my $self = shift;
 
croak "process is already terminated" if $self->{_autodie} && !$self->{_os_obj};
 
# See if the process has already died.
return 1 unless $self->alive;
 
# Kill the process using the OS specific method.
$self->_terminate(@_? ([ @_ ]) : ());
 
# See if the process is still alive.
!$self->alive;
}
 
sub command {
$_[0]->{_command};
}
 
sub exe {
$_[0]->{_exe}
}
 
sub start_time {
$_[0]->{_start_time};
}
 
sub exit_code {
return undef unless exists $_[0]->{_exit_value};
return $_[0]->{_exit_value} >> 8;
}
 
sub exit_signal {
return undef unless exists $_[0]->{_exit_value};
return $_[0]->{_exit_value} & 127;
}
 
sub end_time {
$_[0]->{_end_time};
}
 
sub pid {
$_[0]->{_pid};
}
 
sub timeout_system {
unless (@_ > 1) {
confess "$0: timeout_system passed too few arguments.\n";
}
 
my $timeout = shift;
unless ($timeout =~ /^\d+(?:\.\d*)?$/ or $timeout =~ /^\.\d+$/) {
confess "$0: timeout_system passed a non-positive number first argument.\n";
}
 
my $proc = Proc::Background->new(@_) or return;
my $end_time = $proc->start_time + $timeout;
my $delay= $timeout;
while ($delay > 0 && defined $proc->{_os_obj}) {
last if defined $proc->wait($delay);
# If it times out, it's likely that wait() already waited the entire duration.
# But, if it got interrupted, there might be time remaining.
# But, if the system clock changes, this could break horribly. Constrain it to a sane value.
my $t= time;
if ($t < $end_time - $delay) { # time moved backward!
$end_time= $t + $delay;
} else {
$delay= $end_time - $t;
}
}
 
my $alive = $proc->alive;
$proc->terminate if $alive;
 
if (wantarray) {
return ($proc->wait, $alive);
} else {
return $proc->wait;
}
}
 
1;
 
__END__
 
=pod
 
=encoding UTF-8
 
=head1 NAME
 
Proc::Background - Generic interface to Unix and Win32 background process management
 
=head1 SYNOPSIS
 
use Proc::Background;
timeout_system($seconds, $command, $arg1, $arg2);
timeout_system($seconds, "$command $arg1 $arg2");
my $proc1 = Proc::Background->new($command, $arg1, $arg2) || die "failed";
my $proc2 = Proc::Background->new("$command $arg1 1>&2") || die "failed";
if ($proc1->alive) {
$proc1->terminate;
$proc1->wait;
}
say 'Ran for ' . ($proc1->end_time - $proc1->start_time) . ' seconds';
Proc::Background->new({
autodie => 1, # Throw exceptions instead of returning undef
cwd => 'some/path/', # Set working directory for the new process
exe => 'busybox', # Specify executable different from argv[0]
command => [ $command ] # resolve ambiguity of command line vs. argv[0]
});
# Set initial file handles
Proc::Background->new({
stdin => undef, # /dev/null or NUL
stdout => '/append/to/fname', # will try to open()
stderr => $log_fh, # use existing handle
command => \@command,
});
# Automatically kill the process if the object gets destroyed
my $proc4 = Proc::Background->new({ autoterminate => 1 }, $command);
$proc4 = undef; # calls ->terminate
 
=head1 DESCRIPTION
 
This is a generic interface for placing processes in the background on
both Unix and Win32 platforms. This module lets you start, kill, wait
on, retrieve exit values, and see if background processes still exist.
 
=head1 CONSTRUCTOR
 
=over 4
 
=item B<new> [options] I<command>, [I<arg>, [I<arg>, ...]]
 
=item B<new> [options] 'I<command> [I<arg> [I<arg> ...]]'
 
This creates a new background process. Just like C<system()>, you can
supply a single string of the entire command line, or individual
arguments. The first argument may be a hashref of named options.
To resolve the ambiguity between a command line vs. a single-element
argument list, see the C<command> option below.
 
By default, the constructor returns an empty list on failure,
except for a few cases of invalid arguments which call C<croak>.
 
For platform-specific details, see L<Proc::Background::Unix/IMPLEMENTATION>
or L<Proc::Background::Win32/IMPLEMENTATION>, but in short:
 
=over 7
 
=item Unix
 
This implementation uses C<fork>/C<exec>. If you supply a single-string
command line, it is passed to the shell. If you supply multiple arguments,
they are passed to C<exec>. In the multi-argument case, it will also check
that the executable exists before calling C<fork>.
 
=item Win32
 
This implementation uses the L<Windows CreateProcess API|Win32::Process/METHODS>.
If you supply a single-string command line, it derives the executable by
parsing the command line and looking for the first element in the C<PATH>,
appending C<".exe"> if needed. If you supply multiple arguments, the
first is used as the C<exe> and the command line is built using
L<Win32::ShellQuote>.
 
=back
 
B<Options:>
 
=over
 
=item C<autodie>
 
This module traditionally has returned C<undef> if the child could not
be started. Modern Perl recommends the use of exceptions for things
like this. This option, like Perl's L<autodie> pragma, causes all
fatal errors in starting the process to die with exceptions instead of
returning undef.
 
=item C<command>
 
You may specify the command as an option instead of passing the command
as a list. A string value is considered a command line, and an arrayref
value is considered an argument list. This can resolve the ambiguity
between a command line vs. single-element argument list.
 
=item C<exe>
 
Specify the executable. This can serve two purposes:
on Win32 it avoids the parsing of the commandline, and on Unix it can be
used to run an executable while passing a different value for C<$ARGV[0]>.
 
=item C<stdin>, C<stdout>, C<stderr>
 
Specify one or more overrides for the standard handles of the child.
The value should be a Perl filehandle with an underlying system C<fileno>
value. As a convenience, you can pass C<undef> to open the C<NUL> device
on Win32 or C</dev/null> on Unix. You may also pass a plain-scalar file
name which this module will attmept to open for reading or appending.
 
(for anything more elaborate, see L<IPC::Run> instead)
 
Note that on Win32, none of the parent's handles are inherited by default,
which is the opposite on Unix. When you specify any of these handles on
Win32 the default will change to inherit them from the parent.
 
=item C<cwd>
 
Specify a path which should become the child process's current working
directory. The path must already exist.
 
=item C<autoterminate>
 
If you pass a true value for this option, then destruction of the
Proc::Background object (going out of scope, or script-end) will kill the
process via C<< ->terminate >>. Without this option, the child process
continues running. C<die_upon_destroy> is an alias for this option, used
by previous versions of this module.
 
=back
 
=back
 
=head1 ATTRIBUTES
 
=over
 
=item B<command>
 
The command (string or arrayref) that was passed to the constructor.
 
=item B<exe>
 
The path to the executable that was passed as an option to the constructor,
or derived from the C<command>.
 
=item B<start_time>
 
Return the value that the Perl function time() returned when the
process was started.
 
=item B<pid>
 
Returns the process ID of the created process. This value is saved
even if the process has already finished.
 
=item B<alive>
 
Return 1 if the process is still active, 0 otherwise. This makes a
non-blocking call to C<wait> to check the real status of the process if it
has not been reaped yet.
 
=item B<suspended>
 
Boolean whether the process is thought to be stopped. This does not actually
consult the operating system, and just returns the last known status from a
call to C<suspend> or C<resume>. It is always false if C<alive> is false.
 
=item B<exit_code>
 
Returns the exit code of the process, assuming it exited cleanly.
Returns C<undef> if the process has not exited yet, and 0 if the
process exited with a signal (or TerminateProcess). Since 0 is
ambiguous, check for C<exit_signal> first.
 
=item B<exit_signal>
 
Returns the value of the signal the process exited with, assuming it
died on a signal. Returns C<undef> if it has not exited yet, and 0
if it did not die to a signal.
 
=item B<end_time>
 
Return the value that the Perl function time() returned when the exit
status was obtained from the process.
 
=item B<autoterminate>
 
This writeable attribute lets you enable or disable the autoterminate
option, which could also be passed to the constructor.
 
=back
 
=head1 METHODS
 
=over
 
=item B<wait>
 
$exit= $proc->wait; # blocks forever
$exit= $proc->wait($timeout_seconds); # since version 1.20
 
Wait for the process to exit. Return the exit status of the command
as returned by wait() on the system. To get the actual exit value,
divide by 256 or right bit shift by 8, regardless of the operating
system being used. If the process never existed, this returns undef.
This function may be called multiple times even after the process has
exited and it will return the same exit status.
 
Since version 1.20, you may pass an optional argument of the number of
seconds to wait for the process to exit. This may be fractional, and
if it is zero then the wait will be non-blocking. Note that on Unix
this is implemented with L<Time::HiRes/alarm> before a call to wait(),
so it may not be compatible with scripts that use alarm() for other
purposes, or systems/perls that resume system calls after a signal.
In the event of a timeout, the return will be undef.
 
=item B<suspend>
 
Pause the process. This returns true if the process is stopped afterward.
This throws an excetion if the process is not C<alive> and C<autodie> is
enabled.
 
=item B<resume>
 
Resume a paused process. This returns true if the process is not stopped
afterward. This throws an exception if the process is not C<alive> and
C<autodie> is enabled.
 
=item B<terminate>, B<terminate(@kill_sequence)>
 
Reliably try to kill the process. Returns 1 if the process no longer
exists once B<terminate> has completed, 0 otherwise. This will also return
1 if the process has already exited.
 
C<@kill_sequence> is a list of actions and seconds-to-wait for that
action to end the process. The default is C< TERM 2 TERM 8 KILL 3 KILL 7 >.
On Unix this sends SIGTERM and SIGKILL; on Windows it just calls
TerminateProcess (graceful terminationthe second is set to 1 if the process was killed by
B<timeout_system> or 0 if the process exited by itself.
 
The exit status is the value returned from the wait() call. If the
process was killed, then the return value will include the killing of
it. To get the actual exit value, divide by 256.
 
If something failed in the creation of the process, the subroutine
returns an empty list in a list context, an undefined value in a
scalar context, or nothing in a void context.
 
=back
 
=head1 SEE ALSO
 
=over
 
=item L<IPC::Run>
 
IPC::Run is a much more complete solution for running child processes.
It handles dozens of forms of redirection and pipe pumping, and should
probably be your first stop for any complex needs.
 
However, also note the very large and slightly alarming list of
limitations it lists for Win32. Proc::Background is a much simpler design
and should be more reliable for simple needs.
 
=item L<Win32::ShellQuote>
 
If you are running on Win32, this article by Daniel Colascione helps
describe the problem you are up against for passing argument lists:
L<Everyone quotes command line arguments the wrong way|https://blogs.msdn.microsoft.com/twistylittlepassagesallalike/2011/04/23/everyone-quotes-command-line-arguments-the-wrong-way/>
 
This module gives you parsing / quoting per the standard
CommandLineToArgvW behavior. But, if you need to pass arguments to be
processed by C<cmd.exe> then you need to do additional work.
 
=back
 
=head1 AUTHORS
 
=over 4
 
=item *
 
Blair Zajac <blair@orcaware.com>
 
=item *
 
Michael Conrad <mike@nrdvana.net>
 
=back
 
=head1 CONTRIBUTORS
 
=for stopwords Florian Schlichting Kevin Ryde Salvador Fandiño
 
=over 4
 
=item *
 
Florian Schlichting <fsfs@debian.org>
 
=item *
 
Kevin Ryde <user42@zip.com.au>
 
=item *
 
Salvador Fandiño <sfandino@yahoo.com>
 
=back
 
=head1 VERSION
 
version 1.30
 
=head1 COPYRIGHT AND LICENSE
 
This software is copyright (c) 2021 by Michael Conrad, (C) 1998-2009 by Blair Zajac.
 
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
 
=cut
/perl_lib/String/MANIFEST
0,0 → 1,11
README
Changes
MANIFEST
COPYING
Makefile.PL
Similarity.pm
Similarity.xs
fstrcmp.h fstrcmp (from gnu gettext)
fstrcmp.c fstrcmp (from gnu gettext)
t/00_load.t
META.yml Module meta-data (added by MakeMaker)
/perl_lib/String/META.yml
0,0 → 1,20
--- #YAML:1.0
name: String-Similarity
version: 1.04
abstract: ~
author: []
license: unknown
distribution_type: module
configure_requires:
ExtUtils::MakeMaker: 0
build_requires:
ExtUtils::MakeMaker: 0
requires: {}
no_index:
directory:
- t
- inc
generated_by: ExtUtils::MakeMaker version 6.50
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: 1.4
/perl_lib/String/Makefile.PL
0,0 → 1,14
require 5.008;
 
use ExtUtils::MakeMaker;
 
WriteMakefile(
dist => {
PREOP => 'pod2text Similarity.pm | tee README >$(DISTVNAME)/README; chmod -R u=rwX,go=rX . ;',
COMPRESS => 'gzip -9v',
SUFFIX => '.gz',
},
NAME => "String::Similarity",
VERSION_FROM => "Similarity.pm",
);
 
/perl_lib/String/Similarity.pm
0,0 → 1,79
=head1 NAME
 
String::Similarity - calculate the similarity of two strings
 
=head1 SYNOPSIS
 
use String::Similarity;
 
$similarity = similarity $string1, $string2;
$similarity = similarity $string1, $string2, $limit;
 
=head1 DESCRIPTION
 
=over 4
 
=cut
 
package String::Similarity;
 
use Exporter;
use DynaLoader;
 
$VERSION = '1.04';
@ISA = qw/Exporter DynaLoader/;
@EXPORT = qw(similarity);
@EXPORT_OK = qw(fstrcmp);
 
bootstrap String::Similarity $VERSION;
 
=item $factor = similarity $string1, $string2, [$limit]
 
The C<similarity>-function calculates the similarity index of
its two arguments. A value of C<0> means that the strings are
entirely different. A value of C<1> means that the strings are
identical. Everything else lies between 0 and 1 and describes the amount
of similarity between the strings.
 
It roughly works by looking at the smallest number of edits to change one
string into the other.
 
You can add an optional argument C<$limit> (default 0) that gives the
minimum similarity the two strings must satisfy. C<similarity> stops
analyzing the string as soon as the result drops below the given limit,
in which case the result will be invalid but lower than the given
C<$limit>. You can use this to speed up the common case of searching for
the most similar string from a set by specifing the maximum similarity
found so far.
 
=cut
 
# out of historical reasons, I prefer "fstrcmp" as the original name.
*similarity = *fstrcmp;
 
1;
 
=back
 
=head1 SEE ALSO
 
The basic algorithm is described in:
"An O(ND) Difference Algorithm and its Variations", Eugene Myers,
Algorithmica Vol. 1 No. 2, 1986, pp. 251-266;
see especially section 4.2, which describes the variation used below.
 
The basic algorithm was independently discovered as described in:
"Algorithms for Approximate String Matching", E. Ukkonen,
Information and Control Vol. 64, 1985, pp. 100-118.
 
=head1 AUTHOR
 
Marc Lehmann <schmorp@schmorp.de>
http://home.schmorp.de/
 
(the underlying fstrcmp function was taken from gnu diffutils and
modified by Peter Miller <pmiller@agso.gov.au> and Marc Lehmann
<schmorp@schmorp.de>).
 
 
 
perl_lib/String/Similarity.pm Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: perl_lib/String/Similarity.xs =================================================================== --- perl_lib/String/Similarity.xs (nonexistent) +++ perl_lib/String/Similarity.xs (revision 56) @@ -0,0 +1,54 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include "fstrcmp.h" +#include "fstrcmp.c" + +UV * +text2UV (SV *sv, STRLEN *lenp) +{ + STRLEN len; + char *s = SvPV (sv, len); + UV *r = (UV *)SvPVX (sv_2mortal (NEWSV (0, (len + 1) * sizeof (UV)))); + UV *p = r; + + if (SvUTF8 (sv)) + { + STRLEN clen; + while (len) + { + *p++ = utf8n_to_uvchr (s, len, &clen, 0); + + if (clen < 0) + croak ("illegal unicode character in string"); + + s += clen; + len -= clen; + } + } + else + while (len--) + *p++ = *(unsigned char *)s++; + + *lenp = p - r; + return r; +} + +MODULE = String::Similarity PACKAGE = String::Similarity + +double +fstrcmp(s1, s2, minimum_similarity = 0) + SV * s1 + SV * s2 + double minimum_similarity + PROTOTYPE: @ + CODE: +{ + STRLEN l1, l2; + UV *c1 = text2UV (s1, &l1); + UV *c2 = text2UV (s2, &l2); + RETVAL = fstrcmp (c1, l1, c2, l2, minimum_similarity); +} + OUTPUT: + RETVAL Index: perl_lib/String/fstrcmp.c =================================================================== --- perl_lib/String/fstrcmp.c (nonexistent) +++ perl_lib/String/fstrcmp.c (revision 56) @@ -0,0 +1,638 @@ +/* Functions to make fuzzy comparisons between strings + Copyright (C) 1988, 1989, 1992, 1993, 1995 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or (at + your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + + Derived from GNU diff 2.7, analyze.c et al. + + The basic algorithm is described in: + "An O(ND) Difference Algorithm and its Variations", Eugene Myers, + Algorithmica Vol. 1 No. 2, 1986, pp. 251-266; + see especially section 4.2, which describes the variation used below. + + The basic algorithm was independently discovered as described in: + "Algorithms for Approximate String Matching", E. Ukkonen, + Information and Control Vol. 64, 1985, pp. 100-118. + + Modified to work on strings rather than files + by Peter Miller , October 1995 + + Modified to accept a "minimum similarity limit" to stop analyzing the + string when the similarity drops below the given limit by Marc Lehmann + . + + Modified to work on unicode (actually 31 bit are allowed) by Marc Lehmann + . +*/ + +#include +#include +#include +#include + +#include "fstrcmp.h" + +#define PARAMS(proto) proto + +/* + * Data on one input string being compared. + */ +struct string_data +{ + /* The string to be compared. */ + const UV *data; + + /* The length of the string to be compared. */ + int data_length; + + /* The number of characters inserted or deleted. */ + int edit_count; +}; + +static struct string_data string[2]; + +static int max_edits; /* compareseq stops when edits > max_edits */ + +#ifdef MINUS_H_FLAG + +/* This corresponds to the diff -H flag. With this heuristic, for + strings with a constant small density of changes, the algorithm is + linear in the strings size. This is unlikely in typical uses of + fstrcmp, and so is usually compiled out. Besides, there is no + interface to set it true. */ +static int heuristic; + +#endif + + +/* Vector, indexed by diagonal, containing 1 + the X coordinate of the + point furthest along the given diagonal in the forward search of the + edit matrix. */ +static int *fdiag; + +/* Vector, indexed by diagonal, containing the X coordinate of the point + furthest along the given diagonal in the backward search of the edit + matrix. */ +static int *bdiag; + +/* Edit scripts longer than this are too expensive to compute. */ +static int too_expensive; + +/* Snakes bigger than this are considered `big'. */ +#define SNAKE_LIMIT 20 + +struct partition +{ + /* Midpoints of this partition. */ + int xmid, ymid; + + /* Nonzero if low half will be analyzed minimally. */ + int lo_minimal; + + /* Likewise for high half. */ + int hi_minimal; +}; + + +/* NAME + diag - find diagonal path + + SYNOPSIS + int diag(int xoff, int xlim, int yoff, int ylim, int minimal, + struct partition *part); + + DESCRIPTION + Find the midpoint of the shortest edit script for a specified + portion of the two strings. + + Scan from the beginnings of the strings, and simultaneously from + the ends, doing a breadth-first search through the space of + edit-sequence. When the two searches meet, we have found the + midpoint of the shortest edit sequence. + + If MINIMAL is nonzero, find the minimal edit script regardless + of expense. Otherwise, if the search is too expensive, use + heuristics to stop the search and report a suboptimal answer. + + RETURNS + Set PART->(XMID,YMID) to the midpoint (XMID,YMID). The diagonal + number XMID - YMID equals the number of inserted characters + minus the number of deleted characters (counting only characters + before the midpoint). Return the approximate edit cost; this is + the total number of characters inserted or deleted (counting + only characters before the midpoint), unless a heuristic is used + to terminate the search prematurely. + + Set PART->LEFT_MINIMAL to nonzero iff the minimal edit script + for the left half of the partition is known; similarly for + PART->RIGHT_MINIMAL. + + CAVEAT + This function assumes that the first characters of the specified + portions of the two strings do not match, and likewise that the + last characters do not match. The caller must trim matching + characters from the beginning and end of the portions it is + going to specify. + + If we return the "wrong" partitions, the worst this can do is + cause suboptimal diff output. It cannot cause incorrect diff + output. */ + +static int diag PARAMS ((int, int, int, int, int, struct partition *)); + +static int +diag (xoff, xlim, yoff, ylim, minimal, part) + int xoff; + int xlim; + int yoff; + int ylim; + int minimal; + struct partition *part; +{ + int *const fd = fdiag; /* Give the compiler a chance. */ + int *const bd = bdiag; /* Additional help for the compiler. */ + const UV *const xv = string[0].data; /* Still more help for the compiler. */ + const UV *const yv = string[1].data; /* And more and more . . . */ + const int dmin = xoff - ylim; /* Minimum valid diagonal. */ + const int dmax = xlim - yoff; /* Maximum valid diagonal. */ + const int fmid = xoff - yoff; /* Center diagonal of top-down search. */ + const int bmid = xlim - ylim; /* Center diagonal of bottom-up search. */ + int fmin = fmid; + int fmax = fmid; /* Limits of top-down search. */ + int bmin = bmid; + int bmax = bmid; /* Limits of bottom-up search. */ + int c; /* Cost. */ + int odd = (fmid - bmid) & 1; + + /* + * True if southeast corner is on an odd diagonal with respect + * to the northwest. + */ + fd[fmid] = xoff; + bd[bmid] = xlim; + for (c = 1;; ++c) + { + int d; /* Active diagonal. */ + int big_snake; + + big_snake = 0; + /* Extend the top-down search by an edit step in each diagonal. */ + if (fmin > dmin) + fd[--fmin - 1] = -1; + else + ++fmin; + if (fmax < dmax) + fd[++fmax + 1] = -1; + else + --fmax; + for (d = fmax; d >= fmin; d -= 2) + { + int x; + int y; + int oldx; + int tlo; + int thi; + + tlo = fd[d - 1], + thi = fd[d + 1]; + + if (tlo >= thi) + x = tlo + 1; + else + x = thi; + oldx = x; + y = x - d; + while (x < xlim && y < ylim && xv[x] == yv[y]) + { + ++x; + ++y; + } + if (x - oldx > SNAKE_LIMIT) + big_snake = 1; + fd[d] = x; + if (odd && bmin <= d && d <= bmax && bd[d] <= x) + { + part->xmid = x; + part->ymid = y; + part->lo_minimal = part->hi_minimal = 1; + return 2 * c - 1; + } + } + /* Similarly extend the bottom-up search. */ + if (bmin > dmin) + bd[--bmin - 1] = INT_MAX; + else + ++bmin; + if (bmax < dmax) + bd[++bmax + 1] = INT_MAX; + else + --bmax; + for (d = bmax; d >= bmin; d -= 2) + { + int x; + int y; + int oldx; + int tlo; + int thi; + + tlo = bd[d - 1], + thi = bd[d + 1]; + if (tlo < thi) + x = tlo; + else + x = thi - 1; + oldx = x; + y = x - d; + while (x > xoff && y > yoff && xv[x - 1] == yv[y - 1]) + { + --x; + --y; + } + if (oldx - x > SNAKE_LIMIT) + big_snake = 1; + bd[d] = x; + if (!odd && fmin <= d && d <= fmax && x <= fd[d]) + { + part->xmid = x; + part->ymid = y; + part->lo_minimal = part->hi_minimal = 1; + return 2 * c; + } + } + + if (minimal) + continue; + +#ifdef MINUS_H_FLAG + /* Heuristic: check occasionally for a diagonal that has made lots + of progress compared with the edit distance. If we have any + such, find the one that has made the most progress and return + it as if it had succeeded. + + With this heuristic, for strings with a constant small density + of changes, the algorithm is linear in the strings size. */ + if (c > 200 && big_snake && heuristic) + { + int best; + + best = 0; + for (d = fmax; d >= fmin; d -= 2) + { + int dd; + int x; + int y; + int v; + + dd = d - fmid; + x = fd[d]; + y = x - d; + v = (x - xoff) * 2 - dd; + + if (v > 12 * (c + (dd < 0 ? -dd : dd))) + { + if + ( + v > best + && + xoff + SNAKE_LIMIT <= x + && + x < xlim + && + yoff + SNAKE_LIMIT <= y + && + y < ylim + ) + { + /* We have a good enough best diagonal; now insist + that it end with a significant snake. */ + int k; + + for (k = 1; xv[x - k] == yv[y - k]; k++) + { + if (k == SNAKE_LIMIT) + { + best = v; + part->xmid = x; + part->ymid = y; + break; + } + } + } + } + } + if (best > 0) + { + part->lo_minimal = 1; + part->hi_minimal = 0; + return 2 * c - 1; + } + best = 0; + for (d = bmax; d >= bmin; d -= 2) + { + int dd; + int x; + int y; + int v; + + dd = d - bmid; + x = bd[d]; + y = x - d; + v = (xlim - x) * 2 + dd; + + if (v > 12 * (c + (dd < 0 ? -dd : dd))) + { + if (v > best && xoff < x && x <= xlim - SNAKE_LIMIT && + yoff < y && y <= ylim - SNAKE_LIMIT) + { + /* We have a good enough best diagonal; now insist + that it end with a significant snake. */ + int k; + + for (k = 0; xv[x + k] == yv[y + k]; k++) + { + if (k == SNAKE_LIMIT - 1) + { + best = v; + part->xmid = x; + part->ymid = y; + break; + } + } + } + } + } + if (best > 0) + { + part->lo_minimal = 0; + part->hi_minimal = 1; + return 2 * c - 1; + } + } +#endif /* MINUS_H_FLAG */ + + /* Heuristic: if we've gone well beyond the call of duty, give up + and report halfway between our best results so far. */ + if (c >= too_expensive) + { + int fxybest; + int fxbest; + int bxybest; + int bxbest; + + /* Pacify `gcc -Wall'. */ + fxbest = 0; + bxbest = 0; + + /* Find forward diagonal that maximizes X + Y. */ + fxybest = -1; + for (d = fmax; d >= fmin; d -= 2) + { + int x; + int y; + + x = fd[d] < xlim ? fd[d] : xlim; + y = x - d; + + if (ylim < y) + { + x = ylim + d; + y = ylim; + } + if (fxybest < x + y) + { + fxybest = x + y; + fxbest = x; + } + } + /* Find backward diagonal that minimizes X + Y. */ + bxybest = INT_MAX; + for (d = bmax; d >= bmin; d -= 2) + { + int x; + int y; + + x = xoff > bd[d] ? xoff : bd[d]; + y = x - d; + + if (y < yoff) + { + x = yoff + d; + y = yoff; + } + if (x + y < bxybest) + { + bxybest = x + y; + bxbest = x; + } + } + /* Use the better of the two diagonals. */ + if ((xlim + ylim) - bxybest < fxybest - (xoff + yoff)) + { + part->xmid = fxbest; + part->ymid = fxybest - fxbest; + part->lo_minimal = 1; + part->hi_minimal = 0; + } + else + { + part->xmid = bxbest; + part->ymid = bxybest - bxbest; + part->lo_minimal = 0; + part->hi_minimal = 1; + } + return 2 * c - 1; + } + } +} + + +/* NAME + compareseq - find edit sequence + + SYNOPSIS + void compareseq(int xoff, int xlim, int yoff, int ylim, int minimal); + + DESCRIPTION + Compare in detail contiguous subsequences of the two strings + which are known, as a whole, to match each other. + + The subsequence of string 0 is [XOFF, XLIM) and likewise for + string 1. + + Note that XLIM, YLIM are exclusive bounds. All character + numbers are origin-0. + + If MINIMAL is nonzero, find a minimal difference no matter how + expensive it is. */ + +static void compareseq PARAMS ((int, int, int, int, int)); + +static void +compareseq (xoff, xlim, yoff, ylim, minimal) + int xoff; + int xlim; + int yoff; + int ylim; + int minimal; +{ + const UV *const xv = string[0].data; /* Help the compiler. */ + const UV *const yv = string[1].data; + + if (string[1].edit_count + string[0].edit_count > max_edits) + return; + + /* Slide down the bottom initial diagonal. */ + while (xoff < xlim && yoff < ylim && xv[xoff] == yv[yoff]) + { + ++xoff; + ++yoff; + } + + /* Slide up the top initial diagonal. */ + while (xlim > xoff && ylim > yoff && xv[xlim - 1] == yv[ylim - 1]) + { + --xlim; + --ylim; + } + + /* Handle simple cases. */ + if (xoff == xlim) + { + while (yoff < ylim) + { + ++string[1].edit_count; + ++yoff; + } + } + else if (yoff == ylim) + { + while (xoff < xlim) + { + ++string[0].edit_count; + ++xoff; + } + } + else + { + int c; + struct partition part; + + /* Find a point of correspondence in the middle of the strings. */ + c = diag (xoff, xlim, yoff, ylim, minimal, &part); + if (c == 1) + { +#if 0 + /* This should be impossible, because it implies that one of + the two subsequences is empty, and that case was handled + above without calling `diag'. Let's verify that this is + true. */ + abort (); +#else + /* The two subsequences differ by a single insert or delete; + record it and we are done. */ + if (part.xmid - part.ymid < xoff - yoff) + ++string[1].edit_count; + else + ++string[0].edit_count; +#endif + } + else + { + /* Use the partitions to split this problem into subproblems. */ + compareseq (xoff, part.xmid, yoff, part.ymid, part.lo_minimal); + compareseq (part.xmid, xlim, part.ymid, ylim, part.hi_minimal); + } + } +} + + +/* NAME + fstrcmp - fuzzy string compare + + SYNOPSIS + double fstrcmp(const ChaR *s1, int l1, const UV *s2, int l2, double); + + DESCRIPTION + The fstrcmp function may be used to compare two string for + similarity. It is very useful in reducing "cascade" or + "secondary" errors in compilers or other situations where + symbol tables occur. + + RETURNS + double; 0 if the strings are entirly dissimilar, 1 if the + strings are identical, and a number in between if they are + similar. */ + +double +fstrcmp (const UV *string1, int length1, + const UV *string2, int length2, + double minimum) +{ + int i; + + size_t fdiag_len; + static int *fdiag_buf; + static size_t fdiag_max; + + /* set the info for each string. */ + string[0].data = string1; + string[0].data_length = length1; + string[1].data = string2; + string[1].data_length = length2; + + /* short-circuit obvious comparisons */ + if (string[0].data_length == 0 && string[1].data_length == 0) + return 1.0; + if (string[0].data_length == 0 || string[1].data_length == 0) + return 0.0; + + /* Set TOO_EXPENSIVE to be approximate square root of input size, + bounded below by 256. */ + too_expensive = 1; + for (i = string[0].data_length + string[1].data_length; i != 0; i >>= 2) + too_expensive <<= 1; + if (too_expensive < 256) + too_expensive = 256; + + /* Because fstrcmp is typically called multiple times, while scanning + symbol tables, etc, attempt to minimize the number of memory + allocations performed. Thus, we use a static buffer for the + diagonal vectors, and never free them. */ + fdiag_len = string[0].data_length + string[1].data_length + 3; + if (fdiag_len > fdiag_max) + { + fdiag_max = fdiag_len; + fdiag_buf = realloc (fdiag_buf, fdiag_max * (2 * sizeof (int))); + } + fdiag = fdiag_buf + string[1].data_length + 1; + bdiag = fdiag + fdiag_len; + + max_edits = 1 + (string[0].data_length + string[1].data_length) * (1. - minimum); + + /* Now do the main comparison algorithm */ + string[0].edit_count = 0; + string[1].edit_count = 0; + compareseq (0, string[0].data_length, 0, string[1].data_length, 0); + + /* The result is + ((number of chars in common) / (average length of the strings)). + This is admittedly biased towards finding that the strings are + similar, however it does produce meaningful results. */ + return ((double) + (string[0].data_length + string[1].data_length - string[1].edit_count - string[0].edit_count) + / (string[0].data_length + string[1].data_length)); + +} Index: perl_lib/String/fstrcmp.h =================================================================== --- perl_lib/String/fstrcmp.h (nonexistent) +++ perl_lib/String/fstrcmp.h (revision 56) @@ -0,0 +1,25 @@ +/* GNU gettext - internationalization aids + Copyright (C) 1995 Free Software Foundation, Inc. + + This file was written by Peter Miller + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ + +#ifndef _FSTRCMP_H +#define _FSTRCMP_H + +double fstrcmp (const UV *__s1, int __l1, const UV *__s2, int __l2, double __minimum); + +#endif Index: perl_lib/Text/Glob.pm =================================================================== --- perl_lib/Text/Glob.pm (nonexistent) +++ perl_lib/Text/Glob.pm (revision 56) @@ -0,0 +1,202 @@ +package Text::Glob; +use strict; +use Exporter; +use vars qw/$VERSION @ISA @EXPORT_OK + $strict_leading_dot $strict_wildcard_slash/; +$VERSION = '0.11'; +@ISA = 'Exporter'; +@EXPORT_OK = qw( glob_to_regex glob_to_regex_string match_glob ); + +$strict_leading_dot = 1; +$strict_wildcard_slash = 1; + +use constant debug => 0; + +sub glob_to_regex { + my $glob = shift; + my $regex = glob_to_regex_string($glob); + return qr/^$regex$/; +} + +sub glob_to_regex_string +{ + my $glob = shift; + + my $seperator = $Text::Glob::seperator; + $seperator = "/" unless defined $seperator; + $seperator = quotemeta($seperator); + + my ($regex, $in_curlies, $escaping); + local $_; + my $first_byte = 1; + for ($glob =~ m/(.)/gs) { + if ($first_byte) { + if ($strict_leading_dot) { + $regex .= '(?=[^\.])' unless $_ eq '.'; + } + $first_byte = 0; + } + if ($_ eq '/') { + $first_byte = 1; + } + if ($_ eq '.' || $_ eq '(' || $_ eq ')' || $_ eq '|' || + $_ eq '+' || $_ eq '^' || $_ eq '$' || $_ eq '@' || $_ eq '%' ) { + $regex .= "\\$_"; + } + elsif ($_ eq '*') { + $regex .= $escaping ? "\\*" : + $strict_wildcard_slash ? "(?:(?!$seperator).)*" : ".*"; + } + elsif ($_ eq '?') { + $regex .= $escaping ? "\\?" : + $strict_wildcard_slash ? "(?!$seperator)." : "."; + } + elsif ($_ eq '{') { + $regex .= $escaping ? "\\{" : "("; + ++$in_curlies unless $escaping; + } + elsif ($_ eq '}' && $in_curlies) { + $regex .= $escaping ? "}" : ")"; + --$in_curlies unless $escaping; + } + elsif ($_ eq ',' && $in_curlies) { + $regex .= $escaping ? "," : "|"; + } + elsif ($_ eq "\\") { + if ($escaping) { + $regex .= "\\\\"; + $escaping = 0; + } + else { + $escaping = 1; + } + next; + } + else { + $regex .= $_; + $escaping = 0; + } + $escaping = 0; + } + print "# $glob $regex\n" if debug; + + return $regex; +} + +sub match_glob { + print "# ", join(', ', map { "'$_'" } @_), "\n" if debug; + my $glob = shift; + my $regex = glob_to_regex $glob; + local $_; + grep { $_ =~ $regex } @_; +} + +1; +__END__ + +=head1 NAME + +Text::Glob - match globbing patterns against text + +=head1 SYNOPSIS + + use Text::Glob qw( match_glob glob_to_regex ); + + print "matched\n" if match_glob( "foo.*", "foo.bar" ); + + # prints foo.bar and foo.baz + my $regex = glob_to_regex( "foo.*" ); + for ( qw( foo.bar foo.baz foo bar ) ) { + print "matched: $_\n" if /$regex/; + } + +=head1 DESCRIPTION + +Text::Glob implements glob(3) style matching that can be used to match +against text, rather than fetching names from a filesystem. If you +want to do full file globbing use the File::Glob module instead. + +=head2 Routines + +=over + +=item match_glob( $glob, @things_to_test ) + +Returns the list of things which match the glob from the source list. + +=item glob_to_regex( $glob ) + +Returns a compiled regex which is the equivalent of the globbing +pattern. + +=item glob_to_regex_string( $glob ) + +Returns a regex string which is the equivalent of the globbing +pattern. + +=back + +=head1 SYNTAX + +The following metacharacters and rules are respected. + +=over + +=item C<*> - match zero or more characters + +C matches C, C, C and many many more. + +=item C - match exactly one character + +C matches C, but not C, or C + +=item Character sets/ranges + +C matches C and C + +C matches C, C, and C + +=item alternation + +C matches C, C, and +C + +=item leading . must be explicitly matched + +C<*.foo> does not match C<.bar.foo>. For this you must either specify +the leading . in the glob pattern (C<.*.foo>), or set +C<$Text::Glob::strict_leading_dot> to a false value while compiling +the regex. + +=item C<*> and C do not match the seperator (i.e. do not match C) + +C<*.foo> does not match C. For this you must either +explicitly match the / in the glob (C<*/*.foo>), or set +C<$Text::Glob::strict_wildcard_slash> to a false value while compiling +the regex, or change the seperator that Text::Glob uses by setting +C<$Text::Glob::seperator> to an alternative value while compiling the +the regex. + +=back + +=head1 BUGS + +The code uses qr// to produce compiled regexes, therefore this module +requires perl version 5.005_03 or newer. + +=head1 AUTHOR + +Richard Clamp + +=head1 COPYRIGHT + +Copyright (C) 2002, 2003, 2006, 2007 Richard Clamp. All Rights Reserved. + +This module is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L, glob(3) + +=cut Index: perl_lib/constant/boolean.pm =================================================================== --- perl_lib/constant/boolean.pm (nonexistent) +++ perl_lib/constant/boolean.pm (revision 56) @@ -0,0 +1,104 @@ +#!/usr/bin/perl -c + +package constant::boolean; + +=head1 NAME + +constant::boolean - Define TRUE and FALSE constants. + +=head1 SYNOPSIS + + use constant::boolean; + + use File::Spec; + + sub is_package_exist { + my ($package) = @_; + return FALSE unless defined $package; + foreach my $inc (@INC) { + my $filename = File::Spec->catfile( + split( /\//, $inc ), split( /\::/, $package ) + ) . '.pm'; + return TRUE if -f $filename; + }; + return FALSE; + }; + + no constant::boolean; + +=head1 DESCRIPTION + +Defines C and C constants in caller's namespace. You could use +simple values like empty string or zero for false, or any non-empty and +non-zero string value as true, but the C and C constants are more +descriptive. + +It is virtually the same as: + + # double "not" operator is used for converting scalar to boolean value + use constant TRUE => !! 1; + use constant FALSE => !! ''; + +The constants exported by C are not reported by +L, so it is more convenient to use this module than to +define C and C constants by yourself. + +The constants can be removed from class API with C +pragma or some universal tool like L. + +=for readme stop + +=cut + +use 5.006; + +use strict; +use warnings; + +our $VERSION = '0.02'; + + +sub import { + my $caller = caller; + + no strict 'refs'; + # double "not" operator is used for converting scalar to boolean value + *{"${caller}::TRUE"} = sub () { !! 1 }; + *{"${caller}::FALSE"} = sub () { !! '' }; + + return 1; +}; + + +sub unimport { + require Symbol::Util; + + my $caller = caller; + Symbol::Util::delete_sub("${caller}::$_") foreach qw( TRUE FALSE ); + + return 1; +}; + + +1; + + +=head1 BUGS + +If you find the bug or want to implement new features, please report it at +L + +=for readme continue + +=head1 AUTHOR + +Piotr Roszatycki + +=head1 LICENSE + +Copyright 2008, 2009 by Piotr Roszatycki . + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +See L Index: report =================================================================== --- report (revision 55) +++ report (revision 56) @@ -1,9 +1,13 @@ Verification Results: -****************************mesh_4x4_2cycle_mcast_f : Compile *******************************: - model is generated successfully. -****************************mesh_4x4_2cycle_mcast_f : random traffic *******************************: - Passed: zero load (5,15.2151) saturation (30,357.163) -****************************mesh_4x4_2cycle_mcast_f : transposed 1 traffic *******************************: - Error in running simulation: 0: ERROR: Routing module did not set any destination port for an injected multicast packet TOP.router_top_v.router.router_ref.p_[0].multi.multicast_process.debg - 0: ERROR: The self-loop is not enabled in the router while a packet is injected to the NoC with identical source and destination address in endpoint 9. destination nodes:0X0200. : TOP.traffic_gen_top - +****************************star_6 : Compile *******************************: + model generation is FAILED. + %Error: Unknown warning specified: -Wno-TIMESCALEMOD + + %Error: Unknown warning specified: -Wno-TIMESCALEMOD + + %Error: Unknown warning specified: -Wno-TIMESCALEMOD + +****************************star_6 : random traffic *******************************: + failed. Simulation model is not avaialable +****************************star_6 : transposed 1 traffic *******************************: + failed. Simulation model is not avaialable Index: src/src.pl =================================================================== --- src/src.pl (revision 55) +++ src/src.pl (revision 56) @@ -1,7 +1,11 @@ #!/usr/bin/perl -w +use lib "../perl_lib"; + +use List::MoreUtils qw(uniq); use Proc::Background; use File::Path qw( rmtree ); +use Cwd 'abs_path'; my $script_path = dirname(__FILE__); my $dirname = "$script_path/.."; @@ -14,7 +18,7 @@ my $src = "$script_path"; my $report = "$dirname/report"; -require "$root/perl_gui/lib/perl/common.pl"; +#require "$root/perl_gui/lib/perl/common.pl"; require "$root/perl_gui/lib/perl/topology.pl"; use strict; @@ -318,6 +322,17 @@ } +sub check_models_are_exsited { + my ($mref, $inref) = @_; + my @models = get_model_names(@_); + foreach my $m (@models){ + unless (-f $m ){ + die "Error: no such file $m"; + } + } +} + + sub gen_models { my ($mref, $inref) = @_; my @models = get_model_names(@_); @@ -326,6 +341,9 @@ mkdir("$work", 0700); foreach my $m (@models){ print "$m\n"; + unless (-f $m ){ + die "Error: no such file $m"; + } #make noc localparam my $o; $o= do $m; @@ -605,3 +623,204 @@ $self->{'name'}{"$name"}{'traffic'}{$traffic}{'overal_result'}="passed"; } + +sub object_get_attribute_order{ + my ($self,$attribute)=@_; + return unless(defined $self->{parameters_order}{$attribute}); + my @order=@{$self->{parameters_order}{$attribute}}; + return uniq(@order) +} + +sub save_file { + my ($file_path,$text)=@_; + open my $fd, ">$file_path" or die "could not open $file_path: $!"; + print $fd $text; + close $fd; +} + +sub object_add_attribute_order{ + my ($self,$attribute,@param)=@_; + my $r = $self->{'parameters_order'}{$attribute}; + my @a; + @a = @{$r} if(defined $r); + push (@a,@param); + @a=uniq(@a); + $self->{'parameters_order'}{$attribute} =\@a; +} + +sub append_text_to_file { + my ($file_path,$text)=@_; + open(my $fd, ">>$file_path") or die "could not open $file_path: $!"; + print $fd $text; + close $fd; +} + +sub object_add_attribute{ + my ($self,$attribute1,$attribute2,$value)=@_; + if(!defined $attribute2){$self->{$attribute1}=$value;} + else {$self->{$attribute1}{$attribute2}=$value;} + +} + + + +sub object_get_attribute{ + my ($self,$attribute1,$attribute2)=@_; + if(!defined $attribute2) {return $self->{$attribute1};} + return $self->{$attribute1}{$attribute2}; +} + +sub powi{ # x^y + my ($x,$y)=@_; # compute x to the y + my $r=1; + for (my $i = 0; $i < $y; ++$i ) { + $r *= $x; + } + return $r; +} + +sub sum_powi{ # x^(y-1) + x^(y-2) + ...+ 1; + my ($x,$y)=@_; # compute x to the y + my $r = 0; + for (my $i = 0; $i < $y; $i++){ + $r += powi( $x, $i ); + } + return $r; +} + +sub log2{ + my $num=shift; + my $log=($num <=1) ? 1: 0; + while( (1<< $log) < $num) { + $log++; + } + return $log; +} + + +sub remove_not_hex { + my $s=shift; + $s =~ s/[^0-9a-fA-F]//g; + return $s; +} + +sub remove_not_number { + my $s=shift; + $s =~ s/[^0-9]//g; + return $s; + +} + +sub check_file_has_string { + my ($file,$string)=@_; + my $r; + open(FILE,$file); + if (grep{/$string/} ){ + $r= 1; #print "word found\n"; + }else{ + $r= 0; #print "word not found\n"; + } + close FILE; + return $r; +} + + +sub gen_verilator_makefile{ + my ($top_ref,$target_dir) =@_; + my %tops = %{$top_ref}; + my $p=''; + my $q=''; + my $h=''; + my $l; + my $lib_num=0; + my $all_lib=""; + foreach my $top (sort keys %tops) { + $p = "$p ${top}__ALL.a "; + $q = $q."lib$lib_num:\n\t\$(MAKE) -f ${top}.mk\n"; + $h = "$h ${top}.h "; + $l = $top; + $all_lib=$all_lib." lib$lib_num"; + $lib_num++; + } + + my $make= " + +default: sim + + + +include $l.mk + +lib: $all_lib + +$q + + +####################################################################### +# Compile flags + +CPPFLAGS += -DVL_DEBUG=1 +ifeq (\$(CFG_WITH_CCWARN),yes) # Local... Else don't burden users +CPPFLAGS += -DVL_THREADED=1 +CPPFLAGS += -W -Werror -Wall +endif + +SLIB = +HLIB = +ifneq (\$(wildcard synful/synful.a),) +SLIB += synful/synful.a +HLIB += synful/synful.h +endif + +####################################################################### +# Linking final exe -- presumes have a sim_main.cpp + + +sim: testbench.o \$(VK_GLOBAL_OBJS) $p \$(SLIB) + \$(LINK) \$(LDFLAGS) -g \$^ \$(LOADLIBES) \$(LDLIBS) -o testbench \$(LIBS) -Wall -O3 -lpthread 2>&1 | c++filt + +testbench.o: testbench.cpp $h \$(HLIB) + +clean: + rm *.o *.a testbench +"; + +save_file ($target_dir,$make); + +} + + +sub get_project_dir{ #mpsoc directory address + my $dir = Cwd::getcwd(); + my @p= split('/perl_gui',$dir); + @p= split('/Integration_test',$p[0]); + my $d = abs_path("$p[0]/../"); + + return $d; +} + +#return lines containig pattern in a givn file +sub unix_grep { + my ($file,$pattern)=@_; + open(FILE,$file); + my @arr = ; + my @lines = grep /$pattern/, @arr; + return @lines; +} + + +sub regen_object { + my $path=shift; + $path = get_full_path_addr($path); + my $pp= eval { do $path }; + my $r= ($@ || !defined $pp); + return ($pp,$r,$@); +} + +sub get_full_path_addr{ + my $file=shift; + my $dir = Cwd::getcwd(); + my $full_path = "$dir/$file"; + return $full_path if -f ($full_path ); + return $file; +}
/verify.perl
2,6 → 2,7
package ProNOC;
 
use Getopt::Std;
use lib perl_lib;
 
 
# perl verify.pl [model-name] p min max step
45,23 → 46,23
}
 
 
if (defined $options{h} ) {
if (defined $options{h} ) {
print " Usage: perl verify.pl [options]
-h show this help
-h show this help
-p <int number> : Enter the number of parallel simulations or
compilations. The default value is 4.
-u <int number> : Enter the maximum injection ratio in %. Default is 80
-l <int number> : Enter the minimum injection ratio in %. Default is 5
-s <int number> : Enter the injection step increase ratio in %.
-s <int number> : Enter the injection step increase ratio in %.
Default value is 25.
-d <dir name> : The dir name where the simulation models configuration
files are located in. The default dir is \"models\"
-m <simulation model name1,simulation model name2,...> : Enter the
files are located in. The default dir is \"models\"
-m <simulation model name1,simulation model name2,...> : Enter the
simulation model name in simulation dir. If the simulation model name
is not provided, it runs the simulation for all
is not provided, it runs the simulation for all
existing models.
";
exit;
exit;
}
 
my $paralel_run= 4;
80,7 → 81,7
$model_dir = $options{d} if defined $options{d};
 
if (defined $options{m}){
@models = split(",",$options{m});
@models = split(",",$options{m});
}
 
 
91,7 → 92,7
 
 
__PACKAGE__->mk_accessors(qw{
models
models
});
 
my $app = __PACKAGE__->new();
108,11 → 109,14
print "Maximum number of parallel simulation is $paralel_run.\n The injection ratio is set as MIN=$MIN,MAX=$MAX,STEP=$STEP.\n";
print "\t The simulation models are taken from $model_dir\n";
if (defined $options{m}){
foreach my $p (@models ){ print "\t\t$p\n";}
foreach my $p (@models ){
print "\t\t$p\n";
}
}
 
my @log_report_match =("Error","Warning" );
check_models_are_exsited(\@models,\@inputs);
 
my @log_report_match =("Error","Warning" );
 
 
save_file ("$dirname/report","Verification Results:\n");

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.