Class-MethodMaker-2.24/0000755000175000017500000000000012506541335012716 5ustar ss5ss5Class-MethodMaker-2.24/t/0000755000175000017500000000000012506541335013161 5ustar ss5ss5Class-MethodMaker-2.24/t/redefine-warnings.t0000644000175000017500000000313511735360552016762 0ustar ss5ss5# (X)Emacs mode: -*- cperl -*- use strict; =head1 Unit Test Package for Class::MethodMaker This package tests the basic utility of Class::MethodMaker =cut use FindBin 1.42 qw( $Bin ); use Test 1.13 qw( ok plan skip ); use lib $Bin; use test qw( DATA_DIR evcheck save_output restore_output ); BEGIN { # 1 for compilation test, plan tests => 2, todo => [], } # ---------------------------------------------------------------------------- =head2 Test 1: compilation This test confirms that the test script and the modules it calls compiled successfully. =cut ok 1, 1, 'compilation'; # ------------------------------------- =head2 Test 2: no warnings generated This tests for a bug in 2.00 where warnings are generated complaining of 'prototype mismatch' and 'INTEGER redefined' when using Class::MethodMaker with certain other modules. Currently IPC::Run is tested, which is unfortunate, since it is non-core. If someone can suggest a core module that displays this issue with 2.00, that wouldd be great. =cut my $if_MSWin = $^O =~ m/MSWin/ ? 'Skip if under MSWin' : ''; if ($if_MSWin) { skip($if_MSWin, 1, 1, "No warnings generated" ); } else { save_output('stderr', *STDERR{IO}); eval { require IPC::Run; }; my $run_failed = $@; defined $run_failed && $run_failed =~ s/\(.*$// unless defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} > 1; eval { require Class::MethodMaker; }; my $err = restore_output('stderr'); skip $run_failed, $err, '', "No warnings generated\n"; } # ---------------------------------------------------------------------------- Class-MethodMaker-2.24/t/basic.t0000644000175000017500000000222411735360552014432 0ustar ss5ss5# (X)Emacs mode: -*- cperl -*- use strict; =head1 Unit Test Package for Class::MethodMaker This package tests the basic compilation and working of Class::MethodMaker =cut use Data::Dumper qw( ); use FindBin 1.42 qw( $Bin ); use Test 1.13 qw( ok plan ); use lib $Bin; use test qw( DATA_DIR evcheck ); BEGIN { # 1 for compilation test, plan tests => 2, todo => [], } # ---------------------------------------------------------------------------- =head2 Test 1: compilation This test confirms that the test script and the modules it calls compiled successfully. =cut use Class::MethodMaker; ok 1, 1, 'compilation'; # ------------------------------------- =head2 Test 2: scalar =cut package bob; use Class::MethodMaker [ scalar =>[qw/ foo /] ]; package main; my $bob = bless {}, 'bob'; print Data::Dumper->Dump([ $bob ], [qw( bob )]) if $ENV{TEST_DEBUG}; $bob->foo("x"); print Data::Dumper->Dump([ $bob ], [qw( bob )]) if $ENV{TEST_DEBUG}; ok $bob->foo, "x", 'scalar ( 1)'; # ---------------------------------------------------------------------------- Class-MethodMaker-2.24/t/warnings.t0000644000175000017500000000266311735360552015210 0ustar ss5ss5#!perl -w # (X)Emacs mode: -*- cperl -*- use strict; use warnings; =head1 Unit Test Package for Class::MethodMaker This package tests the basic compilation and working of Class::MethodMaker similar to basic but with warnings explicitely on to check for 5.13.2-related new warnings. =cut use Data::Dumper qw( ); use FindBin 1.42 qw( $Bin ); use Test 1.13 qw( ok plan ); use lib $Bin; use test qw( DATA_DIR evcheck ); use vars qw(@MYWARNINGS); BEGIN { $SIG{__WARN__} = sub { push @MYWARNINGS, $_[0] }; } BEGIN { # 1 for compilation test, plan tests => 3, todo => [], } # ---------------------------------------------------------------------------- =head2 Test 1: compilation This test confirms that the test script and the modules it calls compiled successfully. =cut use Class::MethodMaker; ok 1, 1, 'compilation'; # ------------------------------------- =head2 Test 2: scalar =cut package bob; local $^W = 1; use Class::MethodMaker [ scalar =>[qw/ foo /] ]; package main; local $^W = 1; my $bob = bless {}, 'bob'; print Data::Dumper->Dump([ $bob ], [qw( bob )]) if $ENV{TEST_DEBUG}; $bob->foo("x"); print Data::Dumper->Dump([ $bob ], [qw( bob )]) if $ENV{TEST_DEBUG}; ok $bob->foo, "x", 'scalar ( 1)'; # ---------------------------------------------------------------------------- ok scalar(@MYWARNINGS), 0, 'no warnings occurred'; Class-MethodMaker-2.24/t/diffclass.t0000644000175000017500000000755511735360552015323 0ustar ss5ss5# (X)Emacs mode: -*- cperl -*- use strict; =head1 Unit Test Package for Class::MethodMaker This package tests the ability of Class::MethodMaker to insert methods into a class other than the "Calling" class. =cut use Data::Dumper qw( Dumper ); use Fatal 1.02 qw( sysopen close ); use Fcntl 1.03 qw( :DEFAULT ); use File::stat qw( stat ); use FindBin 1.42 qw( $Bin $Script ); use IO::File 1.08 qw( ); use POSIX 1.03 qw( S_ISREG ); use Test 1.13 qw( ok plan ); use lib $Bin; use test qw( DATA_DIR evcheck restore_output save_output ); BEGIN { # 1 for compilation test, plan tests => 22, todo => [], } # ---------------------------------------------------------------------------- =head2 Test 1: compilation This test confirms that the test script and the modules it calls compiled successfully. =cut use Class::MethodMaker [ -target_class => 'X', scalar => [qw/ a /], -target_class => 'Y', scalar => [qw/ b /], ]; ok 1, 1, 'compilation'; # ------------------------------------- =head2 Test 2: bless =cut my ($x, $y); ok evcheck(sub { $x = bless {}, 'X'; $y = bless {}, 'Y'; }, 'bless ( 1)'), 1, 'bless ( 1)'; goto "TEST_$ENV{START_TEST}" if $ENV{START_TEST}; # ------------------------------------- =head2 Tests 3--22: simple non-static =cut { my $n; ok(evcheck(sub { $n = $x->a_isset; }, 'simple non-static ( 1)'), 1, 'simple non-static ( 1)'); ok ! $n; # simple non-static ( 2) ok(evcheck(sub { $n = $x->b_isset; }, 'simple non-static ( 3)'), 0, 'simple non-static ( 3)'); ok(evcheck(sub { $n = $y->b_isset; }, 'simple non-static ( 4)'), 1, 'simple non-static ( 4)'); ok(evcheck(sub { $x->a(4); }, 'simple non-static ( 5)'), 1, 'simple non-static ( 5)'); ok(evcheck(sub { $n = $x->a; }, 'simple non-static ( 6)'), 1, 'simple non-static ( 6)'); ok $n, 4, 'simple non-static ( 7)'; ok(evcheck(sub { $n = $x->a(7); }, 'simple non-static ( 8)'), 1, 'simple non-static ( 8)'); ok $n, 7, 'simple non-static ( 9)'; ok(evcheck(sub { $n = $x->a_isset; }, 'simple non-static (10)'), 1, 'simple non-static (10)'); ok $n; # simple non-static (11) ok(evcheck(sub { $n = $y->b_isset; }, 'simple non-static (12)'), 1, 'simple non-static (12)'); ok ! $n; # simple non-static (13) ok(evcheck(sub { $n = $x->a_reset; }, 'simple non-static (14)'), 1, 'simple non-static (14)'); ok(evcheck(sub { $n = $x->a_isset; }, 'simple non-static (15)'), 1, 'simple non-static (15)'); ok ! $n; # simple non-static (16) ok(evcheck(sub { $n = $x->a; }, 'simple non-static (17)'), 1, 'simple non-static (17)'); ok $n, undef, 'simple non-static (18)'; ok(evcheck(sub { $n = $x->a_isset; }, 'simple non-static (19)'), 1, 'simple non-static (19)'); ok ! $n; # simple non-static (20) } # ------------------------------------- Class-MethodMaker-2.24/t/test.pm0000644000175000017500000005764212474272244014520 0ustar ss5ss5# (X)Emacs mode: -*- cperl -*- package test; use strict; use warnings; =head1 NAME test - tools for helping in test suites (not including running externalprograms). =head1 SYNOPSIS use FindBin 1.42 qw( $Bin ); use Test 1.13 qw( ok plan ); BEGIN { unshift @INC, $Bin }; use test qw( DATA_DIR evcheck runcheck ); BEGIN { plan tests => 3, todo => [], ; } ok evcheck(sub { open my $fh, '>', 'foo'; print $fh "$_\n" for 'Bulgaria', 'Cholet'; close $fh; }, 'write foo'), 1, 'write foo'; save_output('stderr', *STDERR{IO}); warn 'Hello, Mum!'; print restore_output('stderr'); =head1 DESCRIPTION This package provides some variables, and sets up an environment, for test scripts, such as those used in F. This package does not including running external programs; that is provided by C. This is so that suites not needing that can include only test.pm, and so not require the presence of C. Setting up the environment includes: =over 4 =item Prepending F onto the path =item Pushing the module F dir onto the @PERL5LIB var For executed scripts. =item Pushing the module F dir onto the @INC var For internal C calls. =item Changing directory to a temporary directory To avoid cluttering the local dir, and/or allowing the local directory structure to affect matters. =item Cleaning up the temporary directory afterwards Unless TEST_DEBUG is set in the environment. =back =cut # ---------------------------------------------------------------------------- # Pragmas ----------------------------- use 5.006; use strict; use vars qw( @EXPORT_OK ); # Inheritance ------------------------- use base qw( Exporter ); =head2 EXPORTS The following symbols are exported upon request: =over 4 =item BIN_DIR =item DATA_DIR =item REF_DIR =item LIB_DIR =item PERL =item check_req =item compare =item evcheck =item only_files =item save_output =item restore_output =item tmpnam =item tempdir =item find_exec =item read_file =back =cut @EXPORT_OK = qw( BIN_DIR DATA_DIR REF_DIR LIB_DIR PERL check_req compare evcheck find_exec only_files read_file save_output restore_output tempdir tmpnam ); # Utility ----------------------------- use Carp qw( carp croak ); use Cwd 2.01 qw( cwd ); use Env qw( PATH PERL5LIB ); use Fatal 1.02 qw( close open seek sysopen unlink ); use Fcntl 1.03 qw( :DEFAULT ); use File::Basename qw( basename ); use File::Compare 1.1002 qw( ); use File::Path 1.0401 qw( mkpath rmtree ); use File::Spec 0.6 qw( ); use FindBin 1.42 qw( $Bin ); use POSIX 1.02 qw( ); use Test 1.122 qw( ok skip ); use File::Temp; # ---------------------------------------------------------------------------- sub rel2abs { if ( File::Spec->file_name_is_absolute($_[0]) ) { return $_[0]; } else { return catdir(cwd, $_[0]); } } sub catdir { File::Spec->catdir(@_); } sub catfile { File::Spec->catfile(@_); } sub updir { File::Spec->updir(@_); } sub min { croak "Can't min over 0 args!\n" unless @_; my $min = $_[0]; for (@_[1..$#_]) { $min = $_ if $_ < $min; } return $min; } sub max { croak "Can't max over 0 args!\n" unless @_; my $max = $_[0]; for (@_[1..$#_]) { $max = $_ if $_ > $max; } return $max; } # ------------------------------------- # PACKAGE CONSTANTS # ------------------------------------- use constant BIN_DIR => catdir $Bin, updir, 'bin'; use constant DATA_DIR => catdir $Bin, updir, 'data'; use constant REF_DIR => catdir $Bin, updir, 'testref'; use constant LIB_DIR => catdir $Bin, updir, 'lib'; use constant BUILD_SCRIPT_DIR => => catdir $Bin, updir, qw( blib script ); sub find_exec { my ($exec) = @_; for (split /:/, $PATH) { my $try = catfile $_, $exec; return rel2abs($try) if -x $try; } return; } use constant PERL => (basename($^X) eq $^X ? find_exec($^X) : rel2abs($^X)); # ------------------------------------- # PACKAGE ACTIONS # ------------------------------------- # @PERL5LIB not available in Env for perl 5.00503 # unshift @PERL5LIB, LIB_DIR; $PERL5LIB = defined $PERL5LIB ? join(':', LIB_DIR, $PERL5LIB) : LIB_DIR; unshift @INC, LIB_DIR; $PATH = join ':', BUILD_SCRIPT_DIR, split /:/, $PATH; $_ = rel2abs($_) for @INC; my $tmpdn = tempdir(); $| = 1; mkpath $tmpdn; die "Couldn't create temp dir: $tmpdn: $!\n" unless -r $tmpdn and -w $tmpdn and -x $tmpdn and -o $tmpdn and -d $tmpdn; #@INC = map rel2abs($_), @INC; chdir $tmpdn; # ------------------------------------- # PACKAGE FUNCTIONS # ------------------------------------- =head2 only_files =over 4 =item ARGUMENTS =over 4 =item expect Arrayref of names of files to expect to exist. =back =item RETURNS =over 4 =item ok 1 if exactly expected files exist, false otherwise. =back =back =cut sub only_files { my ($expect) = @_; local *MYDIR; opendir MYDIR, '.'; my %files = map { $_ => 1 } readdir MYDIR; closedir MYDIR; my $ok = 1; for (@$expect, '.', '..') { if ( exists $files{$_} ) { delete $files{$_}; } elsif ( ! -e $_ ) { # $_ might be absolute carp "File not found: $_\n" if $ENV{TEST_DEBUG}; $ok = 0; } } for (keys %files) { carp "Extra file found: $_\n" if $ENV{TEST_DEBUG}; $ok = 0; } if ( $ok ) { return 1; } else { return; } } # ------------------------------------- =head2 evcheck Eval code, return status =over 4 =item ARGUMENTS =over 4 =item code Coderef to eval =item name Name to use in error messages =back =item RETURNS =over 4 =item okay 1 if eval was okay, 0 if not. =back =back =cut sub evcheck { my ($code, $name) = @_; my $ok = 0; eval { &$code; $ok = 1; }; if ( $@ ) { carp "Code $name failed: $@\n" if $ENV{TEST_DEBUG}; $ok = 0; } return $ok; } # ------------------------------------- =head2 save_output Redirect a filehandle to temporary storage for later examination. =over 4 =item ARGUMENTS =over 4 =item name Name to store as (used in L) =item filehandle The filehandle to save =back =cut # Map from names to saved filehandles. # Values are arrayrefs, being filehandle that was saved (to restore), the # filehandle being printed to in the meantime, and the original filehandle. # This may be treated as a stack; to allow multiple saves... push & pop this # stack. my %grabs; sub save_output { croak sprintf("%s takes 2 arguments\n", (caller 0)[3]) unless @_ == 2; my ($name, $filehandle) = @_; my $tmpfh = do { local *F; *F; }; my $savefh = do { local *F; *F; }; my $tmpnam = File::Temp::tmpnam(); sysopen $tmpfh, $tmpnam, O_RDWR | O_CREAT | O_EXCL; unlink $tmpnam; select((select($tmpfh), $| = 1)[0]); open $savefh, '>&' . fileno $filehandle or die "can't dup $name: $!"; open $filehandle, '>&' . fileno $tmpfh or die "can't open $name to tempfile: $!"; push @{$grabs{$name}}, $savefh, $tmpfh, $filehandle; } # ------------------------------------- =head2 restore_output Restore a saved filehandle to its original state, return the saved output. =over 4 =item ARGUMENTS =over 4 =item name Name of the filehandle to restore (as passed to L). =back =item RETURNS =over 4 =item saved_string A single string being the output saved. =back =cut sub restore_output { my ($name) = @_; croak "$name has not been saved\n" unless exists $grabs{$name}; croak "All saved instances of $name have been restored\n" unless @{$grabs{$name}}; my ($savefh, $tmpfh, $origfh) = splice @{$grabs{$name}}, -3; close $origfh or die "cannot close $name opened to tempfile: $!"; open $origfh, '>&' . fileno $savefh or die "cannot dup $name back again: $!"; select((select($origfh), $| = 1)[0]); seek $tmpfh, 0, 0; local $/ = undef; my $string = <$tmpfh>; close $tmpfh; return $string; } sub _test_save_restore_output { warn "to stderr 1\n"; save_output("stderr", *STDERR{IO}); warn "Hello, Mum!"; print 'SAVED:->:', restore_output("stderr"), ":<-\n"; warn "to stderr 2\n"; } # ------------------------------------- =head2 tmpnam Very much like the one in L or L, but does not get deleted if TEST_DEBUG has SAVE in the value. =over 4 =item ARGUMENTS =over 4 =item name I. If defined, a name by which to refer to the tmpfile in user messages. =back =item RETURNS =over 4 =item filename Name of temporary file. =item fh Open filehandle to temp file, in r/w mode. Only created & returned in list context. =back =back =cut my @tmpfns; BEGIN { my $savewarn = $SIG{__WARN__}; # Subvert bizarre (& incorrect) subroutine redefined errors in 5.005_03 local $SIG{__WARN__} = sub { $savewarn->(@_) if defined $savewarn and UNIVERSAL::isa($savewarn,'CODE') and $_[0] !~ /^Subroutine tmpnam redefined/; }; *tmpnam = sub { my $tmpnam = File::Temp::tmpnam(); if (@_) { push @tmpfns, [ $tmpnam, $_[0] ]; } else { push @tmpfns, $tmpnam; } if (wantarray) { sysopen my $tmpfh, $tmpnam, O_RDWR | O_CREAT | O_EXCL; return $tmpnam, $tmpfh; } else { return $tmpnam; } } } END { if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) { for (@tmpfns) { if ( ref $_ ) { printf "Used temp file: %s (%s)\n", @$_; } else { print "Used temp file: $_\n"; } } } else { unlink map((ref $_ ? $_->[0] : $_), @tmpfns) if @tmpfns; } } # ------------------------------------- =head2 tempdir Very much like the one in L or L, but does not get deleted if TEST_DEBUG has SAVE in the value (does get deleted otherwise). =over 4 =item ARGUMENTS I =item RETURNS =over 4 =item name Name of temporary dir. =back =back =cut my @tmpdirs; sub tempdir { my $tempdir = File::Temp::tmpnam(); mkdir $tempdir, 0700 or die "Failed to create temporary directory $tempdir: $!\n"; if (@_) { push @tmpdirs, [ $tempdir, $_[0] ]; } else { push @tmpdirs, $tempdir; } return $tempdir; } END { for (@tmpdirs) { if ( ref $_ ) { if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) { printf "Used temp dir: %s (%s)\n", @$_; } else { # Solaris gets narky about removing the pwd. chdir File::Spec->rootdir; rmtree $_->[0]; } } else { if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) { print "Used temp dir: $_\n"; } else { # Solaris gets narky about removing the pwd. chdir File::Spec->rootdir; rmtree $_; } } } } # ------------------------------------- =head2 compare compare(+{ fn1 => $fn1, fn2 => $fn2, gzip => 1 }); This performs one test. =over 4 =item ARGUMENTS A single argument is taken, considered as a hash ref, with the following keys: In TEST_DEBUG mode, if the files do not compare equal, outputs file info on STDERR. =over 4 =item fn1 B File to compare =item fn2 B File to compare =item name B Test name =item sort B sort files prior to comparison. Requires the C command to be on C<$PATH> (else skips). =item gunzip B gunzip files prior to comparison. Requires the C command to be on C<$PATH> (else skips). gzip occurs prior to any sort. =item untar B untar files prior to comparison. Requires the C command to be on C<$PATH> (else skips). any gzip occurs prior to any tar. Tar files are considered equal if they each contain the same filenames & each file contained is equal. If the sort flag is present, each file is sorted prior to comparison. =back =back =cut #XYZ sub _run { #XYZ my ($cmd, $name, $in) = @_; #XYZ #XYZ my $infn = defined $in ? tmpnam : '/dev/null'; #XYZ my $outfn = tmpnam; #XYZ my $errfn = tmpnam; #XYZ #XYZ my $pid = fork; #XYZ croak "Couldn't fork: $!\n" #XYZ unless defined $pid; #XYZ #XYZ if ( $pid == 0 ) { # Child #XYZ open STDOUT, '>', $outfn; #XYZ open STDERR, '>', $errfn; #XYZ open STDIN, '<', $infn; #XYZ #XYZ exec @$cmd; #XYZ } #XYZ #XYZ my $rv = waitpid $pid, 0; #XYZ my $status = $?; #XYZ #XYZ croak "Unexpected waitpid return from child $name: $rv (expected $pid)\n" #XYZ unless $rv == $pid; #XYZ #XYZ local $/ = undef; #XYZ local (OUT, ERR); #XYZ open *OUT, '<', $outfn; #XYZ open *ERR, '<', $errfn; #XYZ my $out = ; #XYZ my $err = ; #XYZ close *OUT; #XYZ close *ERR; #XYZ #XYZ return $status >> 8, $status & 127, $status & 128 , $out, $err #XYZ } # return codes and old-style call semantics left for backwards compatibility BEGIN { my $savewarn = $SIG{__WARN__}; # Subvert bizarre (& incorrect) subroutine redefined errors in 5.005_03 local $SIG{__WARN__} = sub { $savewarn->(@_) if defined $savewarn and UNIVERSAL::isa($savewarn,'CODE') and $_[0] !~ /^Subroutine compare redefined/; }; *compare = sub { my ($fn1, $fn2, $sort) = @_; my ($gzip, $tar, $name); my $notest = 1; if ( @_ == 1 and UNIVERSAL::isa($_[0], 'HASH') ) { ($fn1, $fn2, $name, $sort, $gzip, $tar, $notest) = @{$_[0]}{qw( fn1 fn2 name sort gunzip untar notest )}; my @missing = grep ! defined $_[0]->{$_}, qw( fn1 fn2 name ); carp "Missing mandatory key(s): " . join(', ', @missing) . "\n" if @missing; } my ($name1, $name2) = ($fn1, $fn2); for ( grep ! defined, $fn1, $fn2 ) { carp 'Usage: compare({fn1 => $fn1, fn2 => $fn2, name => "some name"})' ."\n" if $ENV{TEST_DEBUG}; ok 0, 1, $name unless $notest; return -8; } { my $err = 0; for (0..1) { my $fn = ($name1, $name2)[$_]; if ( ! -e $fn ) { carp "Does not exist: $fn\n" if $ENV{TEST_DEBUG}; $err |= 2 ** $_; } elsif ( ! -r $fn ) { carp "Cannot read: $fn\n" if $ENV{TEST_DEBUG}; $err |= 2 ** $_; } } if ( $err ) { ok 0, 1, $name unless $notest; return -$err; } } if ( $gzip ) { unless ( find_exec('gzip') ) { print "ok # Skip gzip not found in path\n"; return -16; } my $tmp1 = tmpnam; my $tmp2 = tmpnam; system "gzip $fn1 -cd > $tmp1" and croak "gzip $fn1 failed: $?\n"; system "gzip $fn2 -cd > $tmp2" and croak "gzip $fn2 failed: $?\n"; ($fn1, $fn2) = ($tmp1, $tmp2); } if ( $tar ) { unless ( find_exec('tar') ) { print "ok # Skip tar not found in path\n"; return -16; } local $/ = "\n"; chomp (my @list1 = sort qx( tar tf $fn1 )); croak "tar tf $fn1 failed with wait status: $?\n" if $?; chomp(my @list2 = sort qx( tar tf $fn2 )); croak "tar tf $fn2 failed with wait status: $?\n" if $?; if ( @list2 > @list1 ) { carp sprintf("More files (%d) in $name2 than $name1 (%d)\n", scalar @list2, scalar @list1) if $ENV{TEST_DEBUG}; ok @list1, @list2, $name unless $notest; return 0; } elsif ( @list1 > @list2 ) { carp sprintf("More files (%d) in $name1 than $name2 (%d)\n", scalar @list1, scalar @list2) if $ENV{TEST_DEBUG}; ok @list1, @list2, $name unless $notest; return 0; } for (my $i = 0; $i < @list1; $i++) { if ( $list1[$i] lt $list2[$i] ) { carp "File $list1[$i] is present in $name1 but not $name2\n" if $ENV{TEST_DEBUG}; ok $list1[$i], $list2[$i], $name unless $notest; return 0; } elsif ( $list1[$i] gt $list2[$i] ) { carp "File $list2[$i] is present in $name2 but not $name1\n" if $ENV{TEST_DEBUG}; ok $list2[$i], $list1[$i], $name unless $notest; return 0; } } for my $fn (@list1) { my $tmp1 = tmpnam; my $tmp2 = tmpnam; system "tar -xf $fn1 -O $fn > $tmp1" and croak "tar -xf $fn1 -O $fn failed: $?\n"; system "tar -xf $fn2 -O $fn > $tmp2" and croak "tar -xf $fn2 -O $fn failed: $?\n"; my $ok = compare({ fn1 => $tmp1, fn2 => $tmp2, sort => $sort, notest => 1, name => qq'Subcheck file "$fn" for compare $name1, $name2', }); unless ( $ok >= 1 ) { carp qq'Difference found testing file "$fn" in tars $name1 ($tmp1), $name2 ($tmp2)\n' if $ENV{TEST_DEBUG}; ok 0, 1, $name unless $notest; return 0; } } ok 1, 1, $name unless $notest; return 1; } if ( $sort ) { unless ( find_exec('sort') ) { print "ok # Skip sort not found in path\n"; return -16; } my $tmp1 = tmpnam; my $tmp2 = tmpnam; system sort => $fn1, -o => $tmp1 and croak "Sort $fn1 failed: $?\n"; system sort => $fn2, -o => $tmp2 and croak "Sort $fn2 failed: $?\n"; ($fn1, $fn2) = ($tmp1, $tmp2); } unless ( File::Compare::compare($fn1, $fn2) ) { ok 1, 1, $name unless $notest; return 1; } if ( $ENV{TEST_DEBUG} ) { my $pid = fork; die "Fork failed: $!\n" unless defined $pid; if ( $pid ) { # Parent my $waitpid = waitpid($pid, 0); die "Waitpid got: $waitpid (expected $pid)\n" unless $waitpid == $pid; } else { # Child open *STDOUT{IO}, ">&" . fileno STDERR; # Uniquify file names my @args = keys %{+{ map {;$_=>1} $name1, $name2, $fn1, $fn2 }}; exec qw(ls -l), @args; } my $fh1 = IO::File->new($fn1, O_RDONLY) or die "Couldn't open $fn1: $!\n"; my $fh2 = IO::File->new($fn2, O_RDONLY) or die "Couldn't open $fn2: $!\n"; local $/ = "\n"; my $found = 0; while ( ! $found and my $line1 = <$fh1> ) { my $line2 = <$fh2>; if ( ! defined $line2 ) { print STDERR "$fn2 ended at line: $.\n"; $found = 1; } elsif ( $line2 ne $line1 ) { my $maxlength = max(map length($_), $line1, $line2); my $minlength = min(map length($_), $line1, $line2); my @diffchars = grep(substr($line1, $_, 1) ne substr($line2, $_, 1), 0..$minlength-1); my $diff = ' ' x $minlength; substr($diff, $_, 1) = '|' for @diffchars; my @extrachars, map((length($line1) > length($line2) ? '^' : 'v'), $minlength..$maxlength-1); $diff = join '', $diff, @extrachars; my $diff_count = @diffchars; my $extra_count = @extrachars; print STDERR <<"END"; Difference at line $. ($diff_count characters differ) (top line is $extra_count chars longer): $name1: -->$line1<-- $diff -->$line2<-- $name2: Differing characters at positions @{[join ',',@diffchars]} (zero-based) END $found = 1; } } if ( ! $found ) { my $line2 = <$fh2>; if ( defined $line2 ) { print STDERR "$name1 ended before line: $.\n"; } else { print STDERR "Difference between $name1, $name2 not found!\n"; } } close $fh1; close $fh2; } ok 0, 1, $name unless $notest; return 0; } } # ------------------------------------- =head2 check_req Perform a requisite check on a given executable. This will skip if the required modules are not present. 4+(n+m)*2 tests are performed, where n is the number of prerequisites expected, and m is the number of outputs expected. =over 4 =item SYNOPSIS check_req('ccu-touch', ['/etc/passwd'], [[REQ_FILE, '/etc/passwd']], [[REQ_FILE, 'passwd.foo']], 'requisites 1'); =item ARGUMENTS =over 4 =item cmd_name The name of the command to run. It is assumed that this command is in blib/script; hence it should be an executable in this package, and C shuold have been run recently. =item args The arguments to pass to the cmd_name, as an arrayref. =item epres The expected prerequisites, as an arrayref, wherein every member is a two-element arrayref, the members being the requisite type, and the requisite value. =item eouts The expected outputs, in the same format as the L. =item testname The name to use in error messages. =back =back =cut sub check_req { my ($cmd_name, $args, $epres, $eouts, $testname) = @_; eval "use Pipeline::DataFlow 1.03 qw( :req_types );"; my $skip; if ( $@ ) { print STDERR "$@\n" if $ENV{TEST_DEBUG}; $skip = 'Skipped: Pipeline::DataFlow 1.03 not found'; } else { $skip = 0; } my $count = 1; my $test = sub { my ($code, $expect) = @_; my $name = sprintf "%s (%2d)", $testname, $count++; my $value = UNIVERSAL::isa($code, 'CODE') ? $code->($name) : $code; skip $skip, $value, $expect, $name; }; # Initialize nicely to cope when read_reqs fails my ($pres, $outs) = ([], []); $test->(sub { evcheck(sub { ($pres, $outs) = Pipeline::DataFlow->read_reqs ([catfile($Bin, updir, 'blib', 'script', $cmd_name), @$args]); }, $_[0]),}, 1); $test->(scalar @$pres, scalar @$epres); my (@epres, @pres); @epres = sort { $a->[1] cmp $b->[1] } @$epres; @pres = sort { $a->[1] cmp $b->[1] } @$pres; for (my $i = 0; $i < @epres; $i++) { my ($type, $value) = @{$epres[$i]}; $test->($type, @pres > $i ? $pres[$i]->[0] : undef); $test->($value, @pres > $i ? $pres[$i]->[1] : undef); } $test->(scalar @$outs, scalar @$eouts); my (@eouts, @outs); @eouts = sort { $a->[1] cmp $b->[1] } @$eouts; @outs = sort { $a->[1] cmp $b->[1] } @$outs; for (my $i = 0; $i < @eouts; $i++) { my ($type, $value) = @{$eouts[$i]}; $test->($type, @outs > $i ? $outs[$i]->[0] : undef); $test->($value, @outs > $i ? $outs[$i]->[1] : undef); } $test->(only_files([]), 1); } # ------------------------------------- =head2 find_exec =over 4 =item ARGUMENTS =over 4 =item proggie The name of the program =back =item RETURNS =over 4 =item path The path to the first executable file with the given name on C<$PATH>. Or nothing, if no such file exists. =back =back =cut # defined further up to use in constants # ------------------------------------- =head2 read_file =over 4 =item ARGUMENTS =over 4 =item filename B =item line-terminator B. Value of C<$/>. Defaults to C<"\n">. =back =item RETURNS =over 4 =item lines A list of lines in the file (lines determined by the value of line-terminator), as an arrayref. =back =back =cut sub read_file { my ($fn, $term) = @_; $term = "\n" unless defined $term; my $fh = do { local *F; *F }; sysopen $fh, $fn, O_RDONLY; local $/ = $term; my @lines = <$fh>; close $fh; return \@lines; } # ---------------------------------------------------------------------------- =head1 EXAMPLES Z<> =head1 BUGS Z<> =head1 REPORTING BUGS Email the author. =head1 AUTHOR Martyn J. Pearce C =head1 COPYRIGHT Copyright (c) 2001, 2002, 2003 Martyn J. Pearce. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO Z<> =cut 1; # keep require happy. __END__ Class-MethodMaker-2.24/t/scalar.t0000644000175000017500000012410511735360552014621 0ustar ss5ss5# (X)Emacs mode: -*- cperl -*- use strict; =head1 Unit Test Package for Class::MethodMaker This package tests the scalar type of Class::MethodMaker =cut use Data::Dumper qw( Dumper ); use Fatal 1.02 qw( sysopen close ); use Fcntl 1.03 qw( :DEFAULT ); use File::Spec::Functions qw( catfile ); use File::stat qw( stat ); use FindBin 1.42 qw( $Bin $Script ); use IO::File 1.08 qw( ); use POSIX 1.03 qw( S_ISREG ); use Test 1.13 qw( ok plan skip ); use lib $Bin; use test qw( DATA_DIR evcheck restore_output save_output ); BEGIN { # 1 for compilation test, plan tests => 314, todo => [], } # ---------------------------------------------------------------------------- =head2 Test 1: compilation This test confirms that the test script and the modules it calls compiled successfully. =cut package X; use Class::MethodMaker [ scalar => [qw/ a b -static s /], ]; package main; ok 1, 1, 'compilation'; # ------------------------------------- =head2 Test 2: bless =cut my $x; ok evcheck(sub { $x = bless {}, 'X'; }, 'bless ( 1)'), 1, 'bless ( 1)'; goto "TEST_$ENV{START_TEST}" if $ENV{START_TEST}; # ------------------------------------- =head2 Tests 3--22: simple non-static =cut { my $n; ok(evcheck(sub { $n = $x->a_isset; }, 'simple non-static ( 1)'), 1, 'simple non-static ( 1)'); ok ! $n; # simple non-static ( 2) ok(evcheck(sub { $n = $x->b_isset; }, 'simple non-static ( 3)'), 1, 'simple non-static ( 3)'); ok ! $n; # simple non-static ( 4) ok(evcheck(sub { $x->a(4); }, 'simple non-static ( 5)'), 1, 'simple non-static ( 5)'); ok(evcheck(sub { $n = $x->a; }, 'simple non-static ( 6)'), 1, 'simple non-static ( 6)'); ok $n, 4, 'simple non-static ( 7)'; ok(evcheck(sub { $n = $x->a(7); }, 'simple non-static ( 8)'), 1, 'simple non-static ( 8)'); ok $n, 7, 'simple non-static ( 9)'; ok(evcheck(sub { $n = $x->a_isset; }, 'simple non-static (10)'), 1, 'simple non-static (10)'); ok $n; # simple non-static (11) ok(evcheck(sub { $n = $x->b_isset; }, 'simple non-static (12)'), 1, 'simple non-static (12)'); ok ! $n; # simple non-static (13) ok(evcheck(sub { $n = $x->a_reset; }, 'simple non-static (14)'), 1, 'simple non-static (14)'); ok(evcheck(sub { $n = $x->a_isset; }, 'simple non-static (15)'), 1, 'simple non-static (15)'); ok ! $n; # simple non-static (16) ok(evcheck(sub { $n = $x->a; }, 'simple non-static (17)'), 1, 'simple non-static (17)'); ok $n, undef, 'simple non-static (18)'; ok(evcheck(sub { $n = $x->a_isset; }, 'simple non-static (19)'), 1, 'simple non-static (19)'); ok ! $n; # simple non-static (20) } # ------------------------------------- =head2 Tests 23--35: lvalue lvalue support has been dropped (I can't find a consistent way to support it in the presence of read callbacks). =cut TEST_23: if ( 0 ) { my $n; # Test lvalueness of b ok(evcheck(sub { $x->b = (); }, 'lvalue ( 1)'), 1, 'lvalue ( 1)'); ok(evcheck(sub { $n = $x->b_isset; }, 'lvalue ( 2)'), 1, 'lvalue ( 2)'); ok $n; # lvalue ( 3) ok(evcheck(sub { $n = $x->b; }, 'lvalue ( 4)'), 1, 'lvalue ( 4)'); ok $n, undef, 'lvalue ( 5)'; ok(evcheck(sub { $x->b = undef; }, 'lvalue ( 6)'), 1, 'lvalue ( 6)'); ok(evcheck(sub { $n = $x->b_isset; }, 'lvalue ( 7)'), 1, 'lvalue ( 7)'); ok $n; # lvalue ( 8) ok(evcheck(sub { $n = $x->b; }, 'lvalue ( 9)'), 1, 'lvalue ( 9)'); ok $n, undef, 'lvalue (10)'; ok(evcheck(sub { $x->b = 13 }, 'lvalue (11)'), 1, 'lvalue (11)'); ok(evcheck(sub { $n = $x->b; }, 'lvalue (12)'), 1, 'lvalue (12)'); ok $n, 13, 'lvalue (13)'; } else { ok 1, 1, sprintf 'lvalue (-%2d)', $_ for 1..13; } # ------------------------------------- =head2 Tests 36--51: typed =cut TEST_36: { my $n; ok(evcheck(sub { package X; Class::MethodMaker->import([scalar => [{ -type => 'File::stat' }, qw( st ), ]])}, 'typed ( 1)'), 1, 'typed ( 1)'); ok(evcheck(sub { $n = $x->st_isset; }, 'typed ( 2)'), 1, 'typed ( 2)'); ok ! $n; # typed ( 3) ok(evcheck(sub { $x->st(4); }, 'typed ( 4)'), 0, 'typed ( 4)'); ok(evcheck(sub { $n = $x->st; }, 'typed ( 5)'), 1, 'typed ( 5)'); ok $n, undef, 'typed ( 6)'; ok(evcheck(sub { $n = $x->st_isset; }, 'typed ( 7)'), 1, 'typed ( 7)'); ok ! $n; # typed ( 8) ok(evcheck(sub { $x->st(undef); }, 'typed ( 9)'), 1, 'typed ( 9)'); ok(evcheck(sub { $n = $x->st_isset; }, 'typed (10)'), 1, 'typed (10)'); ok $n; # typed (11) ok(evcheck(sub { $n = $x->st; }, 'typed (12)'), 1, 'typed (12)'); ok $n, undef, 'typed (13)'; ok(evcheck(sub { $x->st(stat catfile($Bin,$Script)) }, 'typed (14)'), 1, 'typed (14)'); ok(evcheck(sub { $n = $x->st; }, 'typed (15)'), 1, 'typed (15)'); ok S_ISREG($n->mode), 1, 'typed (16)'; } # ------------------------------------- =head2 Tests 52--69: forward =cut { my $n; ok(evcheck(sub { package X; Class::MethodMaker->import([scalar => [{ -type => 'File::stat', -forward => [qw/ mode size /], }, qw( st1 ), # Keeping the second call # here ensures that we check # that mode, size are # forwarded to st1 { -type => 'IO::Handle', -forward => 'read', }, qw( st2 ), ]])}, 'forward ( 1)'), 1, 'forward ( 1)'); ok(evcheck(sub { $n = $x->st1_isset; }, 'forward ( 2)'), 1, 'forward ( 2)'); ok ! $n; # forward ( 3) ok(evcheck(sub { $x->st1(4); }, 'forward ( 4)'), 0, 'forward ( 4)'); ok(evcheck(sub { $n = $x->st1; }, 'forward ( 5)'), 1, 'forward ( 5)'); ok $n, undef, 'forward ( 6)'; ok(evcheck(sub { $n = $x->st1_isset; }, 'forward ( 7)'), 1, 'forward ( 7)'); ok ! $n; # forward ( 8) ok(evcheck(sub { $x->st1(undef); }, 'forward ( 9)'), 1, 'forward ( 9)'); ok(evcheck(sub { $n = $x->st1_isset; }, 'forward (10)'), 1, 'forward (10)'); ok $n; # forward (11) ok(evcheck(sub { $n = $x->st1; }, 'forward (12)'), 1, 'forward (12)'); ok $n, undef, 'forward (13)'; ok(evcheck(sub { $x->st1(stat catfile($Bin,$Script)) }, 'forward (14)'), 1, 'forward (14)'); ok(evcheck(sub { $n = $x->mode; }, 'forward (15)'), 1, 'forward (15)'); ok S_ISREG($n), 1, 'forward (16)'; ok(evcheck(sub { $n = $x->size; }, 'forward (17)'), 1, 'forward (17)'); { sysopen my $fh, catfile($Bin,$Script), O_RDONLY; local $/ = undef; my $text = <$fh>; close $fh; ok $n, length($text), 'forward (18)'; } } # ------------------------------------- =head2 Tests 70--72: forward_args =cut { my $n; # Instantiate st2 as IO::File, which is a subclass of IO::Handle. This # should be fine ok(evcheck(sub { $x->st2(IO::File->new(catfile($Bin,$Script))) }, 'forward_args ( 1)'), 1, 'forward_args ( 1)'); ok(evcheck(sub { $x->read($n, 30); }, 'forward_args ( 2)'), 1, 'forward_args ( 2)'); ok $n, '# (X)Emacs mode: -*- cperl -*-', 'forward_args ( 3)'; } # ------------------------------------- =head2 Tests 73--85: default =cut { my $n; ok(evcheck(sub { package X; Class::MethodMaker->import([scalar => [{ -default => 7, }, qw( df1 ), ], ]); }, 'default ( 1)'), 1, 'default ( 1)'); ok(evcheck(sub { $n = $x->df1_isset; }, 'default ( 2)'), 1, 'default ( 2)'); ok $n; # default ( 3) ok(evcheck(sub { $n = $x->df1; }, 'default ( 4)'), 1, 'default ( 4)'); ok $n, 7, 'default ( 5)'; # lvalue support has been dropped (I can't find a consistent way to support # it in the presence of read callbacks). if ( 0 ) { ok(evcheck(sub { $x->df1 = 13; }, 'default ( 6)'), 1, 'default ( 6)'); ok(evcheck(sub { $n = $x->df1; }, 'default ( 7)'), 1, 'default ( 7)'); ok $n, 13, 'default ( 8)'; } else { ok 1, 1, sprintf 'default (-%2d)', $_ for 6..8; } ok(evcheck(sub { $x->df1_reset; }, 'default ( 9)'), 1, 'default ( 9)'); ok(evcheck(sub { $n = $x->df1_isset; }, 'default (10)'), 1, 'default (10)'); ok $n; # default (11) ok(evcheck(sub { $n = $x->df1; }, 'default (12)'), 1, 'default (12)'); ok $n, 7, 'default (13)'; } # ------------------------------------- =head2 Tests 86--102: default_ctor =cut { package Y; my $count; sub new { my $class = shift; my $i = shift; my $self = @_ ? $_[0] : ++$count; return bless \$self, $class; } sub value { return ${$_[0]}; } } { my $n; ok(evcheck(sub { package X; Class::MethodMaker->import([scalar => [{ -type => 'Y', -default_ctor => 'new', }, qw( df2 ), { -type => 'Y', -default_ctor => sub { Y->new(undef, -3); }, }, qw( df3 ), ], ]); }, 'default ( 1)'), 1, 'default_ctor ( 1)'); ok(evcheck(sub { $n = $x->df2_isset; }, 'default_ctor( 2)'), 1, 'default_ctor ( 2)'); ok $n; # default_ctor ( 3) ok(evcheck(sub { $n = $x->df2->value; }, 'default_ctor( 4)'), 1, 'default_ctor ( 4)'); ok $n, 1, 'default_ctor ( 5)'; # lvalue support has been dropped (I can't find a consistent way to support # it in the presence of read callbacks). if ( 0 ) { ok(evcheck(sub { $x->df2 = Y->new; }, 'default_ctor( 6)'), 1, 'default_ctor ( 6)'); ok(evcheck(sub { $n = $x->df2->value; }, 'default_ctor( 7)'), 1, 'default_ctor ( 7)'); ok $n, 2, 'default_ctor ( 8)'; } else { ok (evcheck(sub { $x->df2(Y->new); }, 'default_ctor(- 6)'), 1, 'default_ctor (- 6)'); ok 1, 1, sprintf 'default_ctor (-%2d)', $_ for 7..8 } ok(evcheck(sub { $x->df2_reset; },'default_ctor( 9)'), 1, 'default_ctor ( 9)'); ok(evcheck(sub { $n = $x->df2_isset; }, 'default_ctor(10)'), 1, 'default_ctor (10)'); ok $n; # default_ctor (11) ok(evcheck(sub { $n = $x->df2->value; }, 'default_ctor(12)'), 1, 'default_ctor (12)'); ok $n, 3, 'default_ctor (13)'; ok(evcheck(sub { $n = $x->df3_isset; }, 'default_ctor(14)'), 1, 'default_ctor (14)'); ok $n; # default_ctor (15) ok(evcheck(sub { $n = $x->df3->value; }, 'default_ctor(16)'), 1, 'default_ctor (16)'); ok $n, -3, 'default_ctor (17)'; } # ------------------------------------- =head2 Tests 103--114: !syntax =cut { my $n; ok(evcheck(sub { package X; Class::MethodMaker->import ([scalar => [qw/ -static bs1 !static bs2 /],]); }, '!syntax ( 1)'), 1, '!syntax ( 1)'); my $y; ok evcheck(sub { $y = bless {}, 'X'; }, '!syntax ( 2)'), 1, '!syntax ( 2)'; ok evcheck(sub { $x->bs1(7); }, '!syntax ( 3)'), 1, '!syntax ( 3)'; ok evcheck(sub { $n = $x->bs1; }, '!syntax ( 4)'), 1, '!syntax ( 4)'; ok $n, 7, '!syntax ( 5)'; ok evcheck(sub { $n = $y->bs1; }, '!syntax ( 6)'), 1, '!syntax ( 6)'; ok $n, 7, '!syntax ( 7)'; ok evcheck(sub { $x->bs2(9); }, '!syntax ( 8)'), 1, '!syntax ( 8)'; ok evcheck(sub { $n = $x->bs2; }, '!syntax ( 9)'), 1, '!syntax ( 9)'; ok $n, 9, '!syntax (10)'; ok evcheck(sub { $n = $y->bs2; }, '!syntax (11)'), 1, '!syntax (11)'; ok $n, undef, '!syntax (12)'; } # ------------------------------------- =head2 Tests 115--126: nested scope =cut { my $n; ok(evcheck(sub { package X; Class::MethodMaker->import ([scalar => [[qw/ -static bs3 /], 'bs4'],]); }, 'nested scope ( 1)'), 1, 'nested scope ( 1)'); my $y; ok(evcheck(sub { $y = bless {}, 'X'; }, 'nested scope ( 2)'), 1, 'nested scope ( 2)'); ok evcheck(sub { $x->bs3(7); }, 'nested scope ( 3)'), 1,'nested scope ( 3)'; ok(evcheck(sub { $n = $x->bs3; }, 'nested scope ( 4)'), 1, 'nested scope ( 4)'); ok $n, 7, 'nested scope ( 5)'; ok(evcheck(sub { $n = $y->bs3; }, 'nested scope ( 6)'), 1, 'nested scope ( 6)'); ok $n, 7, 'nested scope ( 7)'; ok evcheck(sub { $x->bs4(9); }, 'nested scope ( 8)'), 1,'nested scope ( 8)'; ok(evcheck(sub { $n = $x->bs4; }, 'nested scope ( 9)'), 1, 'nested scope ( 9)'); ok $n, 9, 'nested scope (10)'; ok(evcheck(sub { $n = $y->bs4; }, 'nested scope (11)'), 1, 'nested scope (11)'); ok $n, undef, 'nested scope (12)'; } # ------------------------------------- =head2 Tests 127--130: simple name =cut { my $n; ok(evcheck(sub { package X; Class::MethodMaker->import ([scalar => 'simple',]); }, 'simple name ( 1)'), 1, 'simple name ( 1)'); ok evcheck(sub { $x->simple(7); }, 'simple name ( 2)'),1,'simple name ( 2)'; ok evcheck(sub { $n = $x->simple },'simple name ( 3)'),1,'simple name ( 3)'; ok $n, 7, 'simple name ( 4)'; } # ------------------------------------- =head2 Tests 131--142: repeated calls =cut { my $n; ok(evcheck(sub { package X; Class::MethodMaker->import ([scalar => [qw/ -static bs5/ ], scalar => 'bs6' ]); }, 'repeated calls ( 1)'), 1, 'repeated calls ( 1)'); my $y; ok(evcheck(sub { $y = bless {}, 'X'; }, 'repeated calls ( 2)'), 1, 'repeated calls ( 2)'); ok evcheck(sub { $x->bs5(7)},'repeated calls ( 3)'),1,'repeated calls ( 3)'; ok(evcheck(sub { $n = $x->bs5; }, 'repeated calls ( 4)'), 1, 'repeated calls ( 4)'); ok $n, 7, 'repeated calls ( 5)'; ok(evcheck(sub { $n = $y->bs5; }, 'repeated calls ( 6)'), 1, 'repeated calls ( 6)'); ok $n, 7, 'repeated calls ( 7)'; ok evcheck(sub { $x->bs6(9)},'repeated calls ( 8)'),1,'repeated calls ( 8)'; ok(evcheck(sub { $n = $x->bs6; }, 'repeated calls ( 9)'), 1, 'repeated calls ( 9)'); ok $n, 9, 'repeated calls (10)'; ok(evcheck(sub { $n = $y->bs6; }, 'repeated calls (11)'), 1, 'repeated calls (11)'); ok $n, undef, 'repeated calls (12)'; } # ------------------------------------- =head2 Tests 143--153: *_clear =cut { my $n; ok(evcheck(sub { package X; Class::MethodMaker->import ([scalar => [{'*_clear' => '*_clear'}, 'xc1'],]); }, '*_clear ( 1)'), 1, '*_clear ( 1)'); ok evcheck(sub { $x->xc1(7); }, '*_clear ( 2)'), 1, '*_clear ( 2)'; ok evcheck(sub { $n = $x->xc1 }, '*_clear ( 3)'), 1, '*_clear ( 3)'; ok $n, 7, '*_clear ( 4)'; ok evcheck(sub { $n = $x->xc1_isset }, '*_clear ( 5)'), 1, '*_clear ( 5)'; ok $n; # *_clear ( 6) ok evcheck(sub { $x->xc1_clear; }, '*_clear ( 7)'), 1, '*_clear ( 7)'; ok evcheck(sub { $n = $x->xc1 }, '*_clear ( 8)'), 1, '*_clear ( 8)'; ok $n, undef, '*_clear ( 9)'; ok evcheck(sub { $n = $x->xc1_isset }, '*_clear (10)'), 1, '*_clear (10)'; ok $n; # *_clear (11) } # ------------------------------------- =head2 Tests 154--202: rename =cut { my $n; ok(evcheck(sub { package Z; Class::MethodMaker->import ([ scalar => [[{'*_get' => 'get_*', '*_set' => 'set_*'}, qw/ a -static b /], 'c'], ]) }, '*_clear ( 1)'), 1, 'rename ( 0)'); my ($x, $y); ok evcheck(sub { $x = bless {}, 'Z'; }, 'rename ( 1)'), 1, 'rename ( 1)'; ok evcheck(sub { $y = bless {}, 'Z'; }, 'rename ( 1)'), 1, 'rename ( 2)'; { # Perl 5.6.1 gets a bit over-zealous with the used only once warnings. no warnings; ok defined *{Z::get_a}{CODE}; # rename ( 3) ok ! defined *{Z::a_get}{CODE}; # rename ( 4) ok defined *{Z::get_b}{CODE}; # rename ( 5) ok ! defined *{Z::b_get}{CODE}; # rename ( 6) ok defined *{Z::a}{CODE}; # rename ( 7) ok defined *{Z::a_reset}{CODE}; # rename ( 8) ok defined *{Z::a_isset}{CODE}; # rename ( 9) ok ! defined *{Z::a_ref}{CODE}; # rename (10) ok defined *{Z::b}{CODE}; # rename (11) ok defined *{Z::b_reset}{CODE}; # rename (12) ok defined *{Z::b_isset}{CODE}; # rename (13) ok ! defined *{Z::b_ref}{CODE}; # rename (14) ok ! defined *{Z::get_c}{CODE}; # rename (15) ok ! defined *{Z::c_get}{CODE}; # rename (16) ok defined *{Z::c}{CODE}; # rename (17) ok defined *{Z::c_reset}{CODE}; # rename (18) ok defined *{Z::c_isset}{CODE}; # rename (19) ok ! defined *{Z::c_ref}{CODE}; # rename (20) } ok evcheck(sub { $n = $x->set_a(7); }, 'rename (21)'), 1, 'rename (21)'; ok $n, undef, 'rename (22)'; ok evcheck(sub { $n = $x->get_a(9); }, 'rename (23)'), 1, 'rename (23)'; ok $n, 7, 'rename (24)'; ok evcheck(sub { $n = $x->get_a(9); }, 'rename (25)'), 1, 'rename (25)'; ok $n, 7, 'rename (26)'; ok evcheck(sub { $n = $x->get_b(9); }, 'rename (27)'), 1, 'rename (27)'; ok $n, undef, 'rename (28)'; ok evcheck(sub { $n = $y->get_a(9); }, 'rename (29)'), 1, 'rename (29)'; ok $n, undef, 'rename (30)'; ok evcheck(sub { $n = $y->set_b(5); }, 'rename (31)'), 1, 'rename (31)'; ok $n, undef, 'rename (32)'; ok evcheck(sub { $n = $y->get_b(9); }, 'rename (33)'), 1, 'rename (33)'; ok $n, 5, 'rename (34)'; ok evcheck(sub { $n = $y->get_b(9); }, 'rename (35)'), 1, 'rename (35)'; ok $n, 5, 'rename (36)'; ok evcheck(sub { $n = $x->get_b(9); }, 'rename (37)'), 1, 'rename (37)'; ok $n, 5, 'rename (38)'; ok evcheck(sub { $n = $y->c(4); }, 'rename (39)'), 1, 'rename (39)'; ok $n, 4, 'rename (40)'; ok evcheck(sub { $n = $y->c(6); }, 'rename (41)'), 1, 'rename (41)'; ok $n, 6, 'rename (42)'; ok evcheck(sub { $n = $y->get_b(9); }, 'rename (43)'), 1, 'rename (43)'; ok $n, 5, 'rename (44)'; ok evcheck(sub { $n = $x->get_a(9); }, 'rename (45)'), 1, 'rename (45)'; ok $n, 7, 'rename (46)'; ok evcheck(sub { $n = $y->c; }, 'rename (47)'), 1, 'rename (47)'; ok $n, 6, 'rename (48)'; } # ------------------------------------- =head2 Tests 203--204: v1/2 check =cut my $if_MSWin = $^O =~ m/MSWin/ ? 'Skip if under MSWin' : ''; if ($if_MSWin) { skip($if_MSWin, 1, 1, "v1/2 check ( 1)" ); skip($if_MSWin, 1, 1, "v1/2 check ( 2)" ); } else { save_output('stderr', *STDERR{IO}); ok(evcheck(sub { # Eval use statement to execute it at runtime eval qq{ package Z1; use Class::MethodMaker scalar => [qw/ a b -static s /], ; }; if ( $@ ) { print STDERR $@; die $@; } }, 'v1/2 check ( 1)'), 0, 'v1/2 check ( 1)'); my $stderr = restore_output('stderr'); print STDERR "stderr saved: $stderr\n" if $ENV{TEST_DEBUG}; ok($stderr, qr!presenting your arguments to use/import!, 'v1/2 check ( 2)'); } # ------------------------------------- =head2 Tests 205--221: tie =cut { # @z is an audit trail my @z; package W; use Tie::Scalar; use base qw( Tie::StdScalar ); sub TIESCALAR { push @z, [ 'TIESCALAR' ]; $_[0]->SUPER::TIESCALAR } sub FETCH { push @z, [ 'FETCH' ]; $_[0]->SUPER::FETCH } sub STORE { push @z, [ STORE => $_[1] ]; $_[0]->SUPER::STORE($_[1]) } sub DESTROY { push @z, [ 'DESTROY' ]; $_[0]->SUPER::DESTROY } sub UNTIE { push @z, [ UNTIE => $_[1] ]; $_[0]->SUPER::UNTIE($_[1]) } package main; ok(evcheck(sub { package X; Class::MethodMaker->import([scalar => [{ -type => 'File::stat', -tie_class => 'W', -forward => [qw/ mode size /], }, qw( tie1 ), ]])}, 'tie ( 1)'), 1, 'tie ( 1)'); bless ((my $x = {}), 'X'); ok @z, 0, 'tie ( 2)'; my $stat1 = stat catfile($Bin,$Script); my $stat2 = stat $Bin; $x->tie1($stat1); ok @z, 2, 'tie ( 3)'; ok $z[0][0], 'TIESCALAR', 'tie ( 4)'; ok $z[1][0], 'STORE' , 'tie ( 5)'; ok $z[1][1], $stat1 , 'tie ( 6)'; my $y; ok evcheck(sub { $y = $x->tie1 }, 'tie ( 7)'), 1, 'tie ( 7)'; ok $y, $stat1, 'tie ( 8)'; ok @z, 3, 'tie ( 9)'; ok $z[2][0], 'FETCH', 'tie (10)'; ok evcheck(sub { $x->tie1($stat2) }, 'tie (11)'), 1, 'tie (11)'; ok @z, 4, 'tie (12)'; ok $z[3][0], 'STORE', 'tie (13)'; ok $z[3][1], $stat2, 'tie (14)'; ok evcheck(sub { $x->tie1_reset }, 'tie (15)'), 1, 'tie (15)'; ok @z, 5, 'tie (16)'; ok $z[4][0], 'DESTROY', 'tie (17)'; # Beware that indexing items off the end of @z above will auto-vivify the # corresponding entries, so if you see empty members of @z, that's possibly # the cause print Dumper \@z, $x if $ENV{TEST_DEBUG}; } # ------------------------------------- =head Tests 222--230: tie_args =cut { package V; sub TIESCALAR { my $type = shift; my %args = @_ ; my $self={} ; if (defined $args{enum}) { # store all enum values in a hash. This way, checking # whether a value is present in the enum set is easier map {; $self->{enum}{$_} = 1 } @{$args{enum}} ; } else { die ref($self)," error: no enum values defined when calling init"; } $self->{default} = $args{default}; bless $self,$type; } sub STORE { my ($self,$value) = @_ ; die "cannot set ",ref($self)," item to $value. Expected ", join(' ',keys %{$self->{enum}}) unless defined $self->{enum}{$value} ; # we may want to check other rules here ... TBD $self->{value} = $value ; return $value; } sub FETCH { my $self = shift ; return defined $self->{value} ? $self->{value} : $self->{default} ; } package main; ok(evcheck(sub { package X; Class::MethodMaker->import ([scalar => [{ -tie_class => 'V', -tie_args => [enum => [qw/A B C/], default => 'B'], }, qw( tie2 ), ]])}, 'tie_args ( 1)'), 1, 'tie_args ( 1)'); ok $x->tie2, 'B', 'tie_args ( 2)'; my $y; ok evcheck(sub { $y = $x->tie2('A') }, 'tie_args ( 3)'), 1, 'tie_args ( 3)'; ok $y, 'A', 'tie_args ( 4)'; ok evcheck(sub { $y = $x->tie2 }, 'tie_args ( 5)'), 1, 'tie_args ( 5)'; ok $y, 'A', 'tie_args ( 6)'; ok evcheck(sub { $y = $x->tie2('D') }, 'tie_args ( 7)'), 0, 'tie_args ( 7)'; ok evcheck(sub { $y = $x->tie2 }, 'tie_args ( 8)'), 1, 'tie_args ( 8)'; ok $y, 'A', 'tie_args ( 9)'; } # ------------------------------------- =head tests 231--251: read_cb =cut TEST_231: { my $n; ok(evcheck(sub { package X; Class::MethodMaker->import ([scalar => [{ -read_cb => sub { ($_[1]||0) + 1 } }, qw( rcb1 rcb2 ),] ])}, 'read_cb ( 0)'), 1, 'read_cb ( 0)'); ok(evcheck(sub { $n = $x->rcb1_isset; }, 'read_cb ( 1)'), 1, 'read_cb ( 1)'); ok ! $n; # read_cb ( 2) ok(evcheck(sub { $n = $x->rcb2_isset; }, 'read_cb ( 3)'), 1, 'read_cb ( 3)'); ok ! $n; # read_cb ( 4) ok(evcheck(sub { $x->rcb1(4); }, 'read_cb ( 5)'), 1, 'read_cb ( 5)'); ok(evcheck(sub { $n = $x->rcb1; }, 'read_cb ( 6)'), 1, 'read_cb ( 6)'); ok $n, 5, 'read_cb ( 7)'; ok(evcheck(sub { $n = $x->rcb1(7); }, 'read_cb ( 8)'), 1, 'read_cb ( 8)'); ok $n, 8, 'read_cb ( 9)'; ok(evcheck(sub { $n = $x->rcb1_isset; }, 'read_cb (10)'), 1, 'read_cb (10)'); ok $n; # read_cb (11) ok(evcheck(sub { $n = $x->rcb2_isset; }, 'read_cb (12)'), 1, 'read_cb (12)'); ok ! $n; # read_cb (13) ok(evcheck(sub { $n = $x->rcb1_reset; }, 'read_cb (14)'), 1, 'read_cb (14)'); ok(evcheck(sub { $n = $x->rcb1_isset; }, 'read_cb (15)'), 1, 'read_cb (15)'); ok ! $n; # read_cb (16) ok(evcheck(sub { $n = $x->rcb1; }, 'read_cb (17)'), 1, 'read_cb (17)'); ok $n, 1, 'read_cb (18)'; ok(evcheck(sub { $n = $x->rcb1_isset; }, 'read_cb (19)'), 1, 'read_cb (19)'); ok ! $n; # read_cb (20) } # ------------------------------------- =head tests 252--274: store_cb =cut TEST_231: { my $n; ok(evcheck(sub { package X; Class::MethodMaker->import ([scalar => [{ -store_cb => sub { $_[1] + 1 } }, qw( scb1 scb2 ),] ])}, 'store_cb ( 0)'), 1, 'store_cb ( 0)'); ok(evcheck(sub { $n = $x->scb1_isset; }, 'store_cb ( 1)'), 1, 'store_cb ( 1)'); ok ! $n; # store_cb ( 2) ok(evcheck(sub { $n = $x->scb2_isset; }, 'store_cb ( 3)'), 1, 'store_cb ( 3)'); ok ! $n; # store_cb ( 4) ok(evcheck(sub { $x->scb1(4); }, 'store_cb ( 5)'), 1, 'store_cb ( 5)'); ok(evcheck(sub { $n = $x->scb1; }, 'store_cb ( 6)'), 1, 'store_cb ( 6)'); ok $n, 5, 'store_cb ( 7)'; ok(evcheck(sub { $n = $x->scb1(7); }, 'store_cb ( 8)'), 1, 'store_cb ( 8)'); ok $n, 8, 'store_cb ( 9)'; ok(evcheck(sub { $n = $x->scb1_isset; }, 'store_cb (10)'), 1, 'store_cb (10)'); ok $n; # store_cb (11) ok(evcheck(sub { $n = $x->scb2_isset; }, 'store_cb (12)'), 1, 'store_cb (12)'); ok ! $n; # store_cb (13) ok(evcheck(sub { $n = $x->scb1_reset; }, 'store_cb (14)'), 1, 'store_cb (14)'); ok(evcheck(sub { $n = $x->scb1_isset; }, 'store_cb (15)'), 1, 'store_cb (15)'); ok ! $n; # store_cb (16) ok(evcheck(sub { $n = $x->scb1; }, 'store_cb (17)'), 1, 'store_cb (17)'); ok $n, undef, 'store_cb (18)'; ok(evcheck(sub { $n = $x->scb1_isset; }, 'store_cb (19)'), 1, 'store_cb (19)'); ok ! $n; # store_cb (20) ok(evcheck(sub { $x->scb1(4); }, 'store_cb (21)'), 1, 'store_cb (21)'); print Dumper $x if $ENV{TEST_DEBUG}; ok $x->{scb1}, 5, 'store_cb(22)'; } # ------------------------------------- =head Tests 275--294: =cut TEST_275: { my $n; ok(evcheck(sub { package X; Class::MethodMaker->import([scalar => [{ -type => Class::MethodMaker::INTEGER }, qw( int ), ]])}, 'INTEGER ( 1)'), 1, 'INTEGER ( 1)'); ok evcheck(sub { $n = $x->int_isset; }, 'INTEGER ( 2)'), 1, 'INTEGER ( 2)'; ok ! $n; # INTEGER ( 3) ok evcheck(sub { $n = $x->int; }, 'INTEGER ( 4)'), 1, 'INTEGER ( 4)'; ok $n, 0, 'INTEGER ( 5)'; ok evcheck(sub { $x->int(4); }, 'INTEGER ( 6)'), 1, 'INTEGER ( 6)'; ok evcheck(sub { $n = $x->int; }, 'INTEGER ( 7)'), 1, 'INTEGER ( 7)'; ok $n, 4, 'INTEGER ( 8)'; ok(evcheck(sub { $x->int("5x"); }, 'INTEGER ( 9)'), 1, 'INTEGER ( 9)'); ok(evcheck(sub { $n = $x->int; }, 'INTEGER (10)'), 1, 'INTEGER (10)'); ok $n, 5, 'INTEGER (11)'; ok(evcheck(sub { $n = $x->int_incr; }, 'INTEGER (12)'), 1, 'INTEGER (12)'); ok $n, 6, 'INTEGER (13)'; # Check incr isn't installed by default on normal components ok(evcheck(sub { $n = $x->st_incr; }, 'INTEGER (14)'), 0, 'INTEGER (14)'); ok(evcheck(sub { $n = $x->int_decr; }, 'INTEGER (15)'), 1, 'INTEGER (15)'); ok $n, 5, 'INTEGER (16)'; ok(evcheck(sub { $n = $x->int_zero; }, 'INTEGER (17)'), 1, 'INTEGER (17)'); ok $n, 0, 'INTEGER (18)'; ok(evcheck(sub { $n = $x->int; }, 'INTEGER (19)'), 1, 'INTEGER (19)'); ok $n, 0, 'INTEGER (20)'; } # ------------------------------------- =head2 Tests 295--301: non-init ctor This is to test that the default ctor or default is not assigned if a value is supplied. This would particularly be a problem with v1 compatiblity use where a value is explcitly supplied to prevent 'new' being called because there is no 'new' (if the ctor is called anyway, the program barfs). =cut { my $n; ok(evcheck(sub { package X; Class::MethodMaker->import([scalar => [{ -type => 'Y', -default_ctor => 'newx', }, qw( nic ), ], ]); }, 'default ( 1)'), 1, 'non-init ctor ( 1)'); ok(evcheck(sub { $n = $x->nic_isset; }, 'non-init ctor( 2)'), 1, 'non-init ctor ( 2)'); ok $n; # non-init ctor ( 3) ok(evcheck(sub { $n = $x->nic; }, 'non-init ctor( 4)'), 0, 'non-init ctor ( 4)'); ok(evcheck(sub { $x->nic(Y->new); }, 'non-init ctor( 5)'), 1, 'non-init ctor ( 5)'); ok(evcheck(sub { $n = $x->nic; }, 'non-init ctor( 6)'), 1, 'non-init ctor ( 6)'); ok ref $n, 'Y', 'non-init ctor ( 7)'; } # ------------------------------------- =head2 Tests 302--314 default_ctor (arg) =cut TEST_302: { package S; my $count; sub new { my ($class, $arg) = @_; die sprintf "Expected an X, got a '%s'\n", defined($arg) ? ref $arg : '*undef*' unless UNIVERSAL::isa($arg, 'X'); my $self = $arg->int; return bless \$self, $class; } sub value { return ${$_[0]}; } } { my $n; ok(evcheck(sub { package X; Class::MethodMaker->import([scalar => [{ -type => 'S', -default_ctor => 'new', }, qw( dfx ), ], ]); }, 'default_ctor (arg)( 1)'), 1, 'default_ctor (arg) ( 1)'); ok(evcheck(sub { $x->int(1) }, 'default_ctor (arg)( 2)'), 1, 'default_ctor (arg) ( 2)'); ok(evcheck(sub { $n = $x->dfx_isset; }, 'default_ctor (arg)( 3)'), 1, 'default_ctor (arg) ( 3)'); ok $n; # default_ctor (arg) ( 4) ok(evcheck(sub { $n = $x->dfx->value; }, 'default_ctor (arg)( 5)'), 1, 'default_ctor (arg) ( 5)'); ok $n, 1, 'default_ctor (arg) ( 6)'; ok 1, 1, sprintf 'default_ctor (-%2d)', $_ for 7..8; ok(evcheck(sub { $x->dfx_reset; },'default_ctor (arg)( 9)'), 1, 'default_ctor (arg) ( 9)'); ok(evcheck(sub { $n = $x->dfx_isset; }, 'default_ctor (arg)(10)'), 1, 'default_ctor (arg) (10)'); ok $n; # default_ctor (arg) (11) ok(evcheck(sub { $n = $x->dfx->value; }, 'default_ctor (arg)(12)'), 1, 'default_ctor (arg) (12)'); ok $n, 1, 'default_ctor (arg) (13)'; } # ---------------------------------------------------------------------------- Class-MethodMaker-2.24/t/hash.t0000644000175000017500000014504711735360552014307 0ustar ss5ss5# (X)Emacs mode: -*- cperl -*- use strict; =head1 Unit Test Package for Class::MethodMaker This package tests the array type of Class::MethodMaker =cut use B::Deparse 0.59 qw( ); use Data::Dumper qw( Dumper ); use Fcntl 1.03 qw( :DEFAULT ); use File::Spec::Functions qw( catfile ); use File::stat qw( stat ); use FindBin 1.42 qw( $Bin $Script ); use IO::File 1.08 qw( ); use POSIX 1.03 qw( S_ISDIR S_ISREG ); use Test 1.13 qw( ok plan skip ); use lib $Bin; use test qw( evcheck ); BEGIN { # 1 for compilation test, plan tests => 439, todo => [], } # ---------------------------------------------------------------------------- =head2 Test 1: compilation This test confirms that the test script and the modules it calls compiled successfully. =cut package X; use Class::MethodMaker [ hash => [qw/ a b -static s /], ]; package main; ok 1, 1, 'compilation'; # ------------------------------------- =head2 Tests 2--3: bless =cut my ($x, $y); ok evcheck(sub { $x = bless {}, 'X'; }, 'bless ( 1)'), 1, 'bless ( 1)'; ok evcheck(sub { $y = bless {}, 'X'; }, 'bless ( 2)'), 1, 'bless ( 2)'; # ------------------------------------- =head2 Tests 4--29: simple non-static =cut { my $n; ok(evcheck(sub { $n = $x->a_isset; }, 'simple non-static ( 1)'), 1, 'simple non-static ( 1)'); ok ! $n; # simple non-static ( 2) ok(evcheck(sub { $n = $x->b_isset; }, 'simple non-static ( 3)'), 1, 'simple non-static ( 3)'); ok ! $n; # simple non-static ( 4) ok(evcheck(sub { $x->a(a => 4); }, 'simple non-static ( 5)'), 1, 'simple non-static ( 5)'); ok(evcheck(sub { ($n) = $x->a; }, 'simple non-static ( 6)'), 1, 'simple non-static ( 6)'); ok $n, 'a', 'simple non-static ( 7)'; ok(evcheck(sub { ($n) = $x->a(a => 7); }, 'simple non-static ( 8)'), 1, 'simple non-static ( 8)'); ok $n, 'a', 'simple non-static ( 9)'; ok(evcheck(sub { $n = $x->a_isset; }, 'simple non-static (10)'), 1, 'simple non-static (10)'); ok $n; # simple non-static (11) ok(evcheck(sub { $n = $x->b_isset; }, 'simple non-static (12)'), 1, 'simple non-static (12)'); ok ! $n; # simple non-static (13) ok(evcheck(sub { $n = $x->a(b => 7); }, 'simple non-static (14)'), 1, 'simple non-static (14)'); print STDERR Data::Dumper->Dump([$n], [qw($n)]) if $ENV{TEST_DEBUG}; ok ref($n), 'HASH', 'simple non-static (15)'; ok keys %$n, 1, 'simple non-static (16)'; ok $n->{b}, 7, 'simple non-static (17)'; ok(evcheck(sub { $n = $x->a_reset; }, 'simple non-static (18)'), 1, 'simple non-static (18)'); ok(evcheck(sub { $n = $x->a_isset; }, 'simple non-static (19)'), 1, 'simple non-static (19)'); ok ! $n; # simple non-static (20) ok(evcheck(sub { $n = $x->a; }, 'simple non-static (21)'), 1, 'simple non-static (21)'); print STDERR Data::Dumper->Dump([$n], [qw($n)]) if $ENV{TEST_DEBUG}; ok ref($n), 'HASH', 'simple non-static (22)'; ok keys %$n, 0, 'simple non-static (23)'; ok(evcheck(sub { $n = $x->a_isset; }, 'simple non-static (24)'), 1, 'simple non-static (24)'); ok ! $n; # simple non-static (25) # Fail this due to uneven number of arguments ok(evcheck(sub { $x->a(4); }, 'simple non-static ( 5)'), 0, 'simple non-static (26)'); } # ------------------------------------- =head2 Tests 30--60: simple static =cut { my ($m, $n); ok(evcheck(sub { $n = $x->s_isset; }, 'simple static ( 1)'), 1, 'simple static ( 1)'); ok ! $n; # simple static ( 2) ok(evcheck(sub { $n = $y->s_isset; }, 'simple static ( 3)'), 1, 'simple static ( 3)'); ok ! $n; # simple static ( 4) ok(evcheck(sub { $x->s(14, 17); }, 'simple static ( 5)'), 1, 'simple static ( 5)'); ok(evcheck(sub { $n = $x->s_isset; }, 'simple static ( 6)'), 1, 'simple static ( 6)'); ok $n; # simple static ( 7) ok(evcheck(sub { $n = $y->s_isset; }, 'simple static ( 8)'), 1, 'simple static ( 8)'); ok $n; # simple static ( 9) ok(evcheck(sub { ($m, $n) = $x->s; }, 'simple static (10)'), 1, 'simple static (10)'); ok $m, 14, 'simple static (11)'; ok $n, 17, 'simple static (12)'; ok(evcheck(sub { ($m, $n) = $y->s; }, 'simple static (13)'), 1, 'simple static (13)'); ok $m, 14, 'simple static (14)'; ok $n, 17, 'simple static (15)'; ok(evcheck(sub { $n = $y->s; }, 'simple static (16)'), 1, 'simple static (16)'); print STDERR Data::Dumper->Dump([$n], [qw($n)]) if $ENV{TEST_DEBUG}; ok ref($n), 'HASH', 'simple static (17)'; ok keys %$n, 1, 'simple static (18)'; ok exists $n->{14}; ok $n->{14}, 17, 'simple static (20)'; ok(evcheck(sub { $n = $y->s_reset; }, 'simple static (21)'), 1, 'simple static (21)'); ok(evcheck(sub { $n = $x->s_isset; }, 'simple static (22)'), 1, 'simple static (22)'); ok ! $n; # simple static (23) ok(evcheck(sub { $n = $y->s_isset; }, 'simple static (24)'), 1, 'simple static (24)'); ok ! $n; # simple static (25) ok(evcheck(sub { $n = $x->s; }, 'simple static (26)'), 1, 'simple static (26)'); print STDERR Data::Dumper->Dump([$n], [qw($n)]) if $ENV{TEST_DEBUG}; ok ref($n), 'HASH', 'simple static (27)'; ok keys %$n, 0, 'simple static (28)'; ok(evcheck(sub { ($m, $n) = $y->s; }, 'simple static (29)'), 1, 'simple static (29)'); ok $m, undef, 'simple static (30)'; ok $n, undef, 'simple static (31)'; } # ------------------------------------- =head2 Tests 61--81: typed =cut { my $n; ok(evcheck(sub { package X; Class::MethodMaker->import([hash => [{ -type => 'File::stat' }, qw( st ), ]])}, 'typed ( 1)'), 1, 'typed ( 1)'); ok(evcheck(sub { $n = $x->st_isset; }, 'typed ( 2)'), 1, 'typed ( 2)'); ok ! $n; # typed ( 3) ok(evcheck(sub { $x->st(a => 4); }, 'typed ( 4)'), 0, 'typed ( 4)'); print STDERR Data::Dumper->Dump([$x], [qw($x)]) if $ENV{TEST_DEBUG}; ok(evcheck(sub { ($n) = $x->st; }, 'typed ( 5)'), 1, 'typed ( 5)'); print STDERR Data::Dumper->Dump([$x], [qw($x)]) if $ENV{TEST_DEBUG}; ok $n, undef, 'typed ( 6)'; ok(evcheck(sub { $n = $x->st_isset; }, 'typed ( 7)'), 1, 'typed ( 7)'); print STDERR Data::Dumper->Dump([$x], [qw($x)]) if $ENV{TEST_DEBUG}; ok ! $n; # typed ( 8) ok(evcheck(sub { $x->st(bin => undef); }, 'typed ( 9)'), 1, 'typed ( 9)'); ok(evcheck(sub { $n = $x->st_isset; }, 'typed (10)'), 1, 'typed (10)'); ok $n; # typed (11) ok(evcheck(sub { (undef, $n) = $x->st; }, 'typed (12)'), 1, 'typed (12)'); ok $n, undef, 'typed (13)'; my $stat1 = stat catfile($Bin,$Script); my $stat2 = stat $Bin; ok(evcheck(sub { $x->st(script => $stat1, bin => $stat2) }, 'typed (14)'), 1, 'typed (14)'); ok(evcheck(sub { $n = $x->st; }, 'typed (15)'), 1, 'typed (15)'); print STDERR Data::Dumper->Dump([$n], [qw($n)]) if $ENV{TEST_DEBUG}; ok ref($n), 'HASH', 'typed (16)'; ok keys %$n, 2, 'typed (17)'; ok $n->{script}, $stat1, 'typed (18)'; ok $n->{bin}, $stat2, 'typed (19)'; ok S_ISREG($n->{script}->mode), 1, 'typed (20)'; ok S_ISDIR($n->{bin}->mode), 1, 'typed (21)'; } # ------------------------------------- =head2 Tests 82--125: index =cut { my ($n, @n, %n); ok evcheck(sub { $x->a(a=>11,b=>12,c=>13); }, 'index ( 1)'), 1,'index ( 1)'; ok evcheck(sub { $n = $x->a_index('b') }, 'index ( 2)'), 1, 'index ( 2)'; print STDERR Data::Dumper->Dump([$n], [qw($n)]) if $ENV{TEST_DEBUG}; ok $n, 12, 'index ( 3)'; ok evcheck(sub { @n = $x->a_index(qw(c a)); }, 'index ( 4)'),1,'index ( 4)'; print STDERR Data::Dumper->Dump([$n], [qw($n)]) if $ENV{TEST_DEBUG}; ok @n, 2, 'index ( 5)'; ok $n[0], 13, 'index ( 6)'; ok $n[1], 11, 'index ( 7)'; # test lvalue of index # lvalue support has been dropped (I can't find a consistent way to support # it in the presence of read callbacks). ok(evcheck(sub { $x->a_set(2, 31) }, 'index ( 8)'), 1, 'index ( 8)'); ok evcheck(sub { @n = $x->a_index(2); }, 'index ( 9)'), 1, 'index ( 9)'; print STDERR Data::Dumper->Dump([\@n], [qw(@n)]) if $ENV{TEST_DEBUG}; ok @n, 1, 'index (10)'; ok $n[0], 31, 'index (11)'; # test index with multiple indices, also as lvalue # lvalue support has been dropped (I can't find a consistent way to support # it in the presence of read callbacks). ok(evcheck(sub { ($x->a_set(2, 23, 0, 21)) }, 'index (12)'), 1, 'index (12)'); ok evcheck(sub { @n = $x->a_index(0,1,2); }, 'index (13)'), 1, 'index (13)'; print STDERR Data::Dumper->Dump([\@n], [qw(@n)]) if $ENV{TEST_DEBUG}; ok @n, 3, 'index (14)'; ok $n[0], 21, 'index (15)'; ok $n[1], undef, 'index (16)'; ok $n[2], 23, 'index (17)'; # test lvalue with return value, with previously unseen index # lvalue support has been dropped (I can't find a consistent way to support # it in the presence of read callbacks). ok(evcheck(sub { @n = ($x->a_set(4, 42, 1, 45)) }, 'index (18)'), 1, 'index (18)'); if ( 0 ) { print STDERR Data::Dumper->Dump([\@n], [qw(@n)]) if $ENV{TEST_DEBUG}; ok @n, 2, 'index (19)'; ok $n[0], 42, 'index (20)'; ok $n[1], 45, 'index (21)'; } else { ok 1, 1, sprintf("index (%2d)", $_) for 19..21; } # check intermediate index not set ok(evcheck(sub { $n = $x->a_isset(3) }, 'index (22)'), 1, 'index (22)'); ok ! $n; # index (23) ok evcheck(sub { %n = $x->a }, 'index (24)'), 1, 'index (24)'; print STDERR Data::Dumper->Dump([\@n], [qw(@n)]) if $ENV{TEST_DEBUG}; ok keys %n, 7, 'index (25)'; ok $n{a}, 11, 'index (26)'; ok $n{c}, 13, 'index (27)'; ok $n{0}, 21, 'index (28)'; ok $n{1}, 45, 'index (29)'; ok $n{4}, 42, 'index (30)'; # check intermediate index still not set ok(evcheck(sub { $n = $x->a_isset(3) }, 'index (31)'), 1, 'index (31)'); ok ! $n; # index (32) if ( $ENV{_CMM_TEST_AV} ) { # test auto-vivication ok evcheck(sub { @n = $x->a_index(3, 0); }, 'index (33)'), 1,'index (33)'; print STDERR Data::Dumper->Dump([$n], [qw($n)]) if $ENV{TEST_DEBUG}; ok @n, 2, 'index (34)'; ok $n[0], undef, 'index (35)'; ok $n[1], 21, 'index (36)'; # check intermediate index not set (subr not used as lvalue) ok(evcheck(sub { $n = $x->a_isset(3) }, 'index (37)'), 1, 'index (37)'); ok ! $n; # index (38) ok(evcheck(sub { @n = $x->a_index(3, 0) = (); }, 'index (39)'), 1, 'index (39)'); print STDERR Data::Dumper->Dump([$n], [qw($n)]) if $ENV{TEST_DEBUG}; ok @n, 2, 'index (40)'; ok $n[0], undef, 'index (41)'; ok $n[1], undef, 'index (42)'; # check intermediate index now (subr used as lvalue) ok(evcheck(sub { $n = $x->a_isset(3) }, 'index (43)'), 1, 'index (43)'); ok $n; # index (44) } else { ok 1, 1, sprintf "index skip (%02d)", $_ for 33..44; } } # ------------------------------------- =head2 Tests 126--149: count =cut { my ($n, @n, %n); ok evcheck(sub {%n=$x->a(a=>11,b=>12,c=>13); },'count ( 1)'),1,'count ( 1)'; ok keys %n, 3, 'count ( 2)'; ok $n{a}, 11, 'count ( 3)'; ok $n{b}, 12, 'count ( 4)'; ok $n{c}, 13, 'count ( 5)'; ok evcheck(sub { $n = $x->a_count; }, 'count ( 6)'), 1, 'count ( 6)'; ok $n, 3, 'count ( 7)'; ok(evcheck(sub { %n = $x->a(qw(a 14 b 15 c 16 d 17)); }, 'count ( 8)'), 1, 'count ( 8)'); ok keys %n, 4, 'count ( 9)'; ok $n{a}, 14, 'count (10)'; ok $n{b}, 15, 'count (11)'; ok $n{c}, 16, 'count (12)'; ok $n{d}, 17, 'count (13)'; ok evcheck(sub { $n = $x->a_count; }, 'count (14)'), 1, 'count (14)'; ok $n, 4, 'count (15)'; # lvalue support has been dropped (I can't find a consistent way to support ok evcheck(sub { $x->a_set(8, 19); }, 'count (16)'), 1, 'count (16)'; ok evcheck(sub { $n = $x->a_count; }, 'count (17)'), 1, 'count (17)'; ok $n, 5, 'count (18)'; ok(evcheck(sub { @n = $x->a_index(7,8) }, 'count (19)'), 1, 'count (19)'); ok @n, 2, 'count (20)'; ok $n[0], undef, 'count (21)'; ok $n[1], 19, 'count (22)'; # check intermediate index still not set ok(evcheck(sub { $n = $x->a_isset(6) }, 'count (23)'), 1, 'count (23)'); ok ! $n # count (24) } # ------------------------------------- =head2 Tests 150--175: set =cut { my ($n, @n, %n); ok evcheck(sub {%n=$x->a(+{a=>11,b=>12,c=>13}); }, 'set ( 1)'),1,'set ( 1)'; ok keys %n, 3, 'set ( 2)'; ok $n{a}, 11, 'set ( 3)'; ok $n{b}, 12, 'set ( 4)'; ok $n{c}, 13, 'set ( 5)'; ok evcheck(sub { $n = $x->a_set(c=>14,d=>15); }, 'set ( 6)'), 1, 'set ( 6)'; ok $n, undef, 'set ( 7)'; ok(evcheck(sub { %n = $x->a; }, 'set ( 8)'), 1, 'set ( 8)'); ok keys %n, 4, 'set ( 9)'; ok $n{a}, 11, 'set (10)'; ok $n{b}, 12, 'set (11)'; ok $n{c}, 14, 'set (12)'; ok $n{d}, 15, 'set (13)'; ok evcheck(sub { $n = $x->a_count; }, 'set (14)'), 1, 'set (14)'; ok $n, 4, 'set (15)'; ok evcheck(sub {$n = $x->a_set([qw(a e)],[16,17])},'set (16)'),1,'set (16)'; ok $n, undef, 'set (17)'; ok(evcheck(sub { %n = $x->a; }, 'set (18)'), 1, 'set (18)'); ok keys %n, 5, 'set (19)'; ok $n{a}, 16, 'set (20)'; ok $n{b}, 12, 'set (21)'; ok $n{c}, 14, 'set (22)'; ok $n{d}, 15, 'set (23)'; ok $n{e}, 17, 'set (24)'; ok evcheck(sub { $n = $x->a_count; }, 'set (25)'), 1, 'set (25)'; ok $n, 5, 'set (26)'; } # ------------------------------------- =head2 Tests 176--274: default =cut { my ($n, %n); ok(evcheck(sub { package X; Class::MethodMaker->import([ hash => [{ -default => 7, }, qw( df1 ), ], ]); }, 'default ( 1)'), 1, 'default ( 1)'); print STDERR Data::Dumper->Dump([$n], [qw($n)]) if $ENV{TEST_DEBUG}; ok(evcheck(sub { $n = $x->df1_isset; }, 'default ( 2)'), 1, 'default ( 2)'); ok $n; # default ( 3) ok(evcheck(sub { $n = $x->df1_count; }, 'default ( 4)'), 1, 'default ( 4)'); ok $n, undef, 'default ( 5)'; ok(evcheck(sub { $n = $x->df1; }, 'default ( 6)'), 1, 'default ( 6)'); print STDERR Data::Dumper->Dump([$n], [qw($n)]) if $ENV{TEST_DEBUG}; ok ref($n), 'HASH', 'default ( 7)'; ok keys %$n, 0, 'default ( 8)'; # test index (since it has a different implementation with defaults) print STDERR Data::Dumper->Dump([$x], [qw($x)]) if $ENV{TEST_DEBUG}; ok evcheck(sub { $n = $x->df1_index(1) }, 'default ( 9)'), 1,'default ( 9)'; ok $n, 7, 'default (10)'; # check that item has been vivified print STDERR Data::Dumper->Dump([$x], [qw($x)]) if $ENV{TEST_DEBUG}; ok(evcheck(sub { $n = $x->df1_isset; }, 'default (11)'), 1, 'default (11)'); ok $n; # default (12) ok(evcheck(sub { $n = $x->df1_isset(0); }, 'default (13)'),1,'default (13)'); ok $n; # default (14) ok(evcheck(sub { $n = $x->df1_isset(1); }, 'default (15)'),1,'default (15)'); ok $n; # default (16) ok evcheck(sub { $n = $x->df1_count }, 'default (17)'), 1, 'default (17)'; ok $n, 1, 'default (18)'; # test reset (unset value) print STDERR Data::Dumper->Dump([$x], [qw($x)]) if $ENV{TEST_DEBUG}; ok evcheck(sub { $x->df1_reset(0) }, 'default (19)'), 1, 'default (19)'; ok(evcheck(sub { $n = $x->df1_isset; }, 'default (20)'), 1, 'default (20)'); ok $n; # default (21) ok(evcheck(sub { $n = $x->df1_isset(0); }, 'default (22)'),1,'default (22)'); ok $n; # default (23) ok(evcheck(sub { $n = $x->df1_isset(1); }, 'default (24)'),1,'default (24)'); ok $n; # default (25) ok evcheck(sub { $n = $x->df1_count }, 'default (26)'), 1, 'default (26)'; ok $n, 1, 'default (27)'; # test reset (set value) print STDERR Data::Dumper->Dump([$x], [qw($x)]) if $ENV{TEST_DEBUG}; ok evcheck(sub { $x->df1_reset(1) }, 'default (28)'), 1, 'default (28)'; ok(evcheck(sub { $n = $x->df1_isset; }, 'default (29)'), 1, 'default (29)'); ok $n; # default (30) ok(evcheck(sub { $n = $x->df1_isset(0); }, 'default (31)'),1,'default (31)'); ok $n; # default (32) ok(evcheck(sub { $n = $x->df1_isset(1); }, 'default (33)'),1,'default (33)'); ok $n; # default (34) ok evcheck(sub { $n = $x->df1_count }, 'default (35)'), 1, 'default (35)'; ok $n, 0, 'default (36)'; # check that x returns default for unset items ok evcheck(sub { $n = $x->df1_index(1) }, 'default (37)'), 1,'default (37)'; ok $n, 7, 'default (38)'; # check that such items are now set ok(evcheck(sub { $n = $x->df1_isset(0); }, 'default (39)'),1,'default (39)'); ok $n; # default (40) ok(evcheck(sub { $n = $x->df1_isset(1); }, 'default (41)'),1,'default (41)'); ok $n; # default (42) ok evcheck(sub { $n = $x->df1_count }, 'default (43)'), 1, 'default (43)'; ok $n, 1, 'default (44)'; # check this doesn't clobber undef items # lvalue support has been dropped (I can't find a consistent way to support # it in the presence of read callbacks). ok(evcheck(sub { $n = $x->df1_set(0, undef) }, 'default (45)'), 1, 'default (45)'); ok $n, undef, 'default (46)'; ok evcheck(sub { $n = $x->df1_index(0) }, 'default (47)'), 1,'default (47)'; ok $n, undef, 'default (48)'; ok(evcheck(sub { $n = $x->df1_isset(0); }, 'default (49)'),1,'default (49)'); ok $n; # default (50) ok(evcheck(sub { $n = $x->df1_isset(1); }, 'default (51)'),1,'default (51)'); ok $n; # default (52) ok evcheck(sub { $n = $x->df1_count }, 'default (53)'), 1, 'default (53)'; ok $n, 2, 'default (54)'; ok evcheck(sub { $x->df1_reset(0) }, 'default (55)'), 1, 'default (55)'; ok evcheck(sub { $x->df1_reset(1) }, 'default (56)'), 1, 'default (56)'; # set i2 to value, test i2 & i0 & i1 print STDERR Data::Dumper->Dump([$x], [qw($x)]) if $ENV{TEST_DEBUG}; # lvalue support has been dropped (I can't find a consistent way to support # it in the presence of read callbacks). ok evcheck(sub { $x->df1_set(2, 9) }, 'default (57)'), 1, 'default (57)'; print STDERR Data::Dumper->Dump([$x], [qw($x)]) if $ENV{TEST_DEBUG}; ok(evcheck(sub { $n = $x->df1_isset; }, 'default (58)'), 1, 'default (58)'); ok $n; # default (59) ok(evcheck(sub { $n = $x->df1_isset(0); }, 'default (60)'),1,'default (60)'); ok $n; # default (61) ok(evcheck(sub { $n = $x->df1_isset(1); }, 'default (62)'),1,'default (62)'); ok $n; # default (63) ok(evcheck(sub { $n = $x->df1_isset(2); }, 'default (64)'),1,'default (64)'); ok $n; # default (65) ok evcheck(sub { $n = $x->df1_count }, 'default (66)'), 1, 'default (66)'; ok $n, 1, 'default (67)'; ok evcheck(sub { $n = $x->df1_index(2) }, 'default (68)'), 1, 'default (68)'; ok $n, 9, 'default (69)'; # test reset (aggregate) ok evcheck(sub { $x->df1_reset }, 'default (70)'), 1, 'default (70)'; ok(evcheck(sub { $n = $x->df1_isset; }, 'default (71)'), 1, 'default (71)'); ok $n; # default (72) ok evcheck(sub { $n = $x->df1_count }, 'default (73)'), 1, 'default (73)'; ok $n, undef, 'default (74)'; ok(evcheck(sub { $n = $x->df1_isset(0); }, 'default (75)'),1,'default (75)'); ok $n; # default (76) ok(evcheck(sub { $n = $x->df1_isset(1); }, 'default (77)'),1,'default (77)'); ok $n; # default (78) ok(evcheck(sub { $n = $x->df1_isset(2); }, 'default (79)'),1,'default (79)'); ok $n; # default (80) # set value to empty # lvalue support has been dropped (I can't find a consistent way to support # it in the presence of read callbacks). ok evcheck(sub { $x->df1_set(2, undef)},'default (81)'),1,'default (81)'; ok(evcheck(sub { $n = $x->df1_isset; }, 'default (82)'), 1, 'default (82)'); ok $n; # default (83) ok(evcheck(sub { $n = $x->df1_isset(0); }, 'default (84)'),1,'default (84)'); ok $n; # default (85) ok(evcheck(sub { $n = $x->df1_isset(1); }, 'default (86)'),1,'default (86)'); ok $n; # default (87) ok(evcheck(sub { $n = $x->df1_isset(2); }, 'default (88)'),1,'default (88)'); ok $n; # default (89) ok evcheck(sub { $n = $x->df1_count }, 'default (90)'), 1, 'default (90)'; ok $n, 1, 'default (91)'; ok evcheck(sub { $n = $x->df1_index(2) }, 'default (92)'), 1,'default (92)'; ok $n, undef, 'default (93)'; ok evcheck(sub { $n = $x->df1_index(1) }, 'default (94)'), 1,'default (94)'; print STDERR Data::Dumper->Dump([$n], [qw($n)]) if $ENV{TEST_DEBUG}; ok $n, 7, 'default (95)'; ok evcheck(sub { %n = $x->df1 }, 'default (96)'), 1, 'default (96)'; ok keys %n, 2, 'default (97)'; ok $n{1}, 7, 'default (98)'; ok $n{2}, undef, 'default (99)'; } # ------------------------------------- =head2 Tests 275--295: default_ctor =cut { package Y; my $count = 0; sub new { my $class = shift; my $i = shift; my $self = @_ ? $_[0] : ++$count; return bless \$self, $class; } sub value { return ${$_[0]}; } sub reset { $count = 0; } } { my ($n, %n); ok(evcheck(sub { package X; Class::MethodMaker->import([hash => [{ -type => 'Y', -default_ctor => 'new', }, qw( df2 ), { -type => 'Y', -default_ctor => sub { Y->new(undef,-3); }, }, qw( df3 ), ], ]); }, 'default ( 1)'), 1, 'default_ctor ( 1)'); ok(evcheck(sub { $n = $x->df2_isset; }, 'default_ctor( 2)'), 1, 'default_ctor ( 2)'); ok $n; # default_ctor ( 3) ok(evcheck(sub { $n = $x->df2_index(1)->value; }, 'default_ctor( 4)'), 1, 'default_ctor ( 4)'); ok $n, 1, 'default_ctor ( 5)'; # This actually creates two Y instances; one explictly, and one not implictly # by the _index method defaulting one (since it can't see the incoming) # XXX not anymore XXX # lvalue support has been dropped (I can't find a consistent way to support # it in the presence of read callbacks). ok(evcheck(sub { $x->df2_set(2, Y->new); }, 'default_ctor( 6)'), 1, 'default_ctor ( 6)'); ok(evcheck(sub { $n = $x->df2_index(2)->value; }, 'default_ctor( 7)'), 1, 'default_ctor ( 7)'); ok $n, 2, 'default_ctor ( 8)'; ok(evcheck(sub { $x->df2_reset; },'default_ctor( 9)'), 1, 'default_ctor ( 9)'); ok(evcheck(sub { $n = $x->df2_isset; }, 'default_ctor(10)'), 1, 'default_ctor (10)'); ok $n; # default_ctor (11) ok(evcheck(sub { $n = $x->df2_index(2)->value; }, 'default_ctor(12)'), 1, 'default_ctor (12)'); ok $n, 3, 'default_ctor (13)'; ok(evcheck(sub { $n = $x->df3_isset; }, 'default_ctor(14)'), 1, 'default_ctor (14)'); ok $n; # default_ctor (15) ok(evcheck(sub { $n = $x->df3_index(2)->value; }, 'default_ctor(16)'), 1, 'default_ctor (16)'); ok $n, -3, 'default_ctor (17)'; ok evcheck(sub { %n = $x->df2 }, 'default_ctor (18)'),1,'default_ctor (18)'; ok keys %n, 1, 'default_ctor (19)'; ok ref($n{2}), 'Y', 'default_ctor (20)'; ok $n{2}->value, 3, 'default_ctor (21)'; } # ------------------------------------- =head2 Tests 296--320: forward =cut { my ($n, @n, %n); ok(evcheck(sub { package X; Class::MethodMaker->import([hash => [{ -type => 'File::stat', -forward => [qw/ mode size /], }, qw( st1 ), # Keeping the second call # here ensures that we check # that mode, size are # forwarded to st1 { -type => 'IO::Handle', -forward => 'read', }, qw( st2 ), ]])}, 'forward ( 1)'), 1, 'forward ( 1)'); ok(evcheck(sub { $n = $x->st1_isset; }, 'forward ( 2)'), 1, 'forward ( 2)'); ok ! $n; # forward ( 3) ok(evcheck(sub { $x->st1(a=>4); }, 'forward ( 4)'), 0, 'forward ( 4)'); ok(evcheck(sub { @n = $x->st1; }, 'forward ( 5)'), 1, 'forward ( 5)'); ok @n, 0, 'forward ( 6)'; ok(evcheck(sub { $n = $x->st1_isset; }, 'forward ( 7)'), 1, 'forward ( 7)'); ok ! $n; # forward ( 8) ok(evcheck(sub { $x->st1(b=>undef); }, 'forward ( 9)'), 1, 'forward ( 9)'); ok(evcheck(sub { $n = $x->st1_isset; }, 'forward (10)'), 1, 'forward (10)'); ok $n; # forward (11) ok(evcheck(sub { @n = $x->st1; }, 'forward (12)'), 1, 'forward (12)'); ok @n, 2, 'forward (13)'; ok $n[1], undef, 'forward (14)'; ok(evcheck(sub { $x->st1_set(script=>stat(catfile($Bin,$Script)), bin =>stat(catfile($Bin))) }, 'forward (15)'), 1, 'forward (15)'); print STDERR Data::Dumper->Dump([$x],[qw(x)]) if $ENV{TEST_DEBUG}; print STDERR B::Deparse->new('-p', '-sC')->coderef2text(\&X::mode), "\n" if $ENV{TEST_DEBUG}; ok(evcheck(sub { %n = $x->mode; }, 'forward (16)'), 1, 'forward (16)'); print STDERR Data::Dumper->Dump([\%n],[qw(n)]) if $ENV{TEST_DEBUG}; ok keys %n, 3, 'forward (17)'; ok S_ISREG($n{script}), 1, 'forward (18)'; ok S_ISDIR($n{bin}), 1, 'forward (19)'; ok exists $n{b}; # forward (20) ok ! defined $n{b}; # forward (21) ok(evcheck(sub { $n = $x->size; }, 'forward (22)'), 1, 'forward (22)'); ok ref $n, 'HASH', 'forward (23)'; ok keys %$n, 3, 'forward (24)'; { sysopen my $fh, catfile($Bin,$Script), O_RDONLY; local $/ = undef; my $text = <$fh>; close $fh; ok $n->{script}, length($text), 'forward (25)'; } } # ------------------------------------- =head2 Tests 321--323: forward_args =cut { my $n; # Instantiate st2 as IO::File, which is a subclass of IO::Handle. This # should be fine ok(evcheck(sub { $x->st2(script => IO::File->new(catfile($Bin,$Script))) }, 'forward_args ( 1)'), 1, 'forward_args ( 1)'); ok(evcheck(sub { $x->read($n, 30); }, 'forward_args ( 2)'), 1, 'forward_args ( 2)'); ok $n, '# (X)Emacs mode: -*- cperl -*-', 'forward_args ( 3)'; } # ------------------------------------- =head2 Tests 324--364: manipulate =cut { my ($n, @n, %n, @p); ok(evcheck(sub {$x->a(a=>11,b=>12,c=>13); }, 'manipulate ( 1)'),1, 'manipulate ( 1)'); ok(evcheck(sub { @n = sort $x->a_keys }, 'manipulate ( 2)'), 1, 'manipulate ( 2)'); ok @n, 3, 'manipulate ( 3)'; ok $n[0], 'a', 'manipulate ( 4)'; ok $n[1], 'b', 'manipulate ( 5)'; ok $n[2], 'c', 'manipulate ( 6)'; ok(evcheck(sub { $n = $x->a_keys }, 'manipulate ( 7)'), 1, 'manipulate ( 7)'); ok @$n, 3, 'manipulate ( 8)'; @p = sort @$n; ok $p[0], 'a', 'manipulate ( 9)'; ok $p[1], 'b', 'manipulate (10)'; ok $p[2], 'c', 'manipulate (11)'; ok(evcheck(sub { @n = sort {$a<=>$b} $x->a_values }, 'manipulate (12)'), 1, 'manipulate (12)'); ok @n, 3, 'manipulate (13)'; ok $n[0], 11, 'manipulate (14)'; ok $n[1], 12, 'manipulate (15)'; ok $n[2], 13, 'manipulate (16)'; ok(evcheck(sub { $n = $x->a_values }, 'manipulate (17)'), 1, 'manipulate (17)'); ok @$n, 3, 'manipulate (18)'; @p = sort {$a<=>$b} @$n; ok $p[0], 11, 'manipulate (19)'; ok $p[1], 12, 'manipulate (20)'; ok $p[2], 13, 'manipulate (21)'; ok(evcheck(sub { while(my($k,$v)=$x->a_each){$n{$v}=$k} }, 'manipulate (22)'), 1, 'manipulate (22)'); ok keys %n, 3, 'manipulate (23)'; ok $n{11}, 'a', 'manipulate (24)'; ok $n{12}, 'b', 'manipulate (25)'; ok $n{13}, 'c', 'manipulate (26)'; ok(evcheck(sub { $n = $x->a_exists('a') }, 'manipulate (27)'), 1, 'manipulate (27)'); ok $n, 1, 'manipulate (28)'; ok(evcheck(sub { $n = $x->a_exists('a', 'c') }, 'manipulate (29)'), 1, 'manipulate (30)'); ok $n, 1, 'manipulate (31)'; ok(evcheck(sub { $n = $x->a_exists('d') }, 'manipulate (31)'), 1, 'manipulate (32)'); ok $n, undef, 'manipulate (30)'; ok(evcheck(sub { $n = $x->a_exists('a', 'd') }, 'manipulate (33)'), 1, 'manipulate (33)'); ok $n, undef, 'manipulate (34)'; ok(evcheck(sub { $n = $x->a_delete('b') }, 'manipulate (35)'), 1, 'manipulate (35)'); ok(evcheck(sub { %n = $x->a }, 'manipulate (36)'), 1, 'manipulate (36)'); ok keys %n, 2, 'manipulate (37)'; @p = sort keys %n; ok $p[0], 'a', 'manipulate (38)'; ok $p[1], 'c', 'manipulate (39)'; ok(evcheck(sub { $n = $x->a_delete() }, 'manipulate (40)'), 1, 'manipulate (40)'); ok keys %n, 2, 'manipulate (41)'; } # ------------------------------------- =head2 Tests 365-405: tie =cut { # @z is an audit trail my @z; package Z; use Tie::Hash; use base qw( Tie::StdHash ); sub TIEHASH { push @z, [ 'TIEHASH' ]; $_[0]->SUPER::TIEHASH } sub FETCH { push @z, [ FETCH => $_[1] ]; $_[0]->SUPER::FETCH($_[1]) } sub STORE { push @z, [ STORE => @_[1,2]]; $_[0]->SUPER::STORE(@_[1,2]) } # Strangely, Tie::StdHash doesn't have a DESTROY method sub DESTROY { push @z, [ 'DESTROY' ]; } #$_[0]->SUPER::DESTROY } package main; ok(evcheck(sub { package X; Class::MethodMaker->import([hash => [{ -type => 'File::stat', -tie_class => 'Z', -forward => [qw/ mode size /], }, qw( tie1 ), ]])}, 'tie ( 1)'), 1, 'tie ( 1)'); bless ((my $x = {}), 'X'); ok @z, 0, 'tie ( 2)'; my $stat1 = stat catfile($Bin,$Script); my $stat2 = stat $Bin; $x->tie1_set(script => $stat1); ok @z, 2, 'tie ( 3)'; ok $z[0][0], 'TIEHASH', 'tie ( 4)'; ok $z[1][0], 'STORE' , 'tie ( 5)'; ok $z[1][1], 'script' , 'tie ( 6)'; ok $z[1][2], $stat1 , 'tie ( 7)'; my $y; ok evcheck(sub { $y = $x->tie1_index('script') }, 'tie ( 8)'), 1,'tie ( 8)'; ok $y, $stat1, 'tie ( 9)'; ok @z, 3, 'tie (10)'; ok $z[2][0], 'FETCH', 'tie (11)'; ok $z[2][1], 'script', 'tie (12)'; ok evcheck(sub { $y = $x->tie1_index(2) }, 'tie (13)'), 1, 'tie (13)'; ok $y, undef, 'tie (14)'; ok @z, 4, 'tie (15)'; ok $z[3][0], 'FETCH', 'tie (16)'; ok $z[3][1], 2, 'tie (17)'; ok evcheck(sub { $x->tie1_set('bin', $stat2) }, 'tie (18)'), 1, 'tie (18)'; ok @z, 5, 'tie (19)'; ok $z[4][0], 'STORE', 'tie (20)'; ok $z[4][1], 'bin', 'tie (21)'; ok $z[4][2], $stat2, 'tie (22)'; ok evcheck(sub { $y = $x->tie1 }, 'tie (23)'), 1, 'tie (23)'; ok ref $y, 'HASH', 'tie (24)'; ok keys %$y, 2, 'tie (25)'; ok $y->{script}, $stat1, 'tie (26)'; ok $y->{bin}, $stat2, 'tie (27)'; ok @z, 7, 'tie (28)'; ok $z[$_][0], 'FETCH', sprintf 'tie (%02d)', $_+24 for 5..6; my @x = sort $z[5][1], $z[6][1]; ok $x[0], 'bin', 'tie (31)'; ok $x[1], 'script', 'tie (32)'; ok evcheck(sub { $x->tie1_reset }, 'tie (33)'), 1, 'tie (33)'; ok @z, 8, 'tie (34)'; ok $z[7][0], 'DESTROY', 'tie (35)'; ok evcheck(sub { $y = $x->tie1_count }, 'tie (36)'), 1, 'tie (36)'; ok $y, undef, 'tie (37)'; ok @z, 8, 'tie (38)'; ok evcheck(sub { $y = $x->tie1_index(2) }, 'tie (39)'), 1, 'tie (39)'; ok $y, undef, 'tie (40)'; ok @z, 8, 'tie (41)'; # Beware that indexing items off the end of @z above will auto-vivify the # corresponding entries, so if you see empty members of @z, that's possibly # the cause print Dumper \@z, $x if $ENV{TEST_DEBUG}; } # ------------------------------------- =head2 Tests 406-409 : void set Check that calling a(), with no arguments, doesn't instantiate a new instance (in all contexts). =cut { my $x = bless {}, 'X'; ok ! $x->a_isset; $x->a(); ok ! $x->a_isset; my @a = $x->a(); ok ! $x->a_isset; my $a = $x->a(); ok ! $x->a_isset; } # ------------------------------------- =head2 Tests 410--426 : clear =cut { my $n; ok(evcheck(sub { $x->a_reset; }, 'clear ( 1)'), 1, 'clear ( 1)'); ok(evcheck(sub { $n = $x->a_isset; }, 'clear ( 1)'), 1, 'clear ( 2)'); ok ! $n; # clear ( 3) ok(evcheck(sub { $x->a(a => 4, b => 5); }, 'clear ( 3)'), 1, 'clear ( 4)'); ok(evcheck(sub { $x->a_clear('a'); }, 'clear ( 4)'), 1, 'clear ( 5)'); ok(evcheck(sub { $n = $x->a; }, 'clear ( 5)'), 1, 'clear ( 6)'); ok keys %$n, 2, 'clear ( 7)'; ok exists $n->{a}; # clear ( 8) ok exists $n->{b}; # clear ( 9) ok $n->{a}, undef, 'clear (10)'; ok $n->{b}, 5, 'clear (11)'; ok(evcheck(sub { $x->a(a=>4,b=>5,c=>6); }, 'clear (11)'), 1, 'clear (12)'); ok(evcheck(sub { $x->a_clear; }, 'clear (12)'), 1, 'clear (13)'); ok(evcheck(sub { $n = $x->a; }, 'clear (13)'), 1, 'clear (14)'); ok keys %$n, 0, 'clear (15)'; ok(evcheck(sub { $n = $x->a_isset('a'); }, 'clear (15)'), 1, 'clear (16)'); ok ! $n; # clear (17) } # ------------------------------------- =head2 Tests 427--439: default_ctor (arg) =cut { package S; my $count = 0; sub new { my ($class, $arg) = @_; my $self = $arg->a_index("a"); return bless \$self, $class; } sub value { return ${$_[0]}; } sub reset { $count = 0; } } { my ($n, %n); ok(evcheck(sub { package X; Class::MethodMaker->import([hash => [{ -type => 'S', -default_ctor => 'new', }, qw( dfx ), ], ]); }, 'default ( 1)'), 1, 'default_ctor (arg) ( 1)'); ok(evcheck(sub { $n = $x->dfx_isset; }, 'default_ctor (arg)( 2)'), 1, 'default_ctor (arg) ( 2)'); ok $n; # default_ctor (arg) ( 3) $x->a(a=>3); ok(evcheck(sub { $n = $x->dfx_index(1)->value; }, 'default_ctor (arg)( 4)'), 1, 'default_ctor (arg) ( 4)'); ok $n, 3, 'default_ctor (arg) ( 5)'; # This actually creates two Y instances; one explictly, and one not implictly # by the _index method defaulting one (since it can't see the incoming) # XXX not anymore XXX # lvalue support has been dropped (I can't find a consistent way to support # it in the presence of read callbacks). my $xx = bless {}, 'X'; $xx->a(a=>2); ok(evcheck(sub { $x->dfx_set(2, S->new($xx)); }, 'default_ctor (arg)( 6)'), 1, 'default_ctor (arg) ( 6)'); ok(evcheck(sub { $n = $x->dfx_index(2)->value; }, 'default_ctor (arg)( 7)'), 1, 'default_ctor (arg) ( 7)'); ok $n, 2, 'default_ctor (arg) ( 8)'; ok(evcheck(sub { $x->dfx_reset; },'default_ctor (arg)( 9)'), 1, 'default_ctor (arg) ( 9)'); ok(evcheck(sub { $n = $x->dfx_isset; }, 'default_ctor (arg)(10)'), 1, 'default_ctor (arg) (10)'); ok $n; # default_ctor (arg) (11) ok(evcheck(sub { $n = $x->dfx_index(2)->value; }, 'default_ctor (arg)(12)'), 1, 'default_ctor (arg) (12)'); ok $n, 3, 'default_ctor (arg) (13)'; } # ------------------------------------- # _get # _set # _isset(n) _isset(n,m,l) # _reset(n) _reset(n,m,l) # _setref # _grep # _map # _for # _areset # ---------------------------------------------------------------------------- Class-MethodMaker-2.24/t/new.t0000644000175000017500000001052611735360552014146 0ustar ss5ss5# (X)Emacs mode: -*- cperl -*- use strict; =head1 Unit Test Package for Class::MethodMaker This package tests the scalar type of Class::MethodMaker =cut use FindBin 1.42 qw( $Bin $Script ); use Test 1.13 qw( ok plan ); use lib $Bin; use test qw( evcheck ); BEGIN { plan tests => 32, todo => [], } # ---------------------------------------------------------------------------- =head2 Test 1: compilation This test confirms that the test script and the modules it calls compiled successfully. =cut package X; use Class::MethodMaker [ new => 'new', new => [qw/ -hash new_hash_init /], new => [qw/ -init new_with_init -hash new_both /], ]; my @args_in_init; my $foo_called; my $bar_called; sub init { my ($self, @args) = @_; @args_in_init = @args; } sub foo { my ($self, $new) = @_; defined $new and $self->{'foo'} = $new; $foo_called = 1; $self->{'foo'}; } sub bar { my ($self, $new) = @_; defined $new and $self->{'bar'} = $new; $bar_called = 1; $self->{'bar'}; } package main; ok 1, 1, 'compilation'; # ------------------------------------- =head Tests 2--3: new =cut { my $o; ok evcheck(sub { $o = new X; }, 'new ( 1)'), 1, 'new ( 1)'; ok ref $o, 'X', 'new ( 2)'; } # ------------------------------------- =head Tests 4--9: new_with_init =cut { my $o; my @args = (1, 2, 3); ok(evcheck(sub { $o = X->new_with_init(@args) }, 'new_with_init ( 1)'), 1, 'new_with_init ( 1)'); ok ref $o, 'X', 'new_with_init ( 2)'; ok $#args_in_init, $#args, 'new_with_init ( 3)'; ok $args_in_init[$_], $args[$_], sprintf('new_with_init (%2d)', $_+4) for 0..$#args; @args_in_init = (); } # ------------------------------------- =head Tests 10--15: new_hash_init =cut { my $o; ok(evcheck(sub { $o = X->new_hash_init( 'foo' => 123, 'bar' => 456 ) }, 'new_hash_init ( 1)'), 1, 'new_hash_init ( 1)'); ok ref $o, 'X', 'new_hash_init ( 2)'; ok $foo_called, 1, 'new_hash_init ( 3)'; ok $bar_called, 1, 'new_hash_init ( 4)'; ok $o->foo, 123, 'new_hash_init ( 5)'; ok $o->bar, 456, 'new_hash_init ( 6)'; $foo_called = 0; $bar_called = 0; } # ------------------------------------- =head Tests 16--21: new_hash_init (taking hashref) =cut { my $o; $foo_called = 0; $bar_called = 0; ok(evcheck(sub { $o = X->new_hash_init({ 'foo' => 111, 'bar' => 444 }) }, 'new_hash_init (taking hashref) ( 1)'), 1, 'new_hash_init (taking hashref) ( 1)'); ok ref $o, 'X', 'new_hash_init (taking hashref) ( 2)'; ok $foo_called, 1, 'new_hash_init (taking hashref) ( 3)'; ok $bar_called, 1, 'new_hash_init (taking hashref) ( 4)'; ok $o->foo, 111, 'new_hash_init (taking hashref) ( 5)'; ok $o->bar, 444, 'new_hash_init (taking hashref) ( 6)'; $foo_called = 0; $bar_called = 0; } # ------------------------------------- =head Tests 22--32: new_hash_init (with init) =cut { my $o; my @args = ('foo' => 987, 'bar' => 654); ok(evcheck(sub { $o = X->new_both(@args) }, 'new_hash_init (with init) ( 1)'), 1, 'new_hash_init (with init) ( 1)'); ok ref $o, 'X', 'new_hash_init (with init) ( 2)'; ok $foo_called, 1, 'new_hash_init (with init) ( 3)'; ok $bar_called, 1, 'new_hash_init (with init) ( 4)'; ok $o->foo, 987, 'new_hash_init (with init) ( 5)'; ok $o->bar, 654, 'new_hash_init (with init) ( 6)'; ok $#args_in_init, $#args, 'new_hash_init (with init) ( 7)'; ok($args_in_init[$_], $args[$_], sprintf('new_hash_init (with init) (%2d)', $_+8)) for 0..$#args; $foo_called = 0; $bar_called = 0; @args_in_init = (); } # ---------------------------------------------------------------------------- Class-MethodMaker-2.24/t/array.t0000644000175000017500000014741711735360552014505 0ustar ss5ss5# (X)Emacs mode: -*- cperl -*- use strict; =head1 Unit Test Package for Class::MethodMaker This package tests the array type of Class::MethodMaker =cut use B::Deparse 0.59 qw( ); use Data::Dumper qw( Dumper ); use Fcntl 1.03 qw( :DEFAULT ); use File::Spec::Functions qw( catfile ); use File::stat qw( stat ); use FindBin 1.42 qw( $Bin $Script ); use IO::File 1.08 qw( ); use POSIX 1.03 qw( S_ISDIR S_ISREG ); use Test 1.13 qw( ok plan skip ); use lib $Bin; use test qw( evcheck ); BEGIN { # 1 for compilation test, plan tests => 438, todo => [], } # ---------------------------------------------------------------------------- =head2 Test 1: compilation This test confirms that the test script and the modules it calls compiled successfully. =cut package X; use Class::MethodMaker [ array => [qw/ a b -static s /], ]; package main; ok 1, 1, 'compilation'; # ------------------------------------- =head2 Tests 2--3: bless =cut my ($x, $y); ok evcheck(sub { $x = bless {}, 'X'; }, 'bless ( 1)'), 1, 'bless ( 1)'; ok evcheck(sub { $y = bless {}, 'X'; }, 'bless ( 2)'), 1, 'bless ( 2)'; # ------------------------------------- =head2 Tests 4--28: simple non-static =cut { my $n; ok(evcheck(sub { $n = $x->a_isset; }, 'simple non-static ( 1)'), 1, 'simple non-static ( 1)'); ok ! $n; # simple non-static ( 2) ok(evcheck(sub { $n = $x->b_isset; }, 'simple non-static ( 3)'), 1, 'simple non-static ( 3)'); ok ! $n; # simple non-static ( 4) ok(evcheck(sub { $x->a(4); }, 'simple non-static ( 5)'), 1, 'simple non-static ( 5)'); ok(evcheck(sub { ($n) = $x->a; }, 'simple non-static ( 6)'), 1, 'simple non-static ( 6)'); ok $n, 4, 'simple non-static ( 7)'; ok(evcheck(sub { ($n) = $x->a(7); }, 'simple non-static ( 8)'), 1, 'simple non-static ( 8)'); ok $n, 7, 'simple non-static ( 9)'; ok(evcheck(sub { $n = $x->a_isset; }, 'simple non-static (10)'), 1, 'simple non-static (10)'); ok $n; # simple non-static (11) ok(evcheck(sub { $n = $x->b_isset; }, 'simple non-static (12)'), 1, 'simple non-static (12)'); ok ! $n; # simple non-static (13) ok(evcheck(sub { $n = $x->a(7); }, 'simple non-static (14)'), 1, 'simple non-static (14)'); print STDERR Data::Dumper->Dump([$n], [qw($n)]) if $ENV{TEST_DEBUG}; ok ref($n), 'ARRAY', 'simple non-static (15)'; ok @$n, 1, 'simple non-static (16)'; ok $n->[0], 7, 'simple non-static (17)'; ok(evcheck(sub { $n = $x->a_reset; }, 'simple non-static (18)'), 1, 'simple non-static (18)'); ok(evcheck(sub { $n = $x->a_isset; }, 'simple non-static (19)'), 1, 'simple non-static (19)'); ok ! $n; # simple non-static (20) ok(evcheck(sub { $n = $x->a; }, 'simple non-static (21)'), 1, 'simple non-static (21)'); print STDERR Data::Dumper->Dump([$n], [qw($n)]) if $ENV{TEST_DEBUG}; ok ref($n), 'ARRAY', 'simple non-static (22)'; ok @$n, 0, 'simple non-static (23)'; ok(evcheck(sub { $n = $x->a_isset; }, 'simple non-static (24)'), 1, 'simple non-static (24)'); ok ! $n; # simple non-static (25) } # ------------------------------------- =head2 Tests 29--59: simple static =cut { my ($m, $n); ok(evcheck(sub { $n = $x->s_isset; }, 'simple static ( 1)'), 1, 'simple static ( 1)'); ok ! $n; # simple static ( 2) ok(evcheck(sub { $n = $y->s_isset; }, 'simple static ( 3)'), 1, 'simple static ( 3)'); ok ! $n; # simple static ( 4) ok(evcheck(sub { $x->s(14, 17); }, 'simple static ( 5)'), 1, 'simple static ( 5)'); ok(evcheck(sub { $n = $x->s_isset; }, 'simple static ( 6)'), 1, 'simple static ( 6)'); ok $n; # simple static ( 7) ok(evcheck(sub { $n = $y->s_isset; }, 'simple static ( 8)'), 1, 'simple static ( 8)'); ok $n; # simple static ( 9) ok(evcheck(sub { ($m, $n) = $x->s; }, 'simple static (10)'), 1, 'simple static (10)'); ok $m, 14, 'simple static (11)'; ok $n, 17, 'simple static (12)'; ok(evcheck(sub { ($m, $n) = $y->s; }, 'simple static (13)'), 1, 'simple static (13)'); ok $m, 14, 'simple static (14)'; ok $n, 17, 'simple static (15)'; ok(evcheck(sub { $n = $y->s; }, 'simple static (16)'), 1, 'simple static (16)'); print STDERR Data::Dumper->Dump([$n], [qw($n)]) if $ENV{TEST_DEBUG}; ok ref($n), 'ARRAY', 'simple static (17)'; ok @$n, 2, 'simple static (18)'; ok $n->[0], 14, 'simple static (19)'; ok $n->[1], 17, 'simple static (20)'; ok(evcheck(sub { $n = $y->s_reset; }, 'simple static (21)'), 1, 'simple static (21)'); ok(evcheck(sub { $n = $x->s_isset; }, 'simple static (22)'), 1, 'simple static (22)'); ok ! $n; # simple static (23) ok(evcheck(sub { $n = $y->s_isset; }, 'simple static (24)'), 1, 'simple static (24)'); ok ! $n; # simple static (25) ok(evcheck(sub { $n = $x->s; }, 'simple static (26)'), 1, 'simple static (26)'); print STDERR Data::Dumper->Dump([$n], [qw($n)]) if $ENV{TEST_DEBUG}; ok ref($n), 'ARRAY', 'simple static (27)'; ok @$n, 0, 'simple static (28)'; ok(evcheck(sub { ($m, $n) = $y->s; }, 'simple static (29)'), 1, 'simple static (29)'); ok $m, undef, 'simple static (30)'; ok $n, undef, 'simple static (31)'; } # ------------------------------------- =head2 Tests 60--80: typed =cut { my $n; ok(evcheck(sub { package X; Class::MethodMaker->import([array => [{ -type => 'File::stat' }, qw( st ), ]])}, 'typed ( 1)'), 1, 'typed ( 1)'); ok(evcheck(sub { $n = $x->st_isset; }, 'typed ( 2)'), 1, 'typed ( 2)'); ok ! $n; # typed ( 3) ok(evcheck(sub { $x->st(4); }, 'typed ( 4)'), 0, 'typed ( 4)'); print STDERR Data::Dumper->Dump([$x], [qw($x)]) if $ENV{TEST_DEBUG}; ok(evcheck(sub { ($n) = $x->st; }, 'typed ( 5)'), 1, 'typed ( 5)'); print STDERR Data::Dumper->Dump([$x], [qw($x)]) if $ENV{TEST_DEBUG}; ok $n, undef, 'typed ( 6)'; ok(evcheck(sub { $n = $x->st_isset; }, 'typed ( 7)'), 1, 'typed ( 7)'); print STDERR Data::Dumper->Dump([$x], [qw($x)]) if $ENV{TEST_DEBUG}; ok ! $n; # typed ( 8) ok(evcheck(sub { $x->st(undef); }, 'typed ( 9)'), 1, 'typed ( 9)'); ok(evcheck(sub { $n = $x->st_isset; }, 'typed (10)'), 1, 'typed (10)'); ok $n; # typed (11) ok(evcheck(sub { ($n) = $x->st; }, 'typed (12)'), 1, 'typed (12)'); ok $n, undef, 'typed (13)'; my $stat1 = stat catfile($Bin,$Script); my $stat2 = stat $Bin; ok(evcheck(sub { $x->st($stat1, $stat2) }, 'typed (14)'), 1, 'typed (14)'); ok(evcheck(sub { $n = $x->st; }, 'typed (15)'), 1, 'typed (15)'); print STDERR Data::Dumper->Dump([$n], [qw($n)]) if $ENV{TEST_DEBUG}; ok ref($n), 'ARRAY', 'typed (16)'; ok @$n, 2, 'typed (17)'; ok $n->[0], $stat1, 'typed (18)'; ok $n->[1], $stat2, 'typed (19)'; ok S_ISREG($n->[0]->mode), 1, 'typed (20)'; ok S_ISDIR($n->[1]->mode), 1, 'typed (21)'; } # ------------------------------------- =head2 Tests 81--124: index =cut { my ($n, @n); ok evcheck(sub { $x->a(11, 12, 13); }, 'index ( 1)'), 1, 'index ( 1)'; ok evcheck(sub { $n = $x->a_index(1) }, 'index ( 2)'), 1, 'index ( 2)'; print STDERR Data::Dumper->Dump([$n], [qw($n)]) if $ENV{TEST_DEBUG}; ok $n, 12, 'index ( 3)'; ok evcheck(sub { @n = $x->a_index(2, 0); }, 'index ( 4)'), 1, 'index ( 4)'; print STDERR Data::Dumper->Dump([$n], [qw($n)]) if $ENV{TEST_DEBUG}; ok @n, 2, 'index ( 5)'; ok $n[0], 13, 'index ( 6)'; ok $n[1], 11, 'index ( 7)'; # lvalue support has been dropped (I can't find a consistent way to support # it in the presence of read callbacks). ok(evcheck(sub { $x->a_set(2, 31) }, 'index ( 8)'), 1, 'index ( 8)'); ok evcheck(sub { @n = $x->a_index(2); }, 'index ( 9)'), 1, 'index ( 9)'; print STDERR Data::Dumper->Dump([\@n], [qw(@n)]) if $ENV{TEST_DEBUG}; ok @n, 1, 'index (10)'; ok $n[0], 31, 'index (11)'; # lvalue support has been dropped (I can't find a consistent way to support # it in the presence of read callbacks). ok(evcheck(sub { ($x->a_set(2, 23, 0, 21)) }, 'index (12)'), 1, 'index (12)'); ok evcheck(sub { @n = $x->a_index(0,1,2); }, 'index (13)'), 1, 'index (13)'; print STDERR Data::Dumper->Dump([\@n], [qw(@n)]) if $ENV{TEST_DEBUG}; ok @n, 3, 'index (14)'; ok $n[0], 21, 'index (15)'; ok $n[1], 12, 'index (16)'; ok $n[2], 23, 'index (17)'; # lvalue support has been dropped (I can't find a consistent way to support # it in the presence of read callbacks). ok(evcheck(sub { @n = ($x->a_set(4, 42, 1, 45)) }, 'index (18)'), 1, 'index (18)'); if ( 0 ) { print STDERR Data::Dumper->Dump([\@n], [qw(@n)]) if $ENV{TEST_DEBUG}; ok @n, 2, 'index (19)'; ok $n[0], 42, 'index (20)'; ok $n[1], 45, 'index (21)'; } else { ok 1, 1, sprintf('index (%2d)', $_) for 19..21; } # check intermediate index not set ok(evcheck(sub { $n = $x->a_isset(3) }, 'index (22)'), 1, 'index (22)'); ok ! $n; # index (23) ok evcheck(sub { @n = $x->a }, 'index (24)'), 1, 'index (24)'; print STDERR Data::Dumper->Dump([\@n], [qw(@n)]) if $ENV{TEST_DEBUG}; ok @n, 5, 'index (25)'; ok $n[0], 21, 'index (26)'; ok $n[1], 45, 'index (27)'; ok $n[2], 23, 'index (28)'; ok $n[3], undef, 'index (29)'; ok $n[4], 42, 'index (30)'; # check intermediate index still not set ok(evcheck(sub { $n = $x->a_isset(3) }, 'index (31)'), 1, 'index (31)'); ok ! $n; # index (32) if ( $ENV{_CMM_TEST_AV} ) { # test auto-vivication ok evcheck(sub { @n = $x->a_index(3, 0); }, 'index (33)'), 1,'index (33)'; print STDERR Data::Dumper->Dump([$n], [qw($n)]) if $ENV{TEST_DEBUG}; ok @n, 2, 'index (34)'; ok $n[0], undef, 'index (35)'; ok $n[1], 21, 'index (36)'; # check intermediate index not set (subr not used as lvalue) ok(evcheck(sub { $n = $x->a_isset(3) }, 'index (37)'), 1, 'index (37)'); ok ! $n; # index (38) ok(evcheck(sub { @n = $x->a_index(3, 0) = (); }, 'index (39)'), 1, 'index (39)'); print STDERR Data::Dumper->Dump([$n], [qw($n)]) if $ENV{TEST_DEBUG}; ok @n, 2, 'index (40)'; ok $n[0], undef, 'index (41)'; ok $n[1], undef, 'index (42)'; # check intermediate index now (subr used as lvalue) ok(evcheck(sub { $n = $x->a_isset(3) }, 'index (43)'), 1, 'index (43)'); ok $n; # index (44) } else { ok 1, 1, sprintf "index skip (%02d)", $_ for 33..44; } } # ------------------------------------- =head2 Tests 125--148: count =cut { my ($n, @n); ok evcheck(sub { @n = $x->a(11, 12, 13); }, 'count ( 1)'), 1, 'count ( 1)'; ok @n, 3, 'count ( 2)'; ok $n[0], 11, 'count ( 3)'; ok $n[1], 12, 'count ( 4)'; ok $n[2], 13, 'count ( 5)'; ok evcheck(sub { $n = $x->a_count; }, 'count ( 6)'), 1, 'count ( 6)'; ok $n, 3, 'count ( 7)'; ok(evcheck(sub { @n = $x->a(14, 15, 16, 17); }, 'count ( 8)'), 1, 'count ( 8)'); ok @n, 4, 'count ( 9)'; ok $n[0], 14, 'count (10)'; ok $n[1], 15, 'count (11)'; ok $n[2], 16, 'count (12)'; ok $n[3], 17, 'count (13)'; ok evcheck(sub { $n = $x->a_count; }, 'count (14)'), 1, 'count (14)'; ok $n, 4, 'count (15)'; # lvalue support has been dropped (I can't find a consistent way to support # it in the presence of read callbacks). ok evcheck(sub { $x->a_set(8, 19); }, 'count (16)'), 1, 'count (16)'; ok evcheck(sub { $n = $x->a_count; }, 'count (17)'), 1, 'count (17)'; ok $n, 9, 'count (18)'; ok(evcheck(sub { @n = $x->a_index(7,8) }, 'count (19)'), 1, 'count (19)'); ok @n, 2, 'count (20)'; ok $n[0], undef, 'count (21)'; ok $n[1], 19, 'count (22)'; # check intermediate index still not set ok(evcheck(sub { $n = $x->a_isset(6) }, 'count (23)'), 1, 'count (23)'); ok ! $n # count (24) } # ------------------------------------- =head2 Tests 149--243: default =cut { my ($n, @n); ok(evcheck(sub { package X; Class::MethodMaker->import([array => [{ -default => 7, }, qw( df1 ), ], ]); }, 'default ( 1)'), 1, 'default ( 1)'); print STDERR Data::Dumper->Dump([$n], [qw($n)]) if $ENV{TEST_DEBUG}; ok(evcheck(sub { $n = $x->df1_isset; }, 'default ( 2)'), 1, 'default ( 2)'); ok $n; # default ( 3) ok(evcheck(sub { $n = $x->df1_count; }, 'default ( 4)'), 1, 'default ( 4)'); print STDERR Data::Dumper->Dump([$x], [qw($x)]) if $ENV{TEST_DEBUG}; ok $n, undef, 'default ( 5)'; ok(evcheck(sub { $n = $x->df1; }, 'default ( 6)'), 1, 'default ( 6)'); print STDERR Data::Dumper->Dump([$n], [qw($n)]) if $ENV{TEST_DEBUG}; ok ref($n), 'ARRAY', 'default ( 7)'; ok @$n, 0, 'default ( 8)'; # test index (since it has a different implementation with defaults) print STDERR Data::Dumper->Dump([$x], [qw($x)]) if $ENV{TEST_DEBUG}; ok evcheck(sub { $n = $x->df1_index(1) }, 'default ( 9)'), 1,'default ( 9)'; ok $n, 7, 'default (10)'; # check that item has been vivified print STDERR Data::Dumper->Dump([$x], [qw($x)]) if $ENV{TEST_DEBUG}; ok(evcheck(sub { $n = $x->df1_isset; }, 'default (11)'), 1, 'default (11)'); ok $n; # default (12) ok(evcheck(sub { $n = $x->df1_isset(0); }, 'default (13)'),1,'default (13)'); ok $n; # default (14) ok(evcheck(sub { $n = $x->df1_isset(1); }, 'default (15)'),1,'default (15)'); ok $n; # default (16) ok evcheck(sub { $n = $x->df1_count }, 'default (17)'), 1, 'default (17)'; ok $n, 2, 'default (18)'; # test reset (unset value) print STDERR Data::Dumper->Dump([$x], [qw($x)]) if $ENV{TEST_DEBUG}; ok evcheck(sub { $x->df1_reset(0) }, 'default (19)'), 1, 'default (19)'; ok(evcheck(sub { $n = $x->df1_isset; }, 'default (20)'), 1, 'default (20)'); ok $n; # default (21) ok(evcheck(sub { $n = $x->df1_isset(0); }, 'default (22)'),1,'default (22)'); ok $n; # default (23) ok(evcheck(sub { $n = $x->df1_isset(1); }, 'default (24)'),1,'default (24)'); ok $n; # default (25) ok evcheck(sub { $n = $x->df1_count }, 'default (26)'), 1, 'default (26)'; ok $n, 2, 'default (27)'; # test reset (set value) print STDERR Data::Dumper->Dump([$x], [qw($x)]) if $ENV{TEST_DEBUG}; ok evcheck(sub { $x->df1_reset(1) }, 'default (28)'), 1, 'default (28)'; ok(evcheck(sub { $n = $x->df1_isset; }, 'default (29)'), 1, 'default (29)'); ok $n; # default (30) ok(evcheck(sub { $n = $x->df1_isset(0); }, 'default (31)'),1,'default (31)'); ok $n; # default (32) ok(evcheck(sub { $n = $x->df1_isset(1); }, 'default (33)'),1,'default (33)'); ok $n; # default (34) ok evcheck(sub { $n = $x->df1_count }, 'default (35)'), 1, 'default (35)'; ok $n, 0, 'default (36)'; # check that x returns default for unset items ok evcheck(sub { $n = $x->df1_index(1) }, 'default (37)'), 1,'default (37)'; ok $n, 7, 'default (38)'; # check that such items are now set ok(evcheck(sub { $n = $x->df1_isset(0); }, 'default (39)'),1,'default (39)'); ok $n; # default (40) ok(evcheck(sub { $n = $x->df1_isset(1); }, 'default (41)'),1,'default (41)'); ok $n; # default (42) ok evcheck(sub { $n = $x->df1_count }, 'default (43)'), 1, 'default (43)'; ok $n, 2, 'default (44)'; # check this doesn't clobber undef items # lvalue support has been dropped (I can't find a consistent way to support # it in the presence of read callbacks). ok(evcheck(sub { $n = $x->df1_set(0, undef) }, 'default (45)'), 1, 'default (45)'); ok $n, undef, 'default (46)'; ok evcheck(sub { $n = $x->df1_index(0) }, 'default (47)'), 1,'default (47)'; ok $n, undef, 'default (48)'; ok(evcheck(sub { $n = $x->df1_isset(0); }, 'default (49)'),1,'default (49)'); ok $n; # default (50) ok(evcheck(sub { $n = $x->df1_isset(1); }, 'default (51)'),1,'default (51)'); ok $n; # default (52) ok evcheck(sub { $n = $x->df1_count }, 'default (53)'), 1, 'default (53)'; ok $n, 2, 'default (54)'; ok evcheck(sub { $x->df1_reset(0) }, 'default (55)'), 1, 'default (55)'; ok evcheck(sub { $x->df1_reset(1) }, 'default (56)'), 1, 'default (56)'; # set i2 to value, test i2 & i0 & i1 print STDERR Data::Dumper->Dump([$x], [qw($x)]) if $ENV{TEST_DEBUG}; # lvalue support has been dropped (I can't find a consistent way to support # it in the presence of read callbacks). ok evcheck(sub { $x->df1_set(2, 9) }, 'default (57)'), 1, 'default (57)'; print STDERR Data::Dumper->Dump([$x], [qw($x)]) if $ENV{TEST_DEBUG}; ok(evcheck(sub { $n = $x->df1_isset; }, 'default (58)'), 1, 'default (58)'); ok $n; # default (59) ok(evcheck(sub { $n = $x->df1_isset(0); }, 'default (60)'),1,'default (60)'); ok $n; # default (61) ok(evcheck(sub { $n = $x->df1_isset(1); }, 'default (62)'),1,'default (62)'); ok $n; # default (63) ok(evcheck(sub { $n = $x->df1_isset(2); }, 'default (64)'),1,'default (64)'); ok $n; # default (65) ok evcheck(sub { $n = $x->df1_count }, 'default (66)'), 1, 'default (66)'; ok $n, 3, 'default (67)'; ok evcheck(sub { $n = $x->df1_index(2) }, 'default (68)'), 1, 'default (68)'; ok $n, 9, 'default (69)'; # test reset (aggregate) ok evcheck(sub { $x->df1_reset }, 'default (70)'), 1, 'default (70)'; ok(evcheck(sub { $n = $x->df1_isset; }, 'default (71)'), 1, 'default (71)'); ok $n; # default (72) ok evcheck(sub { $n = $x->df1_count }, 'default (73)'), 1, 'default (73)'; ok $n, undef, 'default (74)'; ok(evcheck(sub { $n = $x->df1_isset(0); }, 'default (75)'),1,'default (75)'); ok $n; # default (76) ok(evcheck(sub { $n = $x->df1_isset(1); }, 'default (77)'),1,'default (77)'); ok $n; # default (78) ok(evcheck(sub { $n = $x->df1_isset(2); }, 'default (79)'),1,'default (79)'); ok $n; # default (80) # set value to empty # lvalue support has been dropped (I can't find a consistent way to support # it in the presence of read callbacks). ok evcheck(sub { $x->df1_set(2, undef) },'default (81)'),1,'default (81)'; ok(evcheck(sub { $n = $x->df1_isset; }, 'default (82)'), 1, 'default (82)'); ok $n; # default (83) ok(evcheck(sub { $n = $x->df1_isset(0); }, 'default (84)'),1,'default (84)'); ok $n; # default (85) ok(evcheck(sub { $n = $x->df1_isset(1); }, 'default (86)'),1,'default (86)'); ok $n; # default (87) ok(evcheck(sub { $n = $x->df1_isset(2); }, 'default (88)'),1,'default (88)'); ok $n; # default (89) ok evcheck(sub { $n = $x->df1_count }, 'default (90)'), 1, 'default (90)'; ok $n, 3, 'default (91)'; ok evcheck(sub { $n = $x->df1_index(2) }, 'default (92)'), 1,'default (92)'; ok $n, undef, 'default (93)'; ok evcheck(sub { $n = $x->df1_index(1) }, 'default (94)'), 1,'default (94)'; print STDERR Data::Dumper->Dump([$n], [qw($n)]) if $ENV{TEST_DEBUG}; ok $n, 7, 'default (95)'; ok evcheck(sub { @n = $x->df1 }, 'default (96)'), 1, 'default (96)'; ok @n, 3, 'default (97)'; ok $n[0], 7, 'default (98)'; ok $n[1], 7, 'default (99)'; ok $n[2], undef, 'default (100)'; } # ------------------------------------- =head2 Tests 249--265: default_ctor =cut { package Y; my $count = 0; sub new { my $class = shift; my $i = shift; my $self = @_ ? $_[0] : ++$count; return bless \$self, $class; } sub value { return ${$_[0]}; } sub reset { $count = 0; } } { my ($n, @n); ok(evcheck(sub { package X; Class::MethodMaker->import([array => [{ -type => 'Y', -default_ctor => 'new', }, qw( df2 ), { -type => 'Y', -default_ctor => sub { Y->new(undef, -3); }, }, qw( df3 ), ], ]); }, 'default ( 1)'), 1, 'default_ctor ( 1)'); ok(evcheck(sub { $n = $x->df2_isset; }, 'default_ctor( 2)'), 1, 'default_ctor ( 2)'); ok $n; # default_ctor ( 3) print STDERR Data::Dumper->Dump([$x], [qw($x)]) if $ENV{TEST_DEBUG}; ok(evcheck(sub { $n = $x->df2_index(1)->value; }, 'default_ctor( 4)'), 1, 'default_ctor ( 4)'); ok $n, 1, 'default_ctor ( 5)'; # This actually creates two Y instances; one explictly, and one not implictly # by the _index method defaulting one (since it can't see the incoming) # XXX not anymore XXX # lvalue support has been dropped (I can't find a consistent way to support # it in the presence of read callbacks). ok(evcheck(sub { $x->df2_set(2, Y->new) }, 'default_ctor( 6)'), 1, 'default_ctor ( 6)'); ok(evcheck(sub { $n = $x->df2_index(2)->value; }, 'default_ctor( 7)'), 1, 'default_ctor ( 7)'); ok $n, 2, 'default_ctor ( 8)'; ok(evcheck(sub { $x->df2_reset; },'default_ctor( 9)'), 1, 'default_ctor ( 9)'); ok(evcheck(sub { $n = $x->df2_isset; }, 'default_ctor(10)'), 1, 'default_ctor (10)'); ok $n; # default_ctor (11) ok(evcheck(sub { $n = $x->df2_index(2)->value; }, 'default_ctor(12)'), 1, 'default_ctor (12)'); ok $n, 3, 'default_ctor (13)'; ok(evcheck(sub { $n = $x->df3_isset; }, 'default_ctor(14)'), 1, 'default_ctor (14)'); ok $n; # default_ctor (15) ok(evcheck(sub { $n = $x->df3_index(2)->value; }, 'default_ctor(16)'), 1, 'default_ctor (16)'); ok $n, -3, 'default_ctor (17)'; ok evcheck(sub { @n = $x->df2 }, 'default_ctor (18)'),1,'default_ctor (18)'; ok @n, 3, 'default_ctor (19)'; ok ref($n[2]), 'Y', 'default_ctor (20)'; ok $n[2]->value, 3, 'default_ctor (21)'; ok ref($n[0]), 'Y', 'default_ctor (22)'; ok ref($n[1]), 'Y', 'default_ctor (23)'; } # ------------------------------------- =head2 Tests 272--293: forward =cut { my ($n, @n); ok(evcheck(sub { package X; Class::MethodMaker->import([array => [{ -type => 'File::stat', -forward => [qw/ mode size /], }, qw( st1 ), # Keeping the second call # here ensures that we check # that mode, size are # forwarded to st1 { -type => 'IO::Handle', -forward => 'read', }, qw( st2 ), ]])}, 'forward ( 1)'), 1, 'forward ( 1)'); ok(evcheck(sub { $n = $x->st1_isset; }, 'forward ( 2)'), 1, 'forward ( 2)'); ok ! $n; # forward ( 3) ok(evcheck(sub { $x->st1(4); }, 'forward ( 4)'), 0, 'forward ( 4)'); ok(evcheck(sub { @n = $x->st1; }, 'forward ( 5)'), 1, 'forward ( 5)'); ok @n, 0, 'forward ( 6)'; ok(evcheck(sub { $n = $x->st1_isset; }, 'forward ( 7)'), 1, 'forward ( 7)'); ok ! $n; # forward ( 8) ok(evcheck(sub { $x->st1(undef); }, 'forward ( 9)'), 1, 'forward ( 9)'); ok(evcheck(sub { $n = $x->st1_isset; }, 'forward (10)'), 1, 'forward (10)'); ok $n; # forward (11) ok(evcheck(sub { @n = $x->st1; }, 'forward (12)'), 1, 'forward (12)'); ok @n, 1, 'forward (13)'; ok $n[0], undef, 'forward (14)'; ok(evcheck(sub { $x->st1(stat(catfile($Bin,$Script)), stat(catfile($Bin))) }, 'forward (15)'), 1, 'forward (15)'); print STDERR Data::Dumper->Dump([$x],[qw(x)]) if $ENV{TEST_DEBUG}; print STDERR B::Deparse->new('-p', '-sC')->coderef2text(\&X::mode), "\n" if $ENV{TEST_DEBUG}; ok(evcheck(sub { @n = $x->mode; }, 'forward (16)'), 1, 'forward (16)'); ok @n, 2, 'forward (17)'; ok S_ISREG($n[0]), 1, 'forward (18)'; ok S_ISDIR($n[1]), 1, 'forward (19)'; ok(evcheck(sub { $n = $x->size; }, 'forward (20)'), 1, 'forward (20)'); ok @$n, 2, 'forward (21)'; { sysopen my $fh, catfile($Bin,$Script), O_RDONLY; local $/ = undef; my $text = <$fh>; close $fh; ok $n->[0], length($text), 'forward (22)'; } } # ------------------------------------- =head2 Tests 294--296: forward_args =cut { my $n; # Instantiate st2 as IO::File, which is a subclass of IO::Handle. This # should be fine ok(evcheck(sub { $x->st2(IO::File->new(catfile($Bin,$Script))) }, 'forward_args ( 1)'), 1, 'forward_args ( 1)'); ok(evcheck(sub { $x->read($n, 30); }, 'forward_args ( 2)'), 1, 'forward_args ( 2)'); ok $n, '# (X)Emacs mode: -*- cperl -*-', 'forward_args ( 3)'; } # ------------------------------------- =head2 Tests 297--349: manipulate =cut { my ($n, @n); Y::reset; ok evcheck(sub { $x->df2_reset; }, 'manipulate ( 1)'), 1, 'manipulate ( 1)'; # _push ok evcheck(sub { $x->df2_push(Y->new, Y->new); }, 'manipulate ( 2)'), 1, 'manipulate ( 2)'; ok evcheck(sub { @n = $x->df2; }, 'manipulate ( 3)'), 1, 'manipulate ( 3)'; ok @n, 2, 'manipulate ( 4)'; ok $n[0]->value, 1, 'manipulate ( 5)'; ok $n[1]->value, 2, 'manipulate ( 6)'; # _push typecheck ok(evcheck(sub { $x->df2_push(+{}); }, 'manipulate ( 7)'), 0, 'manipulate ( 7)'); # _unshift ok evcheck(sub { $x->df2_unshift(undef); }, 'manipulate ( 8)'), 1, 'manipulate ( 8)'; ok evcheck(sub { $x->df2_unshift(Y->new); }, 'manipulate ( 9)'), 1, 'manipulate ( 9)'; ok evcheck(sub { @n = $x->df2; }, 'manipulate (10)'), 1, 'manipulate (10)'; ok @n, 4, 'manipulate (11)'; ok $n[0]->value, 3, 'manipulate (12)'; ok $n[1], undef, 'manipulate (13)'; ok $n[2]->value, 1, 'manipulate (14)'; ok $n[3]->value, 2, 'manipulate (15)'; # _unshift typecheck ok(evcheck(sub { $x->df2_unshift(+{}); }, 'manipulate (16)'), 0, 'manipulate (16)'); # _pop ok evcheck(sub { $n = $x->df2_pop }, 'manipulate (17)'),1,'manipulate (17)'; ok $n->value, 2, 'manipulate (18)'; ok evcheck(sub {$n = $x->df2_pop(2)},'manipulate (19)'),1,'manipulate (19)'; ok @$n, 2, 'manipulate (20)'; ok $n->[0], undef, 'manipulate (21)'; ok $n->[1]->value, 1, 'manipulate (22)'; # _shift ok evcheck(sub { $x->df2_push(Y->new, Y->new); }, 'manipulate (23)'), 1, 'manipulate (23)'; ok(evcheck(sub { $n = $x->df2_shift }, 'manipulate (24)'), 1, 'manipulate (24)'); ok $n->value, 3, 'manipulate (25)'; ok(evcheck(sub { @n = $x->df2_shift(2) }, 'manipulate (26)'), 1, 'manipulate (26)'); ok @n, 2, 'manipulate (27)'; ok $n[0]->value, 4, 'manipulate (28)'; ok $n[1]->value, 5, 'manipulate (29)'; print STDERR Data::Dumper->Dump([$x->{df2}], [qw(df2)]) if $ENV{TEST_DEBUG}; # _splice ok(evcheck(sub { $x->df2_push(Y->new, Y->new, Y->new, Y->new); }, 'manipulate (29)'), 1, 'manipulate (30)'); print STDERR B::Deparse->new('-p','-sC')->coderef2text(\&X::df2_splice),"\n" if $ENV{TEST_DEBUG}; print STDERR Data::Dumper->Dump([$x->{df2}], [qw(df2)]) if $ENV{TEST_DEBUG}; ok(evcheck(sub { $n = $x->df2_splice(1, 2) }, 'manipulate (31)'), 1, 'manipulate (31)'); print STDERR Data::Dumper->Dump([$n], [qw($n)]) if $ENV{TEST_DEBUG}; ok @$n, 2, 'manipulate (32)'; ok $n->[0]->value, 7, 'manipulate (33)'; ok $n->[1]->value, 8, 'manipulate (34)'; ok(evcheck(sub { @n = $x->df2_splice(0, 2, Y->new, Y->new, Y->new)}, 'manipulate (35)'), 1, 'manipulate (35)'); ok @n, 2, 'manipulate (36)'; ok $n[0]->value, 6, 'manipulate (37)'; ok $n[1]->value, 9, 'manipulate (38)'; ok(evcheck(sub { @n = $x->df2}, 'manipulate (39)'), 1, 'manipulate (39)'); ok @n, 3, 'manipulate (40)'; ok $n[0]->value, 10, 'manipulate (41)'; ok $n[1]->value, 11, 'manipulate (42)'; ok $n[2]->value, 12, 'manipulate (43)'; # splice with 1 argument (special case in code) ok(evcheck(sub { @n = $x->df2_splice(1) }, 'manipulate (44)'), 1, 'manipulate (44)'); ok @n, 2, 'manipulate (45)'; ok $n[0]->value, 11, 'manipulate (46)'; ok $n[1]->value, 12, 'manipulate (47)'; # splice with 0 arguments (special case in code) ok(evcheck(sub { $x->df2_push(Y->new, Y->new); }, 'manipulate (48)'), 1, 'manipulate (48)'); ok(evcheck(sub { @n = $x->df2_splice }, 'manipulate (48)'), 1, 'manipulate (49)'); ok @n, 3, 'manipulate (50)'; ok $n[0]->value, 10, 'manipulate (51)'; ok $n[1]->value, 13, 'manipulate (52)'; ok $n[2]->value, 14, 'manipulate (53)'; } # ------------------------------------- =head2 Tests 350-392: tie =cut { # @z is an audit trail my @z; package Z; use base qw( Tie::StdArray ); sub TIEARRAY { push @z, [ 'TIEARRAY' ]; $_[0]->SUPER::TIEARRAY } sub FETCH { push @z, [ FETCH => $_[1] ]; $_[0]->SUPER::FETCH($_[1]) } sub PUSH { push @z, [ PUSH => $_[1] ]; $_[0]->SUPER::PUSH(@_[1..$#_]) } sub STORE { push @z, [ STORE => @_[1,2]]; $_[0]->SUPER::STORE(@_[1,2]) } sub DESTROY { push @z, [ 'DESTROY' ]; $_[0]->SUPER::DESTROY } package main; ok(evcheck(sub { package X; Class::MethodMaker->import([array => [{ -type => 'File::stat', -tie_class => 'Z', -forward => [qw/ mode size /], }, qw( tie1 ), ]])}, 'tie ( 1)'), 1, 'tie ( 1)'); bless ((my $x = {}), 'X'); ok @z, 0, 'tie ( 2)'; my $stat1 = stat catfile($Bin,$Script); my $stat2 = stat $Bin; $x->tie1_push($stat1); ok @z, 2, 'tie ( 3)'; ok $z[0][0], 'TIEARRAY', 'tie ( 4)'; ok $z[1][0], 'PUSH' , 'tie ( 5)'; ok $z[1][1], $stat1 , 'tie ( 6)'; my $y; ok evcheck(sub { $y = $x->tie1_index(0) }, 'tie ( 7)'), 1, 'tie ( 7)'; ok $y, $stat1, 'tie ( 8)'; ok @z, 3, 'tie ( 9)'; ok $z[2][0], 'FETCH', 'tie (10)'; ok $z[2][1], 0, 'tie (11)'; ok evcheck(sub { $y = $x->tie1_index(2) }, 'tie (12)'), 1, 'tie (12)'; ok $y, undef, 'tie (13)'; ok @z, 4, 'tie (14)'; ok $z[3][0], 'FETCH', 'tie (15)'; ok $z[3][1], 2, 'tie (16)'; ok evcheck(sub { $x->tie1_set(2, $stat2) }, 'tie (17)'), 1, 'tie (17)'; ok @z, 5, 'tie (18)'; ok $z[4][0], 'STORE', 'tie (19)'; ok $z[4][1], 2, 'tie (20)'; ok $z[4][2], $stat2, 'tie (21)'; ok evcheck(sub { $y = $x->tie1 }, 'tie (22)'), 1, 'tie (22)'; ok ref $y, 'ARRAY', 'tie (23)'; ok @$y, 3, 'tie (24)'; ok $y->[0], $stat1, 'tie (25)'; ok $y->[1], undef, 'tie (26)'; ok $y->[2], $stat2, 'tie (27)'; ok @z, 8, 'tie (28)'; ok $z[$_][0], 'FETCH', sprintf 'tie (%02d)', $_+24 for 5..7; ok $z[$_][1], $_-5, sprintf 'tie (%02d)', $_+27 for 5..7; ok evcheck(sub { $x->tie1_reset }, 'tie (35)'), 1, 'tie (35)'; ok @z, 9, 'tie (36)'; ok $z[8][0], 'DESTROY', 'tie (37)'; ok evcheck(sub { $y = $x->tie1_count }, 'tie (38)'), 1, 'tie (38)'; ok $y, undef, 'tie (39)'; ok @z, 9, 'tie (40)'; ok evcheck(sub { $y = $x->tie1_index(2) }, 'tie (41)'), 1, 'tie (41)'; ok $y, undef, 'tie (42)'; ok @z, 9, 'tie (43)'; # Beware that indexing items off the end of @z above will auto-vivify the # corresponding entries, so if you see empty members of @z, that's possibly # the cause print Dumper \@z, $x if $ENV{TEST_DEBUG}; } # ------------------------------------- =head2 Tests 393-396 : void set Check that calling a(), with no arguments, doesn't instantiate a new instance (in all contexts). =cut { my $x = bless {}, 'X'; ok ! $x->a_isset; $x->a(); ok ! $x->a_isset; my @a = $x->a(); ok ! $x->a_isset; my $a = $x->a(); ok ! $x->a_isset; } # ------------------------------------- =head2 Tests 397--418: _clear =cut { my ($n, @n); ok evcheck(sub { $n = $x->a_reset; }, '_clear ( 1)'), 1, '_clear ( 1)'; ok evcheck(sub { $n = $x->a_isset; }, '_clear ( 2)'), 1, '_clear ( 2)'; ok ! $n; # _clear ( 3) ok evcheck(sub { $x->a(4); }, '_clear ( 4)'), 1, '_clear ( 4)'; ok evcheck(sub { ($n) = $x->a; }, '_clear ( 5)'), 1, '_clear ( 5)'; ok $n, 4, '_clear ( 6)'; ok evcheck(sub { $x->a_clear; }, 'clear ( 7)'), 1, '_clear ( 7)'; ok evcheck(sub { $n = $x->a_isset; }, '_clear ( 8)'), 1, '_clear ( 8)'; ok $n; # _clear ( 9) ok evcheck(sub { (@n) = $x->a; }, '_clear (10)'), 1, '_clear (10)'; ok @n, 0, '_clear (11)'; print STDERR Data::Dumper->Dump([\@n], [qw(@n)]) if $ENV{TEST_DEBUG}; ok evcheck(sub { (@n) = $x->a(7,8,9); }, '_clear (12)'), 1, '_clear (12)'; ok @n, 3, '_clear (13)'; ok evcheck(sub { $x->a_clear; }, 'clear (14)'), 1, '_clear (14)'; ok evcheck(sub { $n = $x->a_isset; }, '_clear (15)'), 1, '_clear (15)'; ok $n; # _clear (16) ok evcheck(sub { (@n) = $x->a; }, '_clear (17)'), 1, '_clear (17)'; ok @n, 0, '_clear (18)'; my $xx = \1; ok evcheck(sub { $x->a($xx); }, '_clear (19)'), 1, '_clear (19)'; ok evcheck(sub { @n = $x->a; }, '_clear (20)'), 1, '_clear (20)'; ok @n, 1, '_clear (21)'; ok $n[0], $xx, '_clear (22)'; } # ------------------------------------- =head2 Tests 419--425: non-init ctor This is to test that the default ctor or default is not assigned if a value is supplied. This would particularly be a problem with v1 compatiblity use where a value is explcitly supplied to prevent 'new' being called because there is no 'new' (if the ctor is called anyway, the program barfs). =cut { my (@n, $n); ok(evcheck(sub { package X; Class::MethodMaker->import([array => [{ -type => 'Y', -default_ctor => 'newx', }, qw( nic ), ], ]); }, 'default ( 1)'), 1, 'non-init ctor ( 1)'); ok(evcheck(sub { $n = $x->nic_isset; }, 'non-init ctor( 2)'), 1, 'non-init ctor ( 2)'); ok $n; # non-init ctor ( 3) ok(evcheck(sub { $n = $x->nic_index(0); }, 'non-init ctor( 4)'), 0, 'non-init ctor ( 4)'); ok(evcheck(sub { $x->nic(Y->new); }, 'non-init ctor( 5)'), 1, 'non-init ctor ( 5)'); ok(evcheck(sub { @n = $x->nic; }, 'non-init ctor( 6)'), 1, 'non-init ctor ( 6)'); ok ref $n[0], 'Y', 'non-init ctor ( 7)'; } # ------------------------------------- =head2 Tests 426--438: default_ctor (arg) =cut { package S; my $count = 0; sub new { my ($class, $arg) = @_; die sprintf "Expected an X, got a '%s'\n", defined($arg) ? ref $arg : '*undef*' unless UNIVERSAL::isa($arg, 'X'); my ($self) = $arg->a; return bless \$self, $class; } sub value { return ${$_[0]}; } } { my ($n, @n); $x->a(3); ok(evcheck(sub { package X; Class::MethodMaker->import([array => [{ -type => 'S', -default_ctor => 'new', }, qw( dfx ), ], ]); }, 'default ( 1)'), 1, 'default_ctor (arg) ( 1)'); ok(evcheck(sub { $n = $x->dfx_isset; }, 'default_ctor (arg)( 2)'), 1, 'default_ctor (arg) ( 2)'); ok $n; # default_ctor (arg) ( 3) ok(evcheck(sub { $n = $x->dfx_index(1)->value; }, 'default_ctor (arg)( 4)'), 1, 'default_ctor (arg) ( 4)'); ok $n, 3, 'default_ctor (arg) ( 5)'; print STDERR Data::Dumper->Dump([$x], [qw($x)]) if $ENV{TEST_DEBUG}; # This actually creates two Y instances; one explictly, and one not implictly # by the _index method defaulting one (since it can't see the incoming) # XXX not anymore XXX # lvalue support has been dropped (I can't find a consistent way to support # it in the presence of read callbacks). my $xx = bless {}, "X"; $xx->a(2); ok(evcheck(sub { $x->dfx_set(2, S->new($xx)) }, 'default_ctor (arg)( 6)'), 1, 'default_ctor (arg) ( 6)'); ok(evcheck(sub { $n = $x->dfx_index(2)->value; }, 'default_ctor (arg)( 7)'), 1, 'default_ctor (arg) ( 7)'); ok $n, 2, 'default_ctor (arg) ( 8)'; ok(evcheck(sub { $x->dfx_reset; },'default_ctor (arg)( 9)'), 1, 'default_ctor (arg) ( 9)'); ok(evcheck(sub { $n = $x->dfx_isset; }, 'default_ctor (arg)(10)'), 1, 'default_ctor (arg) (10)'); ok $n; # default_ctor (arg) (11) ok(evcheck(sub { $n = $x->dfx_index(2)->value; }, 'default_ctor (arg)(12)'), 1, 'default_ctor (arg) (12)'); ok $n, 3, 'default_ctor (arg) (13)'; } # ------------------------------------- # _get _set # _clear # _isset(n,m,l) # _reset(n,m,l) # _setref # _grep # _map # _for # _areset # ---------------------------------------------------------------------------- Class-MethodMaker-2.24/TODO0000644000175000017500000000771311735360552013421 0ustar ss5ss5# Implement/Check scalar ties # Ensure new is available & documented for V2 # Check tie behaviour with persistent files (e.g., picks up written values on # first read). 'Component exists' (as opposed to element exists) should be # mean 'tied' # Arrays - clear should not delete storage; reset sohuld # Arrays/General - tie should be invoked only upon assignment to the collection # Add to list methods: # Add x_clear to reset array without resetting storage (so storage exists, but no members) # x_count(1) - count set values; (2) - count defined values; (3) - count true values # x_grep x_map x_for # x_areset to return a list of indices of set items # ITERATOR # ITERATOR over set values (leave the user to do ITERATOR over defined values, # etc.) # Add x_setref to hash, array as discussed in respective 'x' method # documentation. # Remaining array tests # Integrate Class::MethodMaker::Util # Add _exists, _delete(as for hash) to array # test forward methods on tied attributes (they're set up in scalar.t, # array.t, hash.t?, just not actually tested) # Add introspection # Split doc. for scalar across actual methods, a la array # Tidy up doc writing to eliminiate unnecessary =pod =cut sequences # differ clear & reset; define behaviour in terms of storage (therefore, tie) # finish & document array # finish array.t (check test notes at end) # tie scalars # split methods into files in their own directory # split methodmaker further; turn V1 opts into own class hierarchy? # ; remove bits that are needed only for class # manufacture (OPTEXT, more?) # document 'new' # Check user-defined components still work as they used to # Filehandle, Dirhandle, Code components? # Automatic storage translation? Retrieval translation? Should this just be # considered a likely implementation of tie? Or implemented with tie? Or # would it be faster directly? This could also be used to implement tied data # _items_, as opposed to tied _components_. # Copy method (deep copy? shallow copy? probably an option for both) # freeze/thaw integration (is there really any value in doing this --- # storable already does it)? # Use of array-based classes? # Use of closures for linked-lists, other data-structures (i.e., the instance # is a subref that's closed over the data). # Use of closures as above for iterators? # Iterators over components # Destructor that unties any components # Finish Documentation # Reassign names so error messages come from "right" class name & method # Place doc. for data structures in middle of man page # Add +*_clear syntax to add in non-default methods # Add nonnull option # Add triggered & monitored types # Add ints, strings, timedates # Add enums # Document default_ctor simple value trick with -type to work only with class # types. # TODO from C::MM 1 # Add trees, linked lists, non-destructive hashes, fib heaps # Integrate other CPAN data structures? # Mechanism to allow users to define templates of methods they commonly use # Test for error messages when new, catalalogue are given "standard" options # Add forwarding from one method to another with a different name. Add # mechanism for auto_naming, e.g., '*_name', where * is replaced by component # name, to allow methods to be forwarded to multiple components e.g., # { -forward => {mode => '*_mode'} }, qw/ st1 st2 / to allow st1_mode & # st2_mode # What to do with forwarding to a null value --- explicit check? # Require default value? Just let it happen? # Add writing out of source code to generated classes # Add default_count mechanism to array # Add parameter passed to default_ctor of array specifying slot ID # Add purely generated arrays/hashes; unable to set, both with & without a # finite limit. Are there CPAN modules for this? # Add _lock & _unlock methods to lock values. Limit each to certain classes? # Add ties # Add introspection capability for OODoc. See email from Marcel Gruenauer # Class-MethodMaker-2.24/generate.PL0000644000175000017500000000070511735360552014752 0ustar ss5ss5use Getopt::Long qw( GetOptions ); use lib '.'; use Generate qw( %GENERATE ); my $dump = 0; GetOptions( 'dump' => \$dump ) or die "options parsing failed\n"; if ( $dump ) { print "$_\t$GENERATE{$_}\n" for sort keys %GENERATE; exit 0; } while ( my ($input, $output) = each %GENERATE ) { my @cmd = ('./cmmg.pl', $input, '>', $output); my $cmd = join ' ', @cmd; print "$cmd\n"; system $cmd and die "$cmd failed: $?\n"; } Class-MethodMaker-2.24/lib/0000755000175000017500000000000012506541335013464 5ustar ss5ss5Class-MethodMaker-2.24/lib/Class/0000755000175000017500000000000012506541335014531 5ustar ss5ss5Class-MethodMaker-2.24/lib/Class/MethodMaker/0000755000175000017500000000000012506541335016731 5ustar ss5ss5Class-MethodMaker-2.24/lib/Class/MethodMaker/OptExt.pm0000644000175000017500000002654311735360552020527 0ustar ss5ss5# (X)Emacs mode: -*- cperl -*- package Class::MethodMaker::OptExt; =head1 NAME Class::MethodMaker::OptExt - Constants for C::MM's option extension mechanism =head1 SYNOPSIS This class is internal to Class::MethodMaker and should not be used by any clients. It is B part of the public API. =head1 DESCRIPTION This class contains the constants used by Class::MethodMaker to determine the names of its methods dependent upon options invoked. =cut # ---------------------------------------------------------------------------- # Pragmas ----------------------------- require 5.006; use strict; use warnings; # Inheritance ------------------------- use base qw( Exporter ); our @EXPORT_OK = qw( OPTEXT ); # Utility ----------------------------- use Carp qw( carp croak ); # ---------------------------------------------------------------------------- # CLASS METHODS -------------------------------------------------------------- # ------------------------------------- # CLASS CONSTANTS # ------------------------------------- =head1 CLASS CONSTANTS Z<> =cut use constant COMPONENT_TYPES => qw( scalar array hash ); # Max 8 codepoints else fix dereferencing in encode, below use constant codepoints => [qw( refer decl postac asgnchk predefchk defchk reset read store )]; # codepoint_value is a map from codepoint to a unique power of two, used to # check for illegal combinations of options use constant codepoint_value => +{ map({codepoints->[$_]=>2**$_} 0..$#{codepoints()}) }; use constant cv_reverse => +{ reverse %{codepoint_value()} }; =head2 OPTEXT OPTEXT is a map from options that are implemented as method extensions to the option parameters. Parameter keys are: =over 4 =item encode code number (to allow the option combination to be encoded whilst keeping the length of the subr name no more than 8 chars). encode is required for all opts (for determining method extension), and must be a power of two. =item refer Code for referring to storage (default: '$_[0]->{$name}'). =item decl Code for declaring storage. =item postac Code to execute immediately after any assignment check --- for example, to initialize storage if necessary =item asgnchk Code for checking assignments. =item defchk Code for default checking. =item reset Code to execute when resetting an element =item read Code to execute each time an value is read =item store Code to execute each time a value is stored =back =cut # Defines Matrix # # codepoint-> refer decl postac asgnchk predefchk defchk reset read store # option # # static X X # type X # default X # default_ctor X # tie_class X X X # v1_compat # read_cb X # store_cb X use constant OPTEXT => { DEFAULT => { refer => '$_[0]->{$name}', decl => '', postac => '', asgnchk => '', predefchk => '', defchk => '', reset => '', read => ['__VALUE__', ''], store => '', }, static => { encode => 1, refer => '$store[0]', decl => 'my @store;', }, type => { encode => 2, asgnchk => <<'END', for (__FOO__) { croak(sprintf("Incorrect type for attribute __ATTR__: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } END }, default => { encode => 4, defchk => <<'END', if ( ! exists %%STORAGE%% ) { %%ASGNCHK__SIGIL__($default)%% %%STORAGE%% = $default } END }, default_ctor => { encode => 8, defchk => <<'END', if ( ! exists %%STORAGE%% ) { my $default = $dctor->($_[0]); %%ASGNCHK__SIGIL__($default)%% %%STORAGE%% = $default } END }, tie_class => { encode => 16, postac => <<'END', tie %%STORAGE(__SIGIL__)%%, $tie_class, @tie_args unless exists %%STORAGE%%; END predefchk => <<'END', tie %%STORAGE(__SIGIL__)%%, $tie_class, @tie_args unless exists %%STORAGE%%; END reset => <<'END', untie %%STORAGE(__SIGIL__)%%; END }, v1_compat => { encode => 32, }, read_cb => { encode => 64, read => [(<<'END') x 2], { # Encapsulate scope to avoid redefined $v issues my $v = __VALUE__; $v = $_->($_[0], $v) for @read_callbacks; $v; } END }, store_cb => { encode => 128, store =><<'END', my __NAME__ = __VALUE__; if ( exists %%STORAGE%% ) { my $old = %%STORAGE%%; __NAMEREF__ = $_->($_[0], __NAMEREF__, $name, $old) %%V2ONLY%% __NAMEREF__ = $_->($_[0], __NAMEREF__, $name, $old, __ALL__) %%V1COMPAT%% for @store_callbacks; } else { __NAMEREF__ = $_->($_[0], __NAMEREF__, $name) %%V2ONLY%% __NAMEREF__ = $_->($_[0], __NAMEREF__, $name, undef, __ALL__) %%V1COMPAT%% for @store_callbacks; } END }, typex => { encode => 256, asgnchk => <<'END', for (__FOO__) { # $_ += 0; # croak(sprintf("Incorrect type for attribute __ATTR__: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } END }, }; # Single value representing the codepoints defined for each option sub optdefvalue { my $class = shift; my ($option) = @_; my $code = OPTEXT->{$option}; croak "Illegal option name: '$option'\n" unless defined $code; my $value = 0; for ( @{codepoints()} ) { $value |= codepoint_value->{$_} if exists $code->{$_}; } # return split //, unpack "b9", chr($value >> 8) . chr($value & 255); #print $value; return split //, unpack "b16", chr($value >> 8) . chr($value & 255); } BEGIN { croak "No encode value found for type $_\n" for grep ! OPTEXT->{$_}->{encode}, grep $_ ne 'DEFAULT', keys %{OPTEXT()}; } # ------------------------------------- # CLASS CONSTRUCTION # ------------------------------------- # ------------------------------------- # CLASS COMPONENTS # ------------------------------------- =head1 CLASS COMPONENTS Z<> =cut # ------------------------------------- # CLASS HIGHER-LEVEL FUNCTIONS # ------------------------------------- =head1 CLASS HIGHER-LEVEL FUNCTIONS Z<> =cut =head2 encode Take a set of options, return a two-letter code being the extension to add to the method to incorporate the extensions, and a list (arrayref) of the extensions represented. =over 4 =item SYNOPSIS my ($ext, $opt) = Class::MethodMaker::OptExt->encode([qw( static type foobar )]); =item ARGUMENTS =over 4 =item options The options to encode, as an arrayref of option names =back =item RETURNS =over 4 =item ext A code (string) to append to a methodname to represent the options used. =item opts The options represented by the ext . This is generally a subset of the of those provided in options, for not all general options are handled by an encoded methodname. =back =back =cut sub encode { my $class = shift; my ($type, $options) = @_; { my @check; for my $opt (grep exists OPTEXT->{$_}, @$options) { my @v = $class->optdefvalue($opt); $check[$_] += $v[$_] for 0..$#v; } if ( grep $_ > 1, @check ) { local $" = ','; return; } } my $ext = ''; my @optused; if ( grep $_ eq $type, COMPONENT_TYPES ) { my $value = 0; for (@$options) { push(@optused, $_), $value += OPTEXT->{$_}->{encode} if exists OPTEXT->{$_}; } $ext = sprintf("%04x", $value); } return $ext, \@optused; } # ------------------------------------- sub option_names { grep $_ ne 'DEFAULT', keys %{OPTEXT()} } sub optcode { my $class = shift; my ($codepoint, $options) = @_; my $code; for my $opt (grep exists OPTEXT->{$_}->{$codepoint}, @$options) { $code = OPTEXT->{$opt}->{$codepoint}; } if ( ! defined $code ) { if ( exists OPTEXT->{DEFAULT}->{$codepoint} ) { $code = OPTEXT->{DEFAULT}->{$codepoint}; } else { croak "Codepoint '$codepoint' not recognized\n"; } } return $code; } # ------------------------------------- sub replace { my $class = shift; my ($st) = @_; my %replace; $replace{$_} = Class::MethodMaker::OptExt->optcode($_, $st) for @{Class::MethodMaker::OptExt->codepoints}; return %replace; } # ------------------------------------- # CLASS HIGHER-LEVEL PROCEDURES # ------------------------------------- =head1 CLASS HIGHER-LEVEL PROCEDURES Z<> =cut # INSTANCE METHODS ----------------------------------------------------------- # ------------------------------------- # INSTANCE CONSTRUCTION # ------------------------------------- =head1 INSTANCE CONSTRUCTION Z<> =cut # ------------------------------------- # INSTANCE FINALIZATION # ------------------------------------- # ------------------------------------- # INSTANCE COMPONENTS # ------------------------------------- =head1 INSTANCE COMPONENTS Z<> =cut # ------------------------------------- # INSTANCE HIGHER-LEVEL FUNCTIONS # ------------------------------------- =head1 INSTANCE HIGHER-LEVEL FUNCTIONS Z<> =cut # ------------------------------------- # INSTANCE HIGHER-LEVEL PROCEDURES # ------------------------------------- =head1 INSTANCE HIGHER-LEVEL PROCEDURES Z<> =cut # ---------------------------------------------------------------------------- =head1 EXAMPLES Z<> =head1 BUGS Z<> =head1 REPORTING BUGS Email the development mailing list C. =head1 AUTHOR Martyn J. Pearce =head1 COPYRIGHT Copyright (c) 2003 Martyn J. Pearce. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO Z<> =cut 1; # keep require happy. __END__ Class-MethodMaker-2.24/lib/Class/MethodMaker/V1Compat.pm0000644000175000017500000010745412236775267020751 0ustar ss5ss5# (X)Emacs mode: -*- cperl -*- package Class::MethodMaker::V1Compat; =head1 NAME Class::MethodMaker::V1Compat - V1 compatibility code for C::MM =head1 SYNOPSIS This class is for internal implementation only. It is not a public API. =head1 DESCRIPTION Class::MethodMaker version 2 strives for backward-compatibility with version 1 as far as possible. That is to say, classes built with version 1 should work with few if any changes. However, the calling conventions for building new classes are significantly different: this is necessary to achieve a greater consistency of arguments. Version 2 takes all arguments within a single arrayref: use Class::MethodMaker [ scalar => 'a' ]; If arguments are presented as a list, then Class::MethodMaker assumes that this is a version 1 call, and acts accordingly. Version 1 arguments are passed and internally rephrased to version 2 arguments, and passed off to the version 2 engine. Thus, the majority of version 1 calls can be upgraded to version 2 merely by rephrasing. However, there are a number of behaviours that in version 1 that are internally inconsistent. These behaviours are mimicked in version 1 mode as far as possible, but are not reproducible in version 2 (to allow version 2 clients to rely on a more internally consistent interface). =head2 Version 2 Implementations The nearest equivalent to each 1 component (slot) available in version 2 is shown below using the indicated data-structures & options to create a component called C that mimics the V1 component behaviour as closely as possible: =over 4 =item abstract use Class::MethodMaker [ abstract => 'a' ]; =item boolean Boolean is available as a backwards compatibility hack, but there is currently no V2 equivalent. It is likely that some replacement mechanism will be introduced in the future, but that it will be incompatible with the version 1 boolean. =item code use Class::MethodMaker [ scalar => 'a' ]; Let's face it, the v1 store-if-it's-a-coderef-else-retrieve semantics are rather broken. How do you pass a coderef as argument to one of these? It is on the TODO list to recognize code as fundamental restricted type (analogous to INTEGER), which would add in a C<*_invoke> method. =item copy use Class::MethodMaker [ copy => 'a' ]; The v2 method is the same as v1. =item counter use Class::MethodMaker [ scalar => [{-type => Class::MethodMaker::Constants::INTEGER}, 'a'] ]; =item copy =item deep_copy use Class::MethodMaker [ copy => [ -deep => 'a' ] ]; =item get_concat use Class::MethodMaker [ scalar => [{ -store_cb => sub { defined $_[1] ? ( defined $_[3] ? "$_[3] $_[1]" : $_[1] ) : undef; } }, 'a' ] ]; =item get_set use Class::MethodMaker [ scalar => 'a' ]; =item hash use Class::MethodMaker [ hash => 'a' ]; =item key_attrib Although v1 calls will continue to work, this is not supported in v2. =item key_with_create Although v1 calls will continue to work, this is not supported in v2. =item list use Class::MethodMaker [ list => 'a' ]; Note that the C<*> method now I the whole array if given arguments. =item method See C. =item new use Class::MethodMaker [ new => 'a' ]; =item new_hash_init use Class::MethodMaker [ new => [ -hash => 'a' ] ]; =item new_hash_with_init use Class::MethodMaker [ new => [ -hash => -init => 'a' ] ]; =item new_with_args Although v1 calls will continue to work, this is not supported in v2, for it is a trivial application of C. =item new_with_init use Class::MethodMaker [ new => [ -init => 'a' ] ]; =item object use Class::MethodMaker [ scalar => [{ -type => 'MyClass', -forward => [qw/ method1 method2 /] }, 'a' ] ]; =item object_tie_hash use Class::MethodMaker [ hash => [{ -type => 'MyClass', -forward => [qw/ method1 method2 /], -tie_class => 'Tie::MyTie', -tie_args => [qw/ foo bar baz /], }, 'a' ] ]; =item object_tie_list use Class::MethodMaker [ array => [{ -type => 'MyClass', -forward => [qw/ method1 method2 /], -tie_class => 'Tie::MyTie', -tie_args => [qw/ foo bar baz /], }, 'a' ] ]; =item set_once use Class::MethodMaker [ scalar => [{ -store_cb => sub { die "Already stored $_[3]" if @_ > 3; } }, 'a' ] ]; =item set_once_static use Class::MethodMaker [ scalar => [{ -store_cb => sub { die "Already stored $_[3]" if @_ > 3; }, -static => 1, }, 'a' ] ]; =item singleton use Class::MethodMaker [ new => [ -singleton => -hash => -init => 'a' ] ]; =item static_get_set use Class::MethodMaker [ scalar => [ -static => 'a' ], ]; =item static_hash use Class::MethodMaker [ hash => [ -static => 'a' ], ]; =item static_list use Class::MethodMaker [ list => [ -static => 'a' ], ]; =item tie_hash use Class::MethodMaker [ hash => [ { -tie_class => 'MyTie', -tie_args => [qw/ foo bar baz /], } => 'a' ], ]; =item tie_list use Class::MethodMaker [ array => [ { -tie_class => 'MyTie', -tie_args => [qw/ foo bar baz /], } => 'a' ], ]; =item tie_scalar use Class::MethodMaker [ scalar => [ { -tie_class => 'MyTie', -tie_args => [qw/ foo bar baz /], } => 'a' ], ]; =back =head2 Caveats & Expected Breakages The following version 1 component (slot) types are not currently supported in version 2: =over 4 =item grouped_fields =item hash_of_lists =item listed_attrib =item struct =back =cut # ---------------------------------------------------------------------------- # Pragmas ----------------------------- require 5.006; use strict; use warnings; # Inheritance ------------------------- use base qw( Exporter ); our @EXPORT_OK = qw( V1COMPAT ); # Utility ----------------------------- use Carp qw( ); use Class::MethodMaker::Constants qw( ); # ---------------------------------------------------------------------------- # CLASS METHODS -------------------------------------------------------------- # ------------------------------------- # CLASS CONSTANTS # ------------------------------------- use constant INTEGER => Class::MethodMaker::Constants::INTEGER; use constant SCALAR_RENAME => +{ '*_clear' => 'clear_*', '*_get' => 'get_*', '*_set' => 'set_*', }; use constant SCALAR_ONLY_X_RENAME => +{ '*_clear' => undef, '*_reset' => undef, '*_isset' => undef, }; use constant GET_SET_PATTERN_MAP => +{ -java => [ undef, undef, 'get*', 'set*' ], -eiffel => [ undef, undef, '*', 'set_*' ], -compatibility => [ '*', 'clear_*', undef, undef ], -noclear => [ '*', undef, undef, undef ], }; use constant LIST_RENAME => +{ '*_ref' => '*_ref', '*_reset' => ['*_clear', 'clear_*' ], '*_isset' => undef, '*_get' => undef, '*_set' => undef, '*_count' => ['*_count', 'count_*' ], '*_index' => ['*_index', 'index_*' ], '*_pop' => ['*_pop', 'pop_*' ], '*_push' => ['*_push', 'push_*' ], '*_set' => ['*_set', 'set_*' ], '*_shift' => ['*_shift', 'shift_*' ], '*_splice' => ['*_splice', 'splice_*' ], '*_unshift' => ['*_unshift', 'unshift_*'], }; use constant HASH_RENAME => +{ '*_v1compat' => '*', '*_tally' => '*_tally', '*' => undef, }; use constant HASH_OPT_HANDLER => sub { $_[3]->{substr($_[1], 1)} = 1; }; # ------------------------------------- sub rephrase_prefix_option { my @opts = @_; return sub { return [@opts, ref $_[0] eq 'ARRAY' ? @{$_[0]} : $_[0] ]; } } sub rephrase_tie { # This is deliberately low on error-handling. # We're not supporting V1 programming; if it works # with V1, all is well; if it doesn't, use the V2 # approach. We don't want people coding up new stuff # in V1 mode. # # I.e., anything that currently works with V1 is supported, but # only to avoid breakage of existing classes. All future development # should be done in V2 mode. my ($names) = @_; my @names; # Result for (my $i = 0; $i < @$names; $i+=2) { my ($comps, $args) = @{$names}[$i,$i+1]; my @comps = ref $comps eq 'ARRAY' ? @$comps : $comps; my @args = ref $args eq 'ARRAY' ? @$args : $args; my ($tie_class, @tie_args) = @args; push @names, { -tie_class => $tie_class, -tie_args => \@tie_args, }; push @names, @comps; } return \@names; } sub rephrase_object_tie { # This is deliberately low on error-handling. # We're not supporting V1 programming; if it works # with V1, all is well; if it doesn't, use the V2 # approach. We don't want people coding up new stuff # in V1 mode. # # I.e., anything that currently works with V1 is supported, but # only to avoid breakage of existing classes. All future development # should be done in V2 mode. my ($comps) = @_; my @args; for my $comp (@$comps) { my ($tie_class, @tie_args) = @{$comp->{tie_hash}}; my ($class, @c_args) = @{$comp->{class}}; my $dctor = @c_args ? 'new' : sub { $class->new(@c_args) }; my %opts = (-type => $class, -tie_class => $tie_class, -default_ctor => $dctor, ); $opts{-tie_args} = \@tie_args if @tie_args; push @args, \%opts, ref($comp->{slot}) ? @{$comp->{slot}} : $comp->{slot}; } return \@args; } # ------------------------------------- sub code_store_cb { # A call to read with args (that aren't code references) appears to V2 to # be a store call # :-( # therefore we sneak the args in to an array for read to use when called # ;-/ if ( ref ( $_[1] ) eq 'CODE' ) { # A store is immediately followed by a read. Use undef in position 1 # (second element) as a marker of a recent store that should therefore # be returned without invocation. return [ $_[1], undef ]; } else { return [ $_[3]->[0], [ @_[4..$#_] ] ]; } } # ------------------------------------- sub passthrough_option { # Simple pass through my ($type, $opt, $rename, $local_opts) = @_; if ( ref $opt ) { while ( my ($optname, $optval) = each %$opt ) { $local_opts->{substr($optname, 1)} = $optval; } } else { $local_opts->{substr($opt, 1)} = 1; } } sub get_set_option { my ($type, $opt, $rename, $local_opts, $class) = @_; my @names; if ( ref $opt ) { if ( UNIVERSAL::isa($opt, 'ARRAY') ) { @names = @$opt; } elsif ( UNIVERSAL::isa($opt, 'HASH') ) { $local_opts->{substr($_, 1)} = $opt->{$_} for keys %$opt; } else { die("Option type " . ref($opt) . " not handled by get_set\n"); } } else { if ( exists GET_SET_PATTERN_MAP()->{$opt} ) { @names = @{GET_SET_PATTERN_MAP()->{$opt}}; } else { if ( $opt eq '-static' ) { $local_opts->{static} = 1; } elsif ( $opt =~ /^-(?:set_once(?:_or_(\w+))?)/ ) { my ($action_name) = $1 || 'die'; my %is_set; if ($action_name eq 'ignore') { $local_opts->{store_cb} = sub { # Have to do this here, not prior to the sub, because the # options hash is not available until the methods have been # installed my $options = Class::MethodMaker::Engine->_class_comp_options($class, $_[2]); if ( exists $options->{static} ) { $is_set{$_[2]}++ ? $_[3] : $_[1]; } else { if ( exists $is_set{$_[2]} and grep $_ == $_[0], @{$is_set{$_[2]}} ) { $_[3]; } else { push @{$is_set{$_[2]}}, $_[0]; $_[1]; } } }; } elsif ($action_name =~ /carp|cluck|croak|confess/) { $local_opts->{store_cb} = sub { # Have to do this here, not prior to the sub, because the # options hash is not available until the methods have been # installed my $options = Class::MethodMaker::Engine->_class_comp_options($class, $_[2]); my $action = join '::', 'Carp', $action_name; no strict 'refs'; if ( exists $options->{static} ) { $is_set{$_[2]}++ ? &$action("Attempt to set slot ", ref($_[0]), '::', $_[2], " more than once") : $_[1]; } else { if ( exists $is_set{$_[2]} and grep $_ == $_[0], @{$is_set{$_[2]}} ) { &$action("Attempt to set slot ", ref($_[0]), '::', $_[2], " more than once") } else { push @{$is_set{$_[2]}}, $_[0]; $_[1]; } } }; } elsif ($action_name =~ /die|warn/){ my $action = join '::', 'CORE', $action_name; $action = eval("sub { $action(\@_) }"); $local_opts->{store_cb} = sub { # Have to do this here, not prior to the sub, because the # options hash is not available until the methods have been # installed my $options = Class::MethodMaker::Engine->_class_comp_options($class, $_[2]); if ( exists $options->{static} ) { $is_set{$_[2]}++ ? $action->("Attempt to set slot ", ref($_[0]), '::', $_[2], " more than once") : $_[1]; } else { if ( exists $is_set{$_[2]} and grep $_ == $_[0], @{$is_set{$_[2]}} ) { $action->("Attempt to set slot ", ref($_[0]), '::', $_[2], " more than once") } else { push @{$is_set{$_[2]}}, $_[0]; $_[1]; } } }; } else { $local_opts->{store_cb} = sub { # Have to do this here, not prior to the sub, because the # options hash is not available until the methods have been # installed my $options = Class::MethodMaker::Engine->_class_comp_options($class, $_[2]); my $action = join '::', ref($_[0]), $action_name; no strict 'refs'; if ( exists $options->{static} ) { $is_set{$_[2]}++ ? &{$action}(@_[4..$#_]) : $_[1]; } else { if ( exists $is_set{$_[2]} and grep $_ == $_[0], @{$is_set{$_[2]}} ) { &{$action}(@_[4..$#_]); } else { push @{$is_set{$_[2]}}, $_[0]; $_[1]; } } }; } } else { die "Option $opt not recognized for get_set\n"; } } } $local_opts->{static} = 1 if $type eq 'static_get_set'; for (0..3) { $rename->{qw( * *_clear *_get *_set )[$_]} = $names[$_] if $_ < @names; } }; sub key_option { my ($v1type, $name, $rename, $local_opts, $target_class) = @_; my %list; if ( $name eq '-dummy' ) { $local_opts->{_value_list} = \%list; $local_opts->{key_create} = 1 if substr($v1type, -6) eq 'create'; $local_opts->{store_cb} = sub { if ( defined $_[3] ) { # the object must be in the hash under its old # value so that entry needs to be deleted delete $list{$_[3]}; } if ( defined $_[1] and exists $list{$_[1]} and $list{$_[1]} ne $_[0] ) { # There's already an object stored under that # value so we need to unset it's value my $x = $_[2]; $list{$_[1]}->$x(undef); } $list{$_[1]} = $_[0] if defined $_[1]; $_[1]; } } else { die "Option '$_' to get_concat unrecognized\n"; } } sub object_tie_option { my ($type, $opt, $rename, $local_opts) = @_; if ( ref $opt ) { while ( my ($optname, $optval) = each %$opt ) { $local_opts->{substr($optname, 1)} = $optval unless $optname eq '-ctor_args'; } } else { $local_opts->{substr($opt, 1)} = 1; } my $el_type = $opt->{-type}; my $ctor = $opt->{-default_ctor}; my $ctor_args = $opt->{-ctor_args}; $local_opts->{store_cb} = sub { my (undef, $value) = @_; [ map { if ( UNIVERSAL::isa($_, $el_type) ) { $_; } elsif ( ref($_) eq 'ARRAY' ) { # Nasty hack for nasty inconsistency in V1 implementations my @args = index($type, 'hash') >= 0 ? (@$ctor_args, @$_) : @$_; $el_type->$ctor(@args); } else { $el_type->$ctor(@$ctor_args); } } @$value ]; }; } # ------------------------------------- # Hackery for get_concat my $gc_join = ''; # Recognized keys are: # v2name # Name of v2 component type that implements this v1 call under the hood # rename # Method renames to apply (see create_methods) to make this look like the # v1 call # option # Subr called to parse options. # Receieves args # type ) The type of the component, as called by the user # (e.g., static_get_set) # opt ) The name of the option (including any leading '-'). # rename ) The rename hashref, as set up by rename above # local_opts ) An option hash. This is initially empty, it is the job # of the subr to add/subtract items to this as necessary. # Items may/shall accumulate as options are invoked on a # single typecall. # rephrase # Subr to rephrase arguments to a type call. If defined, this subr is # handed the arguments to the component type, in raw incoming form, and # its return value is used in place. This is to allow arbitrary argument # juggling. use constant V1COMPAT => { # New Methods -------------------- new => +{}, new_hash_with_init => +{ v2name => 'new', option => HASH_OPT_HANDLER, rephrase => rephrase_prefix_option(qw( -hash -init )), }, new_with_init => +{ v2name => 'new', option => HASH_OPT_HANDLER, rephrase => rephrase_prefix_option(qw( -init )) }, new_hash_init => +{ v2name => 'new', option => HASH_OPT_HANDLER, rephrase => rephrase_prefix_option(qw( -hash )), }, singleton => +{ v2name => 'new', option => HASH_OPT_HANDLER, rephrase => rephrase_prefix_option(qw(-hash -singleton -init)), }, # This is provided only for v1 compatibility; no attempt is made to # support this in V2, for it is a trivial application of new_with_init. new_with_args => +{ v2name => 'new', option => HASH_OPT_HANDLER, rephrase => rephrase_prefix_option(qw( -direct-init )) }, # Copy Methods ------------------- copy => +{}, deep_copy => +{ v2name => 'copy', option => sub { $_[3]->{deep} = 1; }, rephrase => rephrase_prefix_option('-dummy'), }, # Scalar Methods ----------------- get_set => { v2name => 'scalar', rename => SCALAR_RENAME, option => \&get_set_option, }, static_get_set => { v2name => 'scalar', rename => SCALAR_RENAME, option => \&get_set_option, rephrase => rephrase_prefix_option('-static'), }, tie_scalar => { v2name => 'scalar', rename => SCALAR_RENAME, rephrase => \&rephrase_tie, option => \&get_set_option, }, counter => { v2name => 'scalar', rename => SCALAR_RENAME, option => \&passthrough_option, rephrase => rephrase_prefix_option(+{-type => INTEGER}), }, get_concat => { v2name => 'scalar', rename => SCALAR_RENAME, option => sub { my ($type, $opt, $rename, $local_opts) = @_; if ( ref $opt ) { for ( keys %$opt ) { if ( $_ eq '-join' ) { $gc_join = $opt->{-join}; } else { die "Option '$_' to get_concat unrecognized\n"; } } } elsif ( $opt eq '-dummy' ) { my $join = $gc_join; $local_opts->{store_cb} = sub { defined $_[1] ? (defined $_[3] ? "$_[3]$join$_[1]" : $_[1] ) : undef; }; $gc_join = ''; } else { $local_opts->{substr($opt, 1)} = 1; } }, rephrase => sub { my @opts = @_; if ( UNIVERSAL::isa($_[0], 'HASH') ) { return [ +{ -join => $_[0]->{join}}, '-dummy', $_[0]->{name} ]; } else { return ['-dummy', ref $_[0] eq 'ARRAY' ? @{$_[0]} : $_[0] ]; } }, }, key_attrib => { v2name => 'scalar', rename => +{ %{SCALAR_RENAME()}, '*_find' => 'find_*', }, option => \&key_option, rephrase => rephrase_prefix_option(qw( -dummy )), }, key_with_create =>{ v2name => 'scalar', rename => +{ %{SCALAR_RENAME()}, '*_find' => 'find_*', }, option => \&key_option, rephrase => rephrase_prefix_option(qw( -dummy )), }, # Code-Based Types code => { v2name => 'scalar', rename => SCALAR_ONLY_X_RENAME, rephrase => rephrase_prefix_option('-dummy'), option => sub { my ($type, $opt, $rename, $local_opts) = @_; # Let's face it, the V1 i/f, with it's # store-if-it's-a-coderef-else-retrieve semantics # is rather broken. Which is why we engage in such # hackery... $local_opts->{read_cb} = sub { if ( ref($_[1]) eq 'ARRAY' ) { if ( @{$_[1]} == 1 ) { # No args return $_[1]->[0]->(); } elsif ( defined $_[1]->[1] ) { # Read with args that was handed to store return $_[1]->[0]->(@{$_[1]->[1]}); } else { # We're reading after a recent store pop @{$_[1]}; return $_[1]->[0]; } } }; $local_opts->{store_cb} = \&code_store_cb; }, }, method => { v2name => 'scalar', rename => SCALAR_ONLY_X_RENAME, rephrase => rephrase_prefix_option('-dummy'), option => sub { my ($type, $opt, $rename, $local_opts) = @_; # Let's face it, the V1 i/f, with it's # store-if-it's-a-coderef-else-retrieve semantics # is rather broken. Which is why we engage in such # hackery... $local_opts->{read_cb} = sub { if ( ref($_[1]) eq 'ARRAY' ) { if ( @{$_[1]} == 1 ) { # No args return $_[1]->[0]->($_[0]); } elsif ( defined $_[1]->[1] ) { # Read with args that was handed to store return $_[1]->[0]->($_[0], @{$_[1]->[1]}); } else { # We're reading after a recent store pop @{$_[1]}; return $_[1]->[0]; } } }; $local_opts->{store_cb} = \&code_store_cb; }, }, # List Methods ------------------- object => { v2name => 'scalar', rephrase => sub { my ($names) = @_; die("v1 meta-method object requires an arrayref as it's ", "argument\n") unless UNIVERSAL::isa($names, 'ARRAY'); my @Results; while ( my($type, $args) = splice @$names, 0, 2 ) { die("type specifier to v1 object must be a non-ref ", "value\n") if ref $type; for (UNIVERSAL::isa($args, 'ARRAY') ? @$args : $args) { my (@names, @fwds); if ( ! ref $_ ) { @names = $_; } elsif ( UNIVERSAL::isa($_, 'HASH') ) { @names = $_->{slot}; @fwds = $_->{comp_mthds}; @fwds = @{$fwds[0]} if UNIVERSAL::isa($fwds[0], 'ARRAY'); } else { die("Argument $_ to 'object' v1 meta-method not ", "comprehended\n"); } push (@Results, { -type => $type, -forward => \@fwds, -default_ctor => 'new', -v1_object => 1, }, @names); } } \@Results; }, option => \&passthrough_option, }, list => { v2name => 'array', rename => LIST_RENAME, }, static_list => { v2name => 'array', rename => LIST_RENAME, rephrase => rephrase_prefix_option('-static'), option => sub { my ($type, $opt, $rename, $local_opts) = @_; $local_opts->{static} = 1; }, }, object_list => { v2name => 'array', rename => LIST_RENAME, rephrase => sub { # This is deliberately low on error-handling. # We're not supporting V1 programming; if it works # with V1, all is well; if it doesn't, use the V2 # approach. We don't want people coding up new stuff # in V1 mode. my ($names) = @_; my @names; # Result for (my $i = 0; $i < @$names; $i+=2) { my ($class, $args) = @{$names}[$i,$i+1]; my @args = ref $args eq 'ARRAY' ? @$args : $args; push @names, +{ -type => $class, -default_ctor => 'new' }; for my $arg (@args) { if ( ref $arg eq 'HASH' ) { my ($slot, $comp_mthds) = @{$arg}{qw( slot comp_mthds )}; my @comp_mthds = ref $comp_mthds ? @$comp_mthds : $comp_mthds; push @names, +{ -forward => \@comp_mthds } if @comp_mthds; push @names, $slot; } else { push @names, $arg; } } } return \@names; }, option => \&passthrough_option, }, tie_list => { v2name => 'array', rename => LIST_RENAME, rephrase => \&rephrase_tie, option => \&passthrough_option, }, object_tie_list => { v2name => 'array', rename => LIST_RENAME, rephrase => sub { # This is deliberately low on error-handling. # We're not supporting V1 programming; if it works # with V1, all is well; if it doesn't, use the V2 # approach. We don't want people coding up new # stuff in V1 mode. my ($names) = @_; my @names; # Result for my $hashr (@$names) { my ($slots, $class, $tie_args) = @{$hashr}{qw( slot class tie_array )}; my @slots = ref $slots eq 'ARRAY' ? @$slots : $slots; my @class_args; ($class, @class_args) = @$class if ref $class eq 'ARRAY'; my $ctor; if ( @class_args ) { $ctor = sub { return $class->new(@class_args); }; } else { $ctor = 'new'; } my ($tie_class, @tie_args) = @$tie_args; push @names, +{ -type => $class, -default_ctor => 'new', -ctor_args => \@class_args, -tie_class => $tie_class, -tie_args => \@tie_args,}; push @names, @slots; } return \@names; }, option => \&object_tie_option, }, object_tie_hash => { v2name => 'hash', rename => HASH_RENAME, rephrase => sub { # This is deliberately low on error-handling. # We're not supporting V1 programming; if it works # with V1, all is well; if it doesn't, use the V2 # approach. We don't want people coding up new # stuff in V1 mode. my ($names) = @_; my @names; # Result for my $hashr (@$names) { my ($slots, $class, $tie_args) = @{$hashr}{qw( slot class tie_hash )}; my @slots = ref $slots eq 'ARRAY' ? @$slots : $slots; my @class_args; ($class, @class_args) = @$class if ref $class eq 'ARRAY'; my $ctor; if ( @class_args ) { $ctor = sub { return $class->new(@class_args); }; } else { $ctor = 'new'; } my ($tie_class, @tie_args) = @$tie_args; push @names, +{ -type => $class, -default_ctor => 'new', -ctor_args => \@class_args, -tie_class => $tie_class, -tie_args => \@tie_args,}; push @names, @slots; } return \@names; }, option => \&object_tie_option, }, # Hash Methods ------------------- hash => +{ rename => HASH_RENAME, }, static_hash => { v2name => 'hash', rename => HASH_RENAME, option => \&passthrough_option, rephrase => rephrase_prefix_option('-static'), }, tie_hash => { v2name => 'hash', rename => HASH_RENAME, rephrase => \&rephrase_tie, option => \&passthrough_option, }, # Misc Methods ------------------- abstract => +{}, boolean => { v2name => '_boolean', rename => +{ '*_set' => 'set_*', '*_clear' => 'clear_*', }, }, }; # ---------------------------------------------------------------------------- =head1 EXAMPLES Z<> =head1 BUGS Z<> =head1 REPORTING BUGS Email the development mailing list C. =head1 AUTHOR Martyn J. Pearce =head1 COPYRIGHT Copyright (c) 2003, 2004 Martyn J. Pearce. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO Z<> =cut 1; # keep require happy. __END__ Class-MethodMaker-2.24/lib/Class/MethodMaker/Constants.pm0000644000175000017500000000262012311332105021226 0ustar ss5ss5# (X)Emacs mode: -*- cperl -*- package Class::MethodMaker::Constants; =head1 NAME Class::MethodMaker::Constants - The Constants Class for Class::MethodMaker =head1 SYNOPSIS Z<> =head1 DESCRIPTION Z<> =cut # ---------------------------------------------------------------------------- # Pragmas ----------------------------- require 5.006; use strict; use warnings; use base qw( Exporter ); our @EXPORT_OK = qw( INTEGER ); # ---------------------------------------------------------------------------- # CLASS METHODS -------------------------------------------------------------- # ------------------------------------- # CLASS CONSTANTS # ------------------------------------- =head1 CLASS CONSTANTS Z<> =cut use constant INTEGER => '+INTEGER'; # Prefix to ensure clients don't just # assume the string: this value may well # change in the future # ---------------------------------------------------------------------------- =head1 EXAMPLES Z<> =head1 BUGS Z<> =head1 REPORTING BUGS Email the development mailing list C =head1 AUTHOR Martyn J. Pearce =head1 COPYRIGHT Copyright (c) 2003 Martyn J. Pearce. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO Z<> =cut 1; # keep require happy. __END__ Class-MethodMaker-2.24/lib/Class/MethodMaker/Engine.pm0000644000175000017500000010561112506541107020475 0ustar ss5ss5# (X)Emacs mode: -*- cperl -*- package Class::MethodMaker::Engine; =head1 NAME Class::MethodMaker::Engine - The parameter passing, method installation & non-data-structure methods of Class::MethodMaker. =head1 SYNOPSIS This class is for internal implementation only. It is not a public API. The non-data-structure methods do form part of the public API, but not called directly: rather, called through the C/C interface, as for data-structure methods. =cut # Pragmas ----------------------------- use 5.006; use strict; use warnings; use warnings::register; # Inheritance ------------------------- our @ISA = qw( AutoLoader ); # Utility ----------------------------- use AutoLoader qw( AUTOLOAD ); use Carp qw( carp croak cluck ); use Class::MethodMaker::OptExt qw( OPTEXT ); use Class::MethodMaker::V1Compat qw( V1COMPAT ); # ---------------------------------------------------------------------------- # CLASS METHODS -------------------------------------------------------------- # ------------------------------------- # CLASS CONSTANTS # ------------------------------------- # Weird "useless use of a constant in void context" without the ?: use constant DEBUG => $ENV{_CMM_DEBUG} ? 1 : 0; BEGIN { if ( DEBUG ) { require B::Deparse; require Data::Dumper; Data::Dumper->import('Dumper'); } } # ------------------------------------- our $PACKAGE = 'Class-MethodMaker'; our $VERSION = '2.24'; # ------------------------------------- # CLASS CONSTRUCTION # ------------------------------------- # ------------------------------------- # CLASS COMPONENTS # ------------------------------------- # A starter for introspective information # For each class, a list of the components installed for that class (as a # hashref from name to hashref. Keys of latter hashref: # 'type' name of component type, e.g., scalar, array, hash # 'assign' name of method to perform assignment. This is used by new with # hash_init. This level of indirection is to cater for the # possibility of an assignment function named other than '*' my %class_comps; sub _class_comp_assign { exists $class_comps{$_[1]}->{$_[2]} ? $class_comps{$_[1]}->{$_[2]}->{assign} : undef; } sub _class_comp_options { exists $class_comps{$_[1]}->{$_[2]} ? $class_comps{$_[1]}->{$_[2]}->{options} : undef; } # ------------------------------------- # CLASS HIGHER-LEVEL FUNCTIONS # ------------------------------------- # ------------------------------------- # CLASS HIGHER-LEVEL PROCEDURES # ------------------------------------- =head1 The Class::MethodMaker Method Installation Engine Z<> =cut # ------------------------------------- =head2 import This performs argument parsing ready for calling create_methods. In particular, this is the point at which v1 & v2 calls are distinguished. This is implicitly called as part of a C statement: use Class::MethodMaker [ scalar => [qw/ foo bar baz /], new => [qw/ new /] , ]; is equivalent to Class::MethodMaker->import([scalar => [qw/ foo bar baz /], new => [qw/ new /] , ]); See L for details of this equivalence. The methods created are installed into the class calling the import - or more accurately, the first class up the calling stack that is not C or a subclass thereof. =over 4 =item SYNOPSIS Class::MethodMaker->import([scalar => [+{ -type => 'File::Stat', -forward => [qw/ mode size /], '*_foo' => '*_fig', '*_gop' => undef, '*_bar' => '*_bar', '*_hal' => '*_sal', }, qw/ -static bob /, ] ]); =back =cut sub import { my $class = shift; my $target = $class->_find_target_class; my (@args); my $mode = 2; return unless @_; if ( @_ == 1 ) { croak "import requires an arrayref" unless UNIVERSAL::isa($_[0], 'ARRAY'); @args = @{$_[0]}; } else { croak("import requires an even number of arguments in v1 compatibility ". "mode") unless @_ % 2 == 0; @args = @_; # -1 on $#args ensures that no range is generated when $#args is 0. # check above ensures that scalar(@args) is even, so $#args is odd, # so $#args-1 is even and ($#args-1)/2 == int ($#args/2). .. provides an # integer context to its operands. $mode = 1 for grep exists V1COMPAT->{$_}, map $args[$_*2], 0..($#args-1)/2; if ( $mode == 1 ) { croak("meta-method type $_ not recognized as a V1 compatibility type\n" . "(cannot mix v1 & v2 options)\n") for grep ! exists V1COMPAT->{$_}, map $args[$_*2], 0..($#args-1)/2; } else { croak('meta-method' . (($#args/2>1) ? 's' : '') . ' ' . join(', ', map qq'"$args[$_*2]"', 0..($#args-1)/2) . " found in v1 compatibility mode, but not recognized as v1.\n" . "please update to v2, presenting your arguments to use/import\n" . "as a single arrayref (wrap them with [...])\n"); } } if ( $mode == 1 ) { $class->parse_v1_options($target, \@args); } else { $class->parse_options($target, \@args); } } # ------------------------------------- =head2 parse_options Parse the arguments given to import and call L appropriately. See main text for options syntax. =over 4 =item SYNOPSIS Class::MethodMaker->parse_options('TargetClass', [scalar => [{ -type => 'File::stat', -forward => [qw/ mode size /], '*_foo' => '*_fig', '*_gop' => undef, '*_bar' => '*_bar', '*_hal' => '*_sal', }, qw( -static bob ), ]])}, Class::MethodMaker->parse_options('TargetClass2', [scalar => ['baz', { -type => 'File::stat', -forward => [qw/ mode size /], '*_foo' => '*_fog', '*_bar' => '*_bar', '*_hal' => '*_sal', }, qw( -static bob ), ]], +{ -type => 'Math::BigInt', }, +{'*_foo' => '*_fig', '*_gop' => undef,}, )}, =item ARGUMENTS =over 4 =item target_class The class into which to install components =item args The arguments to parse, as a single arrayref. =item options A hashref of options to apply to all components created by this call (subject to overriding by explicit option calls). =item renames A hashref of renames to apply to all components created by this call (subject to overriding by explicit rename calls). =back =back =cut sub parse_options { my $class = shift; my ($target_class, $args, $options, $renames) = @_; print STDERR ("Parsing Options: ", Data::Dumper->Dump([$args, $options, $renames], [qw( args options renames )])) if DEBUG; my (%options, %renames); # It is important that components are created in the specified order, so # that e.g., forwarding works as expected (lest the forward method applies # to the wrong component). for (my $i = 0; $i < @$args; $i++) { if ( ! ref $args->[$i] ) { my $type = $args->[$i]; if ( substr($type, 0, 1) eq '-' ) { my $option = substr($type, 1); if ( $option eq 'target_class' ) { croak "No argument found for -target_class\n" if $i == $#$args; $target_class = $args->[++$i]; croak "-target_class takes a simple scalar argument\n" if ref $target_class; } else { croak "Unrecognized option: $type\n"; } } else { # Reset options, renames to input global settings %options = defined $options ? %$options : (); %renames = defined $renames ? %$renames : (); my $created = 0; croak("No arguments found for $type while creating methods for ", $target_class, "\n") if $i == $#$args; my $opts = $args->[++$i]; if ( UNIVERSAL::isa($opts, 'SCALAR') ) { $class->create_methods ($target_class, $type, $opts, \%options, \%renames); $created = 1; } elsif ( UNIVERSAL::isa($opts, 'ARRAY') ) { for (@$opts) { if ( ! ref $_ ) { if ( $_ =~ /^[A-Za-z_][0-9A-Za-z_]*$/ ) { $class->create_methods ($target_class, $type, $_, \%options, \%renames); $created = 1; } elsif ( $_ =~ /^([-!])([0-9A-Za-z_]+)$/ ) { $options{$2} = ($1 eq '!' ? 0 : 1); } else { croak "Argument $_ for type $type not understood\n"; } } elsif ( UNIVERSAL::isa($_, 'HASH') ) { while ( my ($k, $v) = each %$_ ) { if ( index($k, '*') > $[-1 ) { $renames{$k} = $v; } else { $k =~ s/^-//; $options{$k} = $v; } } } elsif ( UNIVERSAL::isa($_, 'ARRAY') ) { $class->parse_options($target_class, [$type, $_], \%options, \%renames); } else { croak("Argument type " . ref($_) . " to type $type not handled\n"); } } } else { $class->create_methods ($target_class, $type, $opts, $options, $renames); $created = 1; } warnif("No attributes found for type $type\n") unless $created; } } else { croak "Argument not handled: ", $args->[$i], "\n"; } } return; } # ------------------------------------- # V1 compatibility is purposely not documented. sub parse_v1_options { my $class = shift; my ($target_class, $args) = @_; print STDERR "V1 Parser (1) : ", Data::Dumper->Dump([$args], [qw( args )]) if DEBUG; while (my ($v1type, $names) = splice @$args, 0, 2 ) { my %options = (v1_compat => 1); croak("No argument found for $v1type while creating methods for ", $target_class, "\n") unless defined $names; my $v2type = $v1type; my ($rename, $opt_handler, $rephrase); if ( exists V1COMPAT->{$v1type} ) { my $v1compat = V1COMPAT->{$v1type}; $v2type = $v1compat->{v2name} if exists $v1compat->{v2name}; ($rename, $opt_handler, $rephrase) = @{$v1compat}{qw(rename option rephrase)}; print STDERR "V1 Parser (2) : ", Data::Dumper->Dump([$v1type, $v2type, $v1compat, $rename, $opt_handler, $rephrase,], [qw(v1type v2type v1compat rename opt_handler rephrase)]) if DEBUG; } print STDERR "V1 Parser (3) : ", Data::Dumper->Dump([$names],[qw(inames)]) if DEBUG; if ( defined $rephrase ) { $names = $rephrase->($names); print STDERR "V1 Parser (3.5) : ", Data::Dumper->Dump([$names],[qw(rephrased)]) if DEBUG; } # warnif("Class::MethodMaker V1 compatibility mode enabled for $type\n"); my @names = UNIVERSAL::isa($names, 'ARRAY') ? @$names : $names; for (@names) { if ( ref($_) or substr($_, 0, 1) eq '-' ) { print STDERR "V1 Parser (4) : ", Data::Dumper->Dump([\%options, $_],[qw(options name)]) if DEBUG; if ( defined $opt_handler ) { $opt_handler->($v1type, $_, $rename, \%options, $target_class); } else { croak "Options not handled for v1 type $v1type\n"; } print STDERR "V1 Parser (4.5) : ", Data::Dumper->Dump([\%options],[qw(options)]) if DEBUG; } else { $class->create_methods($target_class, $v2type, $_, \%options, $rename); } } } } # ------------------------------------- =head2 create_methods Add methods to a class. Methods for multiple components may be added this way, but create_methods handles only one set of options. L is responsible for sorting which options to apply to which components, and calling create_methods appropriately. =over 4 =item SYNOPSIS Class::MethodMaker->create_methods($target_class, scalar => bob, +{ static => 1, type => 'File::Stat', forward => [qw/ mode size /], }, +{ '*_foo' => '*_fig', '*_gop' => undef, '*_bar' => '*_bar', '*_hal' => '*_sal', } ); =item ARGUMENTS =over 4 =item targetclass The class to add methods to. =item type The basic data structure to use for the component, e.g., C. =item compname Component name. The name must be a valid identifier, i.e., a continuous non-empty string of word (C<\w>) characters, of which the first may not be a digit. =item options A hashref. Some options (C, C, C, C) are handled by the auto-extender. These will be invoked if the name is present as a key and the value is true. Any other options are passed through to the method in question. The options should be named as-is; no leading hyphen should be applied (i.e., use C<< {static => 1} >> not C<< {-static => 1} >>). =item renames A list of customer renames. It is a hashref from method name to rename. The method name is the generic name (i.e., featuring a C<*> to replace with the component name). The rename is the value to rename with. It may itself contain a C<*> to replace with the component name. If rename is undef, the method is I installed. For methods that would not be installed by default, use a rename value that is the same as the method name. So, if a type would normally install methods '*_foo', '*_gop', '*_tom' and optionally installs (but not by default) '*_bar', '*_wiz', '*_hal' using a renames value of { '*_foo' => '*_fig', '*_gop' => undef, '*_bar' => '*_bar', '*_hal' => '*_sal', } with a component name of C, then C<*_foo> is installed as C, C<*_bar> is installed as C, C<*_wiz> is not installed, C<*_hal> is installed as C, C<*_gop> is not installed, and C<*_tom> is installed as C. The value may actually be an arrayref, in which case the function may be called by any of the multiple names specified. =back =back =cut # This is the bit that does the actual creation. For options-handling # excitement, see import. sub create_methods { my $class = shift; my ($targetclass, $type, $compname, $options, $renames) = @_; if ( exists $class_comps{$targetclass}->{$compname} ) { croak("The component '$compname' has already been installed in class " . "-->$targetclass<-- as a $class_comps{$targetclass}->{$compname}\n" . " (this time a $type)\n"); } print STDERR "Create methods (1) : ", Data::Dumper->Dump ([ $type, $compname, $options, $renames], [qw(type compname options renames)] ) if DEBUG; my (%options) = defined $options ? %$options : (); if ( exists $options{type} and substr($options{type}, 0, 1) eq '+' ) { $options{typex} = substr(delete $options{type}, 1); my $coerce = sub { no warnings 'numeric'; int($_[1]||0) }; for my $optname (qw( store_cb read_cb )) { if ( exists $options{$optname} ) { $options{$optname} = [$options{$optname}] unless ref($options{$optname}) eq 'ARRAY'; push @{$options{$optname}}, $coerce; } else { $options{$optname} = $coerce; } } } croak("Illegal attribute name -->$compname<--" . " (must be a legal perl identifier)\n") unless $compname =~ /^(?!\d)\w+$/; my ($opts, $creator); # Some options are handled by the cmmg.pl auto-extender. # Find the method-name extension & options this represents (my ($ext), $opts) = Class::MethodMaker::OptExt->encode($type, [grep $options{$_}, keys %options]); croak "Illegal combination of options: ", join(',', keys %options), "\n" if ( ! defined $ext ); $creator = length $ext ? join('', substr($type, 0, 4), $ext) : $type; my $create_class = $class; if ( length $ext ) { require "Class/MethodMaker/${type}.pm"; $create_class = "Class::MethodMaker::${type}"; } print STDERR "Create methods (2) : ", Data::Dumper->Dump ([ $create_class, $creator, $ext, $opts], [qw( create_class creator ext opts)] ) if DEBUG; my ($methods, $names); eval { ($methods, $names) = $create_class->$creator($targetclass, $compname, \%options); }; if ( $@ ) { if ( $@ =~ m"^Can't locate auto/Class/MethodMaker/(\S*)" ) { my $message = "Couldn't find meta-method for type $type"; $message .= " with options -->" . join(', ', @$opts) . "<--" if @$opts; croak("$message ($creator [$create_class])\n"); } else { die $@; } } print STDERR "Create methods (3) : ", Data::Dumper->Dump([$methods, $names], [qw(methods names)]) if DEBUG; my $assign_name = exists $names->{'='} ? delete $names->{'='} : '*'; if ( defined $names ) { croak "Names value for key $_ should not be defined ($names->{$_})\n" for grep defined $names->{$_}, keys %$names; } my %methods; my %realname; METHNAME: while ( my ($methname, $code) = each %$methods ) { # If a method's raw name is preceded by a '!', don't install it unless # explicitly requested (exists in customer renames) print STDERR "CREATE: Considering method $methname\n" if DEBUG; if ( index($methname, ':') > -1 ) { # Some typed method. Only install if the appropriate type is specified. $methname =~ s/(\w+)://; my $type = $1; next METHNAME unless exists $options{typex} and $type eq $options{typex}; } unless ( substr($methname, 0, 1) eq '!' and ! exists $renames->{substr($methname, 1)} ) { $methname =~ s/^!//; my $realname = exists $renames->{$methname} ? $renames->{$methname} : $methname; # If the subr is required (because it's used by other subrs of the # attribute) but isn't wanted by the user (renamed to undef), sneak it # into the symbol table prefixed by a space, so it's not normally # accessible. if ( ! defined $realname and exists $names->{$methname} ) { $realname = " $methname"; } print STDERR ("CREATE: Using realname ", (defined $realname ? (ref $realname ? "[" . join (',', map "'$_'", @$realname) . "]" : "'$realname'") : '*undef*' ), "\n") if DEBUG; if ( defined $realname ) { for my $rn (ref $realname ? @$realname : $realname) { my $copy = $rn; # Copy to avoid clobbering the original array $copy =~ s/\*/$compname/g; print STDERR "CREATE: Installing $copy\n" if DEBUG; $methods{$copy} = $code; $names->{$methname} = $copy if defined $names; # It's okay if this gets assigned multiple times (because $realname # is an arrayref); each assignment gives it a valid name, we care # not which is used. $realname{$methname} = $copy; } } else { $realname{$methname} = undef; } } } print STDERR "Create methods (4) : ", Data::Dumper->Dump([\%methods, \%realname], [qw(*methods *realname)]) if DEBUG; # Now, I want some installed methods to be able to call some others. # However, I also want to be able to rename methods on the fly to the # users' specification. # I can't pass a set of renames into the component creator without the # caller knowing the set of names for the component to rename --- only the # component knows the names of the methods to create, and they may be # affected by arguments. I don't want to duplicate that knowledge elsewhere. # I can't have the methods call each other via names in the symbol table, # lest the method called gets renamed. # If we have the sub called directly (without the symbol table), we get # burnt when users replace the method (expecting it to get called) # or override it from a subclass. # If we don't call methods from one to another, but instead 'inline' the # relevant code, then we're liable to introduce more bugs (esp. as updates # are made) in addition to the same problem set as calling the methods # without the symbol table. Therefore, we have the 'names' hash, # returned above. This hash specifies a set of methods to be installed # whatever (i.e., even if they're not visible to the user), so that they # may be called by other methods. The hash keys are the default name of # the method, the values are set (by this subroutine, 'create_methods') to # the actual code, whatever name it gets installed as. $class->install_methods($targetclass, \%methods); $class_comps{$targetclass}->{$compname} = +{ type => $type , assign => $realname{$assign_name}, options => \%options, }; return; } # ------------------------------------- # Find the class to add the methods to. I'm assuming that it would be the # first class in the caller() stack that's not a subclass of MethodMaker. If # you want something more sophisticated implement it --- and call # create_methods, specifying exactly the target class. If you can think of a # better way of determining the target class, let me know! sub _find_target_class { my $class = shift; my $target; my $i = 0; do { $target = (caller($i))[0]; $i++; } while ( ( $target->isa('Class::MethodMaker::Engine') or $target->isa('Class::MethodMaker') ) and # This is "supported" for v1 compatibility only. Direct calling # of create_methods is the preferred way of using # Class::MethodMaker to build C::MM subclasses (! $target->can ('ima_method_maker') or ( warnif("Class::MethodMaker::ima_method_maker deprecated\n"), &{$target->can ('ima_method_maker')} ) ) ); return $target; } # ------------------------------------- =head2 install_methods =over 4 =item SYNOPSIS Class::MethodMaker->install_methods ($classname, { incr => sub { $i++ }, decr => sub { $i-- }, } ); =item ARGUMENTS =over 4 =item target The class into which the methods are to be installed =item methods The methods to install, as a hashref. Keys are the method names; values are the methods themselves, as code refs. =back =back =cut sub install_methods { my $class = shift; my ($target, $methods) = @_; while ( my ($name, $code) = each %$methods ) { if ( DEBUG ) { print STDERR "Installing method '$name' into $target\n"; eval { my @opts = qw( -sC -i2); push @opts, '-l' if DEBUG > 1; print STDERR B::Deparse->new(@opts)->coderef2text($code), "\n"; }; if ($@) { print STDERR "Couldn't deparse '$name': $@\n"; } } my $reftype = ref $code; if ( $reftype eq 'CODE' ) { my $methname = join '::', $target, $name; no strict 'refs'; if ( ! defined *{$methname}{CODE} ) { *{$methname} = $code; # Generate a unique stash name for the sub. Use a preceding space # to avoid collisions with anything in the Perl space. croak "Could not create stash name for '$name'" unless Class::MethodMaker::set_sub_name($code, $target, $name, "${target}::${name}"); } } else { croak "What do you expect me to do with this?: $code\n"; } } } # ------------------------------------- # CLASS UTILITY FUNCTIONS # ------------------------------------- sub warnif { warnings::warnif (@_) }; # sub warnif { warnings::warn (@_) if (warnings::enabled()) }; sub check_opts { my ($known_opts, $options) = @_; $known_opts = +{ map {;$_=>1} @$known_opts } if ref $known_opts eq 'ARRAY'; if ( my @bad_opt = grep ! exists $known_opts->{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type scalar: ", join(', ', @bad_opt), "\n"); } } # ------------------------------------- # META-METHODS # ------------------------------------- 1; # keep require happy __END__ =head1 Non-data-structure components Z<> =cut =head2 new use Class::MethodMaker [ new => 'new' ]; Creates a basic constructor. Takes a single string or a reference to an array of strings as its argument. For each string creates a simple method that creates and returns an object of the appropriate class. The generated method may be called as a class method, as usual, or as in instance method, in which case a new object of the same class as the instance will be created. =head3 Options =over 4 =item -hash The constructor will accept as arguments a list of pairs, from component name to initial value. For each pair, the named component is initialized by calling the method of the same name with the given value. E.g., package MyClass; use Class::MethodMaker [ new => [qw/ -hash new /], scalar => [qw/ b c /], ]; sub d { my $self = shift; $self->{d} = $_[0] if @_; return $self->{d}; } package main; # The statement below implicitly calls # $m->b(1); $m->c(2); $m->d(3) # on the newly constructed m. my $m = MyClass->new(b => 1, c => 2, d => 3); Note that this can also call user-supplied methods that have the name of the component. Instead of a list of pairs, a single hashref may also be passed, which will be expanded appropriately. So the above is equivalent to: my $m = MyClass->new({ b => 1, c => 2, d => 3 }); I Class::MethodMaker method renaming is taken into account, so even if the C<*> method is renamed or removed, this will still work. =item -init This option causes the new method to call an initializer method. The method is called C (original, eh?) by default, but the option may be given an alternative value. The init method is passed any arguments that were passed to the constructor, but the method is invoked on the newly constructed instance. use Class::MethodMaker [ new => [qw/ -init new1 /, { -init => 'bob' } => 'init2' ]]; Constructing with new1 involves an implicit call to C, whilst constructing with new2 involves an implicit call to C (I of C). It is the responsibility of the user to ensure that an C method (or whatever name) is defined. =item -singleton Creates a basic constructor which only ever returns a single instance of the class: i.e., after the first call, repeated calls to this constructor return the I instance. Note that the instance is instantiated at the time of the first call, not before. =back =cut sub new { my $cmm_class = shift; my ($target_class, $name, $options, $global) = @_; check_opts([qw/ init hash direct-init v1_compat singleton /], $options); my $init_meth = $options->{init}; $init_meth = 'init' if defined $init_meth and $init_meth eq '1'; my $new; my $singleton; if ( $options->{hash} ) { $new = sub { my $self = $options->{singleton} ? ($singleton || ($singleton = bless {}, $_[0])) : (ref ($_[0]) ? $_[0] : bless {}, $_[0]) ; my $class = ref $self || $self; my %args; if ( @_ == 2 and ref($_[1]) eq 'HASH' ) { %args = %{ $_[1] }; } elsif ( @_ % 2 ) { %args = @_[1..$#_]; } else { die "Odd number of arguments for $name\n"; } foreach (keys %args) { my $assign = $cmm_class->_class_comp_assign($class, $_); if ( defined $assign and my $setter = $class->can($assign) ) { $setter->($self, $args{$_}); } else { $self->$_($args{$_}); } } $self->$init_meth(@_[1..$#_]) if $init_meth; $self; }; } elsif ( $init_meth ) { $new = sub { my $class = ref $_[0] || $_[0]; my $self = $options->{singleton} ? ($singleton || ($singleton = bless +{}, $class)) : bless(+{}, $class) ; $self->$init_meth(@_[1..$#_]); $self; }; } elsif ( $options->{'direct-init'} ) { # This is here purely for v1 compatibility. It can be trivially # implemented with -init, so is not explicitly supported for V2. $new = sub { my $class = ref $_[0] || $_[0]; bless +{@_[1..$#_]}, $class; }; } else { $new = sub { my $class = ref $_[0] || $_[0]; $options->{singleton} ? ($singleton || ($singleton = bless +{}, $class)) : bless(+{}, $class) ; }; } return +{ '*' => $new, }; } # ---------------------------------------------------------------------------- =head2 abstract use Class::MethodMaker [ abstract => [ qw / foo bar baz / ] ]; This creates a number of methods that will die if called. This is intended to support the use of abstract methods, that must be overridden in a useful subclass. =cut sub abstract { my $class = shift; my ($tclass, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type abstract: ", join(', ', @bad_opt), "\n"); } return +{ '*' => sub { my ($self) = @_; my $cclass = ref $self; die <<"END"; Cannot invoke abstract method '${tclass}::${name}', called from '$cclass'. END }, }; } # ---------------------------------------------------------------------------- =head2 copy use Class::MethodMaker [ copy => [qw/ shallow -deep deep /] ]; This creates method that produce a copy of self. The copy is a by default a I copy; any references will be shared by the instance upon which the method is called and the returned newborn. One option is taken, C<-deep>, which causes the method to create I copies instead (i.e., references are copied recursively). B Deep copies are performed using the C module if available, else C. The C module is liable to be much quicker. However, this implementation note is not an API specification: the implementation details are open to change in a future version as faster/better ways of performing a deep copy become available. Note that deep copying does not currently support the copying of coderefs, ties or XS-based objects. =cut sub copy { my $class = shift; my ($tclass, $name, $options, $global) = @_; check_opts([qw/ v1_compat deep /], $options); if ( $options->{deep} ) { eval 'use Storable;'; eval 'use Data::Dumper;' if $@; die("Couldn't find required Data::Dumper module for deep copying: $@\n", "(which is odd, 'cause it's part of the core...\n") if $@; return +{ '*' => sub { my $self = shift; my $class = ref $self; if ( Storable->VERSION ) { return Storable::dclone $self; } else { my $copy; eval Data::Dumper->Dump([$self],['copy']); return $copy; } }, }; } else { return +{ '*' => sub { my $self = shift; my $class = ref $self; return bless { %$self }, $class; }, }; } } # ---------------------------------------------------------------------------- # This supplied for V1 compatiblity only my (%BooleanPos, %BooleanFields); sub _boolean { my $class = shift; my ($tclass, $name, $options, $global) = @_; check_opts([qw/ v1_compat /], $options); my $bstore = join '__', $tclass, 'boolean'; $BooleanFields{$tclass} ||= []; my $boolean_fields = $BooleanFields{$tclass}; my $bfp = $BooleanPos{$tclass}++; # $boolean_pos a global declared at top of file. We need to make a local # copy because it will be captured in the closure and if we capture the # global version the changes to it will effect all the closures. (Note also # that it's value is reset with each call to import_into_class.) push @$boolean_fields, $name; # $boolean_fields is also declared up above. It is used to store a list of # the names of all the bit fields. return +{ 'bits' => sub { my ($self, $new) = @_; defined $new and $self->{$bstore} = $new; $self->{$bstore}; }, 'bit_fields' => sub { @$boolean_fields; }, 'bit_dump' => sub { my ($self) = @_; map { ($_, $self->$_()) } @$boolean_fields; }, '*' => sub { my ($self, $on_off) = @_; defined $self->{$bstore} or $self->{$bstore} = ""; if (defined $on_off) { vec($self->{$bstore}, $bfp, 1) = $on_off ? 1 : 0; } vec($self->{$bstore}, $bfp, 1); }, '*_set' => sub { my ($self) = @_; $self->$name(1); }, '*_clear' => sub { my ($self) = @_; $self->$name(0); }, }; } =head1 AUTHOR Martyn J. Pearce =cut Class-MethodMaker-2.24/lib/Class/.placeholder0000644000175000017500000000000011735360552017005 0ustar ss5ss5Class-MethodMaker-2.24/lib/Class/MethodMaker.pm0000644000175000017500000006633512506541107017301 0ustar ss5ss5# (X)Emacs mode: -*- cperl -*- package Class::MethodMaker; use strict; use warnings; use Class::MethodMaker::Constants qw( ); use Class::MethodMaker::Engine qw(); # Make this line self-contained so MakeMaker can eval() it. our $VERSION = '2.24'; our $PACKAGE = 'Class-MethodMaker'; our $AUTOLOAD; use XSLoader qw(); XSLoader::load 'Class::MethodMaker', $VERSION; sub AUTOLOAD { (my $x = $AUTOLOAD) =~ s/^Class::MethodMaker/Class::MethodMaker::Engine/; goto &$x(@_); } sub import { Class::MethodMaker::Engine->import(@_[1..$#_]) } sub INTEGER() { Class::MethodMaker::Constants::INTEGER() } 1; # keep require happy __END__ =head1 NAME Class::MethodMaker - Create generic methods for OO Perl =head1 SYNOPSIS use Class::MethodMaker [ scalar => [qw/ foo bar baz /], new => [qw/ new /] , ]; =head1 DESCRIPTION This module solves the problem of having to continually write accessor methods for your objects that perform standard tasks. The argument to 'use' is an B, as pairs whose "keys" are the names of types of generic methods generated by MethodMaker and whose "values" tell method maker what methods to make. To override any generated methods, it is sufficient to ensure that the overriding method is defined when Class::MethodMaker is called. Note that the C keyword introduces a C block, so you may need to define (or at least declare) your overriding method in a C block. =head2 Simple Use A simple class made with C looks like this: package MyClass; use Class::MethodMaker [ scalar => [qw/ name /], new => [qw/ new /], ]; This creates a class, of which new instances may be created using C, each with a single scalar component called C. Name may be queried and (re)set using the methods C, C and C: package main; my $m = MyClass->new; my $n; $\ = "\n"; print $m->name_isset ? "true" : "false"; # false $m->name("foo"); $n = $m->name; print defined $n ? "->$n<-" : "*undef*"; # ->foo<- print $m->name_isset ? "true" : "false"; # true $m->name(undef); $n = $m->name; print defined $n ? "->$n<-" : "*undef*"; # *undef* print $m->name_isset ? "true" : "false"; # true $m->name_reset; $n = $m->name; print defined $n ? "->$n<-" : "*undef*"; # *undef* print $m->name_isset ? "true" : "false"; # false The available component types are L, L, L. Certain non-data-type utilities are also provided: L, for constructors, L and L for object copies, and L for creating abstract methods. Each of the components take common options. These include L<-static>, for per-class rather than per-instance data, L<-type>, to restrict the data stored to certain types (e.g., objects of a certain class), L<-forward> to forward (proxy) given methods onto components, L<-default>/L<-default_ctor> to set default values for components, L<-tie_class> to tie the storage of a data type to a given class, L<-read_cb>/L<-store_cb> to call user-defined functions on read/store (without the overhead/complexity of ties; and allowing callbacks on existing tie classes). =head2 Detailed Use C installs I into a class, by means of methods that interrogate and amend those components. A component, sometimes referred in other documentation as a I is a group of one or more attributes (variables) that are associated with an instance of a class (sometimes called an object), or occasionally a class itself (often referred to as a I component). A component is intended as a cohesive unit of data that should only normally be interrogated or set through the methods provided. Given an instance of a class where each instance represents a car, examples of components are the C and C (each of which would be a simple scalar, a string), the engine (a simple scalar, an instance of Engine::Combustion), and the wheels (an array of instances of Wheel). Note that the wheels form one component, an array. Of course, the implementor might instead choose to use four components, each being a scalar wheel. To have the components created, the principle use of Class::MethodMaker is to specify the type (data-structure) and name of each component to the import method of Class::MethodMaker package MyClass; use Class::MethodMaker [ scalar => 'name', new => [qw/ new /], ]; In this example, the import is called implicitly via the C statement. The components are installed in the package in effect where the import is called. The argument to import is arranged as pairs, where the first of each pair is the type of the data-structure, the second is the arguments for that data-structure; in the most simple case, the name of a component to install using that data-structure. The second of the pair should be an arrayref if not a simple name. Data-structures may be repeated in the call: use Class::MethodMaker [ scalar => 'name1', new => [qw/ new /], scalar => 'name2', ]; It is an error to attempt to install a two or more components with the same name twice. Options may be given to data structures to amend the nature and behaviour of the components created. Some options are common across all data structure (e.g., C) whilst some are specific to their respective data structures. Option syntax is laid out in detail below. In simple, options are provided by way of hashrefs from option name to option value. Options and component names are order-sensitive; options appearing after a component do not affect that component. Options only apply to the data-structure to which they are specified. B options (e.g., static) may be abbreviated to -option to set, !option to unset, without a hashref. use Class::MethodMaker [ scalar => [+{ -type => 'File::stat' }, qw/ -static name /], new => 'new', ]; There are also non-data-structure methods that may be created by Class::MethodMaker. C is an example of one such value; it instead causes a standard C method to be created for the calling class. The arguments and options syntax remains the same, but many options clearly do not apply (e.g., C for C). =head2 Interaction with Superclasses Basically, C takes no notice of class hierarchies. If you choose to install a component x in a class B that is a subclass of class A that already has a component x, then the methods addressing x in B will simply override those in class A in the usual fashion. C takes no special action for this situation. This is a feature. =head2 Option Syntax The arguments to Class::MethodMaker are passed in a single arrayref, as pairs, with the first of each pair being the name of the data-structure, and the second being the arguments to that structure. use Class::MethodMaker [ scalar => 'name', new => [qw/ new /], ]; The second of the pair may in the most simple case be a single scalar that is the name of a component to use. use Class::MethodMaker [ scalar => 'bob', ]; For anything more complex, the second argument must itself be an arrayreference. Simple names within this arrayreference are again taken as component names to use; in the following example, both C and C scalar components are created: use Class::MethodMaker [ scalar => [qw/ foo bar /], ]; Options to the data-structure, to change the behaviour of the component, or methods available, etc., are specified by the presence of a hash reference in line with the component names. Each key of the hashref is the name of an option; the corresponding value is the option value. Option names are easily recognized by a leading hyphen (C<->) (or leading exclamation mark, C). The options affect only the components named I the option itself. In the following example, C is non-static (the default), whilst bar is a static: use Class::MethodMaker [ scalar => ['foo', { -static => 1 }, 'bar'], ]; Naturally, options may be altered by later settings overriding earlier ones. The example below has exactly the same effect as the one above: use Class::MethodMaker [ scalar => [{ -static => 1 }, 'bar', { -static => 0 }, 'foo'], ]; Options that are boolean (on/off) valued, such as C<-static>, may be specified external to any hashref as C<-optionname> to set them on and C to set them off. The example below has exactly the same effect as the one above: use Class::MethodMaker [ scalar => [ qw/ -static bar !static foo /], ]; Options that take a value, e.g., C<-type>, must be specified within a hashref: use Class::MethodMaker [ scalar => [ +{ type => 'File::stat' }, 'bob' ], ]; Options affect is limited by the scope of the nearest enclosing arrayref. This particularly means that for multiple invocations of a data structure type, options on earlier invocations do not affect later ones. In the following example, C is non-static (the default), whilst bar is a static: use Class::MethodMaker [ scalar => [ qw/ -static bar /], scalar => [ 'foo' ], ]; This is true even if later invocations do not use an arrayref. The example below has exactly the same effect as the one above: use Class::MethodMaker [ scalar => [ qw/ -static bar /], scalar => 'foo', ]; Arrayrefs may be employed within a set of arguments for a single data-structure to likewise limit scope. The example below has exactly the same effect as the one above: use Class::MethodMaker [ scalar => [ [ qw/ -static bar / ], 'foo' ], ]; =head2 Method Renaming Methods may be renamed, by providing options that map from one generic name to another. These are identified by the presence of a '*' in the option name. The example below installs component C as a scalar, but the method that would normally be installed as C is instead installed as C, and likewise C is installed in place of C. use Class::MethodMaker [ scalar => [ { '*_get' => 'get_*', '*_set' => 'set_*', }, 'a' ], ]; =head2 Default & Optional Methods Class::MethodMaker installs a number of methods by default. Some methods, considered to be useful only to a subset of developers are installed only on request. Each method is marked in the text to state whether it is installed by default or only upon request. To request that a non-default method is installed, one needs to rename it (even possibly to its normal name). So, to install the C<*_get> method for a scalar attribute (as C<*_get>), the syntax is: package MyClass; use Class::MethodMaker [ scalar => [{'*_get' => '*_get'}, 'a'] ]; The method may be installed using a non-default name using similar syntax: package MyClass; use Class::MethodMaker [ scalar => [{'*_get' => 'get_*'}, 'a'] ]; The client may choose to not install a default method by renaming it to undef: use Class::MethodMaker [ scalar => [{'*' => undef }, 'a'] ]; Note Class::MethodMaker will not install a method in place of an existing method, so if the intent is to not install a default method because the client has their own version, an alternative to the above is to define the client version before calling Class::MethodMaker. =head2 Naming & Method-Design Conventions The standard method names are designed with predictability and class extendibility in mind. =head3 Naming For any component I that Class::MethodMaker creates, the method names are always C or C. This enables predictability, for you do not need to remember which methods are named C and which C<*_x>, and also you can name methods that you create by avoiding prefixing them with C, and so avoid any clash with Class::MethodMaker-generated methods (even if Class::MethodMaker is upgraded with shiny new extra methods). Class::MethodMaker users may rename methods (see L). For any B component (scalar, array, hash, etc.) I that Class::MethodMaker creates, the method C I the value of that component: i.e., overriding any existing value, not amending or modifying. E.g., for array components, C does not push or pull values but all old values are removed, and new ones placed in their stead: package MyClass; use Class::MethodMaker [ array => 'a', new => 'new', ]; package main; my $m = MyClass->new; $m->a(4,5); print join(' ', $m->a), "\n"; # 4 5 $m->a(6,7); print join(' ', $m->a), "\n"; # 6 7 The method returns the I value of the component: print join(' ', $m->a(8,9)), "\n"; # 8 9 Note that calling the method with an empty list B reset the value to empty; this is so that normal lookups work on the method (i.e., if $m->a emptied the component, then @a = $m->a would always give an empty list: not that useful. =head3 Set/Unset Each data-structure component has the concept of being set/unset as a whole, independent of individual members being set. Each component starts life unset (unless a default or default option or tie class has been supplied), and is becomes set by any assignment. The component is then reset with the C<*_reset> method. Thus it is possible to distinguish between a component that has been set to an explicitly empty value, and one that has not been set (or been reset). This distinction is analogous to the distinction in hashes between a missing key and a key whose value is undef. package MyClass; use Class::MethodMaker [ new => 'new', scalar => 'x', ]; package main; my $m = MyClass->new; $\ = "\n"; print $m->x_isset ? "true" : "false"; # false; components start this way my $x = $m->x; print defined $n ? "->$n<-" : '*undef*'; # *undef* print $m->x_isset ? "true" : "false"; # false; reading doesn't set $m->x(undef); $x = $m->x; print $m->x_isset ? "true" : "false"; # true; print defined $n ? "->$n<-" : '*undef*'; # ->foo<- $m->x("foo"); $x = $m->x; print $m->x_isset ? "true" : "false"; # true; undef is valid value print defined $n ? "->$n<-" : '*undef*'; # *undef* $m->x_reset; $x = $m->x; print defined $n ? "->$n<-" : '*undef*'; # *undef* print $m->x_isset ? "true" : "false"; # false It is not an error to query the value of an unset component: the value is undef. Querying (any passive command, or pure function) an unset component does not cause it to become set; only assigning (any active command, or procedure) changes the set status of a component. NOTE THAT lvalues are still experimental (as of perl 5.8.0), and so their implementation may change r disappear in the future. Note that lvalue use defeats type-checking. This may be considered a bug, and so may be fixed if possible at some point in the future. =head3 Other Design Considerations Further design goals for Class::MethodMaker version 2: =over 4 =item Consistency of Options The options passed to components are now handled in a single place, to try to be phrased consistently. As many options as possible are common to all data-structures. =item Flexibility It is intended that all common class-construction options are supported across all data-types, so that e.g., defaults, ties, typing may be used with your data-structure of choice, and combined. =item Speed The methods are intended to be as fast as possible, within other constraints outlined here. =back =head2 Options to C/C =over 4 =item C<-target_class> By default, the target class is determined to be the last (latest) class in the call stack that is not a Class::MethodMaker::Engine subtype. This is what is wanted 99% of the time, and typical users need not worry. However, the target class may be set explicitly in the call to C/C: use Class::MethodMaker [ -target_class => 'X', scalar => [qw/ a /], -target_class => 'Y', scalar => [qw/ b /], ]; Note that the C<-target_class> option is order sensitive: it affects only components requested I it in the call to C/C. As shown, the same call may handle specify multiple target classes. Any components requested before the first C<-target_class> are created in the default-determined class, as outlined above. Setting the target class in this way does B persist over multiple calls to C/C. A subsequent call to either will use the default-determined class as target (unless again overridden by C<-target_class>). =back =head2 Standard Options for Data-Structure Components. The following options are observed by all data structure components (L, L, L). =over 4 =item -static package MyClass; use Class::MethodMaker [ scalar => [qw/ -static s /], ]; This option causes components to hold class-specific, rather than instance-specific values. Thus: package main; my $m = MyClass->new; my $n = MyClass->new; $m->a(4,5); print join(' ', $m->a), "\n"; # 4 5 print join(' ', $n->a), "\n"; # 4 5 $n->a(6,7); print join(' ', $n->a), "\n"; # 6 7 print join(' ', $m->a), "\n"; # 6 7 =item -type use Class::MethodMaker [ scalar => [{ -type => 'File::stat' }, 'st' ]]; Takes the name of a class, and checks that all values assigned to the component are of the appropriate type (uses UNIVERSAL::isa, so subtypes are permissible). =item -forward This option takes as value an arrayref (or a simple scalar). The values specify a list of methods that when called on an instance of the target class, are "forwarded on" to the given component. For example, package X; use Class::MethodMaker [scalar => [{ -type => 'File::stat', -forward => [qw/ mode size /], }, 'st1', ], ])}, any call of C or C on an instance of C will simply call the method of the same name on the value stored in the component C, with the same arguments, and returns the value(s) of this call. Forwarding only applies to the first named component (since the methodname is fixed, without the a componentname part). This is because the components are installed in the order in which they are created, and Class::MethodMaker never overwrites a pre-existing method. So, in the following example, C and C forward to the C component, and C forwards to the C component. package MyClass; Class::MethodMaker->import([scalar => [{ -type => 'File::stat', -forward => [qw/ mode size /], }, qw( st1 ), { -type => 'IO::Handle', -forward => 'read', }, qw( st2 ), ]])}, Forwarding a method to a component of composite data type (e.g., array, hash) causes the method to be mapped over the values of that component. The returned value is appropriate to the component type; so a method forwarded to an array will return a list, like the array that is the component, but with each value being the instead result of applying the forwarded method to the corresponding value of the array. The following code populates the C<@sizes> array with the sizes of F, F, in that order. package main; my $m = MyClass->new; $m->st1("/etc/passwd", "/etc/group"); my @sizes = $m->size; Calling the forwarding method in a scalar context will get the same results, but as an arrayref: my $sizes = $m->size; # [ 921, 598 ] for example Likewise, forwarding to a hash component will return a hash from original key to result of method on the corresponding component, or an equivalent hashref in scalar context. =item -default use Class::MethodMaker [ scalar => [{ -default => 7 }, 'df1' ]]; Takes a simple value; must be either undef or an instance of the appropriate type if C<-type> has also been specified. Whenever a component is new or reset, its value(s) default to the value given. Hence C<*_isset> will always return true for that component. For compound data-structures, the default applies to the each element of the structure, not the compound itself. So, for array structures, the default applies to each element of the array, not the array itself. It is an error to specify the C<-default> option and the C<-default_ctor> option simultaneously. =item -default_ctor use Class::MethodMaker [scalar => [{ -default_ctor => sub { Y->new(-3); }, 'df2', { -type => 'Y', -default_ctor => 'new' }, 'df3', ] ]; Takes a coderef to call to generate the default value. This is called the first time a value is required, and afterwards whenever reset is called. The subr is called with one argument, which is the object upon which the component exists (or the name of the class upon which the component is created, if the call is made on the class). If the C<-type> option is in effect, then the value may be a simple value, which shall be considered the name of a method to call on the class specified by C<-type>. It is an error to specify the C<-default> option and the C<-default_ctor> option simultaneously. =cut Beware when using a default_ctor with lvalue methods; given a statement such as $x->df2_index(2) = Y->new; where df2 is an array component, assuming index(2) is currently unset, then index(2) will get a shiny new instance of Y (or whatever the default_ctor creates), I the assignment takes place --- so there'll be I<2> new instances created. In the lvalue case, the component has no way of knowing whether there'll be an assignment, since it takes place after the call has completed. =pod =item -tie_class # @z is an audit trail my @z; package W; use Tie::Scalar; use base qw( Tie::StdScalar ); sub TIESCALAR { push @z, [ 'TIESCALAR' ]; $_[0]->SUPER::TIESCALAR } sub FETCH { push @z, [ 'FETCH' ]; $_[0]->SUPER::FETCH } sub STORE { push @z, [ STORE => $_[1] ]; $_[0]->SUPER::STORE($_[1]) } sub DESTROY { push @z, [ 'DESTROY' ]; $_[0]->SUPER::DESTROY } sub UNTIE { push @z, [ UNTIE => $_[1] ]; $_[0]->SUPER::UNTIE($_[1]) } package X; Class::MethodMaker->import([scalar => [{ -type => 'File::stat', -tie_class => 'W', -forward => [qw/ mode size /], }, qw( tie1 ), new => 'new', ]]); This option takes a simple value as argument, which is taken be the name of a class that is to be tied to the storage for the component, e.g., for an array component, a class that implements the API for tied arrays is needed (see L for more information on this). Likewise for scalar components, hash components, etc. Note that it is the component that is tied, not the data items. package main; my $x = X->new; # @z is empty my $stat1 = stat "/etc/passwd"; my $stat2 = stat "/etc/group"; $x->tie1($stat1); # @z is (['TIESCALAR'], ['STORE', $stat1]) my $y = $x->tie1; # $y is $stat1 # @z is (['TIESCALAR'], ['STORE', $stat1], ['FETCH']) $x->tie1($stat2); # @z is (['TIESCALAR'], ['STORE', $stat1], ['FETCH'], ['STORE', $stat2]) $x->tie1_reset; # @z is (['TIESCALAR'], ['STORE', $stat1], ['FETCH'], ['STORE', $stat2],\ # ['DESTROY']) =cut Note that using a tied component will render the use of lvalue subs unsupported for that component. =pod =item -tie_args package X; Class::MethodMaker->import ([scalar => [{ -tie_class => 'V', -tie_args => [enum => [qw/A B C/], default => 'B'], }, qw( tie2 ), ]]); This option takes an array reference, whose members are passed as arguments to any tie invoked on the component (by virtue C<-tie_class>). If C<-tie_class> is not in force, this is ignored. As a convenience measure, a single argument may be passed directly, rather than embedding in an array ref --- unless that arg is an array ref itself... =item -read_cb B package MyClass; use Class::MethodMaker [ scalar => [{ -read_cb => sub { ($_[1]||0) + 1 } }, 'rcb1' ] new => 'new'; ]; This option takes as argument a coderef, which is called whenever a value is read. It is called with two arguments: the instance upon which the method was called, and the value stored in the component. The return value of the given coderef is the value which is passed to the caller of the method as the component value. Thus, the above example adds one to whatever the stored value is. Note that the value is returned to the callee, but not stored in the object package main; my $m = MyClass->new; $m->rcb1(4); my $n = $x->rcb1; # 5 my $n = $x->rcb1; # 5 =item -store_cb B package MyClass; use Class::MethodMaker [ scalar => [{ -store_cb => sub { $_[1] + 1 } }, 'scb1' ] new => 'new'; ]; This option takes as argument a coderef, which is called whenever a value is stored. It is called with four arguments: the instance upon which the method was called, the value to store in the component, the name of the component, and the previous value of the component (if any; if the given element of the component was previously unset, only three arguments are passed). The return value of the given coderef is the value which is actually stored in the component. Thus, the above example stores 1 greater than the value passed in. package main; my $m = MyClass->new; $m->scb1(4); my $n = $x->scb1; # 5 Generally, store callbacks are cheaper than read callbacks, because values are read more often than they are stored. But that is a generalization. YMMV. =back =head1 EXPERIMENTAL & COMPATIBILITY notes Some new facilities may be marked as EXPERIMENTAL in the documentation. These facilities are being trialled, and whilst it is hoped that they will become mainstream code, no promises are made. They may change or disappear at any time. Caveat Emptor. The maintainer would be delighted to hear any feedback particularly regarding such facilities, be it good or bad, so long as it is constructive. Some old facilities may be marked as COMPATIBILITY in the documentation. These facilities are being maintained purely for compatibility with old versions of this module, but will ultimately disappear. They are normally replaced by alternatives that are considered preferable. Please avoid using them, and consider amending any existing code that does use them not to. If you believe that their removal will cast an unacceptable pall over your life, please contact the maintainer. =head1 SEE ALSO L, L, L, L, L =cut Class-MethodMaker-2.24/examples/0000755000175000017500000000000012506541335014534 5ustar ss5ss5Class-MethodMaker-2.24/examples/simple10000644000175000017500000000126111735360552016034 0ustar ss5ss5use strict; package MyClass; use Class::MethodMaker [ scalar => [qw/ name /], new => [qw/ new /], ]; package main; my $m = MyClass->new; my $n; $\ = "\n"; print $m->name_isset ? "true" : "false"; # false $m->name("foo"); $n = $m->name; print defined $n ? "->$n<-" : "*undef*"; # ->foo<- print $m->name_isset ? "true" : "false"; # true $m->name(undef); $n = $m->name; print defined $n ? "->$n<-" : "*undef*"; # *undef* print $m->name_isset ? "true" : "false"; # true $m->name_reset; $n = $m->name; print defined $n ? "->$n<-" : "*undef*"; # *undef* print $m->name_isset ? "true" : "false"; # false Class-MethodMaker-2.24/MANIFEST.SKIP0000644000175000017500000000072411735360552014622 0ustar ss5ss5^(.*/)?CVS/.* ^(.*/)?.svn/.* ^Makefile(.old)?$ ^Build$ ^Clean$ ^RollingBuild$ ^blib/.* ^pm_to_blib$ ^.cvsignore$ ^MANIFEST.bak$ ^testcheck$ ^.*/\.cvsignore$ ^lib/Class/MethodMaker/(?:array|hash|scalar)\.pm$ ^lib/Class/MethodMaker/\.\#.*$ ^lib/Class/MethodMaker\.(?:bs|o|c)$ ^html(?:/.*)?$ ^(.*/)?.cvsignore$ ^(.*/)?.svnignore$ ^INFO.yaml$ ^_build/ ^misc/ ^*~$ ^make-dist$ ^MethodMaker\.(?:bs|o|c)$ ^lib/Class/MethodMaker.xs$ .git .gitignore ^Class-MethodMaker-.*\..*$ Class-MethodMaker-2.24/benchmark/0000755000175000017500000000000012506541335014650 5ustar ss5ss5Class-MethodMaker-2.24/benchmark/lexical.pl0000644000175000017500000000165111735360552016634 0ustar ss5ss5use Benchmark qw(cmpthese); package Foo; sub new { bless {slot => "blot"}, shift } sub getset_orig { my $self = shift; if (@_) { $self->{slot} = shift; } else { $self->{slot}; } } sub getset_fast { return $_[0]->{slot} if @_ == 1; return $_[0]->{slot} = $_[1]; } # lvalue doesn't play nicely with return :-( sub getset_lvalue { if ( @_ == 1 ) { $_[0]->{slot}; } else { $_[0]->{slot} = $_[1]; } } package main; my $obj = Foo->new(); cmpthese(-2, { getset_orig => sub { $_ = $obj->getset_orig(); $obj->getset_orig($_); }, getset_fast => sub { $_ = $obj->getset_fast(); $obj->getset_fast($_); }, getset_lvalue => sub { $_ = $obj->getset_lvalue(); $obj->getset_lvalue($_); }, }); Class-MethodMaker-2.24/Makefile.PL0000644000175000017500000001037112506541157014674 0ustar ss5ss5require 5.006; use strict; use Config qw( %Config ); use ExtUtils::MakeMaker qw( WriteMakefile ); use File::Basename qw( basename ); use File::Find qw( find ); use File::Spec::Functions qw( catfile ); use Getopt::Long qw( GetOptions ); use constant RAW_COMPS => map(join('.', basename($_, '.m'), 'pm'), glob(catfile qw(components *.m))); use constant COMPONENTS => +{map {catfile('components', join('.',basename($_,'.pm'),'m')) => catfile(qw(MethodMaker), $_)} RAW_COMPS}; use constant OPTEXT => catfile qw( lib Class MethodMaker OptExt.pm ); use constant MACOSX_INST => +{ INSTALLDIRS => "vendor", INSTALLVENDORBIN => $Config{installbin} || $Config{installvendorbin} || $Config{installsitebin}, INSTALLVENDORARCH => $Config{installarchlib} || $Config{installvendorarch} || $Config{installsitearch}, INSTALLVENDORLIB => $Config{installprivlib} || $Config{installvendorlib} || $Config{installsitelib}, INSTALLVENDORMAN1DIR => $Config{installman1dir}, INSTALLVENDORMAN3DIR => $Config{installman3dir}, }; my $macosx; # my OS X installation only works if given some wacky paths :-( GetOptions( 'macosx' => \$macosx ) or die "options parsing failed\n"; my %pm; find (sub { $File::Find::prune = 1, return if -d $_ and $_ eq 'CVS'; return unless /\.pm$/; (my $target = $File::Find::name) =~ s!^$File::Find::topdir/Class!\$(INST_LIBDIR)!; $pm{$File::Find::name} = $target; }, 'lib'); $pm{catfile qw( lib Class ), $_} = catfile '$(INST_LIBDIR)', $_ #$pm{catfile 'lib', $_} = $_ for values %{COMPONENTS()}; my %MakefileArgs = ( NAME => 'Class::MethodMaker', DISTNAME => 'Class-MethodMaker', VERSION => '2.24', AUTHOR => 'Martyn J. Pearce', LICENSE => 'perl', ABSTRACT => 'a module for creating generic methods', PREREQ_PM => +{ }, EXE_FILES => [ ], # Need this to stop Makefile treating Build.PL as a producer of Build as a # target for 'all'. PL_FILES => +{}, PM => \%pm, clean => +{ FILES => join(' ', qw( Build _build ), map(catfile(qw(lib Class MethodMaker), $_), RAW_COMPS), catfile(qw(lib Class MethodMaker.bs)), ) }, depend => +{ map({;catfile(qw( lib Class ), COMPONENTS->{$_}) => join(' ', 'cmmg.pl', %_, OPTEXT) . "\n\t" . join(' ', '$(PERL)', 'cmmg.pl', $_, '>', '$@') } keys %{COMPONENTS()} ) }, ); if ( $macosx ) { while ( my($k,$v) = each %{MACOSX_INST()} ) { $MakefileArgs{$k} = $v; } } WriteMakefile1( MIN_PERL_VERSION => '5.006', META_MERGE => { resources => { repository => 'git://github.com/renormalist/class-methodmaker.git', }, }, #BUILD_REQUIRES => { #}, %MakefileArgs ); sub WriteMakefile1 { #Written by Alexandr Ciornii, version 0.21. Added by eumm-upgrade. my %params=@_; my $eumm_version=$ExtUtils::MakeMaker::VERSION; $eumm_version=eval $eumm_version; die "EXTRA_META is deprecated" if exists $params{EXTRA_META}; die "License not specified" if not exists $params{LICENSE}; if ($params{BUILD_REQUIRES} and $eumm_version < 6.5503) { #EUMM 6.5502 has problems with BUILD_REQUIRES $params{PREREQ_PM}={ %{$params{PREREQ_PM} || {}} , %{$params{BUILD_REQUIRES}} }; delete $params{BUILD_REQUIRES}; } delete $params{CONFIGURE_REQUIRES} if $eumm_version < 6.52; delete $params{MIN_PERL_VERSION} if $eumm_version < 6.48; delete $params{META_MERGE} if $eumm_version < 6.46; delete $params{META_ADD} if $eumm_version < 6.46; delete $params{LICENSE} if $eumm_version < 6.31; delete $params{AUTHOR} if $] < 5.005; delete $params{ABSTRACT_FROM} if $] < 5.005; delete $params{BINARY_LOCATION} if $] < 5.005; WriteMakefile(%params); } Class-MethodMaker-2.24/INSTALL0000644000175000017500000000072011735360552013751 0ustar ss5ss5To install this module, use ./configure make make test make install This will install using /usr/bin/perl . If you wish to install using the perl in your PATH, use 'perl ./configure' instead of 'configure'. If you wish to install to a non-standard location, use 'configure --prefix=location' instead of 'configure'. So, to use the perl in your PATH to install to '/tmp', use perl ./configure --prefix=/tmp make make test make install Enjoy. Class-MethodMaker-2.24/end.pod0000644000175000017500000000207411735360552014176 0ustar ss5ss5=head1 EXAMPLES Z<> =head1 COMPATIBILITY NOTES Users porting from the v1 versions of Class::MethodMaker would do well to observe the following: =over 4 =item ima_method_maker This class method is deprecated. It was a way round the fact the C::MM works out what class to create methods in by looking up the calling stack. It is unfortunate, for the first C::MM class in the calling stack that sets ima_method_maker to be false gets the method --- that may not be what is wanted (i.e., if one derived class calls another for C::MM work). By calling create_methods, the target class may is explicitly specified in the argument list. =back =head1 BUGS Z<> =head1 REPORTING BUGS Email the development mailing-list C =head1 AUTHOR Martyn J. Pearce =head1 CONTRIBUTIONS Steffen Schwigon (Co-Maintainer) Jens Rehsack Lubomir Rintel =head1 COPYRIGHT Copyright (c) 2001--2009 Martyn J. Pearce. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO Z<> =cut Class-MethodMaker-2.24/META.yml0000664000175000017500000000107112506541335014170 0ustar ss5ss5--- abstract: 'a module for creating generic methods' author: - 'Martyn J. Pearce' build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.9, CPAN::Meta::Converter version 2.143240' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Class-MethodMaker no_index: directory: - t - inc requires: perl: '5.006' resources: repository: git://github.com/renormalist/class-methodmaker.git version: '2.24' Class-MethodMaker-2.24/Changes0000644000175000017500000001302312506541013014201 0ustar ss5ss5Revision History for Class::MethodMaker (versions 2) 2.24 Mar 31 2015 - fix missing OUTPUT section - RT#103113 (Zefram) 2.23 Mar 05 2015 - Use strict and warnings everywhere (Neil Bowers) - renamed CommonMethods.pm to CommonMethods.pmt, as it's a template for module code. CPANTS was assuming it's a module from the name, and failing it (Neil Bowers) 2.22 Jan 14 2015 - use File::Temp::tmpnam as needed in Android (Brian Fraser) 2.21 Mar 16 2014 - sync with Debian patches - RT#91658 - fix copyright and license entries - RT#43463 2.20 Feb 03 2014 - drop t/v1*.t unit tests due to license issue https://github.com/renormalist/class-methodmaker/issues/2 2.19 Dec 15 2013 - Fix 5.19 incompatibility - RT#88934 (Zefram) - small distro polishing 2.18 Apr 16 2011 - Fix 5.14 incompatibility - RT#66196 (Nicholas Clark) 2.17 Mar 02 2011 - Just an intermediate release! (in order to get help on fixing Class::MethodMaker for 5.14) - already fixed breakage with 5.13.3 (rt#66196) (CvGV is now an rvalue, so use CvGV_set instead of assigning directly -- credits to ANDK, rafl and Zefram) - added test for no warnings to additionally be able to bisect annoying warnings since 5.13.2 - Stay tuned -- 2.18 will hopefully completely revitalize C:MM for Perl 5.13+. 2.16 May 11 2010 - Drop signature self test in order to fix rt#57359 - fix missing use base (Yan Fitterer / Martyn J. Pearce) - fix case of "LICENSE" key and upgrade Makefile.PL (cpanservice@chorny.net) 2.15 Feb 15 2009 - Skip some tests on MSWin (#16601) 2.14 Feb 15 2009 - Fix Incorrect value checking in set_sub_name, introduced in v2.13 (#41994) (Jens Rehsack) 2.13 Dec 02 2008 - Improve diagnostics and avoid crash with bad arguments. (Lubomir Rintel) 2.12 Jul 20 2008 - fixed warnings: Name " X::foo" used only once (#35840, #37023) 2.11 Mar 24 2008 - Drop Module::Build support (which was broken anyway for a long time, #19167, #16241, #17059, #15987, #13755) - Correct "use version" statements (#19585) 2.10 Apr 27 09:24:30 CEST 2007 - Fixed SIGNATURE 2.09 Dec 5 0:31AM GMT 2006 - Fixed compile problems with 5.9.4 upwards (rt.cpan.org #22413) 2.07 Apr 10 10:13PM GMT 2005 - Fixed case error in Build.PL (rt.cpan.org #12107) - Re-jiggle INSTALL* settings in Makefile.PL 2.06 Mar 13 6:25PM GMT 2005 - Fix for passing arguments to v1 object - Add patch to correctly allow single hashref initialization of hashes patch courtesy of tuck at whistlingfish dot net. 2.05 Jan 30 1:28 PM GMT 2005 - Rejig build system, using ExtUtils::MakeMaker to play nicely 2.04 Oct 16 3:03 PM GMT 2004 - Use Module::Build's compatibility mode to create a Makefile.PL - Add an argument of the subject object to default ctor calls 2.03 Oct 9 6:12 PM GMT 2004 - Use Module::Build rather than ExtUtils::MakeMaker - Add XS code to set created sub names in profiler, etc. - Documentation tweaks 2.02 Apr 9 11:02 AM GMT 2004 - Fix redefine warnings (with V1Compat) under perl-5.8.3 2.01 Apr 3 12:22 PM GMT 2004 - Fix obscure handling of -hash_init with v1 hash - Fix hash in v1 mode to return reference to the actual storage - Make VERSION evaluate on single line to work with ExtUtils::MakeMaker. Patch contributed by Ed Avis (ed at membled dot com) 2.00 Nov 19 10:13 AM GMT 2003 - Flatten list passed to * in v1 list - Fix buglet in object that called default_ctor method even when an explicit value was supplied - Add compatiblity support for boolean - Lots of documentation improvements - Add html target to Makefile.PL - Add implementation of _clear by default - Add *_clear to array - Add support for 5.6.x - Add new -singleton - Add compatiblity support for singleton - Add compatiblity support for get_concat - Add basic support for INTEGER type - Add compatiblity support for get_counter - Bug fixes to read callback - Add compatiblity support for key_{attrib,with_create} 2.00a09 Sep 18 11:04 AM GMT 2003 - Add tie_scalar, static_hash, tie_hash for V1 - Abandon lvalue methods - Add read & store callbacks (incomplete implementation; just enough for V1 methods) - Add code for V1 - Add new_with_hash_with_init for V1 - Correct handling of default in array to auto-instantiate for prior keys as needed - fix object_tie_list - add set_once from V1 - add singleton for V1 - add basic INTEGER handling - add get_concat, get_counter for V1 - add key_attrib for V1 2.00a08 Jul 19 10:07 AM GMT 2003 - Fixes for static_get_set - Add v1 tie_list, static_list, object_tie_list - Add 'new' - Add new_with_args for V1 - Add basic hash handling - Many doc patches 2.00a07 May 10 8:11 AM GMT 2003 - Tune object '*' method - Add !syntax, nested scope, simple name, repeated calls to V2 syntax - Add method-renaming syntax - Add basic array type - Make basic v1 lists work - Add tie functionality - Add v1 object_list 2.00a06 Wed Jun 19 6:56 PM GMT 2002 - Add object v1 compatibility 2.00a05 Tue Jun 18 7:06 AM GMT 2002 - Add '-default', '-default_ctor' options to scalar 2.00a04 Sun Jun 16 3:48 PM GMT 2002 - Add '-forward' option to scalar 2.00a03 Sun Jun 16 12:44 AM GMT 2002 - Add '-type' option to scalar 2.00a02 Tue Jun 11 8:10 PM GMT 2002 - Add tests for scalar (v2) - Add warning(s) for v2 types appearing in v1 mode 2.00a01 Fri Jun 6 2:38 AM GMT 2002 - Basic scalar implemented, passing get_set and static_get_set tests from v1 Class-MethodMaker-2.24/MANIFEST0000644000175000017500000000121612506541335014047 0ustar ss5ss5benchmark/lexical.pl Changes cmmg.pl components/array.m components/CommonMethods.pmt components/hash.m components/scalar.m configure end.pod examples/simple1 generate.PL Generate.pm INSTALL lib/Class/.placeholder lib/Class/MethodMaker.pm lib/Class/MethodMaker/Constants.pm lib/Class/MethodMaker/Engine.pm lib/Class/MethodMaker/OptExt.pm lib/Class/MethodMaker/V1Compat.pm Makefile.PL MANIFEST This list of files MANIFEST.SKIP META.yml MethodMaker.xs README t/array.t t/basic.t t/diffclass.t t/hash.t t/new.t t/redefine-warnings.t t/scalar.t t/test.pm t/warnings.t TODO META.json Module JSON meta-data (added by MakeMaker) Class-MethodMaker-2.24/configure0000755000175000017500000000054411735360552014633 0ustar ss5ss5#!/usr/bin/perl -w # Pragma ------------------------------ use 5.006; use strict; # Utility ----------------------------- use Getopt::Long 2.19 qw( GetOptions ); my $prefix; GetOptions('prefix=s' => \$prefix,) or die "Options parsing failed"; my @cmd = ($^X => 'Makefile.PL'); push @cmd, "PREFIX=$prefix" if defined $prefix; exec @cmd; Class-MethodMaker-2.24/README0000644000175000017500000000206212311346433013572 0ustar ss5ss5Perl Module Class::MethodMaker: Easy building of Perl Classes Description: Modules & Classes: Class::MethodMaker - build instance components Executables: *None* Required Perl Version: 5.6.0 Required Packages: *None* Required Executables: *None* Package Maintainer: Martyn J. Pearce Bugs: class-mmaker-devel@lists.sourceforge.net Patches: class-mmaker-devel@lists.sourceforge.net Discussion: class-mmaker-devel@lists.sourceforge.net Public Repository: git clone git://github.com/renormalist/class-methodmaker.git See also: http://github.com/renormalist/class-methodmaker Copyright: Copyright (c) 2014, 2013, 2012, 2010, 2009, 2008, 2004, 2003, 2002, 2001, 2000 Martyn J. Pearce and others. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Copyright (c) 1996 Organic Online. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. 3rd April, 2004 Class-MethodMaker-2.24/Generate.pm0000644000175000017500000000063212474272244015013 0ustar ss5ss5package Generate; use 5.006; use strict; use warnings; use File::Spec::Functions qw( catfile ); use File::Basename qw( basename ); use base qw( Exporter ); our @EXPORT_OK = qw( %GENERATE ); our %GENERATE = ( map {; ($output = basename $_) =~ s/\.m/.pm/; $_ => catfile 'lib', 'Class', 'MethodMaker', $output } grep /\.m$/, glob(catfile 'components', '*') ); Class-MethodMaker-2.24/MethodMaker.xs0000644000175000017500000000150512506540161015467 0ustar ss5ss5#include "EXTERN.h" #include "perl.h" #include "XSUB.h" /* inspired/stolen from Clone::Closure, to keep in sync with 5.13.3+ */ #ifndef CvGV_set #define CvGV_set(cv,gv) CvGV(cv) = (gv) #endif MODULE = Class::MethodMaker PACKAGE = Class::MethodMaker PROTOTYPES: ENABLE int set_sub_name(SV *sub, char *pname, char *subname, char *stashname) INIT: if (!SvTRUE(ST(0)) || !SvTRUE(ST(1)) || !SvTRUE(ST(2)) || !SvTRUE(ST(3))) XSRETURN_UNDEF; CODE: CvGV_set((CV*)SvRV(sub), gv_fetchpv(stashname, TRUE, SVt_PV)); GvSTASH(CvGV((GV*)SvRV(sub))) = gv_stashpv(pname, 1); #ifdef gv_name_set gv_name_set(CvGV((GV*)SvRV(sub)), subname, strlen(subname), GV_NOTQUAL); #else GvNAME(CvGV((GV*)SvRV(sub))) = savepv(subname); GvNAMELEN(CvGV((GV*)SvRV(sub))) = strlen(subname); #endif RETVAL = 1; OUTPUT: RETVAL Class-MethodMaker-2.24/META.json0000664000175000017500000000174512506541335014350 0ustar ss5ss5{ "abstract" : "a module for creating generic methods", "author" : [ "Martyn J. Pearce" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.9, CPAN::Meta::Converter version 2.143240", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Class-MethodMaker", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "perl" : "5.006" } } }, "release_status" : "stable", "resources" : { "repository" : { "url" : "git://github.com/renormalist/class-methodmaker.git" } }, "version" : "2.24" } Class-MethodMaker-2.24/components/0000755000175000017500000000000012506541335015103 5ustar ss5ss5Class-MethodMaker-2.24/components/hash.m0000644000175000017500000004543512253324026016212 0ustar ss5ss5# (X)Emacs mode: -*- cperl -*- # This file is preprocessed by cmmg.pl . Subs are sought, as 'sub name {' (at # a line begin) until '}' at a line begin. Optional POD documentation may # precede, if started with =head (and ended with =cut). Blank lines & # comments in between will be silently ignored, and anything else will be # noisily ignored. # ------------------------------------- =head1 NAME Class::Method::hash - Create methods for handling a hash value. =head1 SYNOPSIS use Class::MethodMaker [ hash => [qw/ x /] ]; $instance->x; # empty $instance->x(a => 1, b => 2, c => 3); $instance->x_count == 3; # true $instance->x = (b => 5, d => 8); # Note this *replaces* the hash, # not adds to it $instance->x_index('b') == 5; # true $instance->x_exists('c'); # false $instance->x_exists('d'); # true =head1 DESCRIPTION Creates methods to handle hash values in an object. For a component named C, by default creates methods C, C, C, C, C, C, C, C, C, C, C, C, C. =cut sub hash { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; %%STORDECL%% # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { =pod Methods available are: =cut =pod =head3 C<*> I. This method returns the list of keys and values stored in the slot (they are returned pairwise, i.e., key, value, key, value; as with perl hashes, no order of keys is guaranteed). If any arguments are provided to this method, they B the current hash contents. In an array context it returns the keys, values as an array and in a scalar context as a hash-reference. Note that this reference is no longer a direct reference to the storage, in contrast to Class::MethodMaker v1. This is to protect encapsulation. See x_ref if you need that functionality (and are prepared to take the associated risk.) If a single argument is provided that is an arrayref or hashref, it is expanded and its contents used in place of the existing contents. This is a more efficient passing mechanism for large numbers of values. =cut '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists %%STORAGE%% ) { return unless defined $want; if ( $want ) { %{%%STORAGE%%}; } else { +{%{%%STORAGE%%}}; %%V2ONLY%% %%STORAGE%%; %%V1COMPAT%% } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { %%STORE(+{%{$_[1]}},$v)%% # Only asgn-check the potential *values* %%ASGNCHK%(%%IFSTORE(values %$v, values %{$_[1]})%%)%% if ( ! defined $want ) { %{%%STORAGE%%} = %%IFSTORE(%$v,%{$_[1]})%%; return; } if ( $want ) { (%{%%STORAGE%%} = %%IFSTORE(%$v,%{$_[1]})%%); } else { +{%{%%STORAGE%%} = %%IFSTORE(%$v,%{$_[1]})%%}; %%V2ONLY%% %%V1COMPAT_ON%% %{%%STORAGE%%} = %%IFSTORE(%$v,%{$_[1]})%%; %%STORAGE%%; %%V1COMPAT_OFF%% } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; %%STORE(+{@_[1..$#_]},$v)%% # Only asgn-check the potential *values* %%ASGNCHK%(%%IFSTORE(values %$v, @_[map $_*2,1..($#_/2)])%%)%% if ( ! defined $want ) { %{%%STORAGE%%} = %%IFSTORE(%$v,@_[1..$#_])%%; return; } if ( $want ) { (%{%%STORAGE%%} = %%IFSTORE(%$v,@_[1..$#_])%%); } else { +{%{%%STORAGE%%} = %%IFSTORE(%$v,@_[1..$#_])%%}; %%V2ONLY%% %%V1COMPAT_ON%% %{%%STORAGE%%} = %%IFSTORE(%$v,@_[1..$#_])%%; %%STORAGE%%; %%V1COMPAT_OFF%% } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; %%STORAGE%% = +{} unless exists %%STORAGE%%; return $want ? %{%%STORAGE%%} : %%STORAGE%%; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{%%STORAGE%%} : %%STORAGE%%; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{%%STORAGE%%} : %%STORAGE%%; } }, =pod =head3 C<*_reset> I. Called without an argument, this resets the component as a whole; deleting any associated storage, and returning the component to its default state. Normally, this means that I<*_isset> will return false, and I<*> will return undef. If C<-default> is in effect, then the component will be set to the default value, and I<*_isset> will return true. If C<-default_ctor> is in effect, then the default subr will be invoked, and its return value used to set the value of the component, and I<*_isset> will return true. If called with arguments, these arguments are treated as indexes into the component, and the individual elements thus referenced are reset (their storage deleted, so that I<*_isset(n)> will return false for appropriate I, except where C<-default> or C<-default_ctor> are in force, as above). As with perl arrays, resetting the highest set value implicitly decreases the count (but x_reset(n) never unsets the aggregate itself, even if all the elements are not set). =cut '*_reset' => sub : method { if ( @_ == 1 ) { %%RESET%%% delete %%STORAGE%%; } else { delete @{%%STORAGE%%}{@_[1..$#_]}; } return; }, =pod =head3 C<*_clear> I. Empty the component of all elements, but without deleting the storage itself. If given a list of keys, then the elements I indexed by those keys are set to undef (but not deleted). Note the very different semantics: C<< $x->a_clear('b') >> sets the value of C in component 'a' to undef (if C) already exists (so C<< $x->a_isset('b')) >> returns true), but C<< $x->a_clear() >> deletes the element C from component 'a' (so C<< $x->a_isset('b')) >> returns false). =cut '*_clear' => sub : method { if ( @_ == 1 ) { %{%%STORAGE%%} = (); } else { ${%%STORAGE%%}{$_} = undef for grep exists ${%%STORAGE%%}{$_}, @_[1..$#_]; } return; }, =pod =head3 C<*_isset> I. Whether the component is currently set. This is different from being defined; initially, the component is not set (and if read, will return undef); it can be set to undef (which is a set value, which also returns undef). Having been set, the only way to unset the component is with C<*_reset>. If a default value is in effect, then C<*_isset> will always return true. I<*_isset()> tests the component as a whole. I<*_isset(a)> tests the element indexed by I. I<*_isset(a,b)> tests the elements indexed by I, I, and returns the logical conjunction (I) of the tests. =cut '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists %%STORAGE%% } elsif ( @_ == 2 ) { exists %%STORAGE%%->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists %%STORAGE%%->{$_}; } return 1; } } ), =pod =head3 C<*_count> I. Returns the number of elements in this component. This is not affected by presence (or lack) of a C (or C). Returns C if whole component not set (as per I<*_isset>). =cut '*_count' => sub : method { if ( exists %%STORAGE%% ) { return scalar keys %{%%STORAGE%%}; } else { return; } }, =pod =head3 C<*_index> I. Takes a list of indices, returns a list of the corresponding values. If a default (or a default ctor) is in force, then a lookup by index will vivify & set to the default the respective elements (and therefore the aggregate data-structure also, if it's not already). =cut # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { %%DEFCHECK%(%%STORAGE%%->{$_})%% } @{%%STORAGE%%}{@_[1..$#_]}; } : sub : method { @{%%STORAGE%%}{@_[1..$#_]}; } ), =pod =head3 C<*_keys> I. The known keys, as a list in list context, as an arrayref in scalar context. If you're expecting a count of the keys in scalar context, see I<*_count>. =cut '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{%%STORAGE%%}] : keys %{%%STORAGE%%}; }, =pod =head3 C<*_values> I. The known values, as a list in list context, as an arrayref in scalar context. =cut '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{%%STORAGE%%}] : values %{%%STORAGE%%}; }, =pod =head3 C<*_each> I. The next pair of key, value (as a list) from the hash. =cut '*_each' => sub : method { return each %{%%STORAGE%%}; }, =pod =head3 C<*_exists> I. Takes any number of arguments, considers each as a key, and determines whether the key exists in the has. Returns the logical conjunction (I). =cut '*_exists' => sub : method { return for grep ! exists %%STORAGE%%->{$_}, @_[1..$#_]; return 1; }, =pod =head3 C<*_delete> I. This operates exactly like I<*_reset>, except that calling this with no args does nothing. This is provided for orthogonality with the Perl C operator, while I<*_reset> is provided for orthogonality with other component types. =cut '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, =pod =head3 C<*_set> %n = $x->h; # (a=>1,b=>2,c=>3) (in some order) $h->h_set(b=>4,d=>7); %n = $h->a; # (a=>1,b=>4,c=>3,d=>7) (in some order) I. Takes a list, treated as pairs of index => value; each given index is set to the corresponding value. No return. If two arguments are given, of which the first is an arrayref, then it is treated as a list of indices of which the second argument (which must also be an arrayref) are the corresponding values. Thus the following two commands are equivalent: $x->a_set(b=>4,d=>7); $x->a_set(['b','d'],[4,7]); =cut '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { %%STORE([@{$_[2]}], $v)%% %%ASGNCHK%(%%IFSTORE(@$v,@{$_[2]})%%)%% @{%%STORAGE%%}{@{$_[1]}} = %%IFSTORE(@$v,@{$_[2]})%%; } else { %%STORE([@_[map {$_*2} 1..($#_/2)]], $v)%% %%ASGNCHK%(%%IFSTORE(@$v,@_[map {$_*2} 1..($#_/2)])%%)%% ${%%STORAGE%%}{$_[$_*2-1]} = %%IFSTORE($v->[$_-1], $_[$_*2])%% for 1..($#_/2); } return; }, =pod =head3 C<*_get> I. Retrieves the value of the component without setting (ignores any arguments passed). =cut '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { %%STORAGE%% }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } Class-MethodMaker-2.24/components/array.m0000644000175000017500000004277112253324026016405 0ustar ss5ss5# (X)Emacs mode: -*- cperl -*- # This file is preprocessed by cmmg.pl . Subs are sought, as 'sub name {' (at # a line begin) until '}' at a line begin. Optional POD documentation may # precede, if started with =head (and ended with =cut). Blank lines & # comments in between will be silently ignored, and anything else will be # noisily ignored. # ------------------------------------- =head1 NAME Class::Method::array - Create methods for handling an array value. =head1 SYNOPSIS use Class::MethodMaker [ array => [qw/ x /] ]; $instance->x; # empty $instance->x(1, 1, 2, 3, 5, 8); $instance->x_count == 6; # true $instance->x = (13, 21, 34); $instance->x_index(1) == 21; # true =head1 DESCRIPTION Creates methods to handle array values in an object. For a component named C, by default creates methods C, C, C, C, C, C, C, C, C, C, C. =cut # Sentinel value to tell array to clear. Note that by being a reference, # reconstructing it elsewhere won't work: so passing in a normal reference to # 1 will store that reference to one, as expected. \undef strangely doesn't # work. sub array { my $SENTINEL_CLEAR = \1; my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to array ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; %%STORDECL%% # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_reset *_index ); return { =pod Methods available are: =head3 C<*> I This method returns the list of values stored in the slot. If any arguments are provided to this method, they B the current list contents. In an array context it returns the values as an array and in a scalar context as a reference to an array. Note that this reference is no longer a direct reference to the storage, in contrast to Class::MethodMaker v1. This is to protect encapsulation. See x_ref if you need that functionality (and are prepared to take the associated risk.) This function no longer auto-expands arrayrefs input as arguments, since that makes it awkward to set individual values to arrayrefs. See x_setref for that functionality. If a default value is in force, then that value will be auto-vivified (and therefore set) for each otherwise I (not I) value up to the array max (so new items will not be appended) =cut '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { %%DEFAULT_ON%% if ( exists %%STORAGE%% ) { for (0..$#{%%STORAGE%%}) { %%DEFCHECK@(%%STORAGE%%->[$_])%%; } } %%DEFAULT_OFF%% if ( exists %%STORAGE%% ) { if ( ! defined $want ) { return; } elsif ( $want ) { return @{%%STORAGE%%}; } else { return [@{%%STORAGE%%}]; } } else { if ( ! defined $want ) { return; } elsif ( $want ) { return (); } else { return []; } } } else { { no warnings "numeric"; $#_ = 0 if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR; } my @x; %%V1COMPAT_ON%% if ( $options->{tie_class} ) { @x = @_[1..$#_]; } else { @x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_]; } %%V1COMPAT_OFF%% %%V2ONLY_ON%% @x = @_[1..$#_]; %%V2ONLY_OFF%% %%STORE(\@x, $v)%% %%ASGNCHK@(%%IFSTORE(@$v,@x)%%)%% if ( ! defined $want ) { @{%%STORAGE%%} = %%IFSTORE(@$v,@x)%%; return; } elsif ( $want ) { @{%%STORAGE%%} = %%IFSTORE(@$v,@x)%%; } else { [@{%%STORAGE%%} = %%IFSTORE(@$v,@x)%%]; } } }, =pod =head3 C<*_reset> I Called without an argument, this resets the component as a whole; deleting any associated storage, and returning the component to its default state. Normally, this means that C<*_isset> will return false, and C<*> will return undef. If C<-default> is in effect, then the component will be set to the default value, and C<*_isset> will return true. If C<-default_ctor> is in effect, then the default subr will be invoked, and its return value used to set the value of the component, and C<*_isset> will return true. If called with arguments, these arguments are treated as indexes into the component, and the individual elements thus referenced are reset (their storage deleted, so that C<*_isset(n)> will return false for appropriate I, except where C<-default> or C<-default_ctor> are in force, as above). As with perl arrays, resetting the highest set value implicitly decreases the count (but x_reset(n) never unsets the aggregate itself, even if all the elements are not set). =cut '*_reset' => sub : method { if ( @_ == 1 ) { %%RESET@%% delete %%STORAGE%%; } else { delete @{%%STORAGE%%}[@_[1..$#_]]; } return; }, =pod =head3 C<*_clear> package MyClass; use Class::MethodMaker [ scalar => [{'*_clear' => '*_clear'}, 'a'], new => new, ]; package main; my $m = MyClass->new; $m->a(5); $a = $m->a; # 5 $x = $m->a_isset; # true $m->a_clear; $a = $m->a; # *undef* $x = $m->a_isset; # true I. A shorthand for setting to undef. Note that the component will be set to undef, not reset, so C<*_isset> will return true. =cut '*_clear' => sub : method { my $x = $names{'*'}; $_[0]->$x($SENTINEL_CLEAR); return; }, =pod =head3 C<*_isset> I Whether the component is currently set. This is different from being defined; initially, the component is not set (and if read, will return undef); it can be set to undef (which is a set value, which also returns undef). Having been set, the only way to unset the component is with <*_reset>. If a default value is in effect, then <*_isset> will always return true. C<*_isset()> tests the component as a whole. C<*_isset(a)> tests the element indexed by I. C<*_isset(a,b)> tests the elements indexed by I, I, and returns the logical conjunction (I) of the tests. =cut '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists %%STORAGE%% } elsif ( @_ == 2 ) { exists %%STORAGE%%->[$_[1]] } else { return for grep ! exists %%STORAGE%%->[$_], @_[1..$#_]; return 1; } } ), =pod =head3 C<*_count> I Returns the number of elements in this component. This is not affected by presence (or lack) of a C (or C). Returns C if whole component not set (as per C<*_isset>). =cut '*_count' => sub : method { if ( exists %%STORAGE%% ) { return scalar @{%%STORAGE%%}; } else { return; %%V2ONLY%% return 0; %%V1COMPAT%% } }, =pod =head3 C<*_index> I Takes a list of indices, returns a list of the corresponding values. If a default (or a default ctor) is in force, then a lookup by index will vivify & set to the default the respective elements (and therefore the aggregate data-structure also, if it's not already). Beware of a bug in perl 5.6.1 that will sometimes invent values in previously unset slots of arrays that previously contained a value. So, vivifying a value (e.g. by x_index(2)) where x_index(1) was previously unset might cause x_index(1) to be set spuriously. This is fixed in 5.8.0. =cut # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { %%DEFCHECK@(%%STORAGE%%->[$_])%% } @{%%STORAGE%%}[@_[1..$#_]]; } : sub : method { @{%%STORAGE%%}[@_[1..$#_]]; } ), =pod =head3 C<*_push> I Push item(s) onto the end of the list. No return value. =cut '*_push' => sub : method { %%ASGNCHK@(@_[1..$#_])%% push @{%%STORAGE%%}, @_[1..$#_]; return; %%V2ONLY%% }, =pod =head3 C<*_pop> I Given a number, pops that many items off the end of the list, and returns them (as a ref in scalar context, as a list in list context). Without an arg, always returns a single element. Given a number, returns them in array order (not in reverse order as multiple pops would). =cut '*_pop' => sub : method { if ( @_ == 1 ) { pop @{%%STORAGE%%}; } else { return unless defined wantarray; ! wantarray ? [splice @{%%STORAGE%%}, -$_[1]] : splice @{%%STORAGE%%}, -$_[1] ; } }, =pod =head3 C<*_unshift> I Push item(s) onto the start of the list. No return value. =cut '*_unshift' => sub : method { %%ASGNCHK@(@_[1..$#_])%% unshift @{%%STORAGE%%}, @_[1..$#_]; return; %%V2ONLY%% }, =pod =head3 C<*_shift> I Given a number, shifts that many items off the start of the list, and returns them (as a ref in scalar context, as a list in list context). Without an arg, always returns a single element. Given a number, returns them in array order. =cut '*_shift' => sub : method { if ( @_ == 1 ) { shift @{%%STORAGE%%}; } else { splice @{%%STORAGE%%}, 0, $_[1], return unless defined wantarray; ! wantarray ? [splice @{%%STORAGE%%}, 0, $_[1]] : splice @{%%STORAGE%%}, 0, $_[1] ; } }, =pod =head3 C<*_splice> I Arguments as for L. Returns an arrayref in scalar context (even if a single item is spliced), and a list in list context. =cut '*_splice' => sub : method { # Disturbing weirdness due to prototype of splice. # splice @{%%STORAGE%%}, @_[1..$#_] # doesn't work because the prototype wants a scalar for # argument 2, so the @_[1..$#_] gets evaluated in a scalar # context, thus counts the elements of @_ (subtract 1). # Ripping of the head elements # splice @{%%STORAGE%%}, $_[1], $_[2], @_[3..$#_] # almost works, but that the $_[2] if not present presents an # undef, which works as a zero, whereas # splice @{%%STORAGE%%}, $_[1] # splices to the end of the array if ( @_ < 3 ) { if ( @_ < 2 ) { $_[1] = 0; } $_[2] = @{%%STORAGE%%} - $_[1] } %%ASGNCHK@(@_[3..$#_])%% splice(@{%%STORAGE%%}, $_[1], $_[2], @_[3..$#_]), return unless defined wantarray; ! wantarray ? [splice(@{%%STORAGE%%}, $_[1], $_[2], @_[3..$#_])] : splice(@{%%STORAGE%%}, $_[1], $_[2], @_[3..$#_]) ; }, =pod =head3 C<*_get> I. Retrieves the value of the component without setting (ignores any arguments passed). =cut '!*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, =pod =head3 C<*_set> @n = $x->a; # (1,2,3) $x->a_set(1=>4,3=>7); @n = $x->a; # (1,4,3,7) I Takes a list, treated as pairs of index => value; each given index is set to the corresponding value. No return. If two arguments are given, of which the first is an arrayref, then it is treated as a list of indices of which the second argument (which must also be an arrayref) are the corresponding values. Thus the following two commands are equivalent: $x->a_set(1=>4,3=>7); $x->a_set([1,3],[4,7]); =cut '*_set' => sub : method { if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { %%ASGNCHK@(@{$_[2]})%% @{%%STORAGE%%}[@{$_[1]}] = @{$_[2]}; } else { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; %%ASGNCHK@(@_[map $_*2,1..($#_/2)])%% ${%%STORAGE%%}[$_[$_*2-1]] = $_[$_*2] for 1..($#_/2); } return; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { %%STORAGE%% }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my @x; my @y = $_[0]->$x(); @x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y; # We don't check for a undefined wantarray here, since # calling this in a void context is a sufficiently # nonsensical thing to do that checking for it is likely # performance hit than the typical saving. ! wantarray ? \@x : @x; } } @forward), }, \%names; } Class-MethodMaker-2.24/components/scalar.m0000644000175000017500000002425512253324026016531 0ustar ss5ss5# (X)Emacs mode: -*- cperl -*- # This file is preprocessed by cmmg.pl . Subs are sought, as 'sub name {' (at # a line begin) until '}' at a line begin. Optional POD documentation may # precede, if started with =head (and ended with =cut). Blank lines & # comments in between will be silently ignored, and anything else will be # noisily ignored. # ------------------------------------- =head1 NAME Class::Method::scalar - Create methods for handling a scalar value. =head1 SYNOPSIS package MyClass; use Class::MethodMaker [ scalar => [qw/ a -static s /]]; sub new { my $class = shift; bless {}, $class; } package main; my $m = MyClass->new; my $a, $x; $a = $m->a; # *undef* $x = $m->a_isset; # false $a = $m->a(1); # 1 $m->a(3); $x = $m->a_isset; # true $a = $m->a; # 3 $a = $m->a(5); # 5; $m->a_reset; $x = $m->a_isset; # false =head1 DESCRIPTION Creates methods to handle array values in an object. For a component named C, by default creates methods C, C, C, C. =cut sub scalar { my $class = shift; my ($target_class, $name, $options, $global) = @_; # options check --------------------- Class::MethodMaker::Engine::check_opts([qw/ static type typex forward default default_ctor read_cb store_cb tie_class tie_args key_create v1_compat v1_object _value_list /], $options); # type option my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; # forward option my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } # default options my ($default, $dctor, $default_defined, $v1object); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to scalar ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; $v1object = $options->{v1_object} if $options->{v1_compat}; } else { $dctor = $options->{default_ctor}; croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " . " (attribute $name) (got '%s')\n", ref $dctor ) ) if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } # tie options my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # V1 Compatibility my ($list, $key_create); ($list, $key_create) = @{$options}{qw/ _value_list key_create/} if exists $options->{_value_list}; # the method definitions ------------ %%STORDECL%% # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * ); =pod Methods available are: =cut my %methods = =pod =head3 C<*> $m->a(3); $a = $m->a; # 3 $a = $m->a(5); # 5; I. If an argument is provided, the component is set to that value. The method returns the value of the component (after assignment to a provided value, if appropriate). =cut ( '*' => sub : method { my $z = \@_; # work around stack problems if ( @_ == 1 ) { %%V1COMPAT_ON%% if ( $v1object and ! exists $_[0]->{$name} ) { %%STORAGE%% = $dctor->(); } %%V1COMPAT_OFF%% %%DEFCHECK$%% %%READ0(%%STORAGE%%)%% } else { %%STORE($_[1],$v)%% %%V2ONLY%% %%V1COMPAT_ON%% %%STORE($_[1],$v,@_[1..$#_])%% unless ( $v1object ) { %%ASGNCHK$(%%IFSTORE($v,$_[1])%%)%% } %%V1COMPAT_OFF%% %%ASGNCHK$(%%IFSTORE($v,$_[1])%%)%% %%V2ONLY%% %%STORAGE%% = %%IFSTORE($v,$_[1])%%; %%V2ONLY%% %%V1COMPAT_ON%% if ( $v1object ) { if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) { %%STORAGE%% = $_[1]; } else { %%STORAGE%% = $dctor->(@_[1..$#_]); } } else { %%STORAGE%% = %%IFSTORE($v,$_[1])%% } %%V1COMPAT_OFF%% %%READ1(%%STORAGE%%)%% } }, =pod =head3 C<*_reset> $m->a_reset; I. Resets the component back to its default. Normally, this means that C<*_isset> will return false, and C<*> will return undef. If C<-default> is in effect, then the component will be set to the default value, and C<*_isset> will return true. If C<-default_ctor> is in effect, then the default subr will be invoked, and its return value used to set the value of the component, and C<*_isset> will return true. B: actually, defaults are assigned as needed: typically, the next time a the value of a component is read. =cut '*_reset' => sub : method { delete %%STORAGE%%; }, =pod =head3 C<*_isset> print $m->a_isset ? "true" : "false"; I. Whether the component is currently set. This is different from being defined; initially, the component is not set (and if read, will return undef); it can be set to undef (which is a set value, which also returns undef). Having been set, the only way to unset the component is with <*_reset>. If a default value is in effect, then <*_isset> will always return true. =cut '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { exists %%STORAGE%%; } ), =pod =head3 C<*_clear> $m->a(5); $a = $m->a; # 5 $x = $m->a_isset; # true $m->a_clear; $a = $m->a; # *undef* $x = $m->a_isset; # true I. A shorthand for setting to undef. Note that the component will be set to undef, not reset, so C<*_isset> will return true. =cut '*_clear' => sub : method { my $x = $names{'*'}; $_[0]->$x(undef); }, =pod =head3 C<*_get> package MyClass; use Class::MethodMaker [ scalar => [{'*_get' => '*_get'}, 'a'], new => new, ]; package main; my $m = MyClass->new; $m->a(3); $a = $m->a_get; # 3 $a = $m->a_get(5); # 3; ignores argument $a = $m->a_get(5); # 3; unchanged by previous call I. Retrieves the value of the component without setting (ignores any arguments passed). =cut '!*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, =pod =head3 C<*_set> package MyClass; use Class::MethodMaker [ scalar => [{'*_set' => '*_set'}, 'a'], new => new, ]; package main; my $m = MyClass->new; $m->a(3); $a = $m->a_set; # *undef* $a = $m->a_set(5); # *undef*; value is set but not returned $a = $m->a; # 5 I. Sets the component to the first argument (or undef if no argument provided). Returns no value. =cut '!*_set' => sub : method { my $x = $names{'*'}; $_[0]->$x($_[1]); return; }, # this is here for V1 compatiblity only '!*_find' => sub : method { my ($self, @args) = @_; if (scalar @args) { if ( $key_create ) { $self->new->$name($_) for grep ! exists $list->{$_}, @args; } return @{$list}{@args}; } else { return $list; } }, %%IMPORT(CommonMethods)%% # forward methods map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; $_[0]->$x()->$f(@_[1..$#_]); } } @forward), ); return \%methods, \%names; } Class-MethodMaker-2.24/components/CommonMethods.pmt0000644000175000017500000000101512474272244020402 0ustar ss5ss5 'INTEGER:*_incr' => sub { my $x = $names{'*'}; my $incr = @_ > 1 ? $_[1] : 1; $_[0]->$x($_[0]->$x()+$incr); }, 'INTEGER:*_decr' => sub { my $x = $names{'*'}; my $decr = @_ > 1 ? $_[1] : 1; $_[0]->$x($_[0]->$x()-$decr); }, 'INTEGER:*_zero' => sub { my $x = $names{'*'}; $_[0]->$x(0); }, Class-MethodMaker-2.24/cmmg.pl0000755000175000017500000002060612474272244014211 0ustar ss5ss5#!/usr/bin/perl -W # Pragmas ----------------------------- use strict; use Fatal qw( open close ); use File::Basename qw( basename ); use File::Spec::Functions qw( catdir catfile ); use FindBin qw( $Bin ); use lib qw( lib ); use Class::MethodMaker::OptExt qw( OPTEXT ); # Constants --------------------------- use constant COMP_DIR => catdir $Bin, 'components'; # Utility ----------------------------- # Main ----------------------------------------------------------------------- sub min { my $Result; for (@_) { $Result = $_ if ! defined $Result or $Result > $_; } return $Result; } sub read_file { my ($fn) = @_; open my $fh, '<', $fn; local $/ = undef; my $text = <$fh>; close $fh; return $text; } # Parse in methods file --------------- my %methods; { for my $fn (@ARGV) { open my $methods, '<', $fn; local $/ = "\n"; my $methname; my ($doc, $text) = ('') x 2; my ($pod, $code) = (0) x 2; while (<$methods>) { chomp; if ( $pod ) { $doc .= "$_\n"; $pod = 0 if /^=cut\b/; } elsif ( /^=(?:pod|head\d?)\b/ ) { $pod = 1; $doc .= "$_\n"; } elsif ( $code ) { if ( /^}\s*$/ ) { $code = 0; } else { $text .= "$_\n"; } } elsif ( /^\s*sub\s+([a-z_]+)\s+\{(.*)$/ms ) { my $protometh = $1; my $prototext = $2; if ( defined $methname ) { $methods{$methname}->{text} = $text; $methods{$methname}->{doc} = $doc; $text = $doc = ''; } $methname = $protometh; if ( length($prototext) and $prototext !~ /^\s*$/ ) { $text = "$prototext\n"; } else { $text = ''; } $code = 1; } } if ( defined $methname ) { $methods{$methname}->{text} = $text; $methods{$methname}->{doc} = $doc; $text = $doc = ''; } } } my @storage_names = Class::MethodMaker::OptExt->option_names; # Write out methods ------------------- my %import; while ( my ($meth, $value) = each %methods ) { print "package Class::MethodMaker::", basename($ARGV[0], '.m'), ";\n"; print <<'END'; use strict; use warnings; use AutoLoader 5.57 qw( AUTOLOAD ); our @ISA = qw( AutoLoader ); use Carp qw( carp croak cluck ); use constant DEBUG => $ENV{_CMM_DEBUG} ? 1 : 0; __END__ END # Print doc if ( exists $value->{doc} ) { my $doc = $value->{doc}; $doc =~ s/^=cut\n=pod\n//mg; print "\n", $doc, "\n"; } # Print each storage type for my $idx (0..2**@storage_names-1) { my @st = map $storage_names[$_], grep $idx & 2**$_, 0..$#storage_names; my ($suffix, undef) = Class::MethodMaker::OptExt->encode($meth, \@st); next if ! defined $suffix; my $name = substr($meth, 0, 4) . $suffix; my $code = $value->{text}; my %replace = Class::MethodMaker::OptExt->replace(\@st); # Do Imports ---------------------- $code =~ s/^(.*)%%IMPORT\((.*)\)%%/ my ($i, $fn) = ($1, $2); my $t; if ( exists $import{$fn} ) { $t = $import{$fn}; } else { $t = $import{$fn} = read_file(catfile COMP_DIR, "${fn}.pmt"); } $t =~ s!^!$i!mg if $i =~ m!^\s+$!; $t/meg; # Handle V1/V2 differences -------- my $v1_compat = grep $_ eq 'v1_compat', @st; my $default = grep /default/, @st; # This needs to be done first because defchk (potentially) refers to # storage # Duplicate changes at YYY below # XXX $code =~ s/%%V1COMPAT_ON%%(.*?)%%V1COMPAT_OFF%%/$v1_compat ? $1 : ''/mseg; $code =~ s/%%V2ONLY_ON%%(.*?)%%V2ONLY_OFF%%/$v1_compat ? '' : $1/mseg; $code =~ s/%%DEFAULT_ON%%(.*?)%%DEFAULT_OFF%%/$default ? $1 : ''/mseg; $code =~ s/^(.*?)\s*%%V1COMPAT%%\s*$/$v1_compat ? $1 : ''/meg; $code =~ s/^(.*?)\s*%%V2ONLY%%\s*$/$v1_compat ? '' : $1/meg; $code =~ s/^(.*?)\s*%%DEFAULTONLY%%\s*$/$default ? $1 : ''/meg; # Handle callback invocations ----- $code =~ s/^(.*)%%READ(\d)\((\S+)\)%%/ my ($i, $n, $v) = ($1, $2, $3); (my $t = $replace{read}->[$n]) =~ s!(?<=.)^!' ' x length($i)!mseg; $t =~ s!__VALUE__!$v!g; "$i$t"; /meg; $code =~ s/^(.*)%%DEFCHECK([@%\$])(.*)%%/ my ($i, $s, $j) = ($1, $2, $3); (my $t = $replace{predefchk} . $replace{defchk}) =~ s!(?<=.)^!' ' x length($i)!mseg; $t =~ s!%%STORAGE%%!$j!g if length $j; $t =~ s!__SIGIL__!$s!g; "$i$t"/meg; my $store = grep $_ eq 'store_cb', @st; $code =~ s/%%IFSTORE\((.*?),(.*?)\)%%/$store ? $1 : $2/meg; # ASGNCHK needs to come before STORAGE because it might well refer to # STORAGE $code =~ s/^(.*)%%ASGNCHK([@%\$])\((.*?)\)%%/ my ($i, $s, $f) = ($1, $2, $3); (my $t = $replace{asgnchk} . $replace{postac}) =~ s!(?<=.)^!' ' x length($i)!mseg; $t =~ s!__FOO__!$f!g; $t =~ s'__ATTR__'$name'g; $t =~ s!__SIGIL__!$s!g; "$i$t"/meg; $code =~ s/^(.*)%%STORE\((.*?),\s*(.*?)(?:,\s*(.*?))?\)%%/ my ($i, $m, $n, $o) = ($1, $2, $3, $4); my $p = substr($n,0,1) eq '$' ? $n : "$n"; $o = '' if ! defined $o; (my $t = $replace{store}) =~ s!(?<=.)^!' ' x length($i)!mseg; $t =~ s!__NAME__!$n!g; $t =~ s!__NAMEREF__!$p!g; $t =~ s!__VALUE__!$m!g; $t =~ s!__ALL__!$o!g; "$i$t"/meg; # READINIT used for performing, e.g., ties even when no assignment has # occurred (because looking up a value into play is enough to justify the # tie, since the tie may provide a value (e.g., a persistent disk cache) $code =~ s/^(.*)%%READINIT([@%\$])%%/ my ($i, $s) = ($1, $2); (my $t = $replace{postac}) =~ s!(?<=.)^!' ' x length($i)!mseg; $t =~ s'__ATTR__'$name'g; $t =~ s'__TYPE__'$type'g; $t =~ s!__SIGIL__!$s!g; "$i$t"/meg; # REFER needs to come before STORAGE because it might well refer to # STORAGE $code =~ s/^(.*)%%RESET([@%\$]?)(?:\((.*?)\))?%%/ my ($i, $s, $f) = ($1, $2, $3); die "Parameterized RESET not yet handled!\n" if defined $f and length $f; die "RESET takes a terminating sigil\n" unless length $s; (my $t = $replace{reset}) =~ s!(?<=.)^!' ' x length($i)!mseg; $t =~ s!__SIGIL__!$s!g; "$i$t"/meg; $code =~ s/%%STORAGE(?:\((.*)\))?%%/ my $f = $1; my $t = $replace{refer}; $t = "$f\{$t\}" # Special case for $ because scalars are stored direct as # scalars rather than as references to scalars (whereas # arrays, for example, are stored as references to arrays). # Although this arrangement is less seamless than using if defined $f and length $f and $f ne '$'; $t; /eg; $code =~ s/%%STORDECL%%/$replace{decl}/g; # And again, because some replaced code uses this too! # Duplicate changes at XXX above # YYY $code =~ s/%%V1COMPAT_ON%%(.*?)%%V1COMPAT_OFF%%/$v1_compat ? $1 : ''/mseg; $code =~ s/%%V2ONLY_ON%%(.*?)%%V2ONLY_OFF%%/$v1_compat ? '' : $1/mseg; $code =~ s/^(.*?)\s*%%V2ONLY%%\s*$/$v1_compat ? '' : $1/meg; $code =~ s/^(.*?)\s*%%V1COMPAT%%\s*$/$v1_compat ? $1 : ''/meg; $code =~ s/(%%\S+)/warn "%% sequence unreplaced: $1\n";$1/eg; # Untabify 1 while $code =~ s/\t+/' ' x (length($&) * 8 - length($`) % 8)/e; # Trim trailing whitespace $code =~ s/ +$//mg; # Tidy identation my $strip = min map length, $code =~ /^ +/mg; $code =~ s/^ {$strip}//mg; $code =~ s/\A\s*(.*?)\s*\Z/$1/ms; $code =~ s!^(.*)$! $_ = $1; my $pod = /^=pod/../^=cut/; $pod ? $_ : " $_"; !emg; print "\n", '#', '-' x 18, "\n"; print '# ', $meth, ' ', join(' - ', @st), "\n"; print "\nsub $name {\n$code\n}\n"; } print "\n", '#', '-' x 36, "\n"; print "\n"; } # Add trailing doc -------------------- print "1; # keep require happy\n"; __END__