Data-Clone-0.003/0000755000175000017500000000000011514324464011561 5ustar gfxgfxData-Clone-0.003/xt/0000755000175000017500000000000011514324464012214 5ustar gfxgfxData-Clone-0.003/xt/01_podspell.t0000644000175000017500000000051111514323233014511 0ustar gfxgfx#!perl -w use strict; use Test::More; eval q{ use Test::Spelling }; plan skip_all => q{Test::Spelling is not installed.} if $@; add_stopwords(map { split /[\s\:\-]/ } ); $ENV{LANG} = 'C'; all_pod_files_spelling_ok('lib'); __DATA__ Goro Fuji (gfx) gfuji(at)cpan.org Data::Clone gfx behaviour clonable CPAN Exportable Data-Clone-0.003/xt/02_pod.t0000644000175000017500000000023411514323233013454 0ustar gfxgfx#!perl -w use strict; use Test::More; eval q{use Test::Pod 1.14}; plan skip_all => 'Test::Pod 1.14 required for testing PODU' if $@; all_pod_files_ok(); Data-Clone-0.003/xt/04_synopsis.t0000644000175000017500000000022311514323233014561 0ustar gfxgfx#!perl -w use strict; use Test::More; eval q{use Test::Synopsis}; plan skip_all => 'Test::Synopsis required for testing' if $@; all_synopsis_ok(); Data-Clone-0.003/xt/03_pod-coverage.t0000644000175000017500000000032311514323233015245 0ustar gfxgfx#!perl -w use Test::More; eval q{use Test::Pod::Coverage 1.04}; plan skip_all => 'Test::Pod::Coverage 1.04 required for testing POD coverage' if $@; all_pod_coverage_ok({ also_private => [qw(TIECLONE)], }); Data-Clone-0.003/xshelper.h0000644000175000017500000000453211514324463013567 0ustar gfxgfx/* THIS FILE IS AUTOMATICALLY GENERATED BY Module::Install::XSUtil 0.36. */ /* =head1 NAME xshelper.h - Helper C header file for XS modules =head1 DESCRIPTION // This includes all the perl header files and ppport.h #include "xshelper.h" =head1 SEE ALSO L, where this file is distributed as a part of =head1 AUTHOR Fuji, Goro (gfx) Egfuji at cpan.orgE =head1 LISENCE Copyright (c) 2010, Fuji, Goro (gfx). All rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut */ #ifdef __cplusplus extern "C" { #endif #define PERL_NO_GET_CONTEXT /* we want efficiency */ #include #include #define NO_XSLOCKS /* for exceptions */ #include #ifdef __cplusplus } /* extern "C" */ #endif #include "ppport.h" /* portability stuff not supported by ppport.h yet */ #ifndef STATIC_INLINE /* from 5.13.4 */ # if defined(__GNUC__) || defined(__cplusplus) || (defined(__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L)) # define STATIC_INLINE static inline # else # define STATIC_INLINE static # endif #endif /* STATIC_INLINE */ #ifndef __attribute__format__ #define __attribute__format__(a,b,c) /* nothing */ #endif #ifndef LIKELY /* they are just a compiler's hint */ #define LIKELY(x) (!!(x)) #define UNLIKELY(x) (!!(x)) #endif #ifndef newSVpvs_share #define newSVpvs_share(s) Perl_newSVpvn_share(aTHX_ STR_WITH_LEN(s), 0U) #endif #ifndef get_cvs #define get_cvs(name, flags) get_cv(name, flags) #endif #ifndef GvNAME_get #define GvNAME_get GvNAME #endif #ifndef GvNAMELEN_get #define GvNAMELEN_get GvNAMELEN #endif #ifndef CvGV_set #define CvGV_set(cv, gv) (CvGV(cv) = (gv)) #endif /* general utility */ #if PERL_BCDVERSION >= 0x5008005 #define LooksLikeNumber(x) looks_like_number(x) #else #define LooksLikeNumber(x) (SvPOKp(x) ? looks_like_number(x) : (I32)SvNIOKp(x)) #endif #define newAV_mortal() (AV*)sv_2mortal((SV*)newAV()) #define newHV_mortal() (HV*)sv_2mortal((SV*)newHV()) #define newRV_inc_mortal(sv) sv_2mortal(newRV_inc(sv)) #define newRV_noinc_mortal(sv) sv_2mortal(newRV_noinc(sv)) #define DECL_BOOT(name) EXTERN_C XS(CAT2(boot_, name)) #define CALL_BOOT(name) STMT_START { \ PUSHMARK(SP); \ CALL_FPTR(CAT2(boot_, name))(aTHX_ cv); \ } STMT_END Data-Clone-0.003/inc/0000755000175000017500000000000011514324464012332 5ustar gfxgfxData-Clone-0.003/inc/Module/0000755000175000017500000000000011514324464013557 5ustar gfxgfxData-Clone-0.003/inc/Module/Install.pm0000644000175000017500000003015011514324462015520 0ustar gfxgfx#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.00'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::getcwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::getcwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::getcwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split /\n/, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[0]) <=> _version($_[1]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2010 Adam Kennedy. Data-Clone-0.003/inc/Module/Install/0000755000175000017500000000000011514324464015165 5ustar gfxgfxData-Clone-0.003/inc/Module/Install/Makefile.pm0000644000175000017500000002703211514324463017243 0ustar gfxgfx#line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # MakeMaker can complain about module versions that include # an underscore, even though its own version may contain one! # Hence the funny regexp to get rid of it. See RT #35800 # for details. my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/; $self->build_requires( 'ExtUtils::MakeMaker' => $v ); $self->configure_requires( 'ExtUtils::MakeMaker' => $v ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT $DB::single = 1; if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 541 Data-Clone-0.003/inc/Module/Install/Can.pm0000644000175000017500000000333311514324463016225 0ustar gfxgfx#line 1 package Module::Install::Can; use strict; use Config (); use File::Spec (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; my $abs = File::Spec->catfile($dir, $_[1]); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 156 Data-Clone-0.003/inc/Module/Install/Metadata.pm0000644000175000017500000004302011514324463017241 0ustar gfxgfx#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; unless ( @_ ) { warn "You MUST provide an explicit true/false value to dynamic_config\n"; return $self; } $self->{values}->{dynamic_config} = $_[0] ? 1 : 0; return 1; } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the reall old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( \Qhttp://rt.cpan.org/\E[^>]+| \Qhttp://github.com/\E[\w_]+/[\w_]+/issues| \Qhttp://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; Data-Clone-0.003/inc/Module/Install/WriteAll.pm0000644000175000017500000000237611514324463017255 0ustar gfxgfx#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; Data-Clone-0.003/inc/Module/Install/Base.pm0000644000175000017500000000214711514324463016400 0ustar gfxgfx#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.00'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 Data-Clone-0.003/inc/Module/Install/Repository.pm0000644000175000017500000000425611514324463017710 0ustar gfxgfx#line 1 package Module::Install::Repository; use strict; use 5.005; use vars qw($VERSION); $VERSION = '0.06'; use base qw(Module::Install::Base); sub _execute { my ($command) = @_; `$command`; } sub auto_set_repository { my $self = shift; return unless $Module::Install::AUTHOR; my $repo = _find_repo(\&_execute); if ($repo) { $self->repository($repo); } else { warn "Cannot determine repository URL\n"; } } sub _find_repo { my ($execute) = @_; if (-e ".git") { # TODO support remote besides 'origin'? if ($execute->('git remote show -n origin') =~ /URL: (.*)$/m) { # XXX Make it public clone URL, but this only works with github my $git_url = $1; $git_url =~ s![\w\-]+\@([^:]+):!git://$1/!; return $git_url; } elsif ($execute->('git svn info') =~ /URL: (.*)$/m) { return $1; } } elsif (-e ".svn") { if (`svn info` =~ /URL: (.*)$/m) { return $1; } } elsif (-e "_darcs") { # defaultrepo is better, but that is more likely to be ssh, not http if (my $query_repo = `darcs query repo`) { if ($query_repo =~ m!Default Remote: (http://.+)!) { return $1; } } open my $handle, '<', '_darcs/prefs/repos' or return; while (<$handle>) { chomp; return $_ if m!^http://!; } } elsif (-e ".hg") { if ($execute->('hg paths') =~ /default = (.*)$/m) { my $mercurial_url = $1; $mercurial_url =~ s!^ssh://hg\@(bitbucket\.org/)!https://$1!; return $mercurial_url; } } elsif (-e "$ENV{HOME}/.svk") { # Is there an explicit way to check if it's an svk checkout? my $svk_info = `svk info` or return; SVK_INFO: { if ($svk_info =~ /Mirrored From: (.*), Rev\./) { return $1; } if ($svk_info =~ m!Merged From: (/mirror/.*), Rev\.!) { $svk_info = `svk info /$1` or return; redo SVK_INFO; } } return; } } 1; __END__ =encoding utf-8 #line 128 Data-Clone-0.003/inc/Module/Install/AuthorTests.pm0000644000175000017500000000221511514324463020007 0ustar gfxgfx#line 1 package Module::Install::AuthorTests; use 5.005; use strict; use Module::Install::Base; use Carp (); #line 16 use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.002'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } #line 42 sub author_tests { my ($self, @dirs) = @_; _add_author_tests($self, \@dirs, 0); } #line 56 sub recursive_author_tests { my ($self, @dirs) = @_; _add_author_tests($self, \@dirs, 1); } sub _wanted { my $href = shift; sub { /\.t$/ and -f $_ and $href->{$File::Find::dir} = 1 } } sub _add_author_tests { my ($self, $dirs, $recurse) = @_; return unless $Module::Install::AUTHOR; my @tests = $self->tests ? (split / /, $self->tests) : 't/*.t'; # XXX: pick a default, later -- rjbs, 2008-02-24 my @dirs = @$dirs ? @$dirs : Carp::confess "no dirs given to author_tests"; @dirs = grep { -d } @dirs; if ($recurse) { require File::Find; my %test_dir; File::Find::find(_wanted(\%test_dir), @dirs); $self->tests( join ' ', @tests, map { "$_/*.t" } sort keys %test_dir ); } else { $self->tests( join ' ', @tests, map { "$_/*.t" } sort @dirs ); } } #line 107 1; Data-Clone-0.003/inc/Module/Install/XSUtil.pm0000644000175000017500000004312111514324463016713 0ustar gfxgfx#line 1 package Module::Install::XSUtil; use 5.005_03; $VERSION = '0.36'; use Module::Install::Base; @ISA = qw(Module::Install::Base); use strict; use Config; use File::Spec; use File::Find; use constant _VERBOSE => $ENV{MI_VERBOSE} ? 1 : 0; my %ConfigureRequires = ( # currently nothing ); my %BuildRequires = ( 'ExtUtils::ParseXS' => 2.21, # the newer, the better ); my %Requires = ( 'XSLoader' => 0.10, # the newer, the better ); my %ToInstall; my $UseC99 = 0; my $UseCplusplus = 0; sub _verbose{ print STDERR q{# }, @_, "\n"; } sub _xs_debugging{ return $ENV{XS_DEBUG} || scalar( grep{ $_ eq '-g' } @ARGV ); } sub _xs_initialize{ my($self) = @_; unless($self->{xsu_initialized}){ $self->{xsu_initialized} = 1; if(!$self->cc_available()){ warn "This distribution requires a C compiler, but it's not available, stopped.\n"; exit; } $self->configure_requires(%ConfigureRequires); $self->build_requires(%BuildRequires); $self->requires(%Requires); $self->makemaker_args->{OBJECT} = '$(O_FILES)'; $self->clean_files('$(O_FILES)'); $self->clean_files('*.stackdump') if $^O eq 'cygwin'; if($self->_xs_debugging()){ # override $Config{optimize} if(_is_msvc()){ $self->makemaker_args->{OPTIMIZE} = '-Zi'; } else{ $self->makemaker_args->{OPTIMIZE} = '-g'; } $self->cc_define('-DXS_ASSERT'); } } return; } # GNU C Compiler sub _is_gcc{ return $Config{gccversion}; } # Microsoft Visual C++ Compiler (cl.exe) sub _is_msvc{ return $Config{cc} =~ /\A cl \b /xmsi; } { my $cc_available; sub cc_available { return defined $cc_available ? $cc_available : ($cc_available = shift->can_cc()) ; } my $want_xs; sub want_xs { my $default = @_ ? shift : 1; # you're using this module, you /must/ want XS by default return $want_xs if defined $want_xs; foreach my $arg(@ARGV){ if($arg eq '--pp'){ return $want_xs = 0; } elsif($arg eq '--xs'){ return $want_xs = 1; } } return $want_xs = $default; } } sub use_ppport{ my($self, $dppp_version) = @_; return if $self->{_ppport_ok}++; $self->_xs_initialize(); my $filename = 'ppport.h'; $dppp_version ||= 3.19; # the more, the better $self->configure_requires('Devel::PPPort' => $dppp_version); $self->build_requires('Devel::PPPort' => $dppp_version); print "Writing $filename\n"; my $e = do{ local $@; eval qq{ use Devel::PPPort; Devel::PPPort::WriteFile(q{$filename}); }; $@; }; if($e){ print "Cannot create $filename because: $@\n"; } if(-e $filename){ $self->clean_files($filename); $self->cc_define('-DUSE_PPPORT'); $self->cc_append_to_inc('.'); } return; } sub use_xshelper { my($self, $opt) = @_; $self->_xs_initialize(); $self->use_ppport(); my $file = 'xshelper.h'; open my $fh, '>', $file or die "Cannot open $file for writing: $!"; print $fh $self->_xshelper_h(); close $fh or die "Cannot close $file: $!"; if(defined $opt) { if($opt eq '-clean') { $self->clean_files($file); } else { $self->realclean_files($file); } } return; } sub _gccversion { my $res = `$Config{cc} --version`; my ($version) = $res =~ /\(GCC\) ([0-9.]+)/; no warnings 'numeric', 'uninitialized'; return sprintf '%g', $version; } sub cc_warnings{ my($self) = @_; $self->_xs_initialize(); if(_is_gcc()){ $self->cc_append_to_ccflags(qw(-Wall)); my $gccversion = _gccversion(); if($gccversion >= 4.0){ $self->cc_append_to_ccflags(qw(-Wextra)); if(!($UseC99 or $UseCplusplus)) { # Note: MSVC++ doesn't support C99, # so -Wdeclaration-after-statement helps # ensure C89 specs. $self->cc_append_to_ccflags(qw(-Wdeclaration-after-statement)); } if($gccversion >= 4.1 && !$UseCplusplus) { $self->cc_append_to_ccflags(qw(-Wc++-compat)); } } else{ $self->cc_append_to_ccflags(qw(-W -Wno-comment)); } } elsif(_is_msvc()){ $self->cc_append_to_ccflags(qw(-W3)); } else{ # TODO: support other compilers } return; } sub c99_available { my($self) = @_; return 0 if not $self->cc_available(); require File::Temp; require File::Basename; my $tmpfile = File::Temp->new(SUFFIX => '.c'); $tmpfile->print(<<'C99'); // include a C99 header #include inline // a C99 keyword with C99 style comments int test_c99() { int i = 0; i++; int j = i - 1; // another C99 feature: declaration after statement return j; } C99 $tmpfile->close(); system "$Config{cc} -c " . $tmpfile->filename; (my $objname = File::Basename::basename($tmpfile->filename)) =~ s/\Q.c\E$/$Config{_o}/; unlink $objname or warn "Cannot unlink $objname (ignored): $!"; return $? == 0; } sub requires_c99 { my($self) = @_; if(!$self->c99_available) { warn "This distribution requires a C99 compiler, but $Config{cc} seems not to support C99, stopped.\n"; exit; } $self->_xs_initialize(); $UseC99 = 1; return; } sub cc_append_to_inc{ my($self, @dirs) = @_; $self->_xs_initialize(); for my $dir(@dirs){ unless(-d $dir){ warn("'$dir' not found: $!\n"); } _verbose "inc: -I$dir" if _VERBOSE; } my $mm = $self->makemaker_args; my $paths = join q{ }, map{ s{\\}{\\\\}g; qq{"-I$_"} } @dirs; if($mm->{INC}){ $mm->{INC} .= q{ } . $paths; } else{ $mm->{INC} = $paths; } return; } sub cc_libs { my ($self, @libs) = @_; @libs = map{ my($name, $dir) = ref($_) eq 'ARRAY' ? @{$_} : ($_, undef); my $lib; if(defined $dir) { $lib = ($dir =~ /^-/ ? qq{$dir } : qq{-L$dir }); } else { $lib = ''; } $lib .= ($name =~ /^-/ ? qq{$name} : qq{-l$name}); _verbose "libs: $lib" if _VERBOSE; $lib; } @libs; $self->cc_append_to_libs( @libs ); } sub cc_append_to_libs{ my($self, @libs) = @_; $self->_xs_initialize(); return unless @libs; my $libs = join q{ }, @libs; my $mm = $self->makemaker_args; if ($mm->{LIBS}){ $mm->{LIBS} .= q{ } . $libs; } else{ $mm->{LIBS} = $libs; } return $libs; } sub cc_assert_lib { my ($self, @dcl_args) = @_; if ( ! $self->{xsu_loaded_checklib} ) { my $loaded_lib = 0; foreach my $checklib (qw(inc::Devel::CheckLib Devel::CheckLib)) { eval "use $checklib 0.4"; if (!$@) { $loaded_lib = 1; last; } } if (! $loaded_lib) { warn "Devel::CheckLib not found in inc/ nor \@INC"; exit 0; } $self->{xsu_loaded_checklib}++; $self->configure_requires( "Devel::CheckLib" => "0.4" ); $self->build_requires( "Devel::CheckLib" => "0.4" ); } Devel::CheckLib::check_lib_or_exit(@dcl_args); } sub cc_append_to_ccflags{ my($self, @ccflags) = @_; $self->_xs_initialize(); my $mm = $self->makemaker_args; $mm->{CCFLAGS} ||= $Config{ccflags}; $mm->{CCFLAGS} .= q{ } . join q{ }, @ccflags; return; } sub cc_define{ my($self, @defines) = @_; $self->_xs_initialize(); my $mm = $self->makemaker_args; if(exists $mm->{DEFINE}){ $mm->{DEFINE} .= q{ } . join q{ }, @defines; } else{ $mm->{DEFINE} = join q{ }, @defines; } return; } sub requires_xs{ my $self = shift; return $self->requires() unless @_; $self->_xs_initialize(); my %added = $self->requires(@_); my(@inc, @libs); my $rx_lib = qr{ \. (?: lib | a) \z}xmsi; my $rx_dll = qr{ \. dll \z}xmsi; # for Cygwin while(my $module = each %added){ my $mod_basedir = File::Spec->join(split /::/, $module); my $rx_header = qr{\A ( .+ \Q$mod_basedir\E ) .+ \. h(?:pp)? \z}xmsi; SCAN_INC: foreach my $inc_dir(@INC){ my @dirs = grep{ -e } File::Spec->join($inc_dir, 'auto', $mod_basedir), File::Spec->join($inc_dir, $mod_basedir); next SCAN_INC unless @dirs; my $n_inc = scalar @inc; find(sub{ if(my($incdir) = $File::Find::name =~ $rx_header){ push @inc, $incdir; } elsif($File::Find::name =~ $rx_lib){ my($libname) = $_ =~ /\A (?:lib)? (\w+) /xmsi; push @libs, [$libname, $File::Find::dir]; } elsif($File::Find::name =~ $rx_dll){ # XXX: hack for Cygwin my $mm = $self->makemaker_args; $mm->{macro}->{PERL_ARCHIVE_AFTER} ||= ''; $mm->{macro}->{PERL_ARCHIVE_AFTER} .= ' ' . $File::Find::name; } }, @dirs); if($n_inc != scalar @inc){ last SCAN_INC; } } } my %uniq = (); $self->cc_append_to_inc (grep{ !$uniq{ $_ }++ } @inc); %uniq = (); $self->cc_libs(grep{ !$uniq{ $_->[0] }++ } @libs); return %added; } sub cc_src_paths{ my($self, @dirs) = @_; $self->_xs_initialize(); return unless @dirs; my $mm = $self->makemaker_args; my $XS_ref = $mm->{XS} ||= {}; my $C_ref = $mm->{C} ||= []; my $_obj = $Config{_o}; my @src_files; find(sub{ if(/ \. (?: xs | c (?: c | pp | xx )? ) \z/xmsi){ # *.{xs, c, cc, cpp, cxx} push @src_files, $File::Find::name; } }, @dirs); foreach my $src_file(@src_files){ my $c = $src_file; if($c =~ s/ \.xs \z/.c/xms){ $XS_ref->{$src_file} = $c; _verbose "xs: $src_file" if _VERBOSE; } else{ _verbose "c: $c" if _VERBOSE; } push @{$C_ref}, $c unless grep{ $_ eq $c } @{$C_ref}; } $self->clean_files(map{ File::Spec->catfile($_, '*.gcov'), File::Spec->catfile($_, '*.gcda'), File::Spec->catfile($_, '*.gcno'), } @dirs); $self->cc_append_to_inc('.'); return; } sub cc_include_paths{ my($self, @dirs) = @_; $self->_xs_initialize(); push @{ $self->{xsu_include_paths} ||= []}, @dirs; my $h_map = $self->{xsu_header_map} ||= {}; foreach my $dir(@dirs){ my $prefix = quotemeta( File::Spec->catfile($dir, '') ); find(sub{ return unless / \.h(?:pp)? \z/xms; (my $h_file = $File::Find::name) =~ s/ \A $prefix //xms; $h_map->{$h_file} = $File::Find::name; }, $dir); } $self->cc_append_to_inc(@dirs); return; } sub install_headers{ my $self = shift; my $h_files; if(@_ == 0){ $h_files = $self->{xsu_header_map} or die "install_headers: cc_include_paths not specified.\n"; } elsif(@_ == 1 && ref($_[0]) eq 'HASH'){ $h_files = $_[0]; } else{ $h_files = +{ map{ $_ => undef } @_ }; } $self->_xs_initialize(); my @not_found; my $h_map = $self->{xsu_header_map} || {}; while(my($ident, $path) = each %{$h_files}){ $path ||= $h_map->{$ident} || File::Spec->join('.', $ident); $path = File::Spec->canonpath($path); unless($path && -e $path){ push @not_found, $ident; next; } $ToInstall{$path} = File::Spec->join('$(INST_ARCHAUTODIR)', $ident); _verbose "install: $path as $ident" if _VERBOSE; my @funcs = $self->_extract_functions_from_header_file($path); if(@funcs){ $self->cc_append_to_funclist(@funcs); } } if(@not_found){ die "Header file(s) not found: @not_found\n"; } return; } my $home_directory; sub _extract_functions_from_header_file{ my($self, $h_file) = @_; my @functions; ($home_directory) = <~> unless defined $home_directory; # get header file contents through cpp(1) my $contents = do { my $mm = $self->makemaker_args; my $cppflags = q{"-I}. File::Spec->join($Config{archlib}, 'CORE') . q{"}; $cppflags =~ s/~/$home_directory/g; $cppflags .= ' ' . $mm->{INC} if $mm->{INC}; $cppflags .= ' ' . ($mm->{CCFLAGS} || $Config{ccflags}); $cppflags .= ' ' . $mm->{DEFINE} if $mm->{DEFINE}; my $add_include = _is_msvc() ? '-FI' : '-include'; $cppflags .= ' ' . join ' ', map{ qq{$add_include "$_"} } qw(EXTERN.h perl.h XSUB.h); my $cppcmd = qq{$Config{cpprun} $cppflags $h_file}; _verbose("extract functions from: $cppcmd") if _VERBOSE; `$cppcmd`; }; unless(defined $contents){ die "Cannot call C pre-processor ($Config{cpprun}): $! ($?)"; } # remove other include file contents my $chfile = q/\# (?:line)? \s+ \d+ /; $contents =~ s{ ^$chfile \s+ (?!"\Q$h_file\E") .*? ^(?= $chfile) }{}xmsig; if(_VERBOSE){ local *H; open H, "> $h_file.out" and print H $contents and close H; } while($contents =~ m{ ([^\\;\s]+ # type \s+ ([a-zA-Z_][a-zA-Z0-9_]*) # function name \s* \( [^;#]* \) # argument list [\w\s\(\)]* # attributes or something ;) # end of declaration }xmsg){ my $decl = $1; my $name = $2; next if $decl =~ /\b typedef \b/xms; next if $name =~ /^_/xms; # skip something private push @functions, $name; if(_VERBOSE){ $decl =~ tr/\n\r\t / /s; $decl =~ s/ (\Q$name\E) /<$name>/xms; _verbose("decl: $decl"); } } return @functions; } sub cc_append_to_funclist{ my($self, @functions) = @_; $self->_xs_initialize(); my $mm = $self->makemaker_args; push @{$mm->{FUNCLIST} ||= []}, @functions; $mm->{DL_FUNCS} ||= { '$(NAME)' => [] }; return; } sub _xshelper_h { my $h = <<'XSHELPER_H'; :/* THIS FILE IS AUTOMATICALLY GENERATED BY Module::Install::XSUtil $VERSION. */ :/* :=head1 NAME : :xshelper.h - Helper C header file for XS modules : :=head1 DESCRIPTION : : // This includes all the perl header files and ppport.h : #include "xshelper.h" : :=head1 SEE ALSO : :L, where this file is distributed as a part of : :=head1 AUTHOR : :Fuji, Goro (gfx) Egfuji at cpan.orgE : :=head1 LISENCE : :Copyright (c) 2010, Fuji, Goro (gfx). All rights reserved. : :This library is free software; you can redistribute it and/or modify :it under the same terms as Perl itself. : :=cut :*/ : :#ifdef __cplusplus :extern "C" { :#endif : :#define PERL_NO_GET_CONTEXT /* we want efficiency */ :#include :#include :#define NO_XSLOCKS /* for exceptions */ :#include : :#ifdef __cplusplus :} /* extern "C" */ :#endif : :#include "ppport.h" : :/* portability stuff not supported by ppport.h yet */ : :#ifndef STATIC_INLINE /* from 5.13.4 */ :# if defined(__GNUC__) || defined(__cplusplus) || (defined(__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L)) :# define STATIC_INLINE static inline :# else :# define STATIC_INLINE static :# endif :#endif /* STATIC_INLINE */ : :#ifndef __attribute__format__ :#define __attribute__format__(a,b,c) /* nothing */ :#endif : :#ifndef LIKELY /* they are just a compiler's hint */ :#define LIKELY(x) (!!(x)) :#define UNLIKELY(x) (!!(x)) :#endif : :#ifndef newSVpvs_share :#define newSVpvs_share(s) Perl_newSVpvn_share(aTHX_ STR_WITH_LEN(s), 0U) :#endif : :#ifndef get_cvs :#define get_cvs(name, flags) get_cv(name, flags) :#endif : :#ifndef GvNAME_get :#define GvNAME_get GvNAME :#endif :#ifndef GvNAMELEN_get :#define GvNAMELEN_get GvNAMELEN :#endif : :#ifndef CvGV_set :#define CvGV_set(cv, gv) (CvGV(cv) = (gv)) :#endif : :/* general utility */ : :#if PERL_BCDVERSION >= 0x5008005 :#define LooksLikeNumber(x) looks_like_number(x) :#else :#define LooksLikeNumber(x) (SvPOKp(x) ? looks_like_number(x) : (I32)SvNIOKp(x)) :#endif : :#define newAV_mortal() (AV*)sv_2mortal((SV*)newAV()) :#define newHV_mortal() (HV*)sv_2mortal((SV*)newHV()) :#define newRV_inc_mortal(sv) sv_2mortal(newRV_inc(sv)) :#define newRV_noinc_mortal(sv) sv_2mortal(newRV_noinc(sv)) : :#define DECL_BOOT(name) EXTERN_C XS(CAT2(boot_, name)) :#define CALL_BOOT(name) STMT_START { \ : PUSHMARK(SP); \ : CALL_FPTR(CAT2(boot_, name))(aTHX_ cv); \ : } STMT_END XSHELPER_H $h =~ s/^://xmsg; $h =~ s/\$VERSION\b/$Module::Install::XSUtil::VERSION/xms; return $h; } package MY; # XXX: We must append to PM inside ExtUtils::MakeMaker->new(). sub init_PM{ my $self = shift; $self->SUPER::init_PM(@_); while(my($k, $v) = each %ToInstall){ $self->{PM}{$k} = $v; } return; } # append object file names to CCCMD sub const_cccmd { my $self = shift; my $cccmd = $self->SUPER::const_cccmd(@_); return q{} unless $cccmd; if (Module::Install::XSUtil::_is_msvc()){ $cccmd .= ' -Fo$@'; } else { $cccmd .= ' -o $@'; } return $cccmd } 1; __END__ #line 980 Data-Clone-0.003/benchmark/0000755000175000017500000000000011514324464013513 5ustar gfxgfxData-Clone-0.003/benchmark/vs_clone.pl0000644000175000017500000000127111514323233015652 0ustar gfxgfx#!perl -w use strict; use Benchmark qw(:all); use Storable (); use Clone (); use Data::Clone (); my @array = ( [1 .. 10], [1 .. 10] ); print "ArrayRef:\n"; cmpthese -1 => { 'Clone' => sub{ my $x = Clone::clone(\@array); }, 'Storable' => sub{ my $x = Storable::dclone(\@array); }, 'Data::Clone' => sub{ my $x = Data::Clone::clone(\@array); }, }; my %hash = ( key => \@array, ); print "HashRef:\n"; cmpthese -1 => { 'Clone' => sub{ my $x = Clone::clone(\%hash); }, 'Storable' => sub{ my $x = Storable::dclone(\%hash); }, 'Data::Clone' => sub{ my $x = Data::Clone::clone(\%hash); }, }; Data-Clone-0.003/benchmark/vs_fast.pl0000644000175000017500000000130611514323233015506 0ustar gfxgfx#!perl -w use strict; use Benchmark qw(:all); use Clone::Fast (); use Clone (); use Data::Clone (); my @array = ( [1 .. 10], [1 .. 10] ); print "ArrayRef:\n"; cmpthese -1 => { 'Clone' => sub{ my $x = Clone::clone(\@array); }, 'Clone::Fast' => sub{ my $x = Clone::Fast::clone(\@array); }, 'Data::Clone' => sub{ my $x = Data::Clone::clone(\@array); }, }; my %hash = ( key => \@array, ); print "HashRef:\n"; cmpthese -1 => { 'Clone' => sub{ my $x = Clone::clone(\%hash); }, 'Clone::Fast' => sub{ my $x = Clone::Fast::clone(\%hash); }, 'Data::Clone' => sub{ my $x = Data::Clone::clone(\%hash); }, }; Data-Clone-0.003/benchmark/object.pl0000644000175000017500000000143211514323233015307 0ustar gfxgfx#!perl -w use strict; use Benchmark qw(:all); use Storable (); use Clone (); use Data::Clone (); BEGIN{ package Object; sub new { my $class = shift; return bless { @_ }, $class; } package ST; use Storable (); our @ISA = qw(Object); *clone = \&Storable::dclone; package C; use Clone qw(clone); our @ISA = qw(Object); package DC; use Data::Clone qw(clone); our @ISA = qw(Object); } my %args = ( foo => 42, inc => { %INC }, ); my $st = ST->new(%args); my $c = C->new(%args); my $dc = DC->new(%args); print "Object:\n"; cmpthese -1 => { 'Clone' => sub{ my $x = $c->clone; }, 'Storable' => sub{ my $x = $st->clone; }, 'Data::Clone' => sub{ my $x = $dc->clone; }, }; Data-Clone-0.003/benchmark/method.pl0000644000175000017500000000076211514323233015326 0ustar gfxgfx#!perl -w use strict; use Benchmark qw(:all); use Data::Clone; BEGIN{ package Object; sub new { my $class = shift; return bless { @_ }, $class; } package DC; use Data::Clone qw(clone); our @ISA = qw(Object); } my %args = ( foo => 42, inc => { %INC }, ); my $o = DC->new(%args); print "Method vs. Function:\n"; cmpthese -1 => { 'method' => sub{ my $x = $o->clone; }, 'function' => sub{ my $x = clone($o); }, }; Data-Clone-0.003/Data-Clone.xs0000644000175000017500000002231411514324031014034 0ustar gfxgfx#define PERL_NO_GET_CONTEXT #define NO_XSLOCKS /* for exceptions */ #include "xshelper.h" #include "data_clone.h" #ifndef SvRXOK #define SvRXOK(sv) (SvROK(sv) && SvMAGICAL(SvRV(sv)) && mg_find(SvRV(sv), PERL_MAGIC_qr)) #endif #define REINTERPRET_CAST(T, value) ((T)value) #define PTR2STR(ptr) REINTERPRET_CAST(const char*, (&ptr)) #define MY_CXT_KEY "Data::Clone::_guts" XS_VERSION typedef struct { U32 depth; HV* seen; CV* caller_cv; GV* my_clone; GV* object_callback; SV* clone_method; /* "clone" */ SV* tieclone_method; /* "TIECLONE" */ } my_cxt_t; START_MY_CXT static SV* clone_rv(pTHX_ pMY_CXT_ SV* const cloning); static SV* clone_sv(pTHX_ pMY_CXT_ SV* const cloning) { assert(cloning); SvGETMAGIC(cloning); if(SvROK(cloning)){ return clone_rv(aTHX_ aMY_CXT_ cloning); } else{ SV* const cloned = newSV(0); /* no need to set SV_GMAGIC */ sv_setsv_flags(cloned, cloning, SV_NOSTEAL); return cloned; } } static void clone_hv_to(pTHX_ pMY_CXT_ HV* const cloning, HV* const cloned) { HE* iter; assert(cloning); assert(cloned); hv_iterinit(cloning); while((iter = hv_iternext(cloning))){ SV* const key = hv_iterkeysv(iter); SV* const val = clone_sv(aTHX_ aMY_CXT_ hv_iterval(cloning, iter)); (void)hv_store_ent(cloned, key, val, 0U); } } static void clone_av_to(pTHX_ pMY_CXT_ AV* const cloning, AV* const cloned) { I32 last, i; assert(cloning); assert(cloned); last = av_len(cloning); av_extend(cloned, last); for(i = 0; i <= last; i++){ SV** const svp = av_fetch(cloning, i, FALSE); if(svp){ (void)av_store(cloned, i, clone_sv(aTHX_ aMY_CXT_ *svp)); } } } static GV* find_method_sv(pTHX_ HV* const stash, SV* const name) { HE* const he = hv_fetch_ent(stash, name, FALSE, 0U); if(he && isGV(HeVAL(he)) && GvCV((GV*)HeVAL(he))){ /* shortcut */ return (GV*)HeVAL(he); } assert(SvPOKp(name)); return gv_fetchmeth_autoload(stash, SvPVX(name), SvCUR(name), 0); } static int sv_has_backrefs(pTHX_ SV* const sv) { if(SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_backref)) { return TRUE; } #ifdef HvAUX else if(SvTYPE(sv) == SVt_PVHV){ return SvOOK(sv) && HvAUX((HV*)sv)->xhv_backreferences != NULL; } #endif return FALSE; } /* my_dopoptosub_at() and caller_cv() are stolen from pp_ctl.c */ static I32 my_dopoptosub_at(pTHX_ const PERL_CONTEXT* const cxstk, I32 const startingblock) { I32 i; assert(cxstk); for (i = startingblock; i >= 0; i--) { const PERL_CONTEXT* const cx = &cxstk[i]; if(CxTYPE(cx) == CXt_SUB){ break; } } return i; } static CV* caller_cv(pTHX) { const PERL_CONTEXT* cx; const PERL_CONTEXT* ccstack = cxstack; const PERL_SI *si = PL_curstackinfo; I32 cxix = my_dopoptosub_at(aTHX_ ccstack, cxstack_ix); I32 count = 0; for (;;) { /* we may be in a higher stacklevel, so dig down deeper */ while (cxix < 0 && si->si_type != PERLSI_MAIN) { si = si->si_prev; ccstack = si->si_cxstack; cxix = my_dopoptosub_at(aTHX_ ccstack, si->si_cxix); } if (cxix < 0) { return NULL; } /* skip &DB::sub */ if (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub)) count++; if (!count--) break; cxix = my_dopoptosub_at(aTHX_ ccstack, cxix - 1); } cx = &ccstack[cxix]; return cx->blk_sub.cv; } static void store_to_seen(pTHX_ pMY_CXT_ SV* const sv, SV* const proto) { (void)hv_store(MY_CXT.seen, PTR2STR(sv), sizeof(sv), proto, 0U); SvREFCNT_inc_simple_void_NN(proto); } static SV* dc_call_sv1(pTHX_ SV* const proc, SV* const arg1) { dSP; SV* ret; assert(proc); assert(arg1); ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(arg1); PUTBACK; call_sv(proc, G_SCALAR); SPAGAIN; ret = POPs; PUTBACK; SvREFCNT_inc_simple_void_NN(ret); FREETMPS; LEAVE; return sv_2mortal(ret); } static int dc_need_to_call(pTHX_ pMY_CXT_ const CV* const method) { //warn("dc_need_co_call 0x%p 0x%p 0x%p", method, GvCV(MY_CXT.my_clone), MY_CXT.caller_cv); return method != GvCV(MY_CXT.my_clone) && method != MY_CXT.caller_cv; } static SV* dc_clone_object(pTHX_ pMY_CXT_ SV* const cloning, SV* const method_sv) { SV* const sv = SvRV(cloning); GV* const method = find_method_sv(aTHX_ SvSTASH(sv), method_sv); if(!method){ /* not a clonable object */ SV* const object_callback = GvSVn(MY_CXT.object_callback); /* try to $Data::Clone::ObjectCallback->($cloning) */ SvGETMAGIC(object_callback); if(SvOK(object_callback)){ SV* const x = dc_call_sv1(aTHX_ object_callback, cloning); if(!SvROK(x)){ croak("ObjectCallback function returned %s, but it must return a reference", SvOK(x) ? SvPV_nolen_const(x) : "undef"); } return x; } return sv_mortalcopy(cloning); croak("Non-clonable object %"SVf" found (missing a %"SVf" method)", cloning, method_sv); } /* has its own clone method */ if(dc_need_to_call(aTHX_ aMY_CXT_ GvCV(method))){ SV* const x = dc_call_sv1(aTHX_ (SV*)GvCV(method), cloning); if(!SvROK(x)){ croak("Cloning method '%"SVf"' returned %s, but it must return a reference", method_sv, SvOK(x) ? SvPV_nolen_const(x) : "undef"); } return x; } else { /* default clone() behavior: deep copy */ return NULL; } } static SV* clone_rv(pTHX_ pMY_CXT_ SV* const cloning) { int may_be_circular; SV* sv; SV* proto; SV* cloned; MAGIC* mg; //CV* old_cv; assert(cloning); assert(SvROK(cloning)); sv = SvRV(cloning); may_be_circular = (SvREFCNT(sv) > 1 || sv_has_backrefs(aTHX_ sv) ); if(may_be_circular){ SV** const svp = hv_fetch(MY_CXT.seen, PTR2STR(sv), sizeof(sv), FALSE); if(svp){ proto = *svp; goto finish; } } if(SvOBJECT(sv) && !SvRXOK(cloning)){ proto = dc_clone_object(aTHX_ aMY_CXT_ cloning, MY_CXT.clone_method); if(proto){ proto = SvRV(proto); goto finish; } /* fall through to make a deep copy */ } else if((mg = SvTIED_mg(sv, PERL_MAGIC_tied))){ assert(SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV); proto = dc_clone_object(aTHX_ aMY_CXT_ SvTIED_obj(sv, mg), MY_CXT.tieclone_method); if(proto){ SV* const varsv = (SvTYPE(sv) == SVt_PVHV ? (SV*)newHV() : (SV*)newAV()); // can we use newSV_type()? sv_magic(varsv, proto, PERL_MAGIC_tied, NULL, 0); proto = varsv; goto finish; } /* fall through to make a deep copy */ } /* XXX: need to save caller_cv, or not? */ //old_cv = MY_CXT.caller_cv; MY_CXT.caller_cv = NULL; if(SvTYPE(sv) == SVt_PVAV){ proto = sv_2mortal((SV*)newAV()); if(may_be_circular){ store_to_seen(aTHX_ aMY_CXT_ sv, proto); } clone_av_to(aTHX_ aMY_CXT_ (AV*)sv, (AV*)proto); } else if(SvTYPE(sv) == SVt_PVHV){ proto = sv_2mortal((SV*)newHV()); if(may_be_circular){ store_to_seen(aTHX_ aMY_CXT_ sv, proto); } clone_hv_to(aTHX_ aMY_CXT_ (HV*)sv, (HV*)proto); } else { proto = sv; /* do nothing */ } //MY_CXT.caller_cv = old_cv; finish: cloned = newRV_inc(proto); if(SvOBJECT(sv)){ sv_bless(cloned, SvSTASH(sv)); } return SvWEAKREF(cloning) ? sv_rvweaken(cloned) : cloned; } /* as SV* sv_clone(SV* sv) */ SV* Data_Clone_sv_clone(pTHX_ SV* const sv) { SV* VOL retval = NULL; CV* VOL old_cv; dMY_CXT; dXCPT; if(++MY_CXT.depth == U32_MAX){ croak("Depth overflow on clone()"); } old_cv = MY_CXT.caller_cv; MY_CXT.caller_cv = caller_cv(aTHX); XCPT_TRY_START { retval = sv_2mortal(clone_sv(aTHX_ aMY_CXT_ sv)); } XCPT_TRY_END MY_CXT.caller_cv = old_cv; if(--MY_CXT.depth == 0){ hv_undef(MY_CXT.seen); } XCPT_CATCH { XCPT_RETHROW; } return retval; } static void my_cxt_initialize(pTHX_ pMY_CXT) { MY_CXT.depth = 0; MY_CXT.seen = newHV(); MY_CXT.my_clone = CvGV(get_cvs("Data::Clone::clone", GV_ADD)); MY_CXT.object_callback = gv_fetchpvs("Data::Clone::ObjectCallback", GV_ADDMULTI, SVt_PV); MY_CXT.clone_method = newSVpvs_share("clone"); MY_CXT.tieclone_method = newSVpvs_share("TIECLONE"); } MODULE = Data::Clone PACKAGE = Data::Clone PROTOTYPES: DISABLE BOOT: { MY_CXT_INIT; my_cxt_initialize(aTHX_ aMY_CXT); } #ifdef USE_ITHREADS void CLONE(...) CODE: { MY_CXT_CLONE; my_cxt_initialize(aTHX_ aMY_CXT); PERL_UNUSED_VAR(items); } #endif void clone(SV* sv) CODE: { ST(0) = sv_clone(sv); XSRETURN(1); } bool is_cloning() CODE: { dMY_CXT; RETVAL = (MY_CXT.depth != 0); } OUTPUT: RETVAL Data-Clone-0.003/t/0000755000175000017500000000000011514324464012024 5ustar gfxgfxData-Clone-0.003/t/05_super.t0000644000175000017500000000411611514323233013646 0ustar gfxgfx#!perl -w use strict; use warnings FATAL => 'all'; use Test::More; use Data::Clone; use Scalar::Util qw(isweak weaken); use Data::Dumper; $Data::Dumper::Indent = 0; $Data::Dumper::Sortkeys = 1; my $c_clone_called; { package A; use Data::Clone; # make clonable sub new { my($class, @args) = @_; return bless {@args}, $class; } package B; our @ISA = qw(A); package C; our @ISA = qw(B); sub clone { my($self) = @_; my $cloned = $self->SUPER::clone(); $cloned->{'c_clone'} = 1; $c_clone_called++; return $cloned; } package D; our @ISA = qw(C); package E; our @ISA = qw(D); } my $b = B->new(foo => 10); my $c = C->new(bar => 20); for(1 .. 2){ note($_); is Dumper($b->clone), Dumper(bless { foo => 10 }, 'B'), 'inherited clone method'; is Dumper(clone($b)), Dumper(bless { foo => 10 }, 'B'), 'inherited clone method via clone() function'; $c_clone_called = 0; is Dumper($c->clone), Dumper(bless { bar => 20, c_clone => 1 }, 'C'), 'work with SUPER::clone()'; is $c_clone_called, 1; $c_clone_called = 0; is Dumper(clone($c)), Dumper(bless { bar => 20, c_clone => 1 }, 'C'), 'work with SUPER::clone()'; is $c_clone_called, 1; is Dumper($c), Dumper(bless { bar => 20 }, 'C'); for my $class(qw(C D E)){ note("for $class"); my @h = ( $class->new(a => 1), $class->new(a => 2), $class->new(a => 3) ); $c_clone_called = 0; is Dumper(clone(\@h)), Dumper([ ( $class->new(a => 1, c_clone => 1), $class->new(a => 2, c_clone => 1), $class->new(a => 3, c_clone => 1) ) ]); is $c_clone_called, 3; my $o = $class->new( c => [$class->new(foo => 42)], c2 => [$class->new(foo => 52)], ); $c_clone_called = 0; is Dumper(clone($o)), Dumper($class->new( c => [$class->new(foo => 42, c_clone => 1)], c2 => [$class->new(foo => 52, c_clone => 1)], c_clone => 1)); is $c_clone_called, 3; } } done_testing; Data-Clone-0.003/t/10_threads.t0000644000175000017500000000431011514323233014132 0ustar gfxgfx#!perl -w use strict; use constant HAS_THREADS => eval{ require threads }; use if !HAS_THREADS, 'Test::More', skip_all => 'This test requires threads'; use Test::More; use warnings FATAL => 'all'; use Data::Clone; use Time::HiRes qw(usleep); { package MyBase; sub new { my $class = shift; return bless {@_}, $class; } package MyNoclonable; our @ISA = qw(MyBase); package MyClonable; use Data::Clone; our @ISA = qw(MyBase); package MyCustomClonable; use Data::Clone qw(data_clone); our @ISA = qw(MyBase); sub clone { my $cloned = data_clone(@_); $cloned->{bar} = 42; return $cloned; } package CreateThreadsInClone; use Data::Clone qw(data_clone); our @ISA = qw(MyBase); sub clone { my $cloned = data_clone(@_); $cloned->{bar} = threads->create(sub{ data_clone([42]) })->join(); return $cloned; } } my @threads; for(1 .. 3){ push @threads, threads->create(sub{ usleep 10;; my $o = MyNoclonable->new(foo => 10); my $c = do{ local $Data::Clone::ObjectCallback = sub{ $_[0] }; clone($o); }; is $c, $o, "tid - " . threads->tid; $c->{foo}++; is $o->{foo}, 11, 'noclonable'; usleep 10; $o = MyClonable->new(foo => 10); $c = clone($o); isnt $c, $o; $c->{foo}++; is $o->{foo}, 10, 'clonable'; usleep 10; $o = MyCustomClonable->new(foo => 10); $c = clone($o); isnt $c, $o; $c->{foo}++; is $o->{foo}, 10, 'clonable'; is_deeply $c, { foo => 11, bar => 42 }, 'custom clone()'; usleep 10; $o = MyCustomClonable->new(foo => MyClonable->new(bar => 42)); $c = clone($o); $c->{foo}{bar}++; is $o->{foo}{bar}, 42, 'clone() is reentrant'; is $c->{foo}{bar}, 43; $o = CreateThreadsInClone->new(foo => 50); $c = clone($o); usleep 10; is $c->{foo}, 50; is_deeply $c->{bar}, [42], 'threads->create in clone()'; return threads->tid; }); } foreach my $thr(@threads){ pass "\$thr->join: " . $thr->join; } done_testing; Data-Clone-0.003/t/11_leaktrace.t0000644000175000017500000000255111514323233014441 0ustar gfxgfx#!perl -w use strict; use Test::Requires qw(Test::LeakTrace); use Test::More; use warnings FATAL => 'all'; use Data::Clone; { package MyBase; sub new { my $class = shift; return bless {@_}, $class; } package MyNoclonable; our @ISA = qw(MyBase); package MyClonable; use Data::Clone; our @ISA = qw(MyBase); package MyCustomClonable; use Data::Clone qw(data_clone); our @ISA = qw(MyBase); sub clone { my $cloned = data_clone(@_); $cloned->{bar} = 42; return $cloned; } package FatalClonable; use Data::Clone qw(data_clone); our @ISA = qw(MyBase); sub clone { my $cloned = data_clone(@_); die 'FATAL'; } } no_leaks_ok { my $o = [ 42 ]; my $c = clone($o); } or die "Memory leaked"; no_leaks_ok { local $Data::Clone::ObjectCallback = sub{ $_[0] }; my $o = MyNoclonable->new(foo => 10); my $c = clone($o); }; no_leaks_ok { my $o = MyClonable->new(foo => 20); my $c = clone($o); }; no_leaks_ok { my $o = MyCustomClonable->new(foo => 30); my $c = clone($o); }; no_leaks_ok { my $o = MyCustomClonable->new(foo => MyClonable->new(bar => 42)); my $c = clone($o); }; no_leaks_ok { my $o = FatalClonable->new(value => MyClonable->new(foo => 50)); eval{ clone($o) }; } 'fatal in clone()'; done_testing; Data-Clone-0.003/t/06_tie.t0000644000175000017500000000374411514324334013303 0ustar gfxgfx#!perl -w use strict; use warnings FATAL => 'all'; use Test::More; use Data::Clone; use Tie::Hash; use Tie::Array; use Data::Dumper; $Data::Dumper::Indent = 0; $Data::Dumper::Sortkeys = 1; $Data::Dumper::Useqq = 1; { package MyNonclonableHash; our @ISA = qw(Tie::StdHash); package MyNonclonableArray; our @ISA = qw(Tie::StdArray); package MyClonableHash; use Data::Clone qw(TIECLONE); our @ISA = qw(Tie::StdHash); package MyClonableArray; use Data::Clone qw(TIECLONE); our @ISA = qw(Tie::StdArray); } # HASH foreach (1 .. 2){ note "for HASH ($_)"; tie my %h, 'MyNonclonableHash'; $h{foo} = 42; $h{bar} = "xyzzy"; my $c; eval{ local $Data::Clone::ObjectCallback = sub{ die 'Non-clonable object' }; clone(\%h); }; like $@, qr/Non-clonable object/, 'clone() croaks'; eval{ $c = clone(\%h); }; is $@, ''; is tied(%{$c}), tied(%h), 'sutface copy'; $c->{foo}++; is Dumper($c), Dumper({ foo => 43, bar => "xyzzy" }); is Dumper(\%h), Dumper({ foo => 43, bar => "xyzzy" }); tie %h, 'MyClonableHash'; $h{foo} = 42; $h{bar} = "xyzzy"; $c = clone(\%h); isnt $c, \%h; $c->{foo}++; is Dumper($c), Dumper({ foo => 43, bar => "xyzzy" }); is Dumper(\%h), Dumper({ foo => 42, bar => "xyzzy" }); # ARRAY note("for ARRAY ($_)"); tie my @a, 'MyNonclonableArray'; @a = (42, "xyzzy"); eval{ local $Data::Clone::ObjectCallback = sub{ die 'Non-clonable object' }; clone(\@a); }; like $@, qr/Non-clonable object/, 'clone() croaks'; eval{ $c = clone(\@a); }; is tied(@{$c}), tied(@a), 'sutface copy'; $c->[0]++; is Dumper($c), Dumper([43, "xyzzy"]); is Dumper(\@a), Dumper([43, "xyzzy"]); tie @a, 'MyClonableArray'; @a = (42, "xyzzy"); $c = clone(\@a); $c->[0]++; is Dumper($c), Dumper([43, "xyzzy"]); is Dumper(\@a), Dumper([42, "xyzzy"]); } done_testing; Data-Clone-0.003/t/02_object.t0000644000175000017500000000501211514324130013744 0ustar gfxgfx#!perl -w use strict; use warnings FATAL => 'all'; use Test::More; use Data::Clone; { package MyBase; sub new { my $class = shift; return bless {@_}, $class; } package MyNoclonable; our @ISA = qw(MyBase); package MyClonable; use Data::Clone; our @ISA = qw(MyBase); package MyCustomClonable; use Data::Clone qw(data_clone); our @ISA = qw(MyBase); sub clone { my $cloned = data_clone(@_); $cloned->{bar} = 42; return $cloned; } package FatalClonable; our @ISA = qw(MyBase); sub clone { die 'FATAL'; } } for(1 .. 2){ # do it twice to test internal data note($_); my($o, $c); $o = MyNoclonable->new(foo => 10); eval { local $Data::Clone::ObjectCallback = sub{ die 'Non-clonable object' }; $c = clone($o); }; like $@, qr/Non-clonable object/, 'die on non-clonables'; is $c, undef; eval { $c = clone($o); }; is $@, ''; is $c, $o; $c->{foo}++; is $o->{foo}, 11, 'noclonable with surface copy'; $o = MyClonable->new(foo => 10); $c = clone($o); isnt $c, $o; $c->{foo}++; is $o->{foo}, 10, 'clonable'; $o = MyCustomClonable->new(foo => 10); $c = clone($o); isnt $c, $o; $c->{foo}++; is $o->{foo}, 10, 'clonable'; is_deeply $c, { foo => 11, bar => 42 }, 'custom clone()'; $o = MyClonable->new( aaa => [[42], MyCustomClonable->new(value => 100)], bbb => [[42], MyCustomClonable->new(value => 200)], ); $c = clone($o); $c->{aaa}[1]{value}++; $c->{bbb}[1]{value}++; is $o->{aaa}[1]{value}, 100, 'clone() is reentrant'; is $c->{aaa}[1]{value}, 101; is $c->{aaa}[1]{bar}, 42; is $o->{bbb}[1]{value}, 200, 'clone() is reentrant'; is $c->{bbb}[1]{value}, 201; is $c->{bbb}[1]{bar}, 42; $o = MyCustomClonable->new(); $o->{ccc} = [MyCustomClonable->new(value => 300)]; $o->{ddd} = $o->{ccc}; $c = clone($o); $c->{ccc}[0]{value}++; $c->{ddd}[0]{value}++; is $o->{ccc}[0]{value}, 300; is $c->{ccc}[0]{value}, 302; is $c->{ccc}[0]{bar}, 42, 'clone methods in clone()'; $o = FatalClonable->new(foo => 10); eval{ clone($o); }; like $@, qr/^FATAL \b/xms, 'FATAL in clone()'; is $o->{foo}, 10; $o = MyCustomClonable->new(value => FatalClonable->new(foo => 10)); eval{ clone($o); }; like $@, qr/^FATAL \b/xms, 'FATAL in clone()'; is $o->{value}{foo}, 10; } done_testing; Data-Clone-0.003/t/03_scalar_ref.t0000644000175000017500000000052211514323233014604 0ustar gfxgfx#!perl -w use strict; use warnings FATAL => 'all'; use Test::More; use Data::Clone; for(1 .. 2){ # do it twice to test internal data my $s = 'foobar'; my @a = (\substr $s, 1, 2); my $c = clone(\@a); is ${$c->[0]}, 'oo'; ${$c->[0]} = 'xx'; is $s, 'fxxbar', 'ScalarRef is copied in surface'; } done_testing; Data-Clone-0.003/t/04_tree.t0000644000175000017500000000210711514323233013444 0ustar gfxgfx#!perl -w use strict; use warnings FATAL => 'all'; use Test::More; use Data::Clone; use Scalar::Util qw(isweak weaken); use Data::Dumper; $Data::Dumper::Indent = 0; $Data::Dumper::Sortkeys = 1; # hash tree my $parent = {}; my $child = {}; $child->{parent} = $parent; $parent->{child} = $child; weaken $child->{parent}; my $cloned = clone($child); is Dumper($cloned), Dumper({ parent => undef }), 'tree structure (child)'; $cloned = clone($parent); is Dumper($cloned), Dumper($parent), 'tree structure (parent)'; cmp_ok $cloned, '==', $cloned->{child}{parent}, 'as circular refs'; ok isweak($cloned->{child}{parent}), 'correctly weaken'; # array tree $parent = ['is_parent']; $child = ['is_child']; push @{$child}, $parent; push @{$parent}, $child; weaken $child->[1]; $cloned = clone($child); is Dumper($cloned), Dumper(['is_child', undef]), 'array tree (child)'; $cloned = clone($parent); is Dumper($cloned), Dumper($parent), 'array tree (parent)'; cmp_ok $cloned, '==', $cloned->[1][1], 'as sircular refs'; ok isweak($cloned->[1][1]), 'correctly weaken'; done_testing; Data-Clone-0.003/t/01_basic.t0000644000175000017500000000331511514323233013565 0ustar gfxgfx#!perl -w use strict; use warnings FATAL => 'all'; use Test::More; use Data::Dumper; use Data::Clone; use Tie::Hash; use Tie::Array; $Data::Dumper::Indent = 0; $Data::Dumper::Sortkeys = 1; ok defined(&clone), 'clone() is exported by default'; ok!defined(&data_clone), 'data_clone() is not exported by default'; for(1 .. 2){ # do it twice to test internal data foreach my $data( "foo", 3.14, 1 != 1, *STDOUT, ["foo", "bar", undef, 42], [qr/foo/, qr/bar/], [\*STDOUT, \*STDOUT], { key => [ 'value', \&ok ] }, { foo => { bar => { baz => 42 } } }, ){ note("for $data"); is Dumper(clone($data)), Dumper($data), 'data'; is Dumper(clone(\$data)), Dumper(\$data), 'data ref'; } my $s; $s = \$s; is Dumper(clone(\$s)), Dumper(\$s), 'ref to self (scalar)'; my @a; @a = \@a; is Dumper(clone(\@a)), Dumper(\@a), 'ref to self (array)'; my %h; $h{foo} = \%h; is Dumper(clone(\%h)), Dumper(\%h), 'ref to self (hash)'; @a = ('foo', 'bar', \%h, \%h); is Dumper(clone(\@a)), Dumper(\@a), 'ref to duplicated refs'; # correctly cloned? $s = 99; %h = (foo => 10, bar => 10, baz => [10], qux => \$s); my $cloned = clone(\%h); $cloned->{foo}++; $cloned->{baz}[0]++; cmp_ok $cloned, '!=', \%h, 'different entity'; is Dumper($cloned), Dumper({foo => 11, bar => 10, baz => [11], qux => \$s}), 'deeply copied'; is Dumper(\%h), Dumper({foo => 10, bar => 10, baz => [10], qux => \$s}), 'the original is not touched'; $s++; is ${$h{qux}}, 100; is ${$cloned->{qux}}, 100, 'scalar ref is not copied deeply'; } done_testing; Data-Clone-0.003/t/00_load.t0000644000175000017500000000020611514323233013416 0ustar gfxgfx#!perl -w use strict; use Test::More tests => 1; BEGIN { use_ok 'Data::Clone' } diag "Testing Data::Clone/$Data::Clone::VERSION"; Data-Clone-0.003/data_clone.h0000644000175000017500000000055511514323233014021 0ustar gfxgfx/* * data_clone.h - Polymorphic data cloning engine * * Tihs header file is a part of Data::Clone * * Copyright (c) 2010, Goro Fuji (gfx). * * See also http://search.cpan.org/dist/Data-Clone/. */ #ifndef PERL_DATA_CLONE_H #define PERL_DATA_CLONE_H SV* Data_Clone_sv_clone(pTHX_ SV* const sv); #define sv_clone(sv) Data_Clone_sv_clone(aTHX_ (sv)) #endif Data-Clone-0.003/MANIFEST0000644000175000017500000000127211514323341012705 0ustar gfxgfxbenchmark/method.pl benchmark/object.pl benchmark/vs_clone.pl benchmark/vs_fast.pl Changes Data-Clone.xs data_clone.h example/scalar_refs.pl inc/Module/Install.pm inc/Module/Install/AuthorTests.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Repository.pm inc/Module/Install/WriteAll.pm inc/Module/Install/XSUtil.pm lib/Data/Clone.pm Makefile.PL MANIFEST This list of files MANIFEST.SKIP META.yml README t/00_load.t t/01_basic.t t/02_object.t t/03_scalar_ref.t t/04_tree.t t/05_super.t t/06_tie.t t/10_threads.t t/11_leaktrace.t xshelper.h xt/01_podspell.t xt/02_pod.t xt/03_pod-coverage.t xt/04_synopsis.t Data-Clone-0.003/Makefile.PL0000644000175000017500000000111411514323233013521 0ustar gfxgfxuse strict; use warnings; use inc::Module::Install; use Module::Install::XSUtil; BEGIN{ *auto_set_repository = sub{ } if !defined &auto_set_repository; } all_from 'lib/Data/Clone.pm'; use_xshelper; cc_warnings; requires 'parent'; test_requires 'Test::More' => 0.88; # done_testing() test_requires 'Test::Requires' => 0.03; install_headers qw(data_clone.h); tests 't/*.t t/*/*.t'; author_tests 'xt'; auto_set_repository() if -d '.git'; clean_files qw( Data-Clone-* *.stackdump *.gcda *.gcno *.gcov nytprof *.out cover_db ); WriteAll check_nmake => 0; Data-Clone-0.003/lib/0000755000175000017500000000000011514324464012327 5ustar gfxgfxData-Clone-0.003/lib/Data/0000755000175000017500000000000011514324464013200 5ustar gfxgfxData-Clone-0.003/lib/Data/Clone.pm0000644000175000017500000001210311514324435014571 0ustar gfxgfxpackage Data::Clone; use 5.008_001; use strict; our $VERSION = '0.003'; use XSLoader; XSLoader::load(__PACKAGE__, $VERSION); use parent qw(Exporter); our @EXPORT = qw(clone); our @EXPORT_OK = qw(data_clone TIECLONE); sub data_clone; *data_clone = \&clone; # alias sub TIECLONE; *TIECLONE = \&clone; # alias 1; __END__ =head1 NAME Data::Clone - Polymorphic data cloning =head1 VERSION This document describes Data::Clone version 0.003. =head1 SYNOPSIS # as a function use Data::Clone; my $data = YAML::Load("foo.yml"); # complex data structure my $cloned = clone($data); # makes Foo clonable package Foo; use Data::Clone; # ... # Foo is clonable my $o = Foo->new(); my $c = clone($o); # $o is deeply copied # used for custom clone methods package Bar; use Data::Clone qw(data_clone); sub clone { my($proto) = @_; my $object = data_clone($proto); $object->do_something(); return $object; } # ... # Bar is also clonable $o = Bar->new(); $c = clone($o); # Bar::clone() is called =head1 DESCRIPTION C does data cloning, i.e. copies things recursively. This is smart so that it works with not only non-blessed references, but also with blessed references (i.e. objects). When C finds an object, it calls a C method of the object if the object has a C, otherwise it makes a surface copy of the object. That is, this module does polymorphic data cloning. Although there are several modules on CPAN which can clone data, this module has a different cloning policy from almost all of them. See L and L for details. =head2 Cloning policy A cloning policy is a rule that how a cloning routine copies data. Here is the cloning policy of C. =head3 Non-reference values Non-reference values are copied normally, which will drop their magics. =head3 Scalar references Scalar references including references to other types of references are B copied deeply. They are copied on surface because it is typically used to refer to something unique, namely global variables or magical variables. =head3 Array references Array references are copied deeply. The cloning policy is applied to each value recursively. =head3 Hash references Hash references are copied deeply. The cloning policy is applied to each value recursively. =head3 Glob, IO and Code references These references are B copied deeply. They are copied on surface. =head3 Blessed references (objects) Blessed references are B copied deeply by default, because objects might have external resources which C could not deal with. They will be copied deeply only if C knows they are clonable, i.e. they have a C method. If you want to make an object clonable, you can use the C function as a method: package Your::Class; use Data::Clone; # ... my $your_class = Your::Class->new(); my $c = clone($your_object); # $your_object->clone() will be called Or you can import C function to define your custom clone method: package Your::Class; use Data::Clone qw(data_clone); sub clone { my($proto) = @_; my $object = data_clone($proto); # anything what you want return $object; } Of course, you can use C, C, and/or anything you want as an implementation of C methods. =head2 Comparison to other cloning modules There are modules which does data cloning. C is a standard module which can clone data with C. It has a different cloning policy from C. By default it tries to make a deep copy of all the data including blessed references, but you can change its behaviour with specific hook methods. C is a well-known cloning module, but it does not polymorphic cloning. This makes a deep copy of data regardless of its types. Moreover, there is no way to change its behaviour, so this is useful only for data which link to no external resources. C makes a deep copy of data only if it knows that the data are clonable. You can change its behaviour simply by defining C methods. It also exceeds C and C in performance. =head1 INTERFACE =head2 Exported functions =head3 B<< clone(Scalar) >> Returns a copy of I. =head2 Exportable functions =head3 B<< data_clone(Salar) >> Returns a copy of I. The same as C. Provided for custom clone methods. =head3 B<< is_cloning() >> Returns true inside the C function, false otherwise. =head1 DEPENDENCIES Perl 5.8.1 or later, and a C compiler. =head1 BUGS No bugs have been reported. Please report any bugs or feature requests to the author. =head1 SEE ALSO L L =head1 AUTHOR Goro Fuji (gfx) Egfuji(at)cpan.orgE =head1 LICENSE AND COPYRIGHT Copyright (c) 2010, Goro Fuji (gfx). All rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Data-Clone-0.003/README0000644000175000017500000000077111514323233012437 0ustar gfxgfxThis is Perl module Data::Clone. INSTALLATION Data::Clone installation is straightforward. If your CPAN shell is set up, you should just be able to do $ cpan Data::Clone Download it, unpack it, then build it as per the usual: $ perl Makefile.PL $ make && make test Then install it: $ make install DOCUMENTATION Data::Clone documentation is available as in POD. So you can do: $ perldoc Data::Clone to read the documentation online with your favorite pager. Goro Fuji (gfx) Data-Clone-0.003/example/0000755000175000017500000000000011514324464013214 5ustar gfxgfxData-Clone-0.003/example/scalar_refs.pl0000644000175000017500000000100511514323233016022 0ustar gfxgfx#!perl -w use strict; use Clone qw(clone); use Data::Clone qw(data_clone); use Storable qw(dclone); use Errno qw(ENOENT); use Devel::Peek; use Data::Dumper; our $errstr = 'foo'; my $data = { errstr_ref => \$errstr, errno_ref => \$! }; my $c1 = clone($data); my $c2 = dclone($data); my $c3 = data_clone($data); $errstr = 'bar'; $! = ENOENT; print Data::Dumper->Dump([$c1], ['Clone']); print Data::Dumper->Dump([$c2], ['Storable']); print Data::Dumper->Dump([$c3], ['DataClone']); #Dump($c1); #Dump($c2); Data-Clone-0.003/MANIFEST.SKIP0000644000175000017500000000151711514323233013454 0ustar gfxgfx #!start included /usr/local/lib/perl5/5.10.0/ExtUtils/MANIFEST.SKIP # Avoid version control files. \bRCS\b \bCVS\b \bSCCS\b ,v$ \B\.svn\b \B\.git\b \B\.gitignore\b \b_darcs\b # Avoid Makemaker generated and utility files. \bMANIFEST\.bak \bMakefile$ \bblib/ \bMakeMaker-\d \bpm_to_blib\.ts$ \bpm_to_blib$ \bblibdirs\.ts$ # 6.18 through 6.25 generated this # Avoid Module::Build generated and utility files. \bBuild$ \b_build/ # Avoid temp and backup files. ~$ \.old$ \#$ \b\.# \.bak$ # Avoid Devel::Cover files. \bcover_db\b #!end included /usr/local/lib/perl5/5.10.0/ExtUtils/MANIFEST.SKIP # skip dot files ^\. # skip author's files \bauthor\b # skip object files Clone\.c$ \.o(?:bj)?$ \.bs$ \.def$ \.out$ # skip devel-cover stuff \.gcda$ \.gcno$ \.gcov$ cover_db/ # skip nytprof stuff nytprof/ \.out$ Data-Clone- ppport\.h$ Data-Clone-0.003/META.yml0000644000175000017500000000135511514324464013036 0ustar gfxgfx--- abstract: 'Polymorphic data cloning' author: - 'Goro Fuji (gfx) ' build_requires: Devel::PPPort: 3.19 ExtUtils::MakeMaker: 6.42 ExtUtils::ParseXS: 2.21 Test::More: 0.88 Test::Requires: 0.03 configure_requires: Devel::PPPort: 3.19 ExtUtils::MakeMaker: 6.42 distribution_type: module generated_by: 'Module::Install version 1.00' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 module_name: Data::Clone name: Data-Clone no_index: directory: - example - inc - t - xt requires: XSLoader: 0.1 parent: 0 perl: 5.8.1 resources: license: http://dev.perl.org/licenses/ repository: git://github.com/gfx/Perl-Data-Clone.git version: 0.003 Data-Clone-0.003/Changes0000644000175000017500000000044311514324427013054 0ustar gfxgfxRevision history for Perl extension Data::Clone 0.003 2011-01-15 23:02:18 - Cloning normal object died as of 0.002, but it seems too strict 0.002 2011-01-15 22:41:13 - Fix a problem on pre-5.10 perls 0.001 Mon Jan 11 10:15:23 2010 - original version; created by Module::Setup