[Bps-public-commit] r13653 - in Scalar-Defer: . inc/Module inc/Module/Install inc/Test inc/Test/Builder
audreyt at bestpractical.com
audreyt at bestpractical.com
Fri Jun 27 12:04:38 EDT 2008
Author: audreyt
Date: Fri Jun 27 12:04:25 2008
New Revision: 13653
Modified:
Scalar-Defer/Changes
Scalar-Defer/MANIFEST
Scalar-Defer/README
Scalar-Defer/inc/Module/Install.pm
Scalar-Defer/inc/Module/Install/AutoInstall.pm
Scalar-Defer/inc/Module/Install/Base.pm
Scalar-Defer/inc/Module/Install/Can.pm
Scalar-Defer/inc/Module/Install/Fetch.pm
Scalar-Defer/inc/Module/Install/Include.pm
Scalar-Defer/inc/Module/Install/Makefile.pm
Scalar-Defer/inc/Module/Install/Metadata.pm
Scalar-Defer/inc/Module/Install/Win32.pm
Scalar-Defer/inc/Module/Install/WriteAll.pm
Scalar-Defer/inc/Test/Builder.pm
Scalar-Defer/inc/Test/Builder/Module.pm
Scalar-Defer/inc/Test/More.pm
Scalar-Defer/lib/Scalar/Defer.pm
Log:
* 0.15.
Modified: Scalar-Defer/Changes
==============================================================================
--- Scalar-Defer/Changes (original)
+++ Scalar-Defer/Changes Fri Jun 27 12:04:25 2008
@@ -1,15 +1,28 @@
-[Changes for 0.13 - 2008-06-27]
+[Changes for 0.15 - 2008-06-27]
* Fix infinite recursion on UNIVERSAL methods used as class methods on
- Scalar::Defer::Deferred itself
+ Scalar::Defer::Deferred itself.
http://rt.cpan.org/Public/Bug/Display.html?id=37153
+[Changes for 0.14 - 2008-01-09]
+
+* Avoid harmless '(in cleanup)' warnings caused by Class::InsideOut's
+ DESTROY method.
+
+* Mention Data::Thunk, a sneakier XS-based implementation of lazy{}.
+
+[Changes for 0.13 - 2008-01-01]
+
+* New exportable function 'is_deferred'.
+
+* Minor code cleanup: removing unused import
+ and constants.
[Changes for 0.12 - 2007-12-18]
-* Clean out the local storage when the InsideOut object goes away.
- Otherwise you leak memory like a sieve for every defer{} or lazy{}
- in your code.
+* Fixed major memory leak caused by defer{} and lazy{}, by cleaning out
+ the local storage when the InsideOut object goes away.
+ Contributed by: Alex Vandiver
[Changes for 0.11 - 2007-11-26]
Modified: Scalar-Defer/MANIFEST
==============================================================================
--- Scalar-Defer/MANIFEST (original)
+++ Scalar-Defer/MANIFEST Fri Jun 27 12:04:25 2008
@@ -21,3 +21,4 @@
META.yml
README
t/01-basic.t
+t/02-is.t
Modified: Scalar-Defer/README
==============================================================================
--- Scalar-Defer/README (original)
+++ Scalar-Defer/README Fri Jun 27 12:04:25 2008
@@ -1,22 +1,27 @@
NAME
- Scalar::Defer - Calculate values on demand
+ Scalar::Defer - Lazy evaluation in Perl
SYNOPSIS
- use Scalar::Defer; # exports 'defer' and 'lazy'
+ use Scalar::Defer; # exports 'defer', 'lazy' and 'force'
my ($x, $y);
- my $dv = defer { ++$x }; # a defer-value (not memoized)
- my $lv = lazy { ++$y }; # a lazy-value (memoized)
+ my $dv = defer { ++$x }; # a deferred value (not memoized)
+ my $lv = lazy { ++$y }; # a lazy value (memoized)
print "$dv $dv $dv"; # 1 2 3
print "$lv $lv $lv"; # 1 1 1
+ my $forced = force $dv; # force a normal value out of $dv
+
+ print "$forced $forced $forced"; # 4 4 4
+
DESCRIPTION
- This module exports two functions, "defer" and "lazy", for building
- values that are evaluated on demand.
+ This module exports two functions, "defer" and "lazy", for constructing
+ values that are evaluated on demand. It also exports a "force" function
+ to force evaluation of a deferred value.
defer {...}
- Takes a block or a code reference, and returns an overloaded value. Each
+ Takes a block or a code reference, and returns a deferred value. Each
time that value is demanded, the block is evaluated again to yield a
fresh result.
@@ -24,26 +29,58 @@
Like "defer", except the value is computed at most once. Subsequent
evaluation will simply use the cached result.
+ force $value
+ Force evaluation of a deferred value to return a normal value. If $value
+ was already a normal value, then "force" simply returns it.
+
+ is_deferred $value
+ Tells whether the argument is a deferred value or not. (Lazy values are
+ deferred too.)
+
+ The "is_deferred" function is not exported by default; to import it,
+ name it explicitly in the import list.
+
NOTES
- Unlike the "tie"-based Data::Lazy, this module operates on *values*, not
- *variables*. Therefore, assigning into $dv and $lv above will simply
- replace the value, instead of triggering a "STORE" method call.
+ Deferred values are not considered objects ("ref" on them returns 0),
+ although you can still call methods on them, in which case the invocant
+ is always the forced value.
- Also, thanks to the "overload"-based implementation, this module is
- about 2x faster than Data::Lazy.
+ Unlike the "tie"-based Data::Lazy, this module operates on *values*, not
+ *variables*. Therefore, assigning another value into $dv and $lv above
+ will simply replace the value, instead of triggering a "STORE" method
+ call.
+
+ Similarily, assigning $dv or $dv into another variable will not trigger
+ a "FETCH" method, but simply propagates the deferred value over without
+ evaluationg. This makes it much faster than a "tie"-based implementation
+ -- even under the worst case scenario, where it's always immediately
+ forced after creation, this module is still twice as fast than
+ Data::Lazy.
+
+CAVEATS
+ Bad things may happen if this module interacts with any other code which
+ fiddles with package 0.
+
+SEE ALSO
+ Data::Thunk, which implements "lazy" values that can replace itself upon
+ forcing, leaving a minimal trace of the thunk, with some sneaky XS magic
+ in Data::Swap.
AUTHORS
Audrey Tang <cpan at audreyt.org>
-COPYRIGHT (The "MIT" License)
- Copyright 2006 by Audrey Tang <cpan at audreyt.org>.
+COPYRIGHT
+ Copyright 2006, 2007, 2008 by Audrey Tang <cpan at audreyt.org>.
+
+ This software is released under the MIT license cited below.
+ The "MIT" License
Permission is hereby granted, free of charge, to any person obtaining a
copy of this software and associated documentation files (the
"Software"), to deal in the Software without restriction, including
without limitation the rights to use, copy, modify, merge, publish,
distribute, sublicense, and/or sell copies of the Software, and to
- permit persons to whom the Software is fur- nished to do so, subject to
+ permit persons to whom the Software is furnished to do so, subject to
the following conditions:
The above copyright notice and this permission notice shall be included
@@ -51,9 +88,9 @@
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
- MERCHANTABILITY, FIT- NESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
- IN NO EVENT SHALL THE X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR
- OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
- ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
- OTHER DEALINGS IN THE SOFTWARE.
+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+ IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+ CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+ TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+ SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
Modified: Scalar-Defer/inc/Module/Install.pm
==============================================================================
--- Scalar-Defer/inc/Module/Install.pm (original)
+++ Scalar-Defer/inc/Module/Install.pm Fri Jun 27 12:04:25 2008
@@ -17,30 +17,20 @@
# 3. The ./inc/ version of Module::Install loads
# }
-BEGIN {
- require 5.004;
-}
+use 5.004;
use strict 'vars';
use vars qw{$VERSION};
BEGIN {
- # All Module::Install core packages now require synchronised versions.
- # This will be used to ensure we don't accidentally load old or
- # different versions of modules.
- # This is not enforced yet, but will be some time in the next few
- # releases once we can make sure it won't clash with custom
- # Module::Install extensions.
- $VERSION = '0.75';
-
- *inc::Module::Install::VERSION = *VERSION;
- @inc::Module::Install::ISA = __PACKAGE__;
-
+ # All Module::Install core packages now require synchronised versions.
+ # This will be used to ensure we don't accidentally load old or
+ # different versions of modules.
+ # This is not enforced yet, but will be some time in the next few
+ # releases once we can make sure it won't clash with custom
+ # Module::Install extensions.
+ $VERSION = '0.68';
}
-
-
-
-
# Whether or not inc::Module::Install is actually loaded, the
# $INC{inc/Module/Install.pm} is what will still get set as long as
# the caller loaded module this in the documented manner.
@@ -48,29 +38,26 @@
# they may not have a MI version that works with the Makefile.PL. This would
# result in false errors or unexpected behaviour. And we don't want that.
my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
-unless ( $INC{$file} ) { die <<"END_DIE" }
-
+unless ( $INC{$file} ) {
+ die <<"END_DIE";
Please invoke ${\__PACKAGE__} with:
- use inc::${\__PACKAGE__};
+ use inc::${\__PACKAGE__};
not:
- use ${\__PACKAGE__};
+ use ${\__PACKAGE__};
END_DIE
-
-
-
-
+}
# If the script that is loading Module::Install is from the future,
# then make will detect this and cause it to re-run over and over
# again. This is bad. Rather than taking action to touch it (which
# is unreliable on some platforms and requires write permissions)
# for now we should catch this and refuse to run.
-if ( -f $0 and (stat($0))[9] > time ) { die <<"END_DIE" }
-
+if ( -f $0 and (stat($0))[9] > time ) {
+ die << "END_DIE";
Your installer $0 has a modification time in the future.
This is known to create infinite loops in make.
@@ -78,142 +65,115 @@
Please correct this, then run $0 again.
END_DIE
-
-
-
-
-
-# Build.PL was formerly supported, but no longer is due to excessive
-# difficulty in implementing every single feature twice.
-if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
-
-Module::Install no longer supports Build.PL.
-
-It was impossible to maintain duel backends, and has been deprecated.
-
-Please remove all Build.PL files and only use the Makefile.PL installer.
-
-END_DIE
-
-
-
-
-
-# To save some more typing in Module::Install installers, every...
-# use inc::Module::Install
-# ...also acts as an implicit use strict.
-$^H |= strict::bits(qw(refs subs vars));
-
-
-
-
+}
use Cwd ();
use File::Find ();
use File::Path ();
use FindBin;
+*inc::Module::Install::VERSION = *VERSION;
+ at inc::Module::Install::ISA = __PACKAGE__;
+
sub autoload {
- my $self = shift;
- my $who = $self->_caller;
- my $cwd = Cwd::cwd();
- my $sym = "${who}::AUTOLOAD";
- $sym->{$cwd} = sub {
- my $pwd = Cwd::cwd();
- if ( my $code = $sym->{$pwd} ) {
- # delegate back to parent dirs
- goto &$code unless $cwd eq $pwd;
- }
- $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
- unshift @_, ( $self, $1 );
- goto &{$self->can('call')} unless uc($1) eq $1;
- };
+ my $self = shift;
+ my $who = $self->_caller;
+ my $cwd = Cwd::cwd();
+ my $sym = "${who}::AUTOLOAD";
+ $sym->{$cwd} = sub {
+ my $pwd = Cwd::cwd();
+ if ( my $code = $sym->{$pwd} ) {
+ # delegate back to parent dirs
+ goto &$code unless $cwd eq $pwd;
+ }
+ $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
+ unshift @_, ($self, $1);
+ goto &{$self->can('call')} unless uc($1) eq $1;
+ };
}
sub import {
- my $class = shift;
- my $self = $class->new(@_);
- my $who = $self->_caller;
-
- unless ( -f $self->{file} ) {
- require "$self->{path}/$self->{dispatch}.pm";
- File::Path::mkpath("$self->{prefix}/$self->{author}");
- $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
- $self->{admin}->init;
- @_ = ($class, _self => $self);
- goto &{"$self->{name}::import"};
- }
-
- *{"${who}::AUTOLOAD"} = $self->autoload;
- $self->preload;
-
- # Unregister loader and worker packages so subdirs can use them again
- delete $INC{"$self->{file}"};
- delete $INC{"$self->{path}.pm"};
-
- return 1;
+ my $class = shift;
+ my $self = $class->new(@_);
+ my $who = $self->_caller;
+
+ unless ( -f $self->{file} ) {
+ require "$self->{path}/$self->{dispatch}.pm";
+ File::Path::mkpath("$self->{prefix}/$self->{author}");
+ $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
+ $self->{admin}->init;
+ @_ = ($class, _self => $self);
+ goto &{"$self->{name}::import"};
+ }
+
+ *{"${who}::AUTOLOAD"} = $self->autoload;
+ $self->preload;
+
+ # Unregister loader and worker packages so subdirs can use them again
+ delete $INC{"$self->{file}"};
+ delete $INC{"$self->{path}.pm"};
}
sub preload {
- my $self = shift;
- unless ( $self->{extensions} ) {
- $self->load_extensions(
- "$self->{prefix}/$self->{path}", $self
- );
- }
-
- my @exts = @{$self->{extensions}};
- unless ( @exts ) {
- my $admin = $self->{admin};
- @exts = $admin->load_all_extensions;
- }
-
- my %seen;
- foreach my $obj ( @exts ) {
- while (my ($method, $glob) = each %{ref($obj) . '::'}) {
- next unless $obj->can($method);
- next if $method =~ /^_/;
- next if $method eq uc($method);
- $seen{$method}++;
- }
- }
-
- my $who = $self->_caller;
- foreach my $name ( sort keys %seen ) {
- *{"${who}::$name"} = sub {
- ${"${who}::AUTOLOAD"} = "${who}::$name";
- goto &{"${who}::AUTOLOAD"};
- };
- }
+ my ($self) = @_;
+
+ unless ( $self->{extensions} ) {
+ $self->load_extensions(
+ "$self->{prefix}/$self->{path}", $self
+ );
+ }
+
+ my @exts = @{$self->{extensions}};
+ unless ( @exts ) {
+ my $admin = $self->{admin};
+ @exts = $admin->load_all_extensions;
+ }
+
+ my %seen;
+ foreach my $obj ( @exts ) {
+ while (my ($method, $glob) = each %{ref($obj) . '::'}) {
+ next unless $obj->can($method);
+ next if $method =~ /^_/;
+ next if $method eq uc($method);
+ $seen{$method}++;
+ }
+ }
+
+ my $who = $self->_caller;
+ foreach my $name ( sort keys %seen ) {
+ *{"${who}::$name"} = sub {
+ ${"${who}::AUTOLOAD"} = "${who}::$name";
+ goto &{"${who}::AUTOLOAD"};
+ };
+ }
}
sub new {
- my ($class, %args) = @_;
+ my ($class, %args) = @_;
- # ignore the prefix on extension modules built from top level.
- my $base_path = Cwd::abs_path($FindBin::Bin);
- unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
- delete $args{prefix};
- }
-
- return $args{_self} if $args{_self};
-
- $args{dispatch} ||= 'Admin';
- $args{prefix} ||= 'inc';
- $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author');
- $args{bundle} ||= 'inc/BUNDLES';
- $args{base} ||= $base_path;
- $class =~ s/^\Q$args{prefix}\E:://;
- $args{name} ||= $class;
- $args{version} ||= $class->VERSION;
- unless ( $args{path} ) {
- $args{path} = $args{name};
- $args{path} =~ s!::!/!g;
- }
- $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm";
- $args{wrote} = 0;
+ # ignore the prefix on extension modules built from top level.
+ my $base_path = Cwd::abs_path($FindBin::Bin);
+ unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
+ delete $args{prefix};
+ }
+
+ return $args{_self} if $args{_self};
+
+ $args{dispatch} ||= 'Admin';
+ $args{prefix} ||= 'inc';
+ $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author');
+ $args{bundle} ||= 'inc/BUNDLES';
+ $args{base} ||= $base_path;
+ $class =~ s/^\Q$args{prefix}\E:://;
+ $args{name} ||= $class;
+ $args{version} ||= $class->VERSION;
+ unless ( $args{path} ) {
+ $args{path} = $args{name};
+ $args{path} =~ s!::!/!g;
+ }
+ $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm";
- bless( \%args, $class );
+ bless( \%args, $class );
}
sub call {
@@ -224,130 +184,98 @@
}
sub load {
- my ($self, $method) = @_;
+ my ($self, $method) = @_;
- $self->load_extensions(
- "$self->{prefix}/$self->{path}", $self
- ) unless $self->{extensions};
-
- foreach my $obj (@{$self->{extensions}}) {
- return $obj if $obj->can($method);
- }
+ $self->load_extensions(
+ "$self->{prefix}/$self->{path}", $self
+ ) unless $self->{extensions};
- my $admin = $self->{admin} or die <<"END_DIE";
+ foreach my $obj (@{$self->{extensions}}) {
+ return $obj if $obj->can($method);
+ }
+
+ my $admin = $self->{admin} or die <<"END_DIE";
The '$method' method does not exist in the '$self->{prefix}' path!
Please remove the '$self->{prefix}' directory and run $0 again to load it.
END_DIE
- my $obj = $admin->load($method, 1);
- push @{$self->{extensions}}, $obj;
+ my $obj = $admin->load($method, 1);
+ push @{$self->{extensions}}, $obj;
- $obj;
+ $obj;
}
sub load_extensions {
- my ($self, $path, $top) = @_;
+ my ($self, $path, $top) = @_;
- unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
- unshift @INC, $self->{prefix};
- }
-
- foreach my $rv ( $self->find_extensions($path) ) {
- my ($file, $pkg) = @{$rv};
- next if $self->{pathnames}{$pkg};
-
- local $@;
- my $new = eval { require $file; $pkg->can('new') };
- unless ( $new ) {
- warn $@ if $@;
- next;
- }
- $self->{pathnames}{$pkg} = delete $INC{$file};
- push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
- }
+ unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
+ unshift @INC, $self->{prefix};
+ }
+
+ foreach my $rv ( $self->find_extensions($path) ) {
+ my ($file, $pkg) = @{$rv};
+ next if $self->{pathnames}{$pkg};
+
+ local $@;
+ my $new = eval { require $file; $pkg->can('new') };
+ unless ( $new ) {
+ warn $@ if $@;
+ next;
+ }
+ $self->{pathnames}{$pkg} = delete $INC{$file};
+ push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
+ }
- $self->{extensions} ||= [];
+ $self->{extensions} ||= [];
}
sub find_extensions {
- my ($self, $path) = @_;
-
- my @found;
- File::Find::find( sub {
- my $file = $File::Find::name;
- return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
- my $subpath = $1;
- return if lc($subpath) eq lc($self->{dispatch});
-
- $file = "$self->{path}/$subpath.pm";
- my $pkg = "$self->{name}::$subpath";
- $pkg =~ s!/!::!g;
+ my ($self, $path) = @_;
- # If we have a mixed-case package name, assume case has been preserved
- # correctly. Otherwise, root through the file to locate the case-preserved
- # version of the package name.
- if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
- my $content = Module::Install::_read($subpath . '.pm');
- my $in_pod = 0;
- foreach ( split //, $content ) {
- $in_pod = 1 if /^=\w/;
- $in_pod = 0 if /^=cut/;
- next if ($in_pod || /^=cut/); # skip pod text
- next if /^\s*#/; # and comments
- if ( m/^\s*package\s+($pkg)\s*;/i ) {
- $pkg = $1;
- last;
- }
- }
- }
+ my @found;
+ File::Find::find( sub {
+ my $file = $File::Find::name;
+ return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
+ my $subpath = $1;
+ return if lc($subpath) eq lc($self->{dispatch});
+
+ $file = "$self->{path}/$subpath.pm";
+ my $pkg = "$self->{name}::$subpath";
+ $pkg =~ s!/!::!g;
+
+ # If we have a mixed-case package name, assume case has been preserved
+ # correctly. Otherwise, root through the file to locate the case-preserved
+ # version of the package name.
+ if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
+ open PKGFILE, "<$subpath.pm" or die "find_extensions: Can't open $subpath.pm: $!";
+ my $in_pod = 0;
+ while ( <PKGFILE> ) {
+ $in_pod = 1 if /^=\w/;
+ $in_pod = 0 if /^=cut/;
+ next if ($in_pod || /^=cut/); # skip pod text
+ next if /^\s*#/; # and comments
+ if ( m/^\s*package\s+($pkg)\s*;/i ) {
+ $pkg = $1;
+ last;
+ }
+ }
+ close PKGFILE;
+ }
- push @found, [ $file, $pkg ];
- }, $path ) if -d $path;
+ push @found, [ $file, $pkg ];
+ }, $path ) if -d $path;
- @found;
+ @found;
}
-
-
-
-
-#####################################################################
-# Utility Functions
-
sub _caller {
- my $depth = 0;
- my $call = caller($depth);
- while ( $call eq __PACKAGE__ ) {
- $depth++;
- $call = caller($depth);
- }
- return $call;
-}
-
-sub _read {
- local *FH;
- open FH, "< $_[0]" or die "open($_[0]): $!";
- my $str = do { local $/; <FH> };
- close FH or die "close($_[0]): $!";
- return $str;
-}
-
-sub _write {
- local *FH;
- open FH, "> $_[0]" or die "open($_[0]): $!";
- foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" }
- close FH or die "close($_[0]): $!";
-}
-
-sub _version {
- my $s = shift || 0;
- $s =~ s/^(\d+)\.?//;
- my $l = $1 || 0;
- my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
- $l = $l . '.' . join '', @v if @v;
- return $l + 0;
+ my $depth = 0;
+ my $call = caller($depth);
+ while ( $call eq __PACKAGE__ ) {
+ $depth++;
+ $call = caller($depth);
+ }
+ return $call;
}
1;
-
-# Copyright 2008 Adam Kennedy.
Modified: Scalar-Defer/inc/Module/Install/AutoInstall.pm
==============================================================================
--- Scalar-Defer/inc/Module/Install/AutoInstall.pm (original)
+++ Scalar-Defer/inc/Module/Install/AutoInstall.pm Fri Jun 27 12:04:25 2008
@@ -6,7 +6,7 @@
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
- $VERSION = '0.75';
+ $VERSION = '0.68';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
Modified: Scalar-Defer/inc/Module/Install/Base.pm
==============================================================================
--- Scalar-Defer/inc/Module/Install/Base.pm (original)
+++ Scalar-Defer/inc/Module/Install/Base.pm Fri Jun 27 12:04:25 2008
@@ -1,7 +1,7 @@
#line 1
package Module::Install::Base;
-$VERSION = '0.75';
+$VERSION = '0.68';
# Suspend handler for "redefined" warnings
BEGIN {
Modified: Scalar-Defer/inc/Module/Install/Can.pm
==============================================================================
--- Scalar-Defer/inc/Module/Install/Can.pm (original)
+++ Scalar-Defer/inc/Module/Install/Can.pm Fri Jun 27 12:04:25 2008
@@ -11,7 +11,7 @@
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
- $VERSION = '0.75';
+ $VERSION = '0.68';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
Modified: Scalar-Defer/inc/Module/Install/Fetch.pm
==============================================================================
--- Scalar-Defer/inc/Module/Install/Fetch.pm (original)
+++ Scalar-Defer/inc/Module/Install/Fetch.pm Fri Jun 27 12:04:25 2008
@@ -6,7 +6,7 @@
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
- $VERSION = '0.75';
+ $VERSION = '0.68';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
Modified: Scalar-Defer/inc/Module/Install/Include.pm
==============================================================================
--- Scalar-Defer/inc/Module/Install/Include.pm (original)
+++ Scalar-Defer/inc/Module/Install/Include.pm Fri Jun 27 12:04:25 2008
@@ -6,7 +6,7 @@
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
- $VERSION = '0.75';
+ $VERSION = '0.68';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
Modified: Scalar-Defer/inc/Module/Install/Makefile.pm
==============================================================================
--- Scalar-Defer/inc/Module/Install/Makefile.pm (original)
+++ Scalar-Defer/inc/Module/Install/Makefile.pm Fri Jun 27 12:04:25 2008
@@ -7,7 +7,7 @@
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
- $VERSION = '0.75';
+ $VERSION = '0.68';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
@@ -37,7 +37,7 @@
sub makemaker_args {
my $self = shift;
my $args = ($self->{makemaker_args} ||= {});
- %$args = ( %$args, @_ ) if @_;
+ %$args = ( %$args, @_ ) if @_;
$args;
}
@@ -63,18 +63,18 @@
sub clean_files {
my $self = shift;
my $clean = $self->makemaker_args->{clean} ||= {};
- %$clean = (
+ %$clean = (
%$clean,
- FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_),
+ FILES => join(' ', grep length, $clean->{FILES}, @_),
);
}
sub realclean_files {
- my $self = shift;
+ my $self = shift;
my $realclean = $self->makemaker_args->{realclean} ||= {};
- %$realclean = (
+ %$realclean = (
%$realclean,
- FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_),
+ FILES => join(' ', grep length, $realclean->{FILES}, @_),
);
}
@@ -104,8 +104,8 @@
unless ( -d $dir ) {
die "tests_recursive dir '$dir' does not exist";
}
- %test_dir = ();
require File::Find;
+ %test_dir = ();
File::Find::find( \&_wanted_t, $dir );
$self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
}
@@ -114,15 +114,10 @@
my $self = shift;
die "&Makefile->write() takes no arguments\n" if @_;
- # Make sure we have a new enough
- require ExtUtils::MakeMaker;
- $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION );
-
- # Generate the
my $args = $self->makemaker_args;
$args->{DISTNAME} = $self->name;
- $args->{NAME} = $self->module_name || $self->name;
- $args->{VERSION} = $self->version;
+ $args->{NAME} = $self->module_name || $self->name || $self->determine_NAME($args);
+ $args->{VERSION} = $self->version || $self->determine_VERSION($args);
$args->{NAME} =~ s/-/::/g;
if ( $self->tests ) {
$args->{test} = { TESTS => $self->tests };
@@ -147,12 +142,9 @@
map { @$_ }
map { @$_ }
grep $_,
- ($self->configure_requires, $self->build_requires, $self->requires)
+ ($self->build_requires, $self->requires)
);
- # Remove any reference to perl, PREREQ_PM doesn't support it
- delete $args->{PREREQ_PM}->{perl};
-
# merge both kinds of requires into prereq_pm
my $subdirs = ($args->{DIR} ||= []);
if ($self->bundles) {
@@ -213,7 +205,7 @@
#$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
# Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
- $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g;
+ $makefile =~ s/("?)-I\$\(PERL_LIB\)\1//g;
# XXX - This is currently unused; not sure if it breaks other MM-users
# $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
@@ -242,4 +234,4 @@
__END__
-#line 371
+#line 363
Modified: Scalar-Defer/inc/Module/Install/Metadata.pm
==============================================================================
--- Scalar-Defer/inc/Module/Install/Metadata.pm (original)
+++ Scalar-Defer/inc/Module/Install/Metadata.pm Fri Jun 27 12:04:25 2008
@@ -6,31 +6,18 @@
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
- $VERSION = '0.75';
+ $VERSION = '0.68';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
my @scalar_keys = qw{
- name
- module_name
- abstract
- author
- version
- license
- distribution_type
- perl_version
- tests
- installdirs
+ name module_name abstract author version license
+ distribution_type perl_version tests installdirs
};
my @tuple_keys = qw{
- configure_requires
- build_requires
- requires
- recommends
- bundles
- resources
+ build_requires requires recommends bundles
};
sub Meta { shift }
@@ -38,85 +25,44 @@
sub Meta_TupleKeys { @tuple_keys }
foreach my $key (@scalar_keys) {
- *$key = sub {
- my $self = shift;
- return $self->{values}{$key} if defined wantarray and !@_;
- $self->{values}{$key} = shift;
- return $self;
- };
-}
-
-sub requires {
- my $self = shift;
- while ( @_ ) {
- my $module = shift or last;
- my $version = shift || 0;
- push @{ $self->{values}->{requires} }, [ $module, $version ];
- }
- $self->{values}{requires};
-}
-
-sub build_requires {
- my $self = shift;
- while ( @_ ) {
- my $module = shift or last;
- my $version = shift || 0;
- push @{ $self->{values}->{build_requires} }, [ $module, $version ];
- }
- $self->{values}{build_requires};
-}
-
-sub configure_requires {
- my $self = shift;
- while ( @_ ) {
- my $module = shift or last;
- my $version = shift || 0;
- push @{ $self->{values}->{configure_requires} }, [ $module, $version ];
- }
- $self->{values}->{configure_requires};
+ *$key = sub {
+ my $self = shift;
+ return $self->{values}{$key} if defined wantarray and !@_;
+ $self->{values}{$key} = shift;
+ return $self;
+ };
+}
+
+foreach my $key (@tuple_keys) {
+ *$key = sub {
+ my $self = shift;
+ return $self->{values}{$key} unless @_;
+
+ my @rv;
+ while (@_) {
+ my $module = shift or last;
+ my $version = shift || 0;
+ if ( $module eq 'perl' ) {
+ $version =~ s{^(\d+)\.(\d+)\.(\d+)}
+ {$1 + $2/1_000 + $3/1_000_000}e;
+ $self->perl_version($version);
+ next;
+ }
+ my $rv = [ $module, $version ];
+ push @rv, $rv;
+ }
+ push @{ $self->{values}{$key} }, @rv;
+ @rv;
+ };
}
-sub recommends {
- my $self = shift;
- while ( @_ ) {
- my $module = shift or last;
- my $version = shift || 0;
- push @{ $self->{values}->{recommends} }, [ $module, $version ];
- }
- $self->{values}->{recommends};
-}
-
-sub bundles {
- my $self = shift;
- while ( @_ ) {
- my $module = shift or last;
- my $version = shift || 0;
- push @{ $self->{values}->{bundles} }, [ $module, $version ];
- }
- $self->{values}->{bundles};
-}
-
-# Resource handling
-sub resources {
- my $self = shift;
- while ( @_ ) {
- my $resource = shift or last;
- my $value = shift or next;
- push @{ $self->{values}->{resources} }, [ $resource, $value ];
- }
- $self->{values}->{resources};
-}
-
-sub repository {
- my $self = shift;
- $self->resources( repository => shift );
- return 1;
-}
+# configure_requires is currently a null-op
+sub configure_requires { 1 }
# Aliases for build_requires that will have alternative
# meanings in some future version of META.yml.
-sub test_requires { shift->build_requires(@_) }
-sub install_requires { shift->build_requires(@_) }
+sub test_requires { shift->build_requires(@_) }
+sub install_requires { shift->build_requires(@_) }
# Aliases for installdirs options
sub install_as_core { $_[0]->installdirs('perl') }
@@ -125,10 +71,10 @@
sub install_as_vendor { $_[0]->installdirs('vendor') }
sub sign {
- my $self = shift;
- return $self->{'values'}{'sign'} if defined wantarray and ! @_;
- $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );
- return $self;
+ my $self = shift;
+ return $self->{'values'}{'sign'} if defined wantarray and ! @_;
+ $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );
+ return $self;
}
sub dynamic_config {
@@ -137,271 +83,254 @@
warn "You MUST provide an explicit true/false value to dynamic_config, skipping\n";
return $self;
}
- $self->{values}{dynamic_config} = $_[0] ? 1 : 0;
+ $self->{'values'}{'dynamic_config'} = $_[0] ? 1 : 0;
return $self;
}
sub all_from {
- my ( $self, $file ) = @_;
-
- unless ( defined($file) ) {
- my $name = $self->name
- or die "all_from called with no args without setting name() first";
- $file = join('/', 'lib', split(/-/, $name)) . '.pm';
- $file =~ s{.*/}{} unless -e $file;
- die "all_from: cannot find $file from $name" unless -e $file;
- }
+ my ( $self, $file ) = @_;
- # Some methods pull from POD instead of code.
- # If there is a matching .pod, use that instead
- my $pod = $file;
- $pod =~ s/\.pm$/.pod/i;
- $pod = $file unless -e $pod;
-
- # Pull the different values
- $self->name_from($file) unless $self->name;
- $self->version_from($file) unless $self->version;
- $self->perl_version_from($file) unless $self->perl_version;
- $self->author_from($pod) unless $self->author;
- $self->license_from($pod) unless $self->license;
- $self->abstract_from($pod) unless $self->abstract;
-
- return 1;
+ unless ( defined($file) ) {
+ my $name = $self->name
+ or die "all_from called with no args without setting name() first";
+ $file = join('/', 'lib', split(/-/, $name)) . '.pm';
+ $file =~ s{.*/}{} unless -e $file;
+ die "all_from: cannot find $file from $name" unless -e $file;
+ }
+
+ $self->version_from($file) unless $self->version;
+ $self->perl_version_from($file) unless $self->perl_version;
+
+ # The remaining probes read from POD sections; if the file
+ # has an accompanying .pod, use that instead
+ my $pod = $file;
+ if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) {
+ $file = $pod;
+ }
+
+ $self->author_from($file) unless $self->author;
+ $self->license_from($file) unless $self->license;
+ $self->abstract_from($file) unless $self->abstract;
}
sub provides {
- my $self = shift;
- my $provides = ( $self->{values}{provides} ||= {} );
- %$provides = (%$provides, @_) if @_;
- return $provides;
+ my $self = shift;
+ my $provides = ( $self->{values}{provides} ||= {} );
+ %$provides = (%$provides, @_) if @_;
+ return $provides;
}
sub auto_provides {
- my $self = shift;
- return $self unless $self->is_admin;
- unless (-e 'MANIFEST') {
- warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
- return $self;
- }
- # Avoid spurious warnings as we are not checking manifest here.
- local $SIG{__WARN__} = sub {1};
- require ExtUtils::Manifest;
- local *ExtUtils::Manifest::manicheck = sub { return };
-
- require Module::Build;
- my $build = Module::Build->new(
- dist_name => $self->name,
- dist_version => $self->version,
- license => $self->license,
- );
- $self->provides( %{ $build->find_dist_packages || {} } );
+ my $self = shift;
+ return $self unless $self->is_admin;
+
+ unless (-e 'MANIFEST') {
+ warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
+ return $self;
+ }
+
+ # Avoid spurious warnings as we are not checking manifest here.
+
+ local $SIG{__WARN__} = sub {1};
+ require ExtUtils::Manifest;
+ local *ExtUtils::Manifest::manicheck = sub { return };
+
+ require Module::Build;
+ my $build = Module::Build->new(
+ dist_name => $self->name,
+ dist_version => $self->version,
+ license => $self->license,
+ );
+ $self->provides(%{ $build->find_dist_packages || {} });
}
sub feature {
- my $self = shift;
- my $name = shift;
- my $features = ( $self->{values}{features} ||= [] );
- my $mods;
-
- if ( @_ == 1 and ref( $_[0] ) ) {
- # The user used ->feature like ->features by passing in the second
- # argument as a reference. Accomodate for that.
- $mods = $_[0];
- } else {
- $mods = \@_;
- }
+ my $self = shift;
+ my $name = shift;
+ my $features = ( $self->{values}{features} ||= [] );
+
+ my $mods;
+
+ if ( @_ == 1 and ref( $_[0] ) ) {
+ # The user used ->feature like ->features by passing in the second
+ # argument as a reference. Accomodate for that.
+ $mods = $_[0];
+ } else {
+ $mods = \@_;
+ }
+
+ my $count = 0;
+ push @$features, (
+ $name => [
+ map {
+ ref($_) ? ( ref($_) eq 'HASH' ) ? %$_
+ : @$_
+ : $_
+ } @$mods
+ ]
+ );
- my $count = 0;
- push @$features, (
- $name => [
- map {
- ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_
- } @$mods
- ]
- );
-
- return @$features;
+ return @$features;
}
sub features {
- my $self = shift;
- while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
- $self->feature( $name, @$mods );
- }
- return $self->{values}->{features}
- ? @{ $self->{values}->{features} }
- : ();
+ my $self = shift;
+ while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
+ $self->feature( $name, @$mods );
+ }
+ return $self->{values}->{features}
+ ? @{ $self->{values}->{features} }
+ : ();
}
sub no_index {
- my $self = shift;
- my $type = shift;
- push @{ $self->{values}{no_index}{$type} }, @_ if $type;
- return $self->{values}{no_index};
+ my $self = shift;
+ my $type = shift;
+ push @{ $self->{values}{no_index}{$type} }, @_ if $type;
+ return $self->{values}{no_index};
}
sub read {
- my $self = shift;
- $self->include_deps( 'YAML::Tiny', 0 );
+ my $self = shift;
+ $self->include_deps( 'YAML', 0 );
- require YAML::Tiny;
- my $data = YAML::Tiny::LoadFile('META.yml');
+ require YAML;
+ my $data = YAML::LoadFile('META.yml');
- # Call methods explicitly in case user has already set some values.
- while ( my ( $key, $value ) = each %$data ) {
- next unless $self->can($key);
- if ( ref $value eq 'HASH' ) {
- while ( my ( $module, $version ) = each %$value ) {
- $self->can($key)->($self, $module => $version );
- }
- } else {
- $self->can($key)->($self, $value);
- }
- }
- return $self;
+ # Call methods explicitly in case user has already set some values.
+ while ( my ( $key, $value ) = each %$data ) {
+ next unless $self->can($key);
+ if ( ref $value eq 'HASH' ) {
+ while ( my ( $module, $version ) = each %$value ) {
+ $self->can($key)->($self, $module => $version );
+ }
+ }
+ else {
+ $self->can($key)->($self, $value);
+ }
+ }
+ return $self;
}
sub write {
- my $self = shift;
- return $self unless $self->is_admin;
- $self->admin->write_meta;
- return $self;
+ my $self = shift;
+ return $self unless $self->is_admin;
+ $self->admin->write_meta;
+ return $self;
}
sub version_from {
- require ExtUtils::MM_Unix;
- my ( $self, $file ) = @_;
- $self->version( ExtUtils::MM_Unix->parse_version($file) );
+ my ( $self, $file ) = @_;
+ require ExtUtils::MM_Unix;
+ $self->version( ExtUtils::MM_Unix->parse_version($file) );
}
sub abstract_from {
- require ExtUtils::MM_Unix;
- my ( $self, $file ) = @_;
- $self->abstract(
- bless(
- { DISTNAME => $self->name },
- 'ExtUtils::MM_Unix'
- )->parse_abstract($file)
- );
-}
-
-# Add both distribution and module name
-sub name_from {
- my ($self, $file) = @_;
- if (
- Module::Install::_read($file) =~ m/
- ^ \s*
- package \s*
- ([\w:]+)
- \s* ;
- /ixms
- ) {
- my ($name, $module_name) = ($1, $1);
- $name =~ s{::}{-}g;
- $self->name($name);
- unless ( $self->module_name ) {
- $self->module_name($module_name);
- }
- } else {
- die "Cannot determine name from $file\n";
- }
+ my ( $self, $file ) = @_;
+ require ExtUtils::MM_Unix;
+ $self->abstract(
+ bless(
+ { DISTNAME => $self->name },
+ 'ExtUtils::MM_Unix'
+ )->parse_abstract($file)
+ );
+}
+
+sub _slurp {
+ my ( $self, $file ) = @_;
+
+ local *FH;
+ open FH, "< $file" or die "Cannot open $file.pod: $!";
+ do { local $/; <FH> };
}
sub perl_version_from {
- my $self = shift;
- if (
- Module::Install::_read($_[0]) =~ m/
- ^
- (?:use|require) \s*
- v?
- ([\d_\.]+)
- \s* ;
- /ixms
- ) {
- my $perl_version = $1;
- $perl_version =~ s{_}{}g;
- $self->perl_version($perl_version);
- } else {
- warn "Cannot determine perl version info from $_[0]\n";
- return;
- }
+ my ( $self, $file ) = @_;
+
+ if (
+ $self->_slurp($file) =~ m/
+ ^
+ use \s*
+ v?
+ ([\d_\.]+)
+ \s* ;
+ /ixms
+ )
+ {
+ my $v = $1;
+ $v =~ s{_}{}g;
+ $self->perl_version($1);
+ }
+ else {
+ warn "Cannot determine perl version info from $file\n";
+ return;
+ }
}
sub author_from {
- my $self = shift;
- my $content = Module::Install::_read($_[0]);
- if ($content =~ m/
- =head \d \s+ (?:authors?)\b \s*
- ([^\n]*)
- |
- =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
- .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
- ([^\n]*)
- /ixms) {
- my $author = $1 || $2;
- $author =~ s{E<lt>}{<}g;
- $author =~ s{E<gt>}{>}g;
- $self->author($author);
- } else {
- warn "Cannot determine author info from $_[0]\n";
- }
+ my ( $self, $file ) = @_;
+ my $content = $self->_slurp($file);
+ if ($content =~ m/
+ =head \d \s+ (?:authors?)\b \s*
+ ([^\n]*)
+ |
+ =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
+ .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
+ ([^\n]*)
+ /ixms) {
+ my $author = $1 || $2;
+ $author =~ s{E<lt>}{<}g;
+ $author =~ s{E<gt>}{>}g;
+ $self->author($author);
+ }
+ else {
+ warn "Cannot determine author info from $file\n";
+ }
}
sub license_from {
- my $self = shift;
- if (
- Module::Install::_read($_[0]) =~ m/
- (
- =head \d \s+
- (?:licen[cs]e|licensing|copyright|legal)\b
- .*?
- )
- (=head\\d.*|=cut.*|)
- \z
- /ixms ) {
- my $license_text = $1;
- my @phrases = (
- 'under the same (?:terms|license) as perl itself' => 'perl', 1,
- 'GNU public license' => 'gpl', 1,
- 'GNU lesser public license' => 'lgpl', 1,
- 'BSD license' => 'bsd', 1,
- 'Artistic license' => 'artistic', 1,
- 'GPL' => 'gpl', 1,
- 'LGPL' => 'lgpl', 1,
- 'BSD' => 'bsd', 1,
- 'Artistic' => 'artistic', 1,
- 'MIT' => 'mit', 1,
- 'proprietary' => 'proprietary', 0,
- );
- while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
- $pattern =~ s{\s+}{\\s+}g;
- if ( $license_text =~ /\b$pattern\b/i ) {
- if ( $osi and $license_text =~ /All rights reserved/i ) {
- print "WARNING: 'All rights reserved' in copyright may invalidate Open Source license.\n";
- }
- $self->license($license);
- return 1;
- }
- }
- }
-
- warn "Cannot determine license info from $_[0]\n";
- return 'unknown';
-}
+ my ( $self, $file ) = @_;
-sub install_script {
- my $self = shift;
- my $args = $self->makemaker_args;
- my $exe = $args->{EXE_FILES} ||= [];
- foreach ( @_ ) {
- if ( -f $_ ) {
- push @$exe, $_;
- } elsif ( -d 'script' and -f "script/$_" ) {
- push @$exe, "script/$_";
- } else {
- die "Cannot find script '$_'";
+ if (
+ $self->_slurp($file) =~ m/
+ (
+ =head \d \s+
+ (?:licen[cs]e|licensing|copyright|legal)\b
+ .*?
+ )
+ (=head\\d.*|=cut.*|)
+ \z
+ /ixms
+ )
+ {
+ my $license_text = $1;
+ my @phrases = (
+ 'under the same (?:terms|license) as perl itself' => 'perl', 1,
+ 'GNU public license' => 'gpl', 1,
+ 'GNU lesser public license' => 'gpl', 1,
+ 'BSD license' => 'bsd', 1,
+ 'Artistic license' => 'artistic', 1,
+ 'GPL' => 'gpl', 1,
+ 'LGPL' => 'lgpl', 1,
+ 'BSD' => 'bsd', 1,
+ 'Artistic' => 'artistic', 1,
+ 'MIT' => 'mit', 1,
+ 'proprietary' => 'proprietary', 0,
+ );
+ while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
+ $pattern =~ s{\s+}{\\s+}g;
+ if ( $license_text =~ /\b$pattern\b/i ) {
+ if ( $osi and $license_text =~ /All rights reserved/i ) {
+ warn "LEGAL WARNING: 'All rights reserved' may invalidate Open Source licenses. Consider removing it.";
}
- }
+ $self->license($license);
+ return 1;
+ }
+ }
+ }
+
+ warn "Cannot determine license info from $file\n";
+ return 'unknown';
}
1;
Modified: Scalar-Defer/inc/Module/Install/Win32.pm
==============================================================================
--- Scalar-Defer/inc/Module/Install/Win32.pm (original)
+++ Scalar-Defer/inc/Module/Install/Win32.pm Fri Jun 27 12:04:25 2008
@@ -4,11 +4,11 @@
use strict;
use Module::Install::Base;
-use vars qw{$VERSION @ISA $ISCORE};
+use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
- $VERSION = '0.75';
- @ISA = qw{Module::Install::Base};
+ $VERSION = '0.68';
$ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
}
# determine if the user needs nmake, and download it if needed
@@ -16,7 +16,7 @@
my $self = shift;
$self->load('can_run');
$self->load('get_file');
-
+
require Config;
return unless (
$^O eq 'MSWin32' and
@@ -38,7 +38,8 @@
remove => 1,
);
- die <<'END_MESSAGE' unless $rv;
+ if (!$rv) {
+ die <<'END_MESSAGE';
-------------------------------------------------------------------------------
@@ -58,7 +59,7 @@
-------------------------------------------------------------------------------
END_MESSAGE
-
+ }
}
1;
Modified: Scalar-Defer/inc/Module/Install/WriteAll.pm
==============================================================================
--- Scalar-Defer/inc/Module/Install/WriteAll.pm (original)
+++ Scalar-Defer/inc/Module/Install/WriteAll.pm Fri Jun 27 12:04:25 2008
@@ -4,37 +4,40 @@
use strict;
use Module::Install::Base;
-use vars qw{$VERSION @ISA $ISCORE};
+use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
- $VERSION = '0.75';
- @ISA = qw{Module::Install::Base};
+ $VERSION = '0.68';
$ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
}
sub WriteAll {
- my $self = shift;
- my %args = (
- meta => 1,
- sign => 0,
- inline => 0,
- check_nmake => 1,
- @_,
- );
-
- $self->sign(1) if $args{sign};
- $self->Meta->write if $args{meta};
- $self->admin->WriteAll(%args) if $self->is_admin;
-
- $self->check_nmake if $args{check_nmake};
- unless ( $self->makemaker_args->{PL_FILES} ) {
- $self->makemaker_args( PL_FILES => {} );
- }
-
- if ( $args{inline} ) {
- $self->Inline->write;
- } else {
- $self->Makefile->write;
- }
+ my $self = shift;
+ my %args = (
+ meta => 1,
+ sign => 0,
+ inline => 0,
+ check_nmake => 1,
+ @_
+ );
+
+ $self->sign(1) if $args{sign};
+ $self->Meta->write if $args{meta};
+ $self->admin->WriteAll(%args) if $self->is_admin;
+
+ if ( $0 =~ /Build.PL$/i ) {
+ $self->Build->write;
+ } else {
+ $self->check_nmake if $args{check_nmake};
+ unless ( $self->makemaker_args->{'PL_FILES'} ) {
+ $self->makemaker_args( PL_FILES => {} );
+ }
+ if ($args{inline}) {
+ $self->Inline->write;
+ } else {
+ $self->Makefile->write;
+ }
+ }
}
1;
Modified: Scalar-Defer/inc/Test/Builder.pm
==============================================================================
--- Scalar-Defer/inc/Test/Builder.pm (original)
+++ Scalar-Defer/inc/Test/Builder.pm Fri Jun 27 12:04:25 2008
@@ -1,11 +1,16 @@
#line 1
package Test::Builder;
-use 5.006;
-use strict;
+use 5.004;
+
+# $^C was only introduced in 5.005-ish. We do this to prevent
+# use of uninitialized value warnings in older perls.
+$^C ||= 0;
-our $VERSION = '0.80';
-$VERSION = eval { $VERSION }; # make the alpha version come out as a number
+use strict;
+use vars qw($VERSION);
+$VERSION = '0.74';
+$VERSION = eval $VERSION; # make the alpha version come out as a number
# Make Test::Builder thread-safe for ithreads.
BEGIN {
@@ -62,7 +67,7 @@
}
-#line 110
+#line 128
my $Test = Test::Builder->new;
sub new {
@@ -72,7 +77,7 @@
}
-#line 132
+#line 150
sub create {
my $class = shift;
@@ -83,7 +88,7 @@
return $self;
}
-#line 151
+#line 169
use vars qw($Level);
@@ -94,6 +99,7 @@
# hash keys is just asking for pain. Also, it was documented.
$Level = 1;
+ $self->{Test_Died} = 0;
$self->{Have_Plan} = 0;
$self->{No_Plan} = 0;
$self->{Original_Pid} = $$;
@@ -112,14 +118,23 @@
$self->{No_Header} = 0;
$self->{No_Ending} = 0;
- $self->{TODO} = undef;
-
$self->_dup_stdhandles unless $^C;
- return;
+ return undef;
+}
+
+#line 221
+
+sub exported_to {
+ my($self, $pack) = @_;
+
+ if( defined $pack ) {
+ $self->{Exported_To} = $pack;
+ }
+ return $self->{Exported_To};
}
-#line 207
+#line 243
sub plan {
my($self, $cmd, $arg) = @_;
@@ -158,7 +173,7 @@
return 1;
}
-#line 254
+#line 290
sub expected_tests {
my $self = shift;
@@ -177,7 +192,7 @@
}
-#line 279
+#line 315
sub no_plan {
my $self = shift;
@@ -186,7 +201,7 @@
$self->{Have_Plan} = 1;
}
-#line 294
+#line 330
sub has_plan {
my $self = shift;
@@ -197,7 +212,7 @@
};
-#line 312
+#line 348
sub skip_all {
my($self, $reason) = @_;
@@ -212,19 +227,7 @@
exit(0);
}
-
-#line 339
-
-sub exported_to {
- my($self, $pack) = @_;
-
- if( defined $pack ) {
- $self->{Exported_To} = $pack;
- }
- return $self->{Exported_To};
-}
-
-#line 369
+#line 382
sub ok {
my($self, $test, $name) = @_;
@@ -246,12 +249,9 @@
Very confusing.
ERR
- my $todo = $self->todo();
-
- # Capture the value of $TODO for the rest of this ok() call
- # so it can more easily be found by other routines.
- local $self->{TODO} = $todo;
+ my($pack, $file, $line) = $self->caller;
+ my $todo = $self->todo($pack);
$self->_unoverload_str(\$todo);
my $out;
@@ -296,14 +296,13 @@
my $msg = $todo ? "Failed (TODO)" : "Failed";
$self->_print_diag("\n") if $ENV{HARNESS_ACTIVE};
- my(undef, $file, $line) = $self->caller;
- if( defined $name ) {
- $self->diag(qq[ $msg test '$name'\n]);
- $self->diag(qq[ at $file line $line.\n]);
- }
- else {
- $self->diag(qq[ $msg test at $file line $line.\n]);
- }
+ if( defined $name ) {
+ $self->diag(qq[ $msg test '$name'\n]);
+ $self->diag(qq[ at $file line $line.\n]);
+ }
+ else {
+ $self->diag(qq[ $msg test at $file line $line.\n]);
+ }
}
return $test ? 1 : 0;
@@ -362,7 +361,7 @@
-#line 521
+#line 530
sub is_eq {
my($self, $got, $expect, $name) = @_;
@@ -419,7 +418,6 @@
}
}
- local $Level = $Level + 1;
return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
got: %s
expected: %s
@@ -427,7 +425,7 @@
}
-#line 600
+#line 608
sub isnt_eq {
my($self, $got, $dont_expect, $name) = @_;
@@ -462,7 +460,7 @@
}
-#line 652
+#line 660
sub like {
my($self, $this, $regex, $name) = @_;
@@ -479,7 +477,7 @@
}
-#line 677
+#line 685
my %numeric_cmps = map { ($_, 1) }
@@ -502,8 +500,7 @@
my $code = $self->_caller_context;
- # Yes, it has to look like this or 5.4.5 won't see the #line
- # directive.
+ # Yes, it has to look like this or 5.4.5 won't see the #line directive.
# Don't ask me, man, I just work here.
$test = eval "
$code" . "\$got $type \$expect;";
@@ -528,8 +525,6 @@
$got = defined $got ? "'$got'" : 'undef';
$expect = defined $expect ? "'$expect'" : 'undef';
-
- local $Level = $Level + 1;
return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
%s
%s
@@ -549,7 +544,7 @@
return $code;
}
-#line 766
+#line 771
sub BAIL_OUT {
my($self, $reason) = @_;
@@ -559,12 +554,12 @@
exit 255;
}
-#line 779
+#line 784
*BAILOUT = \&BAIL_OUT;
-#line 791
+#line 796
sub skip {
my($self, $why) = @_;
@@ -596,7 +591,7 @@
}
-#line 833
+#line 838
sub todo_skip {
my($self, $why) = @_;
@@ -625,7 +620,7 @@
}
-#line 911
+#line 916
sub maybe_regex {
@@ -637,7 +632,7 @@
my($re, $opts);
# Check for qr/foo/
- if( _is_qr($regex) ) {
+ if( ref $regex eq 'Regexp' ) {
$usable_regex = $regex;
}
# Check for '/foo/' or 'm,foo,'
@@ -649,18 +644,7 @@
}
return $usable_regex;
-}
-
-
-sub _is_qr {
- my $regex = shift;
-
- # is_regexp() checks for regexes in a robust manner, say if they're
- # blessed.
- return re::is_regexp($regex) if defined &re::is_regexp;
- return ref $regex eq 'Regexp';
-}
-
+};
sub _regex_ok {
my($self, $this, $regex, $cmp, $name) = @_;
@@ -679,8 +663,7 @@
local($@, $!, $SIG{__DIE__}); # isolate eval
- # Yes, it has to look like this or 5.4.5 won't see the #line
- # directive.
+ # Yes, it has to look like this or 5.4.5 won't see the #line directive.
# Don't ask me, man, I just work here.
$test = eval "
$code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
@@ -694,8 +677,6 @@
unless( $ok ) {
$this = defined $this ? "'$this'" : 'undef';
my $match = $cmp eq '=~' ? "doesn't match" : "matches";
-
- local $Level = $Level + 1;
$self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
%s
%13s '%s'
@@ -710,7 +691,7 @@
# I'm not ready to publish this. It doesn't deal with array return
# values from the code or context.
-#line 1009
+#line 1000
sub _try {
my($self, $code) = @_;
@@ -723,7 +704,7 @@
return wantarray ? ($return, $@) : $return;
}
-#line 1031
+#line 1022
sub is_fh {
my $self = shift;
@@ -739,7 +720,7 @@
}
-#line 1076
+#line 1067
sub level {
my($self, $level) = @_;
@@ -751,7 +732,7 @@
}
-#line 1109
+#line 1100
sub use_numbers {
my($self, $use_nums) = @_;
@@ -763,7 +744,7 @@
}
-#line 1143
+#line 1134
foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
my $method = lc $attribute;
@@ -777,12 +758,12 @@
return $self->{$attribute};
};
- no strict 'refs'; ## no critic
+ no strict 'refs';
*{__PACKAGE__.'::'.$method} = $code;
}
-#line 1197
+#line 1188
sub diag {
my($self, @msgs) = @_;
@@ -809,7 +790,7 @@
return 0;
}
-#line 1234
+#line 1225
sub _print {
my($self, @msgs) = @_;
@@ -833,7 +814,7 @@
print $fh $msg;
}
-#line 1268
+#line 1259
sub _print_diag {
my $self = shift;
@@ -843,7 +824,7 @@
print $fh @_;
}
-#line 1305
+#line 1296
sub output {
my($self, $fh) = @_;
@@ -882,9 +863,10 @@
$fh = $file_or_fh;
}
else {
- open $fh, ">", $file_or_fh or
+ $fh = do { local *FH };
+ open $fh, ">$file_or_fh" or
$self->croak("Can't open test output log $file_or_fh: $!");
- _autoflush($fh);
+ _autoflush($fh);
}
return $fh;
@@ -899,7 +881,6 @@
}
-my($Testout, $Testerr);
sub _dup_stdhandles {
my $self = shift;
@@ -907,47 +888,29 @@
# Set everything to unbuffered else plain prints to STDOUT will
# come out in the wrong order from our own prints.
- _autoflush($Testout);
+ _autoflush(\*TESTOUT);
_autoflush(\*STDOUT);
- _autoflush($Testerr);
+ _autoflush(\*TESTERR);
_autoflush(\*STDERR);
- $self->output ($Testout);
- $self->failure_output($Testerr);
- $self->todo_output ($Testout);
+ $self->output(\*TESTOUT);
+ $self->failure_output(\*TESTERR);
+ $self->todo_output(\*TESTOUT);
}
my $Opened_Testhandles = 0;
sub _open_testhandles {
- my $self = shift;
-
return if $Opened_Testhandles;
-
# We dup STDOUT and STDERR so people can change them in their
# test suites while still getting normal test output.
- open( $Testout, ">&STDOUT") or die "Can't dup STDOUT: $!";
- open( $Testerr, ">&STDERR") or die "Can't dup STDERR: $!";
-
-# $self->_copy_io_layers( \*STDOUT, $Testout );
-# $self->_copy_io_layers( \*STDERR, $Testerr );
-
+ open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!";
+ open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!";
$Opened_Testhandles = 1;
}
-sub _copy_io_layers {
- my($self, $src, $dst) = @_;
-
- $self->_try(sub {
- require PerlIO;
- my @src_layers = PerlIO::get_layers($src);
-
- binmode $dst, join " ", map ":$_", @src_layers if @src_layers;
- });
-}
-
-#line 1423
+#line 1396
sub _message_at_caller {
my $self = shift;
@@ -976,7 +939,7 @@
}
}
-#line 1471
+#line 1444
sub current_test {
my($self, $num) = @_;
@@ -1012,7 +975,7 @@
}
-#line 1516
+#line 1489
sub summary {
my($self) = shift;
@@ -1020,29 +983,27 @@
return map { $_->{'ok'} } @{ $self->{Test_Results} };
}
-#line 1571
+#line 1544
sub details {
my $self = shift;
return @{ $self->{Test_Results} };
}
-#line 1597
+#line 1569
sub todo {
my($self, $pack) = @_;
- return $self->{TODO} if defined $self->{TODO};
-
- $pack = $pack || $self->caller(1) || $self->exported_to;
+ $pack = $pack || $self->exported_to || $self->caller($Level);
return 0 unless $pack;
- no strict 'refs'; ## no critic
+ no strict 'refs';
return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
: 0;
}
-#line 1622
+#line 1590
sub caller {
my($self, $height) = @_;
@@ -1052,9 +1013,9 @@
return wantarray ? @caller : $caller[0];
}
-#line 1634
+#line 1602
-#line 1648
+#line 1616
#'#
sub _sanity_check {
@@ -1067,7 +1028,7 @@
'Somehow you got a different number of results than tests ran!');
}
-#line 1669
+#line 1637
sub _whoa {
my($self, $check, $desc) = @_;
@@ -1080,7 +1041,7 @@
}
}
-#line 1691
+#line 1659
sub _my_exit {
$? = $_[0];
@@ -1089,29 +1050,37 @@
}
-#line 1704
+#line 1672
+
+$SIG{__DIE__} = sub {
+ # We don't want to muck with death in an eval, but $^S isn't
+ # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing
+ # with it. Instead, we use caller. This also means it runs under
+ # 5.004!
+ my $in_eval = 0;
+ for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) {
+ $in_eval = 1 if $sub =~ /^\(eval\)/;
+ }
+ $Test->{Test_Died} = 1 unless $in_eval;
+};
sub _ending {
my $self = shift;
- my $real_exit_code = $?;
$self->_sanity_check();
# Don't bother with an ending if this is a forked copy. Only the parent
# should do the ending.
- if( $self->{Original_Pid} != $$ ) {
- return;
- }
-
# Exit if plan() was never called. This is so "require Test::Simple"
# doesn't puke.
- if( !$self->{Have_Plan} ) {
- return;
- }
-
# Don't do an ending if we bailed out.
- if( $self->{Bailed_Out} ) {
- return;
+ if( ($self->{Original_Pid} != $$) or
+ (!$self->{Have_Plan} && !$self->{Test_Died}) or
+ $self->{Bailed_Out}
+ )
+ {
+ _my_exit($?);
+ return;
}
# Figure out if we passed or failed and print helpful messages.
@@ -1161,7 +1130,7 @@
FAIL
}
- if( $real_exit_code ) {
+ if( $self->{Test_Died} ) {
$self->diag(<<"FAIL");
Looks like your test died just after $self->{Curr_Test}.
FAIL
@@ -1185,7 +1154,7 @@
elsif ( $self->{Skip_All} ) {
_my_exit( 0 ) && return;
}
- elsif ( $real_exit_code ) {
+ elsif ( $self->{Test_Died} ) {
$self->diag(<<'FAIL');
Looks like your test died before it could output anything.
FAIL
@@ -1201,6 +1170,6 @@
$Test->_ending if defined $Test and !$Test->no_ending;
}
-#line 1871
+#line 1847
1;
Modified: Scalar-Defer/inc/Test/Builder/Module.pm
==============================================================================
--- Scalar-Defer/inc/Test/Builder/Module.pm (original)
+++ Scalar-Defer/inc/Test/Builder/Module.pm Fri Jun 27 12:04:25 2008
@@ -1,14 +1,14 @@
#line 1
package Test::Builder::Module;
-use strict;
-
use Test::Builder;
require Exporter;
-our @ISA = qw(Exporter);
+ at ISA = qw(Exporter);
-our $VERSION = '0.80';
+$VERSION = '0.74';
+
+use strict;
# 5.004's Exporter doesn't have export_to_level.
my $_export_to_level = sub {
@@ -24,9 +24,6 @@
sub import {
my($class) = shift;
-
- # Don't run all this when loading ourself.
- return 1 if $class eq 'Test::Builder::Module';
my $test = $class->builder;
@@ -70,12 +67,12 @@
}
-#line 147
+#line 144
sub import_extra {}
-#line 178
+#line 175
sub builder {
return Test::Builder->new;
Modified: Scalar-Defer/inc/Test/More.pm
==============================================================================
--- Scalar-Defer/inc/Test/More.pm (original)
+++ Scalar-Defer/inc/Test/More.pm Fri Jun 27 12:04:25 2008
@@ -1,7 +1,8 @@
#line 1
package Test::More;
-use 5.006;
+use 5.004;
+
use strict;
@@ -16,7 +17,7 @@
use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
-$VERSION = '0.80';
+$VERSION = '0.74';
$VERSION = eval $VERSION; # make the alpha version come out as a number
use Test::Builder::Module;
@@ -31,11 +32,11 @@
plan
can_ok isa_ok
diag
- BAIL_OUT
+ BAIL_OUT
);
-#line 156
+#line 157
sub plan {
my $tb = Test::More->builder;
@@ -69,7 +70,7 @@
}
-#line 256
+#line 257
sub ok ($;$) {
my($test, $name) = @_;
@@ -78,7 +79,7 @@
$tb->ok($test, $name);
}
-#line 323
+#line 324
sub is ($$;$) {
my $tb = Test::More->builder;
@@ -95,7 +96,7 @@
*isn't = \&isnt;
-#line 368
+#line 369
sub like ($$;$) {
my $tb = Test::More->builder;
@@ -104,7 +105,7 @@
}
-#line 384
+#line 385
sub unlike ($$;$) {
my $tb = Test::More->builder;
@@ -113,7 +114,7 @@
}
-#line 424
+#line 425
sub cmp_ok($$$;$) {
my $tb = Test::More->builder;
@@ -122,7 +123,7 @@
}
-#line 460
+#line 461
sub can_ok ($@) {
my($proto, @methods) = @_;
@@ -157,7 +158,7 @@
return $ok;
}
-#line 522
+#line 523
sub isa_ok ($$;$) {
my($object, $class, $obj_name) = @_;
@@ -211,7 +212,7 @@
}
-#line 591
+#line 592
sub pass (;$) {
my $tb = Test::More->builder;
@@ -223,7 +224,7 @@
$tb->ok(0, @_);
}
-#line 652
+#line 653
sub use_ok ($;@) {
my($module, @imports) = @_;
@@ -232,28 +233,30 @@
my($pack,$filename,$line) = caller;
- my $code;
- if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) {
- # probably a version check. Perl needs to see the bare number
- # for it to work with non-Exporter based modules.
- $code = <<USE;
+ # Work around a glitch in $@ and eval
+ my $eval_error;
+ {
+ local($@,$!,$SIG{__DIE__}); # isolate eval
+
+ if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) {
+ # probably a version check. Perl needs to see the bare number
+ # for it to work with non-Exporter based modules.
+ eval <<USE;
package $pack;
use $module $imports[0];
-1;
USE
- }
- else {
- $code = <<USE;
+ }
+ else {
+ eval <<USE;
package $pack;
-use $module \@{\$args[0]};
-1;
+use $module \@imports;
USE
+ }
+ $eval_error = $@;
}
+ my $ok = $tb->ok( !$eval_error, "use $module;" );
- my($eval_result, $eval_error) = _eval($code, \@imports);
- my $ok = $tb->ok( $eval_result, "use $module;" );
-
unless( $ok ) {
chomp $eval_error;
$@ =~ s{^BEGIN failed--compilation aborted at .*$}
@@ -268,21 +271,7 @@
return $ok;
}
-
-sub _eval {
- my($code) = shift;
- my @args = @_;
-
- # Work around oddities surrounding resetting of $@ by immediately
- # storing it.
- local($@,$!,$SIG{__DIE__}); # isolate eval
- my $eval_result = eval $code;
- my $eval_error = $@;
-
- return($eval_result, $eval_error);
-}
-
-#line 718
+#line 707
sub require_ok ($) {
my($module) = shift;
@@ -294,20 +283,20 @@
# Module names must be barewords, files not.
$module = qq['$module'] unless _is_module_name($module);
- my $code = <<REQUIRE;
+ local($!, $@, $SIG{__DIE__}); # isolate eval
+ local $SIG{__DIE__};
+ eval <<REQUIRE;
package $pack;
require $module;
-1;
REQUIRE
- my($eval_result, $eval_error) = _eval($code);
- my $ok = $tb->ok( $eval_result, "require $module;" );
+ my $ok = $tb->ok( !$@, "require $module;" );
unless( $ok ) {
- chomp $eval_error;
+ chomp $@;
$tb->diag(<<DIAGNOSTIC);
Tried to require '$module'.
- Error: $eval_error
+ Error: $@
DIAGNOSTIC
}
@@ -326,7 +315,7 @@
$module =~ /^[a-zA-Z]\w*$/;
}
-#line 795
+#line 784
use vars qw(@Data_Stack %Refs_Seen);
my $DNE = bless [], 'Does::Not::Exist';
@@ -433,7 +422,7 @@
return '';
}
-#line 941
+#line 930
sub diag {
my $tb = Test::More->builder;
@@ -442,7 +431,7 @@
}
-#line 1010
+#line 999
#'#
sub skip {
@@ -470,7 +459,7 @@
}
-#line 1097
+#line 1086
sub todo_skip {
my($why, $how_many) = @_;
@@ -491,7 +480,7 @@
last TODO;
}
-#line 1150
+#line 1139
sub BAIL_OUT {
my $reason = shift;
@@ -500,7 +489,7 @@
$tb->BAIL_OUT($reason);
}
-#line 1189
+#line 1178
#'#
sub eq_array {
@@ -624,7 +613,7 @@
}
-#line 1320
+#line 1309
sub eq_hash {
local @Data_Stack;
@@ -657,7 +646,7 @@
return $ok;
}
-#line 1377
+#line 1366
sub eq_set {
my($a1, $a2) = @_;
@@ -683,6 +672,6 @@
);
}
-#line 1567
+#line 1556
1;
Modified: Scalar-Defer/lib/Scalar/Defer.pm
==============================================================================
--- Scalar-Defer/lib/Scalar/Defer.pm (original)
+++ Scalar-Defer/lib/Scalar/Defer.pm Fri Jun 27 12:04:25 2008
@@ -5,37 +5,44 @@
use warnings;
BEGIN {
- our $VERSION = '0.13';
- our @EXPORT = qw( lazy defer force );
+ our $VERSION = '0.15';
+ our @EXPORT = qw( lazy defer force );
+ our @EXPORT_OK = qw( is_deferred );
}
use Exporter::Lite;
-use Class::InsideOut qw( private register id );
-use constant FALSE_PACKAGE => '0';
-use constant DEFER_PACKAGE => '0';
+use Class::InsideOut qw( register id );
+use constant DEFER_PACKAGE => '0'; # This may change soon
BEGIN {
my %_defer;
sub defer (&) {
- my $cv = shift;
+ my $cv = shift;
my $obj = register( bless(\(my $id) => __PACKAGE__) );
$_defer{ $id = id $obj } = $cv;
bless($obj => DEFER_PACKAGE);
}
sub lazy (&) {
- my $cv = shift;
- my ($value, $forced);
+ my $cv = shift;
my $obj = register( bless(\(my $id) => __PACKAGE__) );
+
+ my ($value, $forced);
$_defer{ $id = id $obj } = sub {
$forced ? $value : scalar(++$forced, $value = &$cv)
};
- bless($obj => DEFER_PACKAGE);
+
+ bless $obj => DEFER_PACKAGE;
}
sub DEMOLISH {
- delete $_defer{ id shift };
+ delete $_defer{ id $_[0] };
+ }
+
+ sub is_deferred ($) {
+ no warnings 'uninitialized';
+ ref $_[0] eq DEFER_PACKAGE;
}
use constant SUB_FORCE => sub ($) {
@@ -62,7 +69,10 @@
my $id = $$self;
bless($self => DEFER_PACKAGE);
$id;
- }} || die("Cannot locate thunk for memory address: ".id($_[0]))
+ }} or do {
+ return 0 if caller eq 'Class::InsideOut';
+ die sprintf("Cannot locate thunk for memory address: 0x%X", id $_[0]);
+ };
};
};
@@ -91,18 +101,20 @@
{
foreach my $sym (grep { $_ ne 'DESTROY' } keys %UNIVERSAL::) {
- my $code = 'sub $sym {
- if ( defined Scalar::Util::blessed($_[0]) ) { # FUCK
- unshift @_, Scalar::Defer::SUB_FORCE()->(shift(@_));
- goto &{$_[0]->can("$sym")};
- } else {
- return shift->SUPER::$sym(@_);
- }
- }';
+ my $code = q[
+ sub $sym {
+ if ( defined Scalar::Util::blessed($_[0]) ) {
+ unshift @_, Scalar::Defer::SUB_FORCE()->(shift(@_));
+ goto &{$_[0]->can("$sym")};
+ } else {
+ return shift->SUPER::$sym(@_);
+ }
+ }
+ ];
- $code =~ s/\$sym/$sym/ge;
+ $code =~ s/\$sym/$sym/ge;
- eval $code;
+ eval $code;
}
*DESTROY = \&Scalar::Defer::DESTROY;
@@ -112,7 +124,7 @@
BEGIN {
no strict 'refs';
- @{FALSE_PACKAGE().'::ISA'} = ('Scalar::Defer::Deferred');
+ @{DEFER_PACKAGE().'::ISA'} = ('Scalar::Defer::Deferred');
}
1;
@@ -158,7 +170,15 @@
=head2 force $value
Force evaluation of a deferred value to return a normal value.
-If C<$value> was already normal value, then C<force> simply returns it.
+If C<$value> was already a normal value, then C<force> simply returns it.
+
+=head2 is_deferred $value
+
+Tells whether the argument is a deferred value or not. (Lazy values are
+deferred too.)
+
+The C<is_deferred> function is not exported by default; to import it, name
+it explicitly in the import list.
=head1 NOTES
@@ -167,7 +187,7 @@
is always the forced value.
Unlike the C<tie>-based L<Data::Lazy>, this module operates on I<values>,
-not I<variables>. Therefore, assigning anothe value into C<$dv> and C<$lv>
+not I<variables>. Therefore, assigning another value into C<$dv> and C<$lv>
above will simply replace the value, instead of triggering a C<STORE> method
call.
@@ -177,13 +197,24 @@
-- even under the worst case scenario, where it's always immediately forced
after creation, this module is still twice as fast than L<Data::Lazy>.
+=head1 CAVEATS
+
+Bad things may happen if this module interacts with any other code which
+fiddles with package C<0>.
+
+=head1 SEE ALSO
+
+L<Data::Thunk>, which implements C<lazy> values that can replace itself
+upon forcing, leaving a minimal trace of the thunk, with some sneaky XS
+magic in L<Data::Swap>.
+
=head1 AUTHORS
Audrey Tang E<lt>cpan at audreyt.orgE<gt>
=head1 COPYRIGHT
-Copyright 2006, 2007 by Audrey Tang <cpan at audreyt.org>.
+Copyright 2006, 2007, 2008 by Audrey Tang <cpan at audreyt.org>.
This software is released under the MIT license cited below.
More information about the Bps-public-commit
mailing list