Scalar-Properties-0.13/0000755000076500007650000000000010705716053015542 5ustar marcelmarcel00000000000000Scalar-Properties-0.13/Changes0000644000076500007650000000340410705615141017032 0ustar marcelmarcel00000000000000Revision history for Perl extension Scalar::Properties. 0.13 Do Okt 18 10:09:39 CEST 2007 - fixed version requirement of Test::More - improved documentation 0.12 Sun Nov 9 11:31:00 2003 by DCANTRELL - applied patch to fix interpolation bug, reported and patch supplied by makamaka@users.sourceforge.jp - added test for this bug - changed true() function in test.pl to show a useful comment for each test if supplied 0.11 Tue Nov 4 18:54:00 2003 by DCANTRELL - fixed operand ordering bug in generated functions for binary ops - fixed bug in test suite which only showed up after fixing above ;-) 0.10 Wed Jun 27 20:31:45 2001 - added code execution methods, abs(), zero() - added is_false() method - added 'has_' prefix for property querying - added property propagation (pass_on(), passed_on(), get_pass_on()) - added property introspection (get_props(), del_props(), del_all_props()) - added tests and documentation for all of the above 0.03 Wed Jun 27 16:08:46 2001 - added many string methods, plus tests and documentation - changed boolean methods to return an overloaded boolean value so it can take properties as well 0.02 Tue Jun 26 00:08:24 2001 - value() stringifies if argument not of this package - added options to import() to be able to selectively specify constant overloading from different packages, e.g. overloading 'qr' from a Regex package - added methods length, size, reverse and tests for those - added TODO document 0.01 Tue Jun 26 19:35:58 2001 - original version; created by h2xs 1.20 with options -XAn Scalar::Properties Scalar-Properties-0.13/inc/0000755000076500007650000000000010705716053016313 5ustar marcelmarcel00000000000000Scalar-Properties-0.13/inc/Module/0000755000076500007650000000000010705716053017540 5ustar marcelmarcel00000000000000Scalar-Properties-0.13/inc/Module/Install/0000755000076500007650000000000010705716053021146 5ustar marcelmarcel00000000000000Scalar-Properties-0.13/inc/Module/Install/Base.pm0000644000076500007650000000203510705716053022356 0ustar marcelmarcel00000000000000#line 1 package Module::Install::Base; $VERSION = '0.67'; # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } ### This is the ONLY module that shouldn't have strict on # use strict; #line 41 sub new { my ($class, %args) = @_; foreach my $method ( qw(call load) ) { *{"$class\::$method"} = sub { shift()->_top->$method(@_); } unless defined &{"$class\::$method"}; } bless( \%args, $class ); } #line 61 sub AUTOLOAD { my $self = shift; local $@; my $autoload = eval { $self->_top->autoload } or return; goto &$autoload; } #line 76 sub _top { $_[0]->{_top} } #line 89 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } sub is_admin { $_[0]->admin->VERSION; } sub DESTROY {} package Module::Install::Base::FakeAdmin; my $Fake; sub new { $Fake ||= bless(\@_, $_[0]) } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 138 Scalar-Properties-0.13/inc/Module/Install/Can.pm0000644000076500007650000000337410705716053022214 0ustar marcelmarcel00000000000000#line 1 package Module::Install::Can; use strict; use Module::Install::Base; use Config (); ### This adds a 5.005 Perl version dependency. ### This is a bug and will be fixed. use File::Spec (); use ExtUtils::MakeMaker (); use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.67'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { my $abs = File::Spec->catfile($dir, $_[1]); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 157 Scalar-Properties-0.13/inc/Module/Install/Fetch.pm0000644000076500007650000000463010705716053022540 0ustar marcelmarcel00000000000000#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base; use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.67'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; Scalar-Properties-0.13/inc/Module/Install/Include.pm0000644000076500007650000000101410705716053023063 0ustar marcelmarcel00000000000000#line 1 package Module::Install::Include; use strict; use Module::Install::Base; use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.67'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } sub include { shift()->admin->include(@_); } sub include_deps { shift()->admin->include_deps(@_); } sub auto_include { shift()->admin->auto_include(@_); } sub auto_include_deps { shift()->admin->auto_include_deps(@_); } sub auto_include_dependent_dists { shift()->admin->auto_include_dependent_dists(@_); } 1; Scalar-Properties-0.13/inc/Module/Install/Makefile.pm0000644000076500007650000001351110705716053023222 0ustar marcelmarcel00000000000000#line 1 package Module::Install::Makefile; use strict 'vars'; use Module::Install::Base; use ExtUtils::MakeMaker (); use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.67'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing, always use defaults if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } sub makemaker_args { my $self = shift; my $args = ($self->{makemaker_args} ||= {}); %$args = ( %$args, @_ ) if @_; $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = sShift; my $name = shift; my $args = $self->makemaker_args; $args->{name} = defined $args->{$name} ? join( ' ', $args->{name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join(' ', grep length, $clean->{FILES}, @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join(' ', grep length, $realclean->{FILES}, @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } my %test_dir = (); sub _wanted_t { /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1; } sub tests_recursive { my $self = shift; if ( $self->tests ) { die "tests_recursive will not work if tests are already defined"; } my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } require File::Find; %test_dir = (); File::Find::find( \&_wanted_t, $dir ); $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $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 }; } if ($] >= 5.005) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = $self->author; } if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) { $args->{NO_META} = 1; } if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } # merge both kinds of requires into prereq_pm my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } map { @$_ } grep $_, ($self->build_requires, $self->requires) ); # merge both kinds of requires into prereq_pm my $subdirs = ($args->{DIR} ||= []); if ($self->bundles) { foreach my $bundle (@{ $self->bundles }) { my ($file, $dir) = @$bundle; push @$subdirs, $dir if -d $dir; delete $prereq->{$file}; } } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } $args->{INSTALLDIRS} = $self->installdirs; my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if (my $preop = $self->admin->preop($user_preop)) { $args{dist} = $preop; } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; my $makefile = do { local $/; }; close MAKEFILE or die $!; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$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; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 363 Scalar-Properties-0.13/inc/Module/Install/Metadata.pm0000644000076500007650000002152710705716053023233 0ustar marcelmarcel00000000000000#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base; use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.67'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } my @scalar_keys = qw{ name module_name abstract author version license distribution_type perl_version tests installdirs }; my @tuple_keys = qw{ build_requires requires recommends bundles }; sub Meta { shift } sub Meta_ScalarKeys { @scalar_keys } 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; }; } 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; }; } # 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(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } 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; } sub dynamic_config { my $self = shift; unless ( @_ ) { warn "You MUST provide an explicit true/false value to dynamic_config, skipping\n"; return $self; } $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; } $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; } 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 || {} }); } 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 $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); 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} } : (); } sub 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', 0 ); 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; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { my ( $self, $file ) = @_; require ExtUtils::MM_Unix; $self->version( ExtUtils::MM_Unix->parse_version($file) ); } sub abstract_from { 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 $/; }; } sub perl_version_from { 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, $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}{<}g; $author =~ s{E}{>}g; $self->author($author); } else { warn "Cannot determine author info from $file\n"; } } sub license_from { my ( $self, $file ) = @_; 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; Scalar-Properties-0.13/inc/Module/Install/StandardTests.pm0000644000076500007650000000671710705716053024302 0ustar marcelmarcel00000000000000#line 1 package Module::Install::StandardTests; use warnings; use strict; use File::Spec; use base 'Module::Install::Base'; our $VERSION = '0.05'; sub use_standard_tests { my ($self, %specs) = @_; my %with = map { $_ => 1 } qw/compile pod pod_coverage perl_critic/; if (exists $specs{without}) { $specs{without} = [ $specs{without} ] unless ref $specs{without}; delete $with{$_} for @{ $specs{without} }; } $self->build_requires('Test::More'); $self->build_requires('UNIVERSAL::require'); # Unlike other tests, this is mandatory. $self->build_requires('Test::Compile'); $self->write_standard_test_compile; # no if; this is mandatory $self->write_standard_test_pod if $with{pod}; $self->write_standard_test_pod_coverage if $with{pod_coverage}; $self->write_standard_test_perl_critic if $with{perl_critic}; } sub write_test_file { my ($self, $filename, $code) = @_; $filename = File::Spec->catfile('t', $filename); # Outdent the code somewhat. Remove first empty line, if any. Then # determine the indent of the first line. Throw that amount of indenting # away from any line. This allows you to indent the code so it's visually # clearer (see methods below) while creating output that's indented more # or less correctly. Smoke result HTML pages link to the .t files, so it # looks neater. $code =~ s/^ *\n//; (my $indent = $code) =~ s/^( *).*/$1/s; $code =~ s/^$indent//gm; print "Creating $filename\n"; open(my $fh, ">$filename") or die "can't create $filename $!"; my $perl = $^X; print $fh <realclean_files($filename); } sub write_standard_test_compile { my $self = shift; $self->write_test_file('000_standard__compile.t', q/ BEGIN { use Test::More; eval "use Test::Compile"; Test::More->builder->BAIL_OUT( "Test::Compile required for testing compilation") if $@; all_pm_files_ok(); } /); } sub write_standard_test_pod { my $self = shift; $self->write_test_file('000_standard__pod.t', q/ use Test::More; eval "use Test::Pod"; plan skip_all => "Test::Pod required for testing POD" if $@; all_pod_files_ok(); /); } sub write_standard_test_pod_coverage { my $self = shift; $self->write_test_file('000_standard__pod_coverage.t', q/ use Test::More; eval "use Test::Pod::Coverage"; plan skip_all => "Test::Pod::Coverage required for testing POD coverage" if $@; all_pod_coverage_ok(); /); } sub write_standard_test_perl_critic { my $self = shift; $self->write_test_file('000_standard__perl_critic.t', q/ use FindBin '$Bin'; use File::Spec; use UNIVERSAL::require; use Test::More; plan skip_all => 'Author test. Set $ENV{TEST_AUTHOR} to a true value to run.' unless $ENV{TEST_AUTHOR}; my %opt; my $rc_file = File::Spec->catfile($Bin, 'perlcriticrc'); $opt{'-profile'} = $rc_file if -r $rc_file; if (Perl::Critic->require('1.078') && Test::Perl::Critic->require && Test::Perl::Critic->import(%opt)) { all_critic_ok("lib"); } else { plan skip_all => $@; } /); } 1; __END__ #line 249 Scalar-Properties-0.13/inc/Module/Install/Win32.pm0000644000076500007650000000341610705716053022412 0ustar marcelmarcel00000000000000#line 1 package Module::Install::Win32; use strict; use Module::Install::Base; use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.67'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); if (!$rv) { die <<'END_MESSAGE'; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } } 1; Scalar-Properties-0.13/inc/Module/Install/WriteAll.pm0000644000076500007650000000162410705716053023232 0ustar marcelmarcel00000000000000#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base; use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.67'; $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; 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; Scalar-Properties-0.13/inc/Module/Install.pm0000644000076500007650000001761110705716052021511 0ustar marcelmarcel00000000000000#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } 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.67'; } # 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. # If not set, the caller may NOT have loaded the bundled version, and thus # 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"; Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: 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"; Your installer $0 has a modification time in the future. This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } use Cwd (); use File::Find (); use File::Path (); use FindBin; *inc::Module::Install::VERSION = *VERSION; @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; }; } 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"}; } sub preload { 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) = @_; # 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 ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { 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); } 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; $obj; } sub load_extensions { 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 ); } $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; # 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 ( ) { $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; @found; } sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } 1; Scalar-Properties-0.13/inc/Test/0000755000076500007650000000000010705716053017232 5ustar marcelmarcel00000000000000Scalar-Properties-0.13/inc/Test/Compile.pm0000644000076500007650000000413510705716053021163 0ustar marcelmarcel00000000000000#line 1 package Test::Compile; use warnings; use strict; use Test::Builder; use File::Spec; use UNIVERSAL::require; our $VERSION = '0.04'; my $Test = Test::Builder->new; sub import { my $self = shift; my $caller = caller; for my $func ( qw( pm_file_ok all_pm_files all_pm_files_ok ) ) { no strict 'refs'; *{$caller."::".$func} = \&$func; } $Test->exported_to($caller); $Test->plan(@_); } sub pm_file_ok { my $file = shift; my $name = @_ ? shift : "Compile test for $file"; if (!-f $file) { $Test->ok(0, $name); $Test->diag("$file does not exist"); return; } my $module = $file; $module =~ s!^(blib/)?lib/!!; $module =~ s!/!::!g; $module =~ s/\.pm$//; my $ok = 1; $module->use; $ok = 0 if $@; my $diag = ''; unless ($ok) { $diag = "couldn't use $module ($file): $@"; } $Test->ok($ok, $name); $Test->diag($diag) unless $ok; $ok; } sub all_pm_files_ok { my @files = @_ ? @_ : all_pm_files(); $Test->plan(tests => scalar @files); my $ok = 1; for (@files) { pm_file_ok($_) or undef $ok; } $ok; } sub all_pm_files { my @queue = @_ ? @_ : _starting_points(); my @pm; while ( @queue ) { my $file = shift @queue; if ( -d $file ) { local *DH; opendir DH, $file or next; my @newfiles = readdir DH; closedir DH; @newfiles = File::Spec->no_upwards(@newfiles); @newfiles = grep { $_ ne "CVS" && $_ ne ".svn" } @newfiles; for my $newfile (@newfiles) { my $filename = File::Spec->catfile($file, $newfile); if (-f $filename) { push @queue, $filename; } else { push @queue, File::Spec->catdir($file, $newfile); } } } if (-f $file) { push @pm, $file if $file =~ /\.pm$/; } } return @pm; } sub _starting_points { return 'blib' if -e 'blib'; return 'lib'; } 1; __END__ #line 261 Scalar-Properties-0.13/inc/Test/More.pm0000644000076500007650000003400010705716053020467 0ustar marcelmarcel00000000000000#line 1 package Test::More; use 5.004; use strict; # Can't use Carp because it might cause use_ok() to accidentally succeed # even though the module being used forgot to use Carp. Yes, this # actually happened. sub _carp { my($file, $line) = (caller(1))[1,2]; warn @_, " at $file line $line\n"; } use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO); $VERSION = '0.70'; $VERSION = eval $VERSION; # make the alpha version come out as a number use Test::Builder::Module; @ISA = qw(Test::Builder::Module); @EXPORT = qw(ok use_ok require_ok is isnt like unlike is_deeply cmp_ok skip todo todo_skip pass fail eq_array eq_hash eq_set $TODO plan can_ok isa_ok diag BAIL_OUT ); #line 157 sub plan { my $tb = Test::More->builder; $tb->plan(@_); } # This implements "use Test::More 'no_diag'" but the behavior is # deprecated. sub import_extra { my $class = shift; my $list = shift; my @other = (); my $idx = 0; while( $idx <= $#{$list} ) { my $item = $list->[$idx]; if( defined $item and $item eq 'no_diag' ) { $class->builder->no_diag(1); } else { push @other, $item; } $idx++; } @$list = @other; } #line 257 sub ok ($;$) { my($test, $name) = @_; my $tb = Test::More->builder; $tb->ok($test, $name); } #line 324 sub is ($$;$) { my $tb = Test::More->builder; $tb->is_eq(@_); } sub isnt ($$;$) { my $tb = Test::More->builder; $tb->isnt_eq(@_); } *isn't = \&isnt; #line 369 sub like ($$;$) { my $tb = Test::More->builder; $tb->like(@_); } #line 385 sub unlike ($$;$) { my $tb = Test::More->builder; $tb->unlike(@_); } #line 425 sub cmp_ok($$$;$) { my $tb = Test::More->builder; $tb->cmp_ok(@_); } #line 461 sub can_ok ($@) { my($proto, @methods) = @_; my $class = ref $proto || $proto; my $tb = Test::More->builder; unless( $class ) { my $ok = $tb->ok( 0, "->can(...)" ); $tb->diag(' can_ok() called with empty class or reference'); return $ok; } unless( @methods ) { my $ok = $tb->ok( 0, "$class->can(...)" ); $tb->diag(' can_ok() called with no methods'); return $ok; } my @nok = (); foreach my $method (@methods) { $tb->_try(sub { $proto->can($method) }) or push @nok, $method; } my $name; $name = @methods == 1 ? "$class->can('$methods[0]')" : "$class->can(...)"; my $ok = $tb->ok( !@nok, $name ); $tb->diag(map " $class->can('$_') failed\n", @nok); return $ok; } #line 523 sub isa_ok ($$;$) { my($object, $class, $obj_name) = @_; my $tb = Test::More->builder; my $diag; $obj_name = 'The object' unless defined $obj_name; my $name = "$obj_name isa $class"; if( !defined $object ) { $diag = "$obj_name isn't defined"; } elsif( !ref $object ) { $diag = "$obj_name isn't a reference"; } else { # We can't use UNIVERSAL::isa because we want to honor isa() overrides my($rslt, $error) = $tb->_try(sub { $object->isa($class) }); if( $error ) { if( $error =~ /^Can't call method "isa" on unblessed reference/ ) { # Its an unblessed reference if( !UNIVERSAL::isa($object, $class) ) { my $ref = ref $object; $diag = "$obj_name isn't a '$class' it's a '$ref'"; } } else { die <isa on your object and got some weird error. Here's the error. $error WHOA } } elsif( !$rslt ) { my $ref = ref $object; $diag = "$obj_name isn't a '$class' it's a '$ref'"; } } my $ok; if( $diag ) { $ok = $tb->ok( 0, $name ); $tb->diag(" $diag\n"); } else { $ok = $tb->ok( 1, $name ); } return $ok; } #line 592 sub pass (;$) { my $tb = Test::More->builder; $tb->ok(1, @_); } sub fail (;$) { my $tb = Test::More->builder; $tb->ok(0, @_); } #line 653 sub use_ok ($;@) { my($module, @imports) = @_; @imports = () unless @imports; my $tb = Test::More->builder; my($pack,$filename,$line) = caller; 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 <ok( !$@, "use $module;" ); unless( $ok ) { chomp $@; $@ =~ s{^BEGIN failed--compilation aborted at .*$} {BEGIN failed--compilation aborted at $filename line $line.}m; $tb->diag(<builder; my $pack = caller; # Try to deterine if we've been given a module name or file. # Module names must be barewords, files not. $module = qq['$module'] unless _is_module_name($module); local($!, $@, $SIG{__DIE__}); # isolate eval local $SIG{__DIE__}; eval <ok( !$@, "require $module;" ); unless( $ok ) { chomp $@; $tb->diag(<builder; unless( @_ == 2 or @_ == 3 ) { my $msg = <ok(0); } my($got, $expected, $name) = @_; $tb->_unoverload_str(\$expected, \$got); my $ok; if( !ref $got and !ref $expected ) { # neither is a reference $ok = $tb->is_eq($got, $expected, $name); } elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't $ok = $tb->ok(0, $name); $tb->diag( _format_stack({ vals => [ $got, $expected ] }) ); } else { # both references local @Data_Stack = (); if( _deep_check($got, $expected) ) { $ok = $tb->ok(1, $name); } else { $ok = $tb->ok(0, $name); $tb->diag(_format_stack(@Data_Stack)); } } return $ok; } sub _format_stack { my(@Stack) = @_; my $var = '$FOO'; my $did_arrow = 0; foreach my $entry (@Stack) { my $type = $entry->{type} || ''; my $idx = $entry->{'idx'}; if( $type eq 'HASH' ) { $var .= "->" unless $did_arrow++; $var .= "{$idx}"; } elsif( $type eq 'ARRAY' ) { $var .= "->" unless $did_arrow++; $var .= "[$idx]"; } elsif( $type eq 'REF' ) { $var = "\${$var}"; } } my @vals = @{$Stack[-1]{vals}}[0,1]; my @vars = (); ($vars[0] = $var) =~ s/\$FOO/ \$got/; ($vars[1] = $var) =~ s/\$FOO/\$expected/; my $out = "Structures begin differing at:\n"; foreach my $idx (0..$#vals) { my $val = $vals[$idx]; $vals[$idx] = !defined $val ? 'undef' : $val eq $DNE ? "Does not exist" : ref $val ? "$val" : "'$val'"; } $out .= "$vars[0] = $vals[0]\n"; $out .= "$vars[1] = $vals[1]\n"; $out =~ s/^/ /msg; return $out; } sub _type { my $thing = shift; return '' if !ref $thing; for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) { return $type if UNIVERSAL::isa($thing, $type); } return ''; } #line 919 sub diag { my $tb = Test::More->builder; $tb->diag(@_); } #line 988 #'# sub skip { my($why, $how_many) = @_; my $tb = Test::More->builder; unless( defined $how_many ) { # $how_many can only be avoided when no_plan is in use. _carp "skip() needs to know \$how_many tests are in the block" unless $tb->has_plan eq 'no_plan'; $how_many = 1; } if( defined $how_many and $how_many =~ /\D/ ) { _carp "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?"; $how_many = 1; } for( 1..$how_many ) { $tb->skip($why); } local $^W = 0; last SKIP; } #line 1075 sub todo_skip { my($why, $how_many) = @_; my $tb = Test::More->builder; unless( defined $how_many ) { # $how_many can only be avoided when no_plan is in use. _carp "todo_skip() needs to know \$how_many tests are in the block" unless $tb->has_plan eq 'no_plan'; $how_many = 1; } for( 1..$how_many ) { $tb->todo_skip($why); } local $^W = 0; last TODO; } #line 1128 sub BAIL_OUT { my $reason = shift; my $tb = Test::More->builder; $tb->BAIL_OUT($reason); } #line 1167 #'# sub eq_array { local @Data_Stack; _deep_check(@_); } sub _eq_array { my($a1, $a2) = @_; if( grep !_type($_) eq 'ARRAY', $a1, $a2 ) { warn "eq_array passed a non-array ref"; return 0; } return 1 if $a1 eq $a2; my $ok = 1; my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; for (0..$max) { my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] }; $ok = _deep_check($e1,$e2); pop @Data_Stack if $ok; last unless $ok; } return $ok; } sub _deep_check { my($e1, $e2) = @_; my $tb = Test::More->builder; my $ok = 0; # Effectively turn %Refs_Seen into a stack. This avoids picking up # the same referenced used twice (such as [\$a, \$a]) to be considered # circular. local %Refs_Seen = %Refs_Seen; { # Quiet uninitialized value warnings when comparing undefs. local $^W = 0; $tb->_unoverload_str(\$e1, \$e2); # Either they're both references or both not. my $same_ref = !(!ref $e1 xor !ref $e2); my $not_ref = (!ref $e1 and !ref $e2); if( defined $e1 xor defined $e2 ) { $ok = 0; } elsif ( $e1 == $DNE xor $e2 == $DNE ) { $ok = 0; } elsif ( $same_ref and ($e1 eq $e2) ) { $ok = 1; } elsif ( $not_ref ) { push @Data_Stack, { type => '', vals => [$e1, $e2] }; $ok = 0; } else { if( $Refs_Seen{$e1} ) { return $Refs_Seen{$e1} eq $e2; } else { $Refs_Seen{$e1} = "$e2"; } my $type = _type($e1); $type = 'DIFFERENT' unless _type($e2) eq $type; if( $type eq 'DIFFERENT' ) { push @Data_Stack, { type => $type, vals => [$e1, $e2] }; $ok = 0; } elsif( $type eq 'ARRAY' ) { $ok = _eq_array($e1, $e2); } elsif( $type eq 'HASH' ) { $ok = _eq_hash($e1, $e2); } elsif( $type eq 'REF' ) { push @Data_Stack, { type => $type, vals => [$e1, $e2] }; $ok = _deep_check($$e1, $$e2); pop @Data_Stack if $ok; } elsif( $type eq 'SCALAR' ) { push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; $ok = _deep_check($$e1, $$e2); pop @Data_Stack if $ok; } elsif( $type ) { push @Data_Stack, { type => $type, vals => [$e1, $e2] }; $ok = 0; } else { _whoa(1, "No type in _deep_check"); } } } return $ok; } sub _whoa { my($check, $desc) = @_; if( $check ) { die < keys %$a2 ? $a1 : $a2; foreach my $k (keys %$bigger) { my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] }; $ok = _deep_check($e1, $e2); pop @Data_Stack if $ok; last unless $ok; } return $ok; } #line 1355 sub eq_set { my($a1, $a2) = @_; return 0 unless @$a1 == @$a2; # There's faster ways to do this, but this is easiest. local $^W = 0; # It really doesn't matter how we sort them, as long as both arrays are # sorted with the same algorithm. # # Ensure that references are not accidentally treated the same as a # string containing the reference. # # Have to inline the sort routine due to a threading/sort bug. # See [rt.cpan.org 6782] # # I don't know how references would be sorted so we just don't sort # them. This means eq_set doesn't really work with refs. return eq_array( [grep(ref, @$a1), sort( grep(!ref, @$a1) )], [grep(ref, @$a2), sort( grep(!ref, @$a2) )], ); } #line 1545 1; Scalar-Properties-0.13/inc/UNIVERSAL/0000755000076500007650000000000010705716053017663 5ustar marcelmarcel00000000000000Scalar-Properties-0.13/inc/UNIVERSAL/require.pm0000644000076500007650000000335510705716053021703 0ustar marcelmarcel00000000000000#line 1 package UNIVERSAL::require; $UNIVERSAL::require::VERSION = '0.11'; # We do this because UNIVERSAL.pm uses CORE::require(). We're going # to put our own require() into UNIVERSAL and that makes an ambiguity. # So we load it up beforehand to avoid that. BEGIN { require UNIVERSAL } package UNIVERSAL; use strict; use vars qw($Level); $Level = 0; #line 69 sub require { my($module, $want_version) = @_; $UNIVERSAL::require::ERROR = ''; die("UNIVERSAL::require() can only be run as a class method") if ref $module; die("UNIVERSAL::require() takes no or one arguments") if @_ > 2; my($call_package, $call_file, $call_line) = caller($Level); # Load the module. my $file = $module . '.pm'; $file =~ s{::}{/}g; # For performance reasons, check if its already been loaded. This makes # things about 4 times faster. return 1 if $INC{$file}; my $return = eval qq{ #line $call_line "$call_file" CORE::require(\$file); }; # Check for module load failure. if( $@ ) { $UNIVERSAL::require::ERROR = $@; return $return; } # Module version check. if( @_ == 2 ) { eval qq{ #line $call_line "$call_file" \$module->VERSION($want_version); }; if( $@ ) { $UNIVERSAL::require::ERROR = $@; return 0; } } return $return; } #line 136 sub use { my($module, @imports) = @_; local $Level = 1; my $return = $module->require or return 0; my($call_package, $call_file, $call_line) = caller; eval qq{ package $call_package; #line $call_line "$call_file" \$module->import(\@imports); }; if( $@ ) { $UNIVERSAL::require::ERROR = $@; return 0; } return $return; } #line 191 1; Scalar-Properties-0.13/lib/0000755000076500007650000000000010705716053016310 5ustar marcelmarcel00000000000000Scalar-Properties-0.13/lib/Scalar/0000755000076500007650000000000010705716053017515 5ustar marcelmarcel00000000000000Scalar-Properties-0.13/lib/Scalar/Properties.pm0000644000076500007650000003511210705716020022203 0ustar marcelmarcel00000000000000package Scalar::Properties; use warnings; use strict; our $VERSION = '0.13'; use overload q{""} => \&value, bool => \&is_true, '+' => \&plus, '-' => \&minus, '*' => \×, '/' => \÷, '%' => \&modulo, '**' => \&exp, '<=>' => \&numcmp, 'cmp' => \&cmp, # the following would be autogenerated from 'cmp', but # we want to make the methods available explicitly, along # with case-insensitive versions 'eq' => \&eq, 'ne' => \&ne, 'lt' => \<, 'gt' => \>, 'le' => \&le, 'ge' => \≥ sub import { my $pkg = shift; my @defs = qw/integer float binary q qr/; my @req; @_ = ':all' unless @_; for my $key (@_) { if ($key eq ':all') { @req = @defs; } else { die __PACKAGE__." does not export '$key'" unless grep /^$key$/ => @defs; push @req => $key; } } overload::constant map { $_ => \&handle } @req; # also manually export some routines my $callpkg = caller(1); no strict 'refs'; *{"$callpkg\::$_"} = \&{"$pkg\::$_"} for qw/pass_on passed_on get_pass_on/; } # object's hash keys that aren't properties (apart from those starting with # and underscore, which are private anyway) our %NON_PROPS = map { $_ => 1 } our @NON_PROPS = qw/true/; # property propagation sub pass_on { our %PASS_ON = map { $_ => 1 } our @PASS_ON = @_ } sub passed_on { our %PASS_ON; exists $PASS_ON{+shift} } sub get_pass_on { our @PASS_ON } sub get_props { # get a list of the value's properties my $self = shift; our %NON_PROPS; return grep { !(/^_/ || exists $NON_PROPS{$_}) } keys %$self } sub del_prop { # delete one or more properties my $self = shift; our %NON_PROPS; for my $prop (@_) { die "$prop is private, not a property" if substr($prop, 0, 1) eq '_'; die "$prop cannot be deleted" if exists $NON_PROPS{$prop}; delete $self->{$prop}; } } sub del_all_props { my $self = shift; my @props = $self->get_props; delete $self->{$_} for @props; } sub handle { # create a new overloaded object my ($orig, $interp, $context, $sub, @prop) = @_; my $self = bless { _value => $orig, _interp => $interp, _context => $context, true => ($orig) ? 1 : 0, }, __PACKAGE__; # propagate properties marked as such via pass_on from # participating overloaded values passed in @prop for my $val (grep { ref $_ eq __PACKAGE__ } @prop) { for my $prop ($val->get_props) { $self->{$prop} = $val->{$prop} if passed_on($prop); } } return $self; } sub create { # take a value and a list of participating values and create # a new object from them by filling in the gaps that handle() # expects with defaults. As seen from handle(), the participating # values (i.e., the values that the first arg was derived from) # are passed so that properties can be properly propagated my ($val, @props) = @_; handle($val, $val, '', sub {}, @props); } # call this as a sub, not a method as it also takes unblessed scalars # anything not of this package is stringified to give any potential # other overloading a chance to get at it's actual value sub value { # my $v = ref $_[0] eq __PACKAGE__ ? $_[0]->{_value} : "$_[0]"; # $v =~ s/\\n/\n/gs; # no idea why newlines become literal '\n' my $v = ref $_[0] eq __PACKAGE__ ? $_[0]->{_interp} : "$_[0]"; return $v; } # ==================== Generated methods ==================== # Generate some string, numeric and boolean methods sub gen_meth { my $template = shift; while (my ($name, $op) = splice(@_, 0, 2)) { (my $code = $template) =~ s/NAME/$name/g; $code =~ s/OP/$op/g; eval $code; die "Internal error: $@" if $@; } } my $binop = 'sub NAME { my($n, $m) = @_[0,1]; ($m, $n) = ($n, $m) if($_[2]); create(value($n) OP value($m), $n, $m) }'; gen_meth $binop, qw! plus + minus - times * divide / modulo % exp ** numcmp <=> cmp cmp eq eq ne ne lt lt gt gt le le ge ge concat . append . !; # needs 'CORE::lc', otherwise 'Ambiguous call resolved as CORE::lc()' my $bool_i = 'sub NAME { create( CORE::lc(value($_[0])) OP CORE::lc(value($_[1])), @_[0,1] ) }'; gen_meth $bool_i, qw! eqi eq nei ne lti lt gti gt lei le gei ge !; my $func = 'sub NAME { create(OP(value($_[0])), $_[0]) }'; gen_meth $func, qw! abs abs length CORE::length size CORE::length uc uc ucfirst ucfirst lc lc lcfirst lcfirst hex hex oct oct !; # ==================== Miscellaneous Numeric methods ==================== sub zero { create( $_[0] == 0, $_[0] ) } # ==================== Miscellaneous Boolean methods ==================== sub is_true { $_[0]->{true} } sub is_false { !$_[0]->{true} } sub true { my $self = shift; $self->{true} = @_ ? shift : 1; return $self; } sub false { $_[0]->true(0) } # ==================== Miscellaneous String methods ==================== sub reverse { create(scalar reverse(value($_[0])), $_[0]) }; sub swapcase { my $s = shift; $s =~ y/A-Za-z/a-zA-Z/; return create($s) } # $foo->split(/PATTERN/, LIMIT) sub split { my ($orig, $pat, $limit) = @_; $limit ||= 0; $pat = qr/\s+/ unless ref($pat) eq 'Regexp'; # The following should work: # map { create($_, $orig) } split $pat => value($orig), $limit; # But there seems to be a bug in split # (cf. p5p: 'Bug report: split splits on wrong pattern') my @el; eval '@el = split $pat => value($orig), $limit;'; die $@ if $@; return map { create($_, $orig) } @el; } # ==================== Code-execution methods ==================== sub times_do { my ($self, $sub) = @_; die 'times_do() method expected a coderef' unless ref $sub eq 'CODE'; for my $i (1..$self) { $sub->($i) } } sub do_upto_step { my ($self, $limit, $step, $sub) = @_; die 'expected last arg to be a coderef' unless ref $sub eq 'CODE'; # for my $i ($self..$limit) { $sub->($i); } my $i = $self; while ($i <= $limit) { $sub->($i); $i += $step; } } sub do_downto_step { my ($self, $limit, $step, $sub) = @_; die 'expected last arg to be a coderef' unless ref $sub eq 'CODE'; my $i = $self; while ($i >= $limit) { $sub->($i); $i -= $step; } } sub do_upto { do_upto_step ($_[0], $_[1], 1, $_[2]) } sub do_downto { do_downto_step($_[0], $_[1], 1, $_[2]) } sub AUTOLOAD { my $self = shift; (my $prop = our $AUTOLOAD) =~ s/.*:://; return if $prop eq 'DESTROY' || substr($prop, 0, 1) eq '_'; # $x->is_foo or $x->has_foo will return true if 'foo' is # a hash key with a true value return defined $self->{ substr($prop, 4) } && $self->{ substr($prop, 4) } if substr($prop, 0, 4) eq 'has_'; return defined $self->{ substr($prop, 3) } && $self->{ substr($prop, 3) } if substr($prop, 0, 3) eq 'is_'; if (@_) { $self->{$prop} = shift; return $self; } return $self->{$prop}; } 1; __END__ =head1 NAME Scalar::Properties - run-time properties on scalar variables =head1 SYNOPSIS use Scalar::Properties; my $val = 0->true; if ($val && $val == 0) { print "yup, its true alright...\n"; } my @text = ( 'hello world'->greeting(1), 'forget it', 'hi there'->greeting(1), ); print grep { $_->is_greeting } @text; my $l = 'hello world'->length; =head1 DESCRIPTION Scalar::Properties attempts to make Perl more object-oriented by taking an idea from Ruby: Everything you manipulate is an object, and the results of those manipulations are objects themselves. 'hello world'->length (-1234)->abs "oh my god, it's full of properties"->index('g') The first example asks a string to calculate its length. The second example asks a number to calculate its absolute value. And the third example asks a string to find the index of the letter 'g'. Using this module you can have run-time properties on initialized scalar variables and literal values. The word 'properties' is used in the Perl 6 sense: out-of-band data, little sticky notes that are attached to the value. While attributes (as in Perl 5's attribute pragma, and see the C family of modules) are handled at compile-time, properties are handled at run-time. Internally properties are implemented by making their values into objects with overloaded operators. The actual properties are then simply hash entries. Most properties are simply notes you attach to the value, but some may have deeper meaning. For example, the C and C properties plays a role in boolean context, as the first example of the Synopsis shows. Properties can also be propagated between values. For details, see the EXPORTS section below. Here is an example why this might be desirable: pass_on('approximate'); my $pi = 3->approximate(1); my $circ = 2 * $rad * $pi; # now $circ->approximate indicates that this value was derived # from approximate values Please don't use properties whose name start with an underscore; these are reserved for internal use. You can set and query properties like this: =over 4 =item C<$var-Emyprop(1)> sets the property to a true value. =item C<$var-Emyprop(0)> sets the property to a false value. Note that this doesn't delete the property (to do so, use the C method described below). =item C<$var-Eis_myprop>, C<$var-Ehas_myprop> returns a true value if the property is set (i.e., defined and has a true value). The two alternate interfaces are provided to make querying attributes sound more natural. For example: $foo->is_approximate; $bar->has_history; =back =head1 METHODS Values thus made into objects also expose various utility methods. All of those methods (unless noted otherwise) return the result as an overloaded value ready to take properties and method calls itself, and don't modify the original value. =head2 INTROSPECTIVE METHODS These methods help in managing a value's properties. =over 4 =item C<$var->get_props> Get a list of names of the value's properties. =item C<$var->del_props(LIST)> Deletes one or more properties from the value. This is different than setting the property value to zero. =item C<$var->del_all_props> Deletes all of the value's properties. =back =head2 NUMERICAL METHODS =over 4 =item C Returns the value that is the sum of the value whose method has been called and the argument value. This method also overloads addition, so: $a = 7 + 2; $a = 7->plus(2); # the same =item C Returns the value that is the the value whose method has been called minus the argument value. This method also overloads subtraction. =item C Returns the value that is the the value whose method has been called times the argument value. This method also overloads multiplication. =item C Returns the value that is the the value whose method has been called divided by the argument value. This method also overloads division. =item C Returns the value that is the the value whose method has been called modulo the argument value. This method also overloads the modulo operator. =item C Returns the value that is the the value whose method has been called powered by the argument value. This method also overloads the exponentiation operator. =item C Returns the absolute of the value. =item C Returns a boolean value indicating whether the value is equal to 0. =back =head2 STRING METHODS =over 4 =item C, C Returns the result of the built-in C function applied to the value. =item C Returns the reverse string of the value. =item C, C, C, C, C, C Return the result of the appropriate built-in function applied to the value. =item C, C Returns the result of the argument expression appended to the value. =item C Returns a version of the value with every character's case reversed, i.e. a lowercase character becomes uppercase and vice versa. =item C Returns a list of overloaded values that is the result of splitting (according to the built-in C function) the value along the pattern, into a number of values up to the limit. =back =head2 BOOLEAN METHODS =over 4 =item C Returns the (overloaded) value of the numerical three-way comparison. This method also overloads the C=E> operator. =item C Returns the (overloaded) value of the alphabetical three-way comparison. This method also overloads the C operator. =item C, C, C, C, C, C Return the (overlaoded) boolean value of the appropriate string comparison. These methods also overload those operators. =item C, C, C, C, C, C These methods are case-insensitive versions of the above operators. =item C, C Returns the (overloaded) boolean status of the value. =back =head1 EXPORTS Three subroutines dealing with how properties are propagated are automatically exported. For an example of propagation, see the DESCRIPTION section above. =over 4 =item C Sets (replaces) the list of properties that are passed on. There is only one such list for the whole mechanism. The whole property interface is experimental, but this one in particular is likely to change in the future. =item C Tests whether a property is passed on and returns a boolean value. =item C Returns a list of names of properties that are passed on. =back =head1 TAGS If you talk about this module in blogs, on del.icio.us or anywhere else, please use the C tag. =head1 BUGS AND LIMITATIONS No bugs have been reported. Please report any bugs or feature requests to C, or through the web interface at L. =head1 INSTALLATION See perlmodinstall for information and options on installing Perl modules. =head1 AVAILABILITY The latest version of this module is available from the Comprehensive Perl Archive Network (CPAN). Visit to find a CPAN site near you. Or see . =head1 AUTHORS Marcel GrEnauer, C<< >> James A. Duncan C<< >> Some contributions from David Cantrell, C<< >> =head1 COPYRIGHT AND LICENSE Copyright 2001-2007 by Marcel GrEnauer This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Scalar-Properties-0.13/Makefile.PL0000644000076500007650000000033710705505633017517 0ustar marcelmarcel00000000000000use inc::Module::Install; name 'Scalar-Properties'; all_from 'lib/Scalar/Properties.pm'; perl_version '5.006'; build_requires 'Test::More' => '0.70'; use_standard_tests(without => 'pod_coverage'); auto_include; WriteAll; Scalar-Properties-0.13/MANIFEST0000644000076500007650000000073210705716030016670 0ustar marcelmarcel00000000000000Changes inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Include.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/StandardTests.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm inc/Test/Compile.pm inc/Test/More.pm inc/UNIVERSAL/require.pm lib/Scalar/Properties.pm Makefile.PL MANIFEST This list of files META.yml README t/01_all.t t/perlcriticrc TODO Scalar-Properties-0.13/META.yml0000644000076500007650000000072210705716053017014 0ustar marcelmarcel00000000000000--- abstract: run-time properties on scalar variables author: Marcel GrEnauer, C<< >> build_requires: Test::Compile: 0 Test::More: 0 UNIVERSAL::require: 0 distribution_type: module generated_by: Module::Install version 0.67 license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.3.html version: 1.3 name: Scalar-Properties no_index: directory: - inc - t requires: perl: 5.6.0 version: 0.13 Scalar-Properties-0.13/README0000644000076500007650000000101010676732614016422 0ustar marcelmarcel00000000000000This is the Perl module Module::Cloud. INSTALLATION Module::Cloud installation is straightforward. If your CPAN shell is set up, you should just be able to do % cpan Module::Cloud Download it, unpack it, then build it as per the usual: % perl Makefile.PL % make && make test Then install it: % make install DOCUMENTATION Module::Cloud documentation is available as in POD. So you can do: % perldoc Module::Cloud to read the documentation online with your favorite pager. Marcel Gruenauer Scalar-Properties-0.13/t/0000755000076500007650000000000010705716053016005 5ustar marcelmarcel00000000000000Scalar-Properties-0.13/t/01_all.t0000644000076500007650000001521710676732614017260 0ustar marcelmarcel00000000000000# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) BEGIN { $| = 1; print "1..151\n"; } END {print "not ok 1\n" unless $loaded;} use Scalar::Properties; $loaded = 1; print "ok 1\n"; ######################### End of black magic. # Insert your test code below (better if it prints "ok 13" # (correspondingly "not ok 13") depending on the success of chunk 13 # of the test code): our $testcount = 1; # compensate for 'ok' above sub true { my $ok = shift; our $testcount; $testcount++; print 'not ' unless $ok; print "ok $testcount ".($_[0]?$_[0]:'')."\n"; } sub false { true(!$_[0]) } my $pkg = 'Scalar::Properties'; { # test added by DCANTRELL to tickle the binary-op operand re-ordering bug true(time - 300 > 0, "binary-op operand re-ordering bug"); } { # test added by DCANTRELL to test for rt.cpan.org bug 4312 my $test = 0; true($test."\$test"."\\$test"."\\\$test"."\\\\$test" eq '0$test\0\$test\\\\0', "variable interpolation bug"); } # die; false(0); true(1); false(0->is_true ); true (0->is_false); false(1->is_false); true (1->is_true ); { my $foo = 0->true; true($foo->value == 0->{_value}); true($foo); $foo += 7; true(ref $foo eq $pkg); true($foo); true($foo == 7); true($foo->{_value} == 7); } { my $bar = 42->times(3); true($bar == 126); true($bar); $bar->false; false($bar); true($bar == 126); true($bar->times(4) == 504); # set a property; note that the '1' itself becomes overloaded. $bar->approximate(1); true($bar->approximate); true($bar->is_approximate); true($bar->has_approximate); $bar->approximate(0); false($bar->approximate); false($bar->is_approximate); false($bar->has_approximate); } { my $val = 0->true; true($val && $val == 0); } { my $quux = 37->prime(1); true($quux); true($quux == 37); true($quux->is_prime); } { my $baza = 42->value; my $bazb = 42; true(ref $baza eq ''); true($baza == $bazb); } { my $h = 'hello world'; true($h); true($h eq 'hello world'); $h->greeting(1); true($h->is_greeting); my @blah; push @blah => $h; push @blah => 'forget it'; push @blah => 'hi there'->greeting(1); my @greets = grep { $_->is_greeting } @blah; true(@greets == 2); true($greets[0] eq 'hello world'); true($greets[1] eq 'hi there'); } { false(''); true(''->true); false(''->false); true('x'); true('x'->true); false('x'->false); } { my $len = 'hello world'->length; true(ref $len eq $pkg); true($len == 11); my $rev = 'hello world'->reverse; true(ref $rev eq $pkg); true($rev eq 'dlrow olleh'); true(1234->length == 4); true(1234->size == 1234->length); true(1234->reverse == 4321); } { my $t = 'hello cruel world'; my @s; @s = $t->split; true(@s == 3); true($s[0] eq 'hello'); true($s[1] eq 'cruel'); true($s[2] eq 'world'); @s = $t->split(qr/ll/); true(@s == 2); true($s[0] eq 'he'); true($s[1] eq 'o cruel world'); @s = $t->split(qr/\s+/, 2); true(@s == 2); true($s[0] eq 'hello'); true($s[1] eq 'cruel world'); # There was a bug with split(), so we try it again to be # sure it works @s = $t->split(qr/ll/); true(@s == 2); true($s[0] eq 'he'); true($s[1] eq 'o cruel world'); } { true('hello world'->uc eq 'HELLO WORLD'); true('hello world'->ucfirst eq 'Hello world'); true('HELLO WORLD'->lc eq 'hello world'); true('HELLO WORLD'->lcfirst eq 'hELLO WORLD'); my $s = 'hello world'; true(ref $s->uc eq $pkg); true(ref $s->ucfirst eq $pkg); true(ref $s->lc eq $pkg); true(ref $s->lcfirst eq $pkg); } { true('0xAf'->hex == 175); true('aF' ->hex == 175); true(123 ->hex == 291); true( 777->oct == 511); true( 123->oct == 83); my $h = '0xffffff'; true(ref $h->hex eq $pkg); true(ref $h->oct eq $pkg); } { true('hello'->concat(' world') eq 'hello world'); true(ref 'hello'->concat(' world') eq $pkg); true(ref 'hello'->append(' world') eq $pkg); } { my $s = 'Hello World'; true($s->swapcase, 'hELLO wORLD'); } { my $s1 = 'aaa'; my $s2 = 'bbb'; true($s1 eq $s1); true($s1->eq($s1)); true($s1 ne $s2); true($s1->ne($s2)); true($s1 lt $s2); true($s1->lt($s2)); true($s2 gt $s1); true($s2->gt($s1)); true($s1 le $s1); true($s1 le $s2); true($s1->le($s1)); true($s1->le($s2)); true($s2 ge $s1); true($s2 ge $s2); true($s2->ge($s1)); true($s2->ge($s2)); true(ref $s1->eq($s1) eq $pkg); true(ref $s1->ne($s1) eq $pkg); true(ref $s1->lt($s1) eq $pkg); true(ref $s1->gt($s1) eq $pkg); true(ref $s1->le($s1) eq $pkg); true(ref $s1->ge($s1) eq $pkg); } { my $s1 = 'aaa'; my $s2 = 'BBB'; true($s1->eqi($s1)); true($s1->nei($s2)); true($s1->lti($s2)); true($s2->gti($s1)); true($s1->lei($s1)); true($s1->lei($s2)); true($s2->gei($s1)); true($s2->gei($s2)); true(ref $s1->eqi($s1) eq $pkg); true(ref $s1->nei($s1) eq $pkg); true(ref $s1->lti($s1) eq $pkg); true(ref $s1->gti($s1) eq $pkg); true(ref $s1->lei($s1) eq $pkg); true(ref $s1->gei($s1) eq $pkg); } { my $out; 3->times_do(sub { $out .= 'Hello' }); true($out eq 'HelloHelloHello'); $out = ''; 5->times_do(sub { $out .= shift }); true($out == 12345); my $sub = sub { $out .= "$_[0].. " }; $out = ''; 1->do_upto(5 => $sub); true($out eq '1.. 2.. 3.. 4.. 5.. '); $out = ''; 1->do_upto_step(5, 2, $sub); true($out eq '1.. 3.. 5.. '); $out = ''; 5->do_upto(1 => $sub); true($out eq ''); $out = ''; 5->do_downto(3 => $sub); true($out eq '5.. 4.. 3.. '); $out = ''; 5->do_downto_step(2, 2, $sub); true($out eq '5.. 3.. '); $out = ''; 3->do_downto(5 => $sub); true($out eq ''); } { true((-1942)->abs() == 1942); true( 0->abs == 0); true( 773->abs == 773); true(0->zero); false(1->zero); my $foo = 27; false($foo->zero); $foo -= 27; true($foo->zero); } { pass_on('approximate'); true(get_pass_on == 1); true(passed_on('approximate')); } { my $foo = 1; $foo->history(1); my $pi = 3->approximate(1); my $bar = $foo + $pi; true($bar->is_approximate); false($bar->has_history); } { my $h1 = 'hi world'->approximate(1); my $h2 = $h1->uc; my @h3 = $h1->split; true($_->approximate) for $h1, $h2, @h3; } { my $ship = 1701->class('galaxy'); $ship->quadrant('alpha'); $ship->crew(1017); my @props = $ship->get_props; true(@props == 3); true(grep /^$_$/ => @props) for qw/class quadrant crew/; $ship->crew(0); true($ship->get_props == 3); $ship->del_prop('crew'); @props = $ship->get_props; true(@props == 2); true(grep /^$_$/ => @props) for qw/class quadrant/; $ship->del_all_props; @props = $ship->get_props; true(@props == 0); } Scalar-Properties-0.13/t/perlcriticrc0000644000076500007650000000021710676732614020425 0ustar marcelmarcel00000000000000# we do eval $asset_pl a lot [-BuiltinFunctions::ProhibitStringyEval] # no strict 'refs' [TestingAndDebugging::ProhibitNoStrict] allow = refs Scalar-Properties-0.13/TODO0000644000076500007650000000522110676732614016242 0ustar marcelmarcel00000000000000* Test constant 'qr' * 'true' and 'false' properties are opposites that still only affect one hash key; define other opposites as well? * test what happens to propagated properties when you delete them on the original object * overload '0+' and the other missing ones * in value(), also check for other escaped chars like '\t' * use it for versioning so you can undo changes? or as in debugging, see the whole history of commands that affected a variable. Cross-references to other variables that were also affected in those statements. A graph...? * in a similar vein, methods like C could add a property to the resulting value that notes where the value comes from: my $l = 'hello world'->length; print $l->origin; # prints "length 'hello world'" (or so) * group methods and make each group a mixin class in a separate module, loaded on import. ':all' loads all; 'split' loads only the split method; ':num' loads all numeric methods etc. The versioning idea above would certainly be a mixin. The propagation methods that are automatically exported so far also should go into an import tag (':pass'?) * methods that generate an array can be lazy; in this case they return an iterator instead of the list. Cf. mjd's talk. * take ideas from Ruby's Numeric and String classes, and from Java's classes. New methods: chr # string containing the ASCII character represented by the value ceil # Returns the smallest integer value greater than or equal to the value floor # Returns the largest integer value less than or equal to the value round # Returns the value rounded to the nearest integer utf8 upgrade, downgrade crlf conversion printf sprintf substr sub $a = "hello there"; $a->sub(1) === 'e' $a->sub(1..3) === 'ell' $a->sub('lo') === 'lo' $a->sub('bye') === undef $a->sub(/th[aeiou]/) === 'the' this returns a (builtin) substr, which is lvaluable, so you can do $a->sub(/[el]+/) = 'xyz' # 'hxyzlo there' match subst (regex subst) tr (y) charlist # split // chomp chop crypt($salt) center($len) ljust($len) rjust($len) trim, ltrim, rtrim dump # replace all nonprinting chars by \nnn, escape special chars each_byte # list of all ords empty # true if length is 0 index rindex succ (next, incr) # overloads ++ pred (prev, decr) # overloads -- replace # straightforward replace, no regex chars squeeze # 'hello world' === 'helowrd' md5 # require Digest::MD5 sum($n) # sum of binary value of each char modulo 2**$n - 1, a weak checksum unpack upto # 'a'->upto('e') = qw/a b c d e/; clone (deep copy, needs Clone module, so definitely as a mixin class)